diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,5 @@ # Changelog for inventory -## Unreleased changes +## 0.1.0.4 + +* Support GHC 9.4.x and 9.6.x diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -81,4 +81,4 @@ signatures for GHC versions less than 9.0.1. - Standalone kind signatures are not yet included in definition counts. - Does not unfold type synonyms when comparing type signatures. -- GHC versions other than 8.8, 8.10, and 9.0 are not currently supported. +- GHC versions less than 8.8.x are not supported. diff --git a/inventory.cabal b/inventory.cabal --- a/inventory.cabal +++ b/inventory.cabal @@ -7,7 +7,7 @@ -- hash: e0077ffac241039a12a7c4c25cbf73cc19bcf4b81132d5a8194a2747df9c137a name: inventory -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Project statistics and definition analysis description: Please see the README on GitHub at category: Utility @@ -18,7 +18,7 @@ copyright: 2021 Aaron Allen license: BSD3 license-file: LICENSE -tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.4 || ==9.6.1 build-type: Simple extra-source-files: README.md @@ -54,13 +54,13 @@ appendmap >=0.1.5 && <0.2 , array >=0.5.4 && <0.6 , base >=4.7 && <5 - , bytestring >=0.10.10 && <0.11 + , bytestring >=0.10.10 , containers >=0.6.2 && <0.7 , directory >=1.3.6 && <1.4 , filepath >=1.4.2 && <1.5 - , ghc >=8.8 && <9.1 - , ghc-paths >=0.1.0 && <0.2 - , mtl >=2.2.2 && <2.3 + , ghc >=8.8 && <9.7 + , ghc-paths >=0.1.0 + , mtl >=2.2.2 && <2.4 default-language: Haskell2010 executable inventory @@ -74,14 +74,14 @@ appendmap >=0.1.5 && <0.2 , array >=0.5.4 && <0.6 , base >=4.7 && <5 - , bytestring >=0.10.10 && <0.11 + , bytestring >=0.10.10 , containers >=0.6.2 && <0.7 , directory >=1.3.6 && <1.4 , filepath >=1.4.2 && <1.5 - , ghc >=8.8 && <9.1 - , ghc-paths >=0.1.0 && <0.2 + , ghc >=8.8 && <9.7 + , ghc-paths >=0.1.0 , inventory - , mtl >=2.2.2 && <2.3 + , mtl >=2.2.2 && <2.4 default-language: Haskell2010 test-suite inventory-test @@ -117,14 +117,14 @@ appendmap >=0.1.5 && <0.2 , array >=0.5.4 && <0.6 , base >=4.7 && <5 - , bytestring >=0.10.10 && <0.11 + , bytestring >=0.10.10 , containers >=0.6.2 && <0.7 , directory >=1.3.6 && <1.4 , filepath >=1.4.2 && <1.5 - , ghc >=8.8 && <9.1 - , ghc-paths >=0.1.0 && <0.2 + , ghc >=8.8 && <9.7 + , ghc-paths >=0.1.0 , inventory - , mtl >=2.2.2 && <2.3 + , mtl >=2.2.2 && <2.4 , tasty , tasty-hunit default-language: Haskell2010 diff --git a/src/DefCounts/ProcessHie.hs b/src/DefCounts/ProcessHie.hs --- a/src/DefCounts/ProcessHie.hs +++ b/src/DefCounts/ProcessHie.hs @@ -58,36 +58,47 @@ | nodeHasAnnotation "IEName" "IEWrappedName" node = AppendMap $ M.singleton ExportThing (numLines $ nodeSpan node, 1) - | otherwise = foldMap ( foldMap (foldMap (tyDeclLines src) . identInfo) - . nodeIdentifiers - . getNodeInfo ) - $ nodeChildren node + | nodeHasAnnotation "IEThingAll" "IE" node + = AppendMap $ M.singleton ExportThing (numLines $ nodeSpan node, 1) + | nodeHasAnnotation "IEPattern" "IEWrappedName" node + = AppendMap $ M.singleton ExportThing (numLines $ nodeSpan node, 1) + + | nodeHasAnnotation "IEVar" "IE" node + = AppendMap $ M.singleton ExportThing (numLines $ nodeSpan node, 1) + + | otherwise = foldNodeChildren (tyDeclLines src) node + numLines :: Span -> Sum Int numLines s = Sum $ srcSpanEndLine s - srcSpanStartLine s + 1 -tyDeclLines :: SourceCode -> ContextInfo -> DefCounter -tyDeclLines src = \case - Decl declTy (Just srcSpan) - | Just defTy <- toDefType srcSpan declTy - -> AppendMap $ M.singleton defTy (numLines srcSpan, 1) - _ -> mempty +tyDeclLines :: SourceCode -> HieAST a -> DefCounter +tyDeclLines src node = fromCurrentNode <> fromChildren where - toDefType srcSpan = \case - FamDec -> Just Fam - SynDec -> Just Syn - DataDec - | isNewtypeDec -> Just Newtype - | otherwise -> Just Data - PatSynDec -> Just PatSyn - ClassDec -> Just Class - InstDec -> Just TyFamInst - _ -> Nothing + fromCurrentNode = + foldMap (foldMap go . identInfo) . nodeIdentifiers $ getNodeInfo node + fromChildren = foldNodeChildren (tyDeclLines src) node + go = \case + Decl declTy (Just srcSpan) + | Just defTy <- toDefType srcSpan declTy + -> AppendMap $ M.singleton defTy (numLines srcSpan, 1) + _ -> mempty where - isNewtypeDec = - let ln = srcSpanStartLine srcSpan - 1 - col = srcSpanStartCol srcSpan - 1 - (lBnd, uBnd) = A.bounds src - in ln >= lBnd && ln <= uBnd - && "newtype" == (BS.take 7 . BS.drop col $ src A.! ln) + toDefType srcSpan = \case + FamDec -> Just Fam + SynDec -> Just Syn + DataDec + | isNewtypeDec -> Just Newtype + | otherwise -> Just Data + PatSynDec -> Just PatSyn + ClassDec -> Just Class + InstDec -> Just TyFamInst + _ -> Nothing + where + isNewtypeDec = + let ln = srcSpanStartLine srcSpan - 1 + col = srcSpanStartCol srcSpan - 1 + (lBnd, uBnd) = A.bounds src + in ln >= lBnd && ln <= uBnd + && "newtype" == (BS.take 7 . BS.drop col $ src A.! ln) diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -3,9 +3,13 @@ ( baseDynFlags, ) where +#if MIN_VERSION_ghc(9,4,0) +import GHC.Data.Bool (OverridingBool(Always)) +#endif import GHC.Api hiding (settings) import GHC.Paths (libdir) +#if !MIN_VERSION_ghc(9,6,0) fakeLlvmConfig :: LlvmConfig fakeLlvmConfig = #if __GLASGOW_HASKELL__ < 810 @@ -13,10 +17,16 @@ #else LlvmConfig [] [] #endif +#endif baseDynFlags :: IO DynFlags baseDynFlags = do settings <- initSysTools libdir - pure $ (defaultDynFlags settings fakeLlvmConfig) - { useColor = Always } + let dynFlags = +#if MIN_VERSION_ghc(9,6,0) + defaultDynFlags settings +#else + defaultDynFlags settings fakeLlvmConfig +#endif + pure dynFlags { useColor = Always } diff --git a/src/HieFile.hs b/src/HieFile.hs --- a/src/HieFile.hs +++ b/src/HieFile.hs @@ -8,13 +8,14 @@ ) where import Control.Exception (onException) -import Control.Monad.State +import Control.Monad import qualified Data.Array as A #if __GLASGOW_HASKELL__ < 900 +import Control.Monad.State import Data.Bifunctor #endif import qualified Data.ByteString.Char8 as BS -#if __GLASGOW_HASKELL__ >= 900 +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,4,0) import Data.IORef #endif import Data.Maybe @@ -72,10 +73,25 @@ let srcFileExists = doesPathExist . hie_hs_file filterM srcFileExists hieFiles -#if __GLASGOW_HASKELL__ >= 900 +#if MIN_VERSION_ghc(9,4,0) hieFilesFromPaths :: [FilePath] -> IO [HieFile] hieFilesFromPaths filePaths = do + nameCache <- mkNameCache + traverse (getHieFile nameCache) filePaths + +getHieFile :: NameCache -> FilePath -> IO HieFile +getHieFile nameCache filePath = + handleHieVersionMismatch filePath . fmap hie_file_result + =<< readHieFileWithVersion + (\(v, _) -> v == hieVersion) + nameCache + filePath + +#elif __GLASGOW_HASKELL__ >= 900 + +hieFilesFromPaths :: [FilePath] -> IO [HieFile] +hieFilesFromPaths filePaths = do nameCacheRef <- newIORef =<< mkNameCache let updater = NCU $ atomicModifyIORef' nameCacheRef traverse (getHieFile updater) filePaths @@ -118,8 +134,12 @@ mkNameCache :: IO NameCache mkNameCache = do +#if MIN_VERSION_ghc(9,4,0) + initNameCache 'z' [] +#else uniqueSupply <- mkSplitUniqSupply 'z' pure $ initNameCache uniqueSupply [] +#endif -- | Recursively search for .hie files in given directory getHieFilesIn :: FilePath -> IO [FilePath] diff --git a/src/MatchSigs/Sig.hs b/src/MatchSigs/Sig.hs --- a/src/MatchSigs/Sig.hs +++ b/src/MatchSigs/Sig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,7 +11,9 @@ , isQual ) where +import Control.Monad import Control.Monad.State +import qualified Data.ByteString as BS import Data.Either import Data.List import qualified Data.Map.Strict as M @@ -26,7 +29,7 @@ -- linked list with the init elems being the context followed by arguments of -- the function and the last being the result type. data Sig varIx - = TyDescriptor !FastString !(Maybe Name) + = TyDescriptor !BS.ByteString !(Maybe Name) | FreeVar !varIx | Arg ![Sig varIx] | Qual ![Sig varIx] @@ -137,8 +140,20 @@ $ KindSig <$> mkSig ty <*> mkSig ki + -- hs sig + | nodeHasAnnotation "HsSig" "HsSigType" node + , rest : userVarNodes <- reverse $ nodeChildren node + = do + vars <- foldM extractFreeVar [] userVarNodes + (VarCtx vars :) <$> mkSig rest + -- any other type - | (ty, "HsType") : _ <- S.toList . nodeAnnotations $ getNodeInfo node +#if MIN_VERSION_ghc(9,2,0) + | NodeAnnotation ty "HsType" +#else + | (ty, "HsType") +#endif + : _ <- S.toList . nodeAnnotations $ getNodeInfo node , let mbName = extractName node = do freeVars <- get @@ -146,7 +161,13 @@ Just name | Just idx <- freeVars M.!? name -> pure [FreeVar idx] - _ -> pure [TyDescriptor ty mbName] + _ -> pure [TyDescriptor +#if MIN_VERSION_ghc(8,10,0) + (bytesFS ty) +#else + (fastStringToByteString ty) +#endif + mbName ] | otherwise = pure [] diff --git a/src/Output.hs b/src/Output.hs --- a/src/Output.hs +++ b/src/Output.hs @@ -6,7 +6,12 @@ import System.IO (stdout) import DefCounts.Output -import GHC.Api (DynFlags) +import GHC.Api +#if MIN_VERSION_ghc(9,2,0) + (DynFlags, initSDocContext) +#else + (DynFlags) +#endif import GHC.Output import HieFile (Counters) import MatchSigs.Output @@ -43,7 +48,11 @@ outputSDoc :: DynFlags -> SDoc -> IO () outputSDoc dynFlags sDoc = do -#if __GLASGOW_HASKELL__ >= 900 +#if MIN_VERSION_ghc(9,2,0) + let pprStyle = setStyleColoured True defaultUserStyle + sDocCtx = initSDocContext dynFlags pprStyle + printSDocLn sDocCtx (PageMode True) stdout sDoc +#elif MIN_VERSION_ghc(9,0,0) let pprStyle = setStyleColoured True defaultUserStyle sDocCtx = initSDocContext dynFlags pprStyle printSDocLn sDocCtx PageMode stdout sDoc diff --git a/src/UseCounts/ProcessHie.hs b/src/UseCounts/ProcessHie.hs --- a/src/UseCounts/ProcessHie.hs +++ b/src/UseCounts/ProcessHie.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module UseCounts.ProcessHie @@ -35,18 +36,32 @@ <> foldMap declaration (listToMaybe $ nodeChildren node) -- only get usages from instance declarations - | any ((== "InstDecl") . snd) (nodeAnnotations $ getNodeInfo node) + | any ((== "InstDecl") . annType) (nodeAnnotations $ getNodeInfo node) = foldMap findUsage (nodeChildren node) | otherwise = foldMap declaration (nodeChildren node) <> foldMap findUsage (nodeChildren node) + where + annType = +#if MIN_VERSION_ghc(9,2,0) + nodeAnnotType +#else + snd +#endif -- | Accrues all the top-level declarations if all different types declaration :: HieAST a -> UsageCounter declaration node - | any ((== "ConDecl") . snd) (nodeAnnotations $ getNodeInfo node) + | any ((== "ConDecl") . annType) (nodeAnnotations $ getNodeInfo node) = dataConDecl node + where + annType = +#if MIN_VERSION_ghc(9,2,0) + nodeAnnotType +#else + snd +#endif declaration node = M.foldMapWithKey f . nodeIdentifiers $ getNodeInfo node where f (Right name) details = foldMap g (identInfo details) where diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -32,7 +32,12 @@ nodeHasAnnotation :: String -> String -> HieAST a -> Bool nodeHasAnnotation constructor ty = - S.member (fromString constructor, fromString ty) + S.member +#if MIN_VERSION_ghc(9,2,0) + (NodeAnnotation (fromString constructor) (fromString ty)) +#else + (fromString constructor, fromString ty) +#endif . nodeAnnotations . getNodeInfo diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} import Data.Bifunctor +import Data.List (sort) import Data.Map.Append.Strict (AppendMap(..)) import qualified Data.Map.Strict as M import Data.Monoid @@ -47,14 +49,19 @@ [ (Class, (1, 1)) , (Data, (1, 1)) , (Newtype, (2, 1)) +#if MIN_VERSION_ghc(9,2,0) + , (Fam, (3, 2)) +#else , (Fam, (2, 2)) +#endif , (Func, (2, 1)) , (PatSyn, (1, 1)) , (Syn, (1, 1)) , (ClassInst, (2, 2)) , (TyFamInst, (2, 2)) + , (TyFamInst, (2, 2)) , (ModImport, (1, 1)) - , (ExportThing, (5, 5)) + , (ExportThing, (8, 8)) ] , testCase "Use Counts" $ do @@ -71,7 +78,8 @@ sigMatchTest testName dynFlags sigGroupSizes = do (_, _, AppendMap sigMap, _) <- getCounters testName dynFlags - assertEqual testName sigGroupSizes + assertEqual testName (sort sigGroupSizes) + . sort . concatMap (map (\(_, _, names) -> length names) . getMatchedSigs) $ M.elems sigMap @@ -83,10 +91,15 @@ useCountTest :: FilePath -> DynFlags -> [(String, Int)] -> IO () useCountTest testName dynFlags expectedUseCount = do (_, AppendMap useCount, _, _) <- getCounters testName dynFlags - let printName = showSDoc dynFlags . pprNameUnqualified + let printName = +#if MIN_VERSION_ghc(9,2,0) + showSDocOneLine (initDefaultSDocContext dynFlags) . pprNameUnqualified +#else + showSDoc dynFlags . pprNameUnqualified +#endif actualCount = map (bimap printName usages) . M.toList $ M.filter locallyDefined useCount - assertEqual testName expectedUseCount actualCount + assertEqual testName (sort expectedUseCount) (sort actualCount) getHiePath :: String -> FilePath getHiePath testName = "test/hie/HieSource/" <> testName <> ".hie"