ocharles/weeder
1
1
Fork 0
mirror of https://github.com/ocharles/weeder.git synced 2024-11-26 16:52:55 +03:00
Code Issues Projects Releases Wiki Activity

Fixes

Browse Source
This commit is contained in:
Ollie Charles 2022-05-12 16:33:22 +01:00
parent b234b20c5a
commit c468cd10bf
3 changed files with 39 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Weeder.hs
View File

@ -48,6 +48,7 @@ import qualified Data.Set as Set
import Data.Generics.Labels () import Data.Generics.Labels ()
-- ghc -- ghc
import GHC.Data.FastString ( unpackFS )
import GHC.Types.Avail import GHC.Types.Avail
( AvailInfo( Avail, AvailTC ) ( AvailInfo( Avail, AvailTC )
, GreName( NormalGreName, FieldGreName ) , GreName( NormalGreName, FieldGreName )
@ -61,7 +62,7 @@ import GHC.Iface.Ext.Types
, HieASTs( HieASTs ) , HieASTs( HieASTs )
, HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file ) , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file )
, IdentifierDetails( IdentifierDetails, identInfo ) , IdentifierDetails( IdentifierDetails, identInfo )
, NodeAnnotation( NodeAnnotation, nodeAnnotConstr, nodeAnnotType ) , NodeAnnotation( NodeAnnotation, nodeAnnotType )
, NodeInfo( nodeIdentifiers, nodeAnnotations ) , NodeInfo( nodeIdentifiers, nodeAnnotations )
, Scope( ModuleScope ) , Scope( ModuleScope )
, getSourcedNodeInfo , getSourcedNodeInfo
@ -276,8 +277,8 @@ topLevelAnalysis n@Node{ nodeChildren } = do
analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do
let bindAnns = Set.fromList [(NodeAnnotation "FunBind" "HsBindLR"), (NodeAnnotation "PatBind" "HsBindLR")] let bindAnns = Set.fromList [("FunBind", "HsBindLR"), ("PatBind", "HsBindLR")]
guard $ any (not . Set.disjoint bindAnns . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo guard $ any (not . Set.disjoint bindAnns . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
for_ ( findDeclarations n ) \d -> do for_ ( findDeclarations n ) \d -> do
define d nodeSpan define d nodeSpan
@ -287,21 +288,21 @@ analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do
analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseRewriteRule n@Node{ sourcedNodeInfo } = do 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 for_ ( uses n ) addImplicitRoot
analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseInstanceDeclaration n@Node{ sourcedNodeInfo } = do 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 ) traverse_ addImplicitRoot ( uses n )
analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseClassDeclaration n@Node{ sourcedNodeInfo } = do 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 isClassDeclaration n ) $
for_ ( findIdentifiers ( const True ) n ) . addDependency 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 :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analyseDataDeclaration n@Node{ sourcedNodeInfo } = do 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_ for_
( foldMap ( foldMap
@ -346,7 +347,7 @@ analyseDataDeclaration n@Node{ sourcedNodeInfo } = do
constructors :: HieAST a -> Seq ( HieAST a ) constructors :: HieAST a -> Seq ( HieAST a )
constructors n@Node{ nodeChildren, sourcedNodeInfo } = 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 pure n
else else
@ -354,7 +355,7 @@ constructors n@Node{ nodeChildren, sourcedNodeInfo } =
analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
analysePatternSynonyms n@Node{ sourcedNodeInfo } = do 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 for_ ( findDeclarations n ) $ for_ ( uses n ) . addDependency
@ -407,3 +408,7 @@ nameToDeclaration :: Name -> Maybe Declaration
nameToDeclaration name = do nameToDeclaration name = do
m <- nameModule_maybe name m <- nameModule_maybe name
return Declaration { declModule = m, declOccName = nameOccName name } return Declaration { declModule = m, declOccName = nameOccName name }
unNodeAnnotation :: NodeAnnotation -> (String, String)
unNodeAnnotation (NodeAnnotation x y) = (unpackFS x, unpackFS y)

31
src/Weeder/Main.hs
View File

@ -9,11 +9,16 @@
module Weeder.Main ( main, mainWithConfig ) where module Weeder.Main ( main, mainWithConfig ) where
-- algebraic-graphs
import Algebra.Graph.Export.Dot ( export, defaultStyleViaShow )
-- base -- base
import Control.Exception ( evaluate )
import Control.Monad ( guard, unless, when ) import Control.Monad ( guard, unless, when )
import Control.Monad.IO.Class ( liftIO ) import Control.Monad.IO.Class ( liftIO )
import Data.Bool import Data.Bool
import Data.Foldable import Data.Foldable
import Data.IORef ( atomicModifyIORef, newIORef, readIORef )
import Data.List ( isSuffixOf ) import Data.List ( isSuffixOf )
import Data.Version ( showVersion ) import Data.Version ( showVersion )
import System.Exit ( exitFailure ) import System.Exit ( exitFailure )
@ -119,14 +124,13 @@ mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeCl
then getFilesIn ".hs" "./." then getFilesIn ".hs" "./."
else pure [] else pure []
nameCache <- do nameCacheUpdater <-
uniqSupply <- mkSplitUniqSupply 'z' mkNameCacheUpdater
return ( initNameCache uniqSupply [] )
analysis <- analysis <-
flip execStateT emptyAnalysis do flip execStateT emptyAnalysis do
for_ hieFilePaths \hieFilePath -> do for_ hieFilePaths \hieFilePath -> do
hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCache hieFilePath ) hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCacheUpdater hieFilePath )
let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths
when (requireHsFiles ==> hsFileExists) do when (requireHsFiles ==> hsFileExists) do
analyseHieFile hieFileResult analyseHieFile hieFileResult
@ -216,9 +220,9 @@ getFilesIn ext path = do
-- | Read a .hie file, exiting if it's an incompatible version. -- | Read a .hie file, exiting if it's an incompatible version.
readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile readCompatibleHieFileOrExit :: NameCacheUpdater -> FilePath -> IO HieFile
readCompatibleHieFileOrExit nameCache path = do readCompatibleHieFileOrExit nameCacheUpdater path = do
res <- readHieFileWithVersion (\(v, _) -> v == hieVersion) (NCU (\f -> return $ snd $ f nameCache)) path res <- readHieFileWithVersion (\(v, _) -> v == hieVersion) nameCacheUpdater path
case res of case res of
Right HieFileResult{ hie_file_result } -> Right HieFileResult{ hie_file_result } ->
return hie_file_result return hie_file_result
@ -233,6 +237,19 @@ readCompatibleHieFileOrExit nameCache path = do
exitFailure 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 ==> infixr 5 ==>

2
weeder.cabal
View File

@ -18,7 +18,7 @@ extra-doc-files:
library library
build-depends: build-depends:
, algebraic-graphs ^>= 0.4 || ^>= 0.5 , algebraic-graphs ^>= 0.4 || ^>= 0.5 || ^>= 0.6
, base ^>= 4.16.0.0 , base ^>= 4.16.0.0
, bytestring ^>= 0.10.9.0 || ^>= 0.11.0.0 , bytestring ^>= 0.10.9.0 || ^>= 0.11.0.0
, containers ^>= 0.6.2.1 , containers ^>= 0.6.2.1