diff --git a/src/Weeder.hs b/src/Weeder.hs index 327b8a4..700a620 100644 --- a/src/Weeder.hs +++ b/src/Weeder.hs @@ -48,6 +48,7 @@ import qualified Data.Set as Set import Data.Generics.Labels () -- ghc +import GHC.Data.FastString ( unpackFS ) import GHC.Types.Avail ( AvailInfo( Avail, AvailTC ) , GreName( NormalGreName, FieldGreName ) @@ -61,7 +62,7 @@ import GHC.Iface.Ext.Types , HieASTs( HieASTs ) , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file ) , IdentifierDetails( IdentifierDetails, identInfo ) - , NodeAnnotation( NodeAnnotation, nodeAnnotConstr, nodeAnnotType ) + , NodeAnnotation( NodeAnnotation, nodeAnnotType ) , NodeInfo( nodeIdentifiers, nodeAnnotations ) , Scope( ModuleScope ) , getSourcedNodeInfo @@ -276,8 +277,8 @@ topLevelAnalysis n@Node{ nodeChildren } = do analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do - let bindAnns = Set.fromList [(NodeAnnotation "FunBind" "HsBindLR"), (NodeAnnotation "PatBind" "HsBindLR")] - guard $ any (not . Set.disjoint bindAnns . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + let bindAnns = Set.fromList [("FunBind", "HsBindLR"), ("PatBind", "HsBindLR")] + guard $ any (not . Set.disjoint bindAnns . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo for_ ( findDeclarations n ) \d -> do define d nodeSpan @@ -287,21 +288,21 @@ analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseRewriteRule n@Node{ sourcedNodeInfo } = do - guard $ any (Set.member (NodeAnnotation "HsRule" "RuleDecl") . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + guard $ any (Set.member ("HsRule", "RuleDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo for_ ( uses n ) addImplicitRoot analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseInstanceDeclaration n@Node{ sourcedNodeInfo } = do - guard $ any (Set.member (NodeAnnotation "ClsInstD" "InstDecl") . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + guard $ any (Set.member ("ClsInstD", "InstDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo traverse_ addImplicitRoot ( uses n ) analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseClassDeclaration n@Node{ sourcedNodeInfo } = do - guard $ any (Set.member (NodeAnnotation "ClassDecl" "TyClDecl") . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + guard $ any (Set.member ("ClassDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo for_ ( findIdentifiers isClassDeclaration n ) $ for_ ( findIdentifiers ( const True ) n ) . addDependency @@ -319,7 +320,7 @@ analyseClassDeclaration n@Node{ sourcedNodeInfo } = do analyseDataDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseDataDeclaration n@Node{ sourcedNodeInfo } = do - guard $ any (Set.member (NodeAnnotation "DataDecl" "TyClDecl") . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + guard $ any (Set.member ("DataDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo for_ ( foldMap @@ -346,7 +347,7 @@ analyseDataDeclaration n@Node{ sourcedNodeInfo } = do constructors :: HieAST a -> Seq ( HieAST a ) constructors n@Node{ nodeChildren, sourcedNodeInfo } = - if any (any ( ("ConDecl" ==) . nodeAnnotType ) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) then + if any (any ( ("ConDecl" ==) . unpackFS . nodeAnnotType) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) then pure n else @@ -354,7 +355,7 @@ constructors n@Node{ nodeChildren, sourcedNodeInfo } = analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analysePatternSynonyms n@Node{ sourcedNodeInfo } = do - guard $ any (Set.member (NodeAnnotation "PatSynBind" "HsBindLR") . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo + guard $ any (Set.member ("PatSynBind", "HsBindLR") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo for_ ( findDeclarations n ) $ for_ ( uses n ) . addDependency @@ -407,3 +408,7 @@ nameToDeclaration :: Name -> Maybe Declaration nameToDeclaration name = do m <- nameModule_maybe name return Declaration { declModule = m, declOccName = nameOccName name } + + +unNodeAnnotation :: NodeAnnotation -> (String, String) +unNodeAnnotation (NodeAnnotation x y) = (unpackFS x, unpackFS y) diff --git a/src/Weeder/Main.hs b/src/Weeder/Main.hs index 58291fe..be36273 100644 --- a/src/Weeder/Main.hs +++ b/src/Weeder/Main.hs @@ -9,11 +9,16 @@ module Weeder.Main ( main, mainWithConfig ) where +-- algebraic-graphs +import Algebra.Graph.Export.Dot ( export, defaultStyleViaShow ) + -- base +import Control.Exception ( evaluate ) import Control.Monad ( guard, unless, when ) import Control.Monad.IO.Class ( liftIO ) import Data.Bool import Data.Foldable +import Data.IORef ( atomicModifyIORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) import Data.Version ( showVersion ) import System.Exit ( exitFailure ) @@ -119,14 +124,13 @@ mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeCl then getFilesIn ".hs" "./." else pure [] - nameCache <- do - uniqSupply <- mkSplitUniqSupply 'z' - return ( initNameCache uniqSupply [] ) + nameCacheUpdater <- + mkNameCacheUpdater analysis <- flip execStateT emptyAnalysis do for_ hieFilePaths \hieFilePath -> do - hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCache hieFilePath ) + hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCacheUpdater hieFilePath ) let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths when (requireHsFiles ==> hsFileExists) do analyseHieFile hieFileResult @@ -216,9 +220,9 @@ getFilesIn ext path = do -- | Read a .hie file, exiting if it's an incompatible version. -readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile -readCompatibleHieFileOrExit nameCache path = do - res <- readHieFileWithVersion (\(v, _) -> v == hieVersion) (NCU (\f -> return $ snd $ f nameCache)) path +readCompatibleHieFileOrExit :: NameCacheUpdater -> FilePath -> IO HieFile +readCompatibleHieFileOrExit nameCacheUpdater path = do + res <- readHieFileWithVersion (\(v, _) -> v == hieVersion) nameCacheUpdater path case res of Right HieFileResult{ hie_file_result } -> return hie_file_result @@ -233,6 +237,19 @@ readCompatibleHieFileOrExit nameCache path = do exitFailure +mkNameCacheUpdater :: IO NameCacheUpdater +mkNameCacheUpdater = do + nameCache <- do + uniqSupply <- mkSplitUniqSupply 'z' + return ( initNameCache uniqSupply [] ) + + nameCacheRef <- newIORef nameCache + + let update_nc f = do r <- atomicModifyIORef nameCacheRef f + _ <- evaluate =<< readIORef nameCacheRef + return r + return (NCU update_nc) + infixr 5 ==> diff --git a/weeder.cabal b/weeder.cabal index cb729d4..d67b050 100644 --- a/weeder.cabal +++ b/weeder.cabal @@ -18,7 +18,7 @@ extra-doc-files: library build-depends: - , algebraic-graphs ^>= 0.4 || ^>= 0.5 + , algebraic-graphs ^>= 0.4 || ^>= 0.5 || ^>= 0.6 , base ^>= 4.16.0.0 , bytestring ^>= 0.10.9.0 || ^>= 0.11.0.0 , containers ^>= 0.6.2.1