nix: Add a tool for checking Haskell imports and exports (#1768)
This commit is contained in:
Remo Rechkemmer
@@ -0,0 +1,358 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | Haskell Imports and Exports tool
|
||||
--
|
||||
-- This tool parses imports and exports from Haskell source files and provides
|
||||
-- analysis on these imports. For example, you can check whether consistent
|
||||
-- import aliases are used across your codebase.
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS8
|
||||
import qualified Data.Csv as Csv
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Dot
|
||||
import qualified GHC
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
|
||||
import qualified Options.Applicative as O
|
||||
import qualified System.FilePath as FP
|
||||
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
import Data.Function ((&))
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (catMaybes, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import HsExtension (GhcPs)
|
||||
import Module (moduleNameString)
|
||||
import OccName (occNameString)
|
||||
import RdrName (rdrNameOcc)
|
||||
import System.Directory.Recursive (getFilesRecursive)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
-- TYPES
|
||||
|
||||
data Options =
|
||||
Options
|
||||
{ command :: Command
|
||||
, sources :: [FilePath]
|
||||
}
|
||||
|
||||
data Command
|
||||
= Dump OutputFormat
|
||||
| GraphSymbols
|
||||
| GraphModules
|
||||
| CheckAliases
|
||||
| CheckWildcards [Text]
|
||||
|
||||
data OutputFormat = OutputCsv | OutputJson
|
||||
|
||||
data ImportedSymbol =
|
||||
ImportedSymbol
|
||||
{ impFromModule :: Text
|
||||
, impModule :: Text
|
||||
, impQualified :: ImportQualified
|
||||
, impAlias :: Maybe Text
|
||||
, impType :: ImportType
|
||||
, impSymbol :: Maybe Text
|
||||
, impInternal :: ModuleInternal
|
||||
, impSource :: FilePath
|
||||
, impFile :: FilePath
|
||||
}
|
||||
deriving (Generic, Csv.ToNamedRecord, Csv.DefaultOrdered, JSON.ToJSON)
|
||||
|
||||
data ImportQualified
|
||||
= Qualified
|
||||
| NotQualified
|
||||
deriving (Eq, Generic, JSON.ToJSON)
|
||||
|
||||
instance Csv.ToField ImportQualified where
|
||||
toField Qualified = "qualified"
|
||||
toField NotQualified = "not qualified"
|
||||
|
||||
data ModuleInternal
|
||||
= Internal
|
||||
| External
|
||||
deriving (Eq, Generic, JSON.ToJSON)
|
||||
|
||||
instance Csv.ToField ModuleInternal where
|
||||
toField Internal = "internal"
|
||||
toField External = "external"
|
||||
|
||||
data ImportType
|
||||
= Wildcard
|
||||
| Hiding
|
||||
| Explicit
|
||||
deriving (Eq, Generic, JSON.ToJSON)
|
||||
|
||||
instance Csv.ToField ImportType where
|
||||
toField Wildcard = "wildcard"
|
||||
toField Hiding = "hiding"
|
||||
toField Explicit = "explicit"
|
||||
|
||||
-- | Mapping of modules to their aliases and to the files they are found in
|
||||
type ModuleAliases = [(Text, [(Text, [FilePath])])]
|
||||
|
||||
-- | Mapping of modules to files
|
||||
type WildcardImports = [(FilePath, [Text])]
|
||||
|
||||
|
||||
-- MAIN
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
run =<< O.customExecParser prefs infoOpts
|
||||
where
|
||||
prefs = O.prefs $ O.subparserInline <> O.showHelpOnEmpty
|
||||
infoOpts =
|
||||
O.info (O.helper <*> opts) $
|
||||
O.fullDesc
|
||||
<> O.header "hsie - Swiss army knife for HaSkell Imports and Exports"
|
||||
<> O.progDesc "Parse Haskell code to analyze imports and exports"
|
||||
opts =
|
||||
Options <$> commandOption <*> O.some srcOption
|
||||
srcOption =
|
||||
O.argument O.str $
|
||||
O.metavar "SRCDIR"
|
||||
<> O.help "Haskell source directory"
|
||||
<> O.action "directory"
|
||||
commandOption =
|
||||
O.subparser $
|
||||
command "dump-imports" "Dump imported symbols as CSV or JSON"
|
||||
(Dump <$> jsonOutputFlag)
|
||||
<> command "graph-modules" "Print dot graph of module imports"
|
||||
(pure GraphModules)
|
||||
<> command "graph-symbols" "Print dot graph of symbol imports"
|
||||
(pure GraphSymbols)
|
||||
<> command "check-aliases"
|
||||
"Check that aliases of imported modules are consistent"
|
||||
(pure CheckAliases)
|
||||
<> command "check-wildcards"
|
||||
"Check that no modules are imported as unqualified wildcards"
|
||||
(CheckWildcards <$> O.many okModuleOption)
|
||||
command name desc options =
|
||||
O.command name . O.info (O.helper <*> options) $ O.progDesc desc
|
||||
jsonOutputFlag =
|
||||
O.flag OutputCsv OutputJson $
|
||||
O.long "json" <> O.short 'j' <> O.help "Output JSON"
|
||||
okModuleOption =
|
||||
O.strOption $
|
||||
O.long "ok"
|
||||
<> O.short 'o'
|
||||
<> O.metavar "OKMODULE"
|
||||
<> O.help "Module that is ok to import as unqualified wildcard"
|
||||
|
||||
run :: Options -> IO ()
|
||||
run Options{command, sources} =
|
||||
runCommand command . markInternal . concat =<< mapM sourceSymbols sources
|
||||
where
|
||||
runCommand :: Command -> [ImportedSymbol] -> IO ()
|
||||
runCommand (Dump format) = LBS8.putStr . dump format
|
||||
runCommand GraphSymbols = T.putStr . symbolsGraph
|
||||
runCommand GraphModules = T.putStr . Dot.encode . modulesGraph
|
||||
runCommand CheckAliases = runInconsistentAliases . inconsistentAliases
|
||||
runCommand (CheckWildcards okModules) = runWildcards . wildcards okModules
|
||||
|
||||
runInconsistentAliases :: ModuleAliases -> IO ()
|
||||
runInconsistentAliases [] = T.putStrLn "No inconsistent module aliases found."
|
||||
runInconsistentAliases xs = T.putStr (formatInconsistentAliases xs) >> exitFailure
|
||||
|
||||
runWildcards :: WildcardImports -> IO ()
|
||||
runWildcards [] = T.putStrLn "No unwanted wildcard imports found."
|
||||
runWildcards xs = T.putStr (formatWildcards xs) >> exitFailure
|
||||
|
||||
-- | Mark imports from modules that are among the analyzed ones as internal.
|
||||
markInternal :: [ImportedSymbol] -> [ImportedSymbol]
|
||||
markInternal symbols =
|
||||
fmap mark symbols
|
||||
where
|
||||
mark s = s { impInternal = if isInternal s then Internal else External }
|
||||
isInternal = flip Set.member internalModules . impModule
|
||||
internalModules = Set.fromList $ fmap impFromModule symbols
|
||||
|
||||
|
||||
-- SYMBOLS
|
||||
|
||||
-- | Parse all imported symbols from a source of Haskell source files
|
||||
sourceSymbols :: FilePath -> IO [ImportedSymbol]
|
||||
sourceSymbols source = do
|
||||
files <- filterExts [".hs", ".imports"] <$> getFilesRecursive source
|
||||
concat <$> mapM moduleSymbols files
|
||||
where
|
||||
filterExts exts = filter $ flip elem exts . FP.takeExtension
|
||||
moduleSymbols filepath = do
|
||||
GHC.HsModule{..} <- parseModule filepath
|
||||
return $ concatMap (importSymbols source filepath . GHC.unLoc) hsmodImports
|
||||
|
||||
-- | Parse a Haskell module
|
||||
parseModule :: String -> IO (GHC.HsModule GhcPs)
|
||||
parseModule filepath = do
|
||||
result <- ExactPrint.parseModule filepath
|
||||
case result of
|
||||
Right (_, hsmod) ->
|
||||
return $ GHC.unLoc hsmod
|
||||
Left (loc, err) ->
|
||||
fail $ "Error with " <> show filepath <> " at " <> show loc <> ": " <> err
|
||||
|
||||
-- | Symbols imported in an import declaration.
|
||||
--
|
||||
-- If the import is a wildcard, i.e. no symbols are selected for import, then
|
||||
-- only one item is returned.
|
||||
importSymbols :: FilePath -> FilePath -> GHC.ImportDecl GhcPs -> [ImportedSymbol]
|
||||
importSymbols _ _ (GHC.XImportDecl _) = mempty
|
||||
importSymbols source filepath GHC.ImportDecl{..} =
|
||||
case ideclHiding of
|
||||
Just (hiding, syms) ->
|
||||
symbol (if hiding then Hiding else Explicit) . Just . GHC.unLoc <$> GHC.unLoc syms
|
||||
Nothing ->
|
||||
[ symbol Wildcard Nothing ]
|
||||
where
|
||||
symbol hiding sym =
|
||||
ImportedSymbol
|
||||
{ impFile = relativePath filepath
|
||||
, impSource = source
|
||||
, impFromModule = T.pack $ moduleFromPath filepath
|
||||
, impModule = T.pack . moduleNameString . GHC.unLoc $ ideclName
|
||||
, impQualified = if ideclQualified then Qualified else NotQualified
|
||||
, impAlias = T.pack . moduleNameString . GHC.unLoc <$> ideclAs
|
||||
, impInternal = External
|
||||
, impType = hiding
|
||||
, impSymbol = T.pack . occNameString . rdrNameOcc . GHC.ieName <$> sym
|
||||
}
|
||||
moduleFromPath =
|
||||
intercalate "." . FP.splitDirectories . FP.dropExtension . relativePath
|
||||
relativePath = FP.makeRelative source
|
||||
|
||||
|
||||
-- DUMP
|
||||
|
||||
-- | Dump list of symbols as CSV or JSON
|
||||
dump :: OutputFormat -> [ImportedSymbol] -> LBS8.ByteString
|
||||
dump OutputCsv = Csv.encodeDefaultOrderedByName
|
||||
dump OutputJson = encodePretty
|
||||
|
||||
|
||||
-- ALIASES
|
||||
|
||||
-- | Find modules that are imported under different aliases
|
||||
inconsistentAliases :: [ImportedSymbol] -> ModuleAliases
|
||||
inconsistentAliases symbols =
|
||||
fmap moduleAlias symbols
|
||||
& foldr insertSetMapMap Map.empty
|
||||
& Map.map (aliases . Map.toList)
|
||||
& Map.filter ((<) 1 . length)
|
||||
& Map.toList
|
||||
where
|
||||
moduleAlias ImportedSymbol{..} =
|
||||
(impModule, impAlias, FP.joinPath [impSource, impFile])
|
||||
insertSetMapMap (k1, k2, v) =
|
||||
Map.insertWith (Map.unionWith Set.union) k1
|
||||
(Map.singleton k2 $ Set.singleton v)
|
||||
aliases :: [(Maybe Text, Set.Set FilePath)] -> [(Text, [FilePath])]
|
||||
aliases = mapMaybe (\(k, v) -> fmap (, Set.toList v) k)
|
||||
|
||||
formatInconsistentAliases :: ModuleAliases -> Text
|
||||
formatInconsistentAliases modules =
|
||||
"The following imports have inconsistent aliases:\n\n"
|
||||
<> T.concat (fmap formatModule modules)
|
||||
where
|
||||
formatModule (modName, aliases) =
|
||||
"Module '"
|
||||
<> modName
|
||||
<> "' has the aliases:\n"
|
||||
<> T.concat (fmap formatAlias aliases)
|
||||
<> "\n"
|
||||
formatAlias (alias, sourceFiles) =
|
||||
" '"
|
||||
<> alias
|
||||
<> "' in file"
|
||||
<> (if length sourceFiles > 2 then "s" else "")
|
||||
<> ":\n"
|
||||
<> T.concat (fmap formatFile sourceFiles)
|
||||
formatFile sourceFile =
|
||||
" " <> T.pack sourceFile <> "\n"
|
||||
|
||||
|
||||
-- WILDCARDS
|
||||
|
||||
-- | Find modules that are imported as wildcards, excluding whitelisted modules.
|
||||
--
|
||||
-- Wildcard imports are ones that are not qualified and do not specify which
|
||||
-- symbols should be imported.
|
||||
wildcards :: [Text] -> [ImportedSymbol] -> WildcardImports
|
||||
wildcards okModules =
|
||||
groupByFile . filter isWildcard . filter (not . isOkModule)
|
||||
where
|
||||
isWildcard ImportedSymbol{..} =
|
||||
impQualified == NotQualified && impType /= Explicit
|
||||
isOkModule = flip Set.member (Set.fromList okModules) . impModule
|
||||
groupByFile = Map.toList . fmap Set.toList . foldr insertMap Map.empty
|
||||
insertMap ImportedSymbol{..} =
|
||||
Map.insertWith Set.union impFile (Set.singleton impModule)
|
||||
|
||||
formatWildcards :: WildcardImports -> Text
|
||||
formatWildcards files =
|
||||
"Modules in the following files were imported as wildcards:\n\n"
|
||||
<> T.concat (fmap formatFile files)
|
||||
where
|
||||
formatFile (filepath, modules) =
|
||||
"In " <> T.pack filepath <> ":\n" <> T.concat (fmap formatModule modules) <> "\n"
|
||||
formatModule moduleName = " " <> moduleName <> "\n"
|
||||
|
||||
|
||||
-- GRAPHS
|
||||
|
||||
modulesGraph :: [ImportedSymbol] -> Dot.DotGraph
|
||||
modulesGraph symbols =
|
||||
Dot.DotGraph Dot.Strict Dot.Directed (Just "Modules") $ fmap edge edges
|
||||
where
|
||||
edge (from, to) =
|
||||
Dot.StatementEdge $ Dot.EdgeStatement
|
||||
(Dot.ListTwo (edgeNode from) (edgeNode to) mempty) mempty
|
||||
edgeNode t = Dot.EdgeNode $ Dot.NodeId (Dot.Id t) Nothing
|
||||
edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols
|
||||
edgeTuple ImportedSymbol{..} = (impFromModule, impModule)
|
||||
unique = Set.toList . Set.fromList
|
||||
|
||||
-- Building Text directly as the Dot package currently doesn't support subgraphs.
|
||||
symbolsGraph :: [ImportedSymbol] -> Text
|
||||
symbolsGraph symbols =
|
||||
"digraph Symbols {\n"
|
||||
<> " rankdir=LR\n"
|
||||
<> " ranksep=5\n"
|
||||
<> T.concat (fmap edge edges)
|
||||
<> T.concat (fmap cluster symbolsByModule)
|
||||
<> "}\n"
|
||||
where
|
||||
edge (from, to, symbol) =
|
||||
" "
|
||||
<> quoted from
|
||||
<> " -> "
|
||||
<> quoted (to <> maybe "" ("." <>) symbol)
|
||||
<> "\n"
|
||||
cluster (moduleName, clusterSymbols) =
|
||||
" subgraph "
|
||||
<> quoted ("cluster_" <> moduleName)
|
||||
<> " {\n"
|
||||
<> " " <> quoted moduleName <> "\n"
|
||||
<> T.concat (fmap (clusterNode moduleName) clusterSymbols)
|
||||
<> " }\n"
|
||||
clusterNode moduleName symbol =
|
||||
" " <> quoted (moduleName <> "." <> symbol) <> "\n"
|
||||
quoted t = "\"" <> t <> "\""
|
||||
edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols
|
||||
edgeTuple ImportedSymbol{..} = (impFromModule, impModule, impSymbol)
|
||||
unique = Set.toList . Set.fromList
|
||||
symbolsByModule =
|
||||
Map.toList . Map.map (catMaybes . Set.toList) . foldr insertMap Map.empty $ edges
|
||||
insertMap (_, to, symbol) = Map.insertWith Set.union to $ Set.singleton symbol
|
||||
Reference in New Issue
Block a user