hhp 1.0.0 → 1.0.1
raw patch · 13 files changed
+209/−86 lines, 13 files
Files
- ChangeLog +0/−18
- ChangeLog.md +29/−0
- hhp.cabal +2/−2
- lib/Hhp/Browse.hs +13/−4
- lib/Hhp/CabalApi.hs +6/−2
- lib/Hhp/Doc.hs +7/−9
- lib/Hhp/Find.hs +2/−1
- lib/Hhp/GHCApi.hs +1/−1
- lib/Hhp/Gap.hs +80/−8
- lib/Hhp/Info.hs +17/−15
- lib/Hhp/Logger.hs +45/−23
- src/hhpi.hs +6/−2
- test/CheckSpec.hs +1/−1
− ChangeLog
@@ -1,18 +0,0 @@-2022-05-30 v0.0.4- * Injecting cabal flags via environment variable. [#13](https://github.com/kazu-yamamoto/hhp/pull/13)- * Update to handle sub-libraries in .cabal file. [#14](https://github.com/kazu-yamamoto/hhp/pull/14)--2022-07-21 v0.0.3- * fixing test due to hlint change.- * supporting GHC 8.10--2019-10-03 v0.0.2- * supporting Cabal 3.0 and GHC 8.8.--2019-06-21 v0.0.1- * setting PartialTypeSignatures and NamedWildCards for check- * Remap save-buffer to hhp-save-buffer [#6](https://github.com/kazu-yamamoto/hhp/pull/6)- * using "-fdefer-typed-holes" for check.--2018-12-18 v0.0.0- * First release
+ ChangeLog.md view
@@ -0,0 +1,29 @@+# ChangeLog for HHP(Happy Haskell Programming)++## 2022-05-30 v1.0.0++- Supporting GHC 9.x only.++## 2022-05-30 v0.0.4++- Injecting cabal flags via environment variable. [#13](https://github.com/kazu-yamamoto/hhp/pull/13)+- Update to handle sub-libraries in .cabal file. [#14](https://github.com/kazu-yamamoto/hhp/pull/14)++## 2020-07-21 v0.0.3++- fixing test due to hlint change.+- supporting GHC 8.10++## 2019-10-03 v0.0.2++- supporting Cabal 3.0 and GHC 8.8.++## 2019-06-21 v0.0.1++- setting PartialTypeSignatures and NamedWildCards for check+- Remap save-buffer to hhp-save-buffer [#6](https://github.com/kazu-yamamoto/hhp/pull/6)+- using "-fdefer-typed-holes" for check.++## 2018-12-18 v0.0.0++- First release
hhp.cabal view
@@ -1,5 +1,5 @@ Name: hhp-Version: 1.0.0+Version: 1.0.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -24,7 +24,7 @@ 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+Extra-Source-Files: ChangeLog.md test/data/*.cabal test/data/*.hs test/data/cabal.sandbox.config.in
lib/Hhp/Browse.hs view
@@ -8,8 +8,11 @@ import GHC.Core.TyCon (isAlgTyCon) import GHC.Core.Type (dropForAlls, splitFunTy_maybe, isPredTy, mkVisFunTy) import GHC.Data.FastString (mkFastString)+import GHC.Driver.Session (initSDocContext) import GHC.Types.Name (getOccString)+import GHC.Utils.Monad (liftIO) +import qualified Control.Exception as E import Control.Monad.Catch (SomeException(..), handle, catch) import Data.Char (isAlpha) import Data.List (sort)@@ -54,10 +57,16 @@ -- If CmdLineError is signalled, we assume the user -- tried browsing a local module. getModule = browsePackageModule `catch` fallback `catch` handler- browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo+ browsePackageModule = do+ -- "findModule" of GHC 9.2 or earlier throws CmdLineError.+ -- But that of GHC 9.4 does not, sigh.+ mx <- G.findModule mdlname mpkgid >>= G.getModuleInfo+ case mx of+ Just _ -> return mx+ _ -> liftIO $ E.throwIO $ CmdLineError "for GHC 9.4" browseLocalModule = handle handler $ do- setTargetFiles [mdl]- G.findModule mdlname Nothing >>= G.getModuleInfo+ setTargetFiles [mdl]+ G.findModule mdlname Nothing >>= G.getModuleInfo fallback (CmdLineError _) = browseLocalModule fallback _ = return Nothing handler (SomeException _) = return Nothing@@ -119,7 +128,7 @@ formatType dflag a = showOutputable dflag $ removeForAlls a showOutputable :: DynFlags -> Type -> String-showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . pprTypeForUser+showOutputable dflag = unwords . lines . showPage (initSDocContext dflag styleUnqualified) . pprSigmaType tyType :: TyCon -> Maybe String tyType typ
lib/Hhp/CabalApi.hs view
@@ -24,7 +24,11 @@ import Distribution.Verbosity (silent) import Distribution.Version (Version) import Distribution.PackageDescription.Configuration (finalizePD)+#if MIN_VERSION_Cabal(3,8,0)+import Distribution.Simple.PackageDescription (readGenericPackageDescription)+#else import Distribution.PackageDescription.Parsec (readGenericPackageDescription)+#endif import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) import Distribution.Types.Flag (mkFlagAssignment, mkFlagName) import Distribution.Types.PackageName (unPackageName)@@ -36,7 +40,7 @@ import Control.Exception (throwIO) import Control.Monad (filterM)-import Data.Maybe (maybeToList, mapMaybe)+import Data.Maybe (maybeToList, mapMaybe, fromMaybe) import Data.Set (fromList, toList) import System.Directory (doesFileExist) import System.Environment (lookupEnv)@@ -59,7 +63,7 @@ where wdir = cradleCurrentDir cradle rdir = cradleRootDir cradle- Just cfile = cradleCabalFile cradle+ cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle thisPkg = dropExtension $ takeFileName cfile buildInfos = cabalAllBuildInfo pkgDesc idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
lib/Hhp/Doc.hs view
@@ -5,27 +5,25 @@ , styleUnqualified ) where -import GHC (Ghc, DynFlags, getPrintUnqual, pprCols)-import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PrintUnqualified, PprStyle, Depth(..), mkUserStyle)-import GHC.Driver.Session (initSDocContext)+import GHC (Ghc, getPrintUnqual)+import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PrintUnqualified, PprStyle, Depth(..), mkUserStyle, sdocLineLength, SDocContext) import GHC.Utils.Ppr (Mode(..), Style(..), renderStyle, style) import Hhp.Gap ---------------------------------------------------------------- -showPage :: DynFlags -> PprStyle -> SDoc -> String+showPage :: SDocContext -> SDoc -> String showPage = showSDocWithMode pagemode -showOneLine :: DynFlags -> PprStyle -> SDoc -> String+showOneLine :: SDocContext -> SDoc -> String showOneLine = showSDocWithMode OneLineMode -showSDocWithMode :: Mode -> DynFlags -> PprStyle -> SDoc -> String-showSDocWithMode md dflags pprstyle sdoc = renderStyle style' doc+showSDocWithMode :: Mode -> SDocContext -> SDoc -> String+showSDocWithMode md ctx sdoc = renderStyle style' doc where- ctx = initSDocContext dflags pprstyle doc = runSDoc sdoc ctx- style' = style { mode = md, lineLength = pprCols dflags }+ style' = style { mode = md, lineLength = sdocLineLength ctx } ----------------------------------------------------------------
lib/Hhp/Find.hs view
@@ -13,6 +13,7 @@ import GHC.Unit.Info (UnitInfo, unitExposedModules, mkUnit) import GHC.Unit.State (listUnitInfo, UnitState) import GHC.Utils.Outputable (ppr)+import GHC.Driver.Session (initSDocContext) import Control.DeepSeq (force) import Control.Monad.Catch (SomeException(..), catch)@@ -71,7 +72,7 @@ where mdl = G.moduleNameString (G.moduleName m) names = G.modInfoExports inf- toStr = showOneLine dflag styleUnqualified . ppr+ toStr = showOneLine (initSDocContext dflag styleUnqualified) . ppr packageModules :: UnitState -> [Module] packageModules us = concatMap fromUnitInfo $ listUnitInfo us
lib/Hhp/GHCApi.hs view
@@ -148,7 +148,7 @@ -- | Set the files as targets and load them. setTargetFiles :: [FilePath] -> Ghc () setTargetFiles files = do- targets <- forM files $ \file -> G.guessTarget file Nothing+ targets <- forM files $ \file -> guessTarget file G.setTargets targets void $ G.load LoadAllTargets
lib/Hhp/Gap.hs view
@@ -20,6 +20,10 @@ , ErrorMessages , locA , LOC+ , guessTarget+ , pprSigmaType+ , getMessages+ , hsPatType ) where import GHC (Ghc, DynFlags(..), GhcLink(..))@@ -29,17 +33,66 @@ import GHC.Driver.Session (supportedLanguagesAndExtensions) import GHC.Utils.Outputable (SDoc) -#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 904 ---------------------------------------------------------------- import GHC (Backend(..), pushLogHookM)-import GHC.Types.TyThing.Ppr-import GHC.Types.TyThing (implicitTyThings) 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.Utils.Logger (LogAction)-import GHC.Utils.Error (ErrorMessages, pprLocMsgEnvelope, MsgEnvelope, DecoratedSDoc)+import GHC.Tc.Utils.TcType (pprSigmaType)+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)++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 = Interpreter+ }++setLogger :: LogAction -> Ghc ()+setLogger logaction = pushLogHookM (\__defaultLogAction -> logaction)++pprLocErrMessage :: MsgEnvelope GhcMessage -> SDoc+pprLocErrMessage = pprLocMsgEnvelope++type LOC = LocatedA++guessTarget :: G.GhcMonad m => String -> m G.Target+guessTarget file = G.guessTarget file Nothing Nothing+----------------------------------------------------------------+#elif __GLASGOW_HASKELL__ >= 902+----------------------------------------------------------------+import GHC (Backend(..), pushLogHookM)+import GHC.Driver.Env (hsc_units) import GHC.Parser.Annotation (locA, LocatedA)+import GHC.Platform.Host (hostPlatformArchOS)+import GHC.Tc.Utils.Zonk (hsPatType)+import GHC.Types.SourceError (SourceError, srcErrorMessages)+import GHC.Types.TyThing (implicitTyThings)+import GHC.Types.TyThing.Ppr+import GHC.Utils.Error (ErrorMessages, DecoratedSDoc, pprLocMsgEnvelope, MsgEnvelope)+import GHC.Utils.Logger (LogAction) pagemode :: Mode pagemode = PageMode True@@ -69,17 +122,27 @@ pprLocErrMessage = pprLocMsgEnvelope type LOC = LocatedA++guessTarget :: G.GhcMonad m => String -> m G.Target+guessTarget file = G.guessTarget file Nothing++pprSigmaType :: G.Type -> SDoc+pprSigmaType = pprTypeForUser++getMessages :: a -> a+getMessages = id+ ---------------------------------------------------------------- #else ---------------------------------------------------------------- import GHC (HscTarget(..), getSessionDynFlags, setSessionDynFlags, Located) import GHC.Core.Ppr.TyThing+import GHC.Data.Bag (Bag) import GHC.Driver.Session (LogAction)-import GHC.Driver.Types (implicitTyThings)+import GHC.Driver.Types (SourceError, srcErrorMessages, implicitTyThings) import GHC.Platform.Host (cHostPlatformMini)-import GHC.Driver.Types (SourceError, srcErrorMessages)+import GHC.Tc.Utils.Zonk (hsPatType) import GHC.Utils.Error (ErrMsg, pprLocErrMsg)-import GHC.Data.Bag (Bag) import Control.Monad (void) @@ -118,5 +181,14 @@ locA = id type LOC = Located++guessTarget :: G.GhcMonad m => String -> m G.Target+guessTarget file = G.guessTarget file Nothing++pprSigmaType :: G.Type -> SDoc+pprSigmaType = pprTypeForUser++getMessages :: a -> a+getMessages = id ---------------------------------------------------------------- #endif
lib/Hhp/Info.hs view
@@ -7,7 +7,7 @@ , types ) where -import GHC (Ghc, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L), ModSummary, mgModSummaries, mg_ext, LHsBind, Type, LPat, LHsExpr)+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)@@ -15,9 +15,9 @@ import GHC.Hs.Expr (MatchGroupTc(..)) import GHC.Hs.Extension (GhcTc) import GHC.HsToCore (deSugarExpr)-import GHC.Tc.Utils.Zonk (hsPatType) import GHC.Utils.Monad (liftIO)-import GHC.Utils.Outputable (PprStyle)+import GHC.Utils.Outputable (SDocContext)+import GHC.Driver.Session (initSDocContext) import Control.Applicative ((<|>)) import Control.Monad (filterM)@@ -54,9 +54,9 @@ -> Ghc String info opt file expr = convert opt <$> handle handler body where- body = inModuleContext file $ \dflag style -> do+ body = inModuleContext file $ \ctx -> do sdoc <- infoThing expr- return $ showPage dflag style sdoc+ return $ showPage ctx sdoc handler (SomeException _e) = return $ "Cannot show info: " ++ show _e ----------------------------------------------------------------@@ -80,10 +80,10 @@ -> Ghc String types opt file lineNo colNo = convert opt <$> handle handler body where- body = inModuleContext file $ \dflag style -> do+ body = inModuleContext file $ \ctx -> do modSum <- fileModSummary file srcSpanTypes <- getSrcSpanType modSum lineNo colNo- return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes+ return $ map (toTup ctx) $ sortBy (cmp `on` fst) srcSpanTypes handler (SomeException _) = return [] type LExpression = LHsExpr GhcTc@@ -108,33 +108,35 @@ | b `G.isSubspanOf` a = O.GT | otherwise = O.EQ -toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)-toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)+toTup :: SDocContext -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup ctx (spn, typ) = (fourInts spn, pretty ctx typ) fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts = fromMaybe (0,0,0,0) . getSrcSpan -pretty :: DynFlags -> PprStyle -> Type -> String-pretty dflag style = showOneLine dflag style . pprTypeForUser+pretty :: SDocContext -> Type -> String+pretty ctx = showOneLine ctx . pprSigmaType ---------------------------------------------------------------- -inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a+inModuleContext :: FilePath -> (SDocContext -> Ghc a) -> Ghc a inModuleContext file action = withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do setTargetFiles [file] withContext $ do dflag <- G.getSessionDynFlags style <- getStyle- action dflag style+ action $ initSDocContext dflag style ---------------------------------------------------------------- fileModSummary :: FilePath -> Ghc ModSummary fileModSummary file = do mss <- mgModSummaries <$> G.getModuleGraph- let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss- return ms+ let xs = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss+ case xs of+ [ms] -> return ms+ _ -> error "fileModSummary" withContext :: Ghc a -> Ghc a withContext action = bracket setup teardown body
lib/Hhp/Logger.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Hhp.Logger (@@ -10,11 +11,19 @@ import qualified GHC as G import GHC.Data.Bag (bagToList) import GHC.Data.FastString (unpackFS)-import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices))-import GHC.Utils.Error (Severity(..), errMsgSpan)+import GHC.Driver.Session (initSDocContext)+import GHC.Utils.Error (Severity(..)) -- errMsgSpan import GHC.Utils.Monad (liftIO)-import GHC.Utils.Outputable (PprStyle, SDoc, defaultDumpStyle)+import GHC.Utils.Outputable (SDoc, SDocContext) +#if __GLASGOW_HASKELL__ >= 904+import GHC.Utils.Error (MessageClass(..))+import GHC.Utils.Logger (LogFlags(..))+#else+import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices))+import Hhp.Doc (styleUnqualified)+#endif+ import Control.Monad.Catch (handle) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf)@@ -28,22 +37,35 @@ ---------------------------------------------------------------- -type Builder = [String] -> [String]+type LogInfo = (Bool,SDocContext,Severity,SrcSpan,SDoc) -newtype LogRef = LogRef (IORef Builder)+newtype LogRef = LogRef (IORef ([LogInfo] -> [LogInfo])) newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef id readAndClearLogRef :: Options -> LogRef -> IO String readAndClearLogRef opt (LogRef ref) = do- b <- readIORef ref+ build <- readIORef ref writeIORef ref id- return $! convert opt (b [])+ let logInfos = build []+ logmsg = map ppMsg logInfos+ return $! convert opt logmsg appendLogRef :: LogRef -> LogAction-appendLogRef (LogRef ref) df _mc sev src msg = do- let !l = ppMsg src sev df msg+#if __GLASGOW_HASKELL__ >= 904+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)+#else+appendLogRef (LogRef ref) flag _ sev src msg = do+ let ctx = initSDocContext flag styleUnqualified+ dump = isDumpSplices flag+ !l = (dump, ctx, sev, src, msg)+#endif modifyIORef ref (\b -> b . (l:)) ----------------------------------------------------------------@@ -69,36 +91,34 @@ sourceError opt err = do dflag <- G.getSessionDynFlags style <- getStyle- let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err+ let ctx = initSDocContext dflag style+ ret = convert opt . errBagToStrList ctx . srcErrorMessages $ err return (Left ret) -errBagToStrList :: DynFlags -> PprStyle -> ErrorMessages -> [String]-errBagToStrList dflag style = map (ppErrMsg style) . reverse . bagToList+errBagToStrList :: SDocContext -> ErrorMessages -> [String]+errBagToStrList ctx = map ppErrMsg . reverse . bagToList . getMessages where- ppErrMsg _style_fixme err = ppMsg spn SevError dflag msg -- ++ ext+ ppErrMsg err = showPage ctx msg where- spn = errMsgSpan err+-- spn = errMsgSpan err msg = pprLocErrMessage err- -- fixme- -- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) -ppMsg :: SrcSpan -> Severity -> DynFlags -> SDoc -> String-ppMsg spn sev dflag msg = prefix ++ cts+ppMsg :: (Bool, SDocContext, Severity, SrcSpan, SDoc) -> String+ppMsg (True,ctx,_ ,_ ,msg) = showPage ctx msg+ppMsg (_, ctx,sev,spn,msg) = prefix ++ showPage ctx msg where- cts = showPage dflag defaultDumpStyle msg- defaultPrefix- | isDumpSplices dflag = ""- | otherwise = checkErrorPrefix- prefix = fromMaybe defaultPrefix $ do+ prefix = fromMaybe checkErrorPrefix $ do (line,col,_,_) <- getSrcSpan spn file <- normalise <$> getSrcFile spn let severityCaption = showSeverityCaption sev return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption + checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" showSeverityCaption :: Severity -> String+-- showSeverityCaption SevError is not necessary for historical reasons showSeverityCaption SevWarning = "Warning: " showSeverityCaption _ = "" @@ -106,8 +126,10 @@ getSrcFile (G.RealSrcSpan spn _) = Just . unpackFS . G.srcSpanFile $ spn getSrcFile _ = Nothing +#if __GLASGOW_HASKELL__ < 904 isDumpSplices :: DynFlags -> Bool isDumpSplices dflag = dopt Opt_D_dump_splices dflag+#endif getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) getSrcSpan (RealSrcSpan spn _) = Just ( G.srcSpanStartLine spn
src/hhpi.hs view
@@ -214,7 +214,9 @@ -> FilePath -> Ghc (String, Bool, Set FilePath) showInfo opt set fileArg = do- let [file, expr] = words fileArg+ let (file, expr) = case words fileArg of+ [file0, expr0] -> (file0, expr0)+ _ -> error "showInfo" set' <- newFileSet set file ret <- info opt file expr return (ret, True, set')@@ -224,7 +226,9 @@ -> FilePath -> Ghc (String, Bool, Set FilePath) showType opt set fileArg = do- let [file, line, column] = words fileArg+ let (file, line, column) = case words fileArg of+ [file0, line0, column0] -> (file0, line0, column0)+ _ -> error "showInfo" set' <- newFileSet set file ret <- types opt file (read line) (read column) return (ret, True, set')
test/CheckSpec.hs view
@@ -28,7 +28,7 @@ withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["Mutual1.hs"]- res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)+ res `shouldSatisfy` ("a cycle" `isInfixOf`) it "can check a module using QuasiQuotes" $ do withDirectory_ "test/data" $ do