importify (empty) → 1.0
raw patch · 39 files changed
+2883/−0 lines, 39 filesdep +Cabaldep +aesondep +aeson-prettysetup-changed
Dependencies added: Cabal, aeson, aeson-pretty, autoexporter, base, bytestring, containers, filepath, fmt, foldl, hashable, haskell-names, haskell-src-exts, hse-cpp, hspec, importify, log-warper, microlens-platform, optparse-applicative, path, path-io, pretty-simple, syb, template-haskell, text, text-format, turtle, universum, unordered-containers, yaml
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- app/Main.hs +39/−0
- app/Options.hs +115/−0
- importify.cabal +164/−0
- src/Extended/Data/Bool.hs +13/−0
- src/Extended/Data/List.hs +23/−0
- src/Extended/Data/Str.hs +28/−0
- src/Extended/Lens/TH.hs +28/−0
- src/Extended/System/Wlog.hs +52/−0
- src/Importify/Cabal.hs +1/−0
- src/Importify/Cabal/Extension.hs +42/−0
- src/Importify/Cabal/Module.hs +71/−0
- src/Importify/Cabal/Package.hs +60/−0
- src/Importify/Cabal/Target.hs +254/−0
- src/Importify/Environment.hs +82/−0
- src/Importify/Main.hs +1/−0
- src/Importify/Main/Cache.hs +308/−0
- src/Importify/Main/File.hs +208/−0
- src/Importify/ParseException.hs +51/−0
- src/Importify/Path.hs +123/−0
- src/Importify/Preprocessor.hs +87/−0
- src/Importify/Pretty.hs +71/−0
- src/Importify/Resolution.hs +1/−0
- src/Importify/Resolution/Explicit.hs +73/−0
- src/Importify/Resolution/Hiding.hs +58/−0
- src/Importify/Resolution/Implicit.hs +44/−0
- src/Importify/Resolution/Qualified.hs +77/−0
- src/Importify/Stack.hs +177/−0
- src/Importify/Syntax.hs +1/−0
- src/Importify/Syntax/Import.hs +101/−0
- src/Importify/Syntax/Module.hs +64/−0
- src/Importify/Syntax/Scoped.hs +34/−0
- src/Importify/Syntax/Text.hs +41/−0
- src/Importify/Tree.hs +169/−0
- test/GGenerator.hs +57/−0
- test/hspec/Runner.hs +29/−0
- test/hspec/Test/Cache.hs +57/−0
- test/hspec/Test/File.hs +56/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Serokell++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,39 @@+{-| Tool for managing import sections.++ Remove redundant imports algorithm (current version):+ 1. For every import declaration that in @loadEnvironment@+ traverse list of import names and collect those that are not in module.+ 2. Remove every name from corresponding imports lists.+ 3. Print new modified version of file with imports changed.+ -}++module Main where++import Universum++import System.Wlog (severityPlus)++import Extended.System.Wlog (initImportifyLogger)+import Importify.Environment (runCache)+import Importify.Main (importifyCacheList, importifyCacheProject, importifyFileOptions)++import Options (CabalCacheOptions (..), Command (..), ImportifyCliArgs (..), SingleFileOptions (..),+ coLoggingSeverity, parseOptions)++main :: IO ()+main = do+ ImportifyCliArgs{..} <- parseOptions+ initImportifyLogger (severityPlus $ coLoggingSeverity icaCommon)+ case icaCommand of+ SingleFile sfOpts -> importifySingleFile sfOpts+ CabalCache ccOpts -> buildCabalCache ccOpts++importifySingleFile :: SingleFileOptions -> IO ()+importifySingleFile SingleFileOptions{..} =+ importifyFileOptions sfoOutput sfoFileName++buildCabalCache :: CabalCacheOptions -> IO ()+buildCabalCache CabalCacheOptions{..} =+ runCache ccoSaveSources $ case ccoDependencies of+ [] -> importifyCacheProject+ (d:ds) -> importifyCacheList (d :| ds)
+ app/Options.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ApplicativeDo #-}++-- | Command line options for Importify++module Options+ ( ImportifyCliArgs (..)+ , CommonOptions (..)+ , Command (..)+ , CabalCacheOptions (..)+ , SingleFileOptions (..)++ , parseOptions+ ) where++import Universum++import Options.Applicative (Parser, ParserInfo, auto, command, execParser, flag', fullDesc, help,+ helper, info, long, metavar, option, progDesc, short, showDefault,+ strArgument, strOption, subparser, switch, value)+import System.Wlog (Severity (Info))++import Importify.Main (OutputOptions (..))++data ImportifyCliArgs = ImportifyCliArgs+ { icaCommon :: !CommonOptions+ , icaCommand :: !Command+ } deriving (Show)++newtype CommonOptions = CommonOptions+ { coLoggingSeverity :: Severity -- ^ Severity for logger+ } deriving (Show)++data Command+ = SingleFile SingleFileOptions+ | CabalCache CabalCacheOptions+ deriving (Show)++data SingleFileOptions = SingleFileOptions+ { sfoFileName :: !FilePath -- ^ File where all redundant imports should be removed+ , sfoOutput :: !OutputOptions -- ^ Options for @importify file@ output+ } deriving (Show)++data CabalCacheOptions = CabalCacheOptions+ { ccoSaveSources :: !Bool -- ^ Don't delete downloaded package cache+ , ccoDependencies :: ![Text] -- ^ Use specified dependencies overriding .cabal ones+ } deriving (Show)++cliArgumentsParser :: Parser ImportifyCliArgs+cliArgumentsParser = do+ icaCommon <- commonArgsParser+ icaCommand <- commandParser+ pure ImportifyCliArgs{..}++commonArgsParser :: Parser CommonOptions+commonArgsParser = do+ coLoggingSeverity <- option auto $+ metavar "SEVERITY"+ <> long "logging-severity"+ <> short 'l'+ <> value Info+ <> showDefault+ <> help "Severity for logger"+ pure CommonOptions{..}++commandParser :: Parser Command+commandParser = subparser $+ command "file"+ (info (helper <*> fileParser)+ (fullDesc <> progDesc "Importify a single file."))+ <> command "cache"+ (info (helper <*> cacheParser)+ (fullDesc <> progDesc+ "Search for .cabal file in current directory. If it's found then cache \+ \all dependencies for every target and store them inside ./.importify folder."))++fileParser :: Parser Command+fileParser = do+ sfoFileName <- strArgument+ $ metavar "FILE"+ <> help "File to importify"+ sfoOutput <- outputOptionsParser+ pure (SingleFile SingleFileOptions{..})+ where+ outputOptionsParser :: Parser OutputOptions+ outputOptionsParser =+ flag' InPlace ( long "in-place"+ <> short 'i'+ <> help "Write changes directly to file")+ <|> ToFile <$> strOption ( long "to"+ <> short 't'+ <> help "Write to specified file")+ <|> pure ToConsole++cacheParser :: Parser Command+cacheParser = do+ ccoSaveSources <- switch+ $ long "preserve"+ <> short 'p'+ <> help "Don't remove downloaded package cache"+ ccoDependencies <- many $ strOption+ $ metavar "[STRING]"+ <> long "dependency"+ <> short 'd'+ <> help "List of manually specified dependencies that should be used \+ \for caching instead of libraries from .cabal file. This option \+ \overrides default behavior."+ pure (CabalCache CabalCacheOptions{..})++optsInfo :: ParserInfo ImportifyCliArgs+optsInfo = info+ (helper <*> cliArgumentsParser)+ (fullDesc <> progDesc "Importify - manage Haskell imports easily")++parseOptions :: IO ImportifyCliArgs+parseOptions = execParser optsInfo
+ importify.cabal view
@@ -0,0 +1,164 @@+name: importify+version: 1.0+synopsis: Tool for haskell imports refactoring+description: Please see README.md+homepage: https://github.com/serokell/importify+bug-reports: https://github.com/serokell/importify/issues+license: MIT+license-file: LICENSE+author: @serokell+maintainer: Serokell <hi@serokell.io>+copyright: 2017 Serokell+category: Development, Refactoring+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 8.0.1+ , GHC == 8.0.2+ , GHC == 8.2.1++source-repository head+ type: git+ location: https://github.com/serokell/importify++library+ hs-source-dirs: src+ exposed-modules:+ Importify.Cabal+ Importify.Cabal.Extension+ Importify.Cabal.Module+ Importify.Cabal.Package+ Importify.Cabal.Target+ Importify.Environment+ Importify.Main+ Importify.Main.Cache+ Importify.Main.File+ Importify.ParseException+ Importify.Path+ Importify.Preprocessor+ Importify.Pretty+ Importify.Resolution+ Importify.Resolution.Explicit+ Importify.Resolution.Hiding+ Importify.Resolution.Implicit+ Importify.Resolution.Qualified+ Importify.Stack+ Importify.Syntax+ Importify.Syntax.Import+ Importify.Syntax.Module+ Importify.Syntax.Scoped+ Importify.Syntax.Text+ Importify.Tree++ Extended.System.Wlog++ other-modules: Extended.Data.Bool+ Extended.Data.List+ Extended.Data.Str+ Extended.Lens.TH++ build-depends: base >= 4.7 && < 5+ , aeson+ , aeson-pretty+ , autoexporter+ , bytestring+ , Cabal+ , containers+ , filepath+ , fmt+ , foldl+ , hashable+ , haskell-names+ , haskell-src-exts+ , hse-cpp+ , log-warper >= 1.8.2+ , microlens-platform+ , path+ , path-io+ , pretty-simple+ , syb+ , template-haskell+ , text+ , text-format+ , turtle+ , universum >= 1.0.0+ , unordered-containers+ , yaml++ ghc-options: -Wall+ if os(linux)+ ghc-options: -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold++ default-language: Haskell2010+ default-extensions: GeneralizedNewtypeDeriving+ LambdaCase+ NoImplicitPrelude+ OverloadedStrings+ PartialTypeSignatures+ RecordWildCards++executable importify+ hs-source-dirs: app+ main-is: Main.hs+ other-modules: Options++ build-depends: base, importify+ , log-warper >= 1.8.2+ , optparse-applicative+ , universum >= 1.0.0++ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ if os(linux)+ ghc-options: -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold++ default-language: Haskell2010+ default-extensions: GeneralizedNewtypeDeriving+ NoImplicitPrelude+ OverloadedStrings+ RecordWildCards++executable golden-generator+ hs-source-dirs: test+ main-is: GGenerator.hs++ build-depends: base, importify+ , text+ , path+ , path-io+ , universum >= 1.0.0++ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ if os(linux)+ ghc-options: -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold++ default-language: Haskell2010++test-suite importify-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test/hspec+ main-is: Runner.hs+ other-modules: Test.Cache+ Test.File++ build-depends: base, importify+ , filepath+ , hspec+ , log-warper >= 1.8.2+ , microlens-platform+ , path+ , path-io+ , universum >= 1.0.0+ , unordered-containers++ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ if os(linux)+ ghc-options: -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold++ default-language: Haskell2010+ default-extensions: GeneralizedNewtypeDeriving+ NoImplicitPrelude+ OverloadedStrings+ RecordWildCards
+ src/Extended/Data/Bool.hs view
@@ -0,0 +1,13 @@+-- | Extended utilities for 'Bool' type.++module Extended.Data.Bool+ ( (==>)+ ) where++import Universum++-- | Logical implication.+(==>) :: Bool -> Bool -> Bool+False ==> _ = True+True ==> x = x+infixr 4 ==>
+ src/Extended/Data/List.hs view
@@ -0,0 +1,23 @@+-- | This module contains additional utility functions for list.++module Extended.Data.List+ ( removeAt+ , removeAtMultiple+ ) where++import Universum++-- | Removes element from list by given index. If there's+-- no element at such index then list returns unchanged.+removeAt :: Int -> [a] -> [a]+removeAt i l | i < 0 = l+removeAt i l = case after of+ [] -> l+ (_:rest) -> before ++ rest+ where (before, after) = splitAt i l++-- | Like 'removeAt' but takes list of indices to remove.+removeAtMultiple :: [Int] -> [a] -> [a]+removeAtMultiple indices = map snd+ . filter ((`notElem` indices) . fst)+ . zip [0..]
+ src/Extended/Data/Str.hs view
@@ -0,0 +1,28 @@+-- | Utilities to work with textual types.++module Extended.Data.Str+ ( -- * Wrapping+ charWrap+ , wordWrap+ ) where++import Universum++import qualified Data.Text as T++-- | Wraps given string into lines non exceeding given length+-- splitting by chars.+charWrap :: Int -> String -> Text+charWrap n = unlines . T.chunksOf n . toText++-- | Wraps given string into lines non exceeding given length+-- splitting by words.+wordWrap :: Int -> String -> Text+wordWrap n = unlines . map unwords . go 0 [] . words . toText+ where+ go :: Int -> [Text] -> [Text] -> [[Text]]+ go _ row [] = [row]+ go acc row (w:ws) = let newAcc = acc + T.length w+ in if newAcc > n+ then row : go 0 [] ws+ else go newAcc (row ++ [w]) ws
+ src/Extended/Lens/TH.hs view
@@ -0,0 +1,28 @@+-- | @TemplateHaskell@ utilities for generating lens fields.++module Extended.Lens.TH+ ( fieldsVerboseLensRules+ ) where++import Universum++import Data.Char (toUpper)+import Data.List (stripPrefix)+import Language.Haskell.TH.Syntax (Name, mkName, nameBase)+import Lens.Micro.Platform (DefName (MethodName), LensRules,+ camelCaseFields, lensField, makeLensesWith)++-- | A field namer for 'fieldsVerboseLensRules'.+verboseFieldsNamer :: Name -> [Name] -> Name -> [DefName]+verboseFieldsNamer _ _ fieldName = maybeToList $ do+ fieldUnprefixed@(x:xs) <- stripPrefix "_" (nameBase fieldName)+ let className = "HasPoly" ++ toUpper x : xs+ let methodName = fieldUnprefixed+ pure (MethodName (mkName className) (mkName methodName))++-- | Custom rules for generating lenses. This is similar to+-- @makeFields@ but generated type classes have names like @HasPolyFoo@+-- instead of @HasFoo@ so they supposed to be used by introducing new+-- constraint aliases. See 'Importify.Environment' for details.+fieldsVerboseLensRules :: LensRules+fieldsVerboseLensRules = camelCaseFields & lensField .~ verboseFieldsNamer
+ src/Extended/System/Wlog.hs view
@@ -0,0 +1,52 @@+-- | Extended @log-warper@ functionality to work with importify tool.++module Extended.System.Wlog+ ( initImportifyLogger+ , printDebug+ , printError+ , printInfo+ , printNotice+ , printWarning+ ) where++import Universum++import Lens.Micro.Platform (zoom, (.=), (?=))+import System.Wlog (LoggerConfig, LoggerNameBox, Severities, lcShowTime, lcTree, logDebug, logError,+ logInfo, logNotice, logWarning, ltSeverity, productionB, setupLogging,+ usingLoggerName, warningPlus, zoomLogger)++importifyLoggerConfig :: Severities -> LoggerConfig+importifyLoggerConfig importifySeverities = executingState productionB $ do+ lcShowTime .= Any False+ zoom lcTree $ do+ ltSeverity ?= warningPlus+ zoomLogger "importify" $+ ltSeverity ?= importifySeverities++-- | Initializes importify logger.+initImportifyLogger :: MonadIO m => Severities -> m ()+initImportifyLogger = setupLogging Nothing . importifyLoggerConfig++withImportify :: LoggerNameBox m a -> m a+withImportify = usingLoggerName "importify"++-- | Prints 'System.Wlog.Debug' message.+printDebug :: MonadIO m => Text -> m ()+printDebug = liftIO . withImportify . logDebug++-- | Prints 'Info' message.+printInfo :: MonadIO m => Text -> m ()+printInfo = liftIO . withImportify . logInfo++-- | Prints 'Notice' message.+printNotice :: MonadIO m => Text -> m ()+printNotice = liftIO . withImportify . logNotice++-- | Prints 'Warning' message.+printWarning :: MonadIO m => Text -> m ()+printWarning = liftIO . withImportify . logWarning++-- | Prints 'Error' message.+printError :: MonadIO m => Text -> m ()+printError = liftIO . withImportify . logError
+ src/Importify/Cabal.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Importify/Cabal/Extension.hs view
@@ -0,0 +1,42 @@+-- | Functions that work with 'Extension's in .cabal file and in+-- separate.++module Importify.Cabal.Extension+ ( buildInfoExtensions+ , withHarmlessExtensions+ ) where++import Universum++import qualified Distribution.ModuleName as Cabal+import Distribution.PackageDescription (BuildInfo (..))+import qualified Language.Haskell.Extension as Cabal (Extension (..))+import Language.Haskell.Exts.Extension (Extension (..), KnownExtension (..))+++-- | Get list of all extensions from 'BuildInfo' and convert them into+-- 'HSE.Extension'.+buildInfoExtensions :: BuildInfo -> [Extension]+buildInfoExtensions BuildInfo{..} = mapMaybe cabalExtToHseExt+ $ defaultExtensions ++ otherExtensions++cabalExtToHseExt :: Cabal.Extension -> Maybe Extension+cabalExtToHseExt = readMaybe . show++{-+showExt :: Cabal.Extension -> String+showExt (Cabal.EnableExtension ext) = show ext+showExt (Cabal.DisableExtension ext) = "No" ++ show ext+showExt (Cabal.UnknownExtension name) = name+-}++-- | This function add list of harmless extensions wich helps to avoid+-- some parsing errors but doesn't affect already correct parsing+-- results.+withHarmlessExtensions :: [Extension] -> [Extension]+withHarmlessExtensions = ordNub+ . (++ map EnableExtension [ MultiParamTypeClasses+ , FlexibleContexts+ , ConstraintKinds+ , ExplicitNamespaces+ ])
+ src/Importify/Cabal/Module.hs view
@@ -0,0 +1,71 @@+-- | Functions to operate with @exposed-modules@ and @other-modules@+-- parts of .cabal file.++module Importify.Cabal.Module+ ( modulePaths+ , splitOnExposedAndOther+ ) where++import Universum hiding (fromString)++import Data.List (partition)+import Distribution.ModuleName (ModuleName, fromString, toFilePath)+import qualified Distribution.ModuleName as Cabal+import Distribution.PackageDescription (BuildInfo (..), Library (..))+import qualified Language.Haskell.Exts as HSE+import Path (Abs, Dir, File, Path, Rel, parseRelDir,+ parseRelFile, (</>))+import Path.IO (doesFileExist)++import Importify.Syntax (getModuleTitle)++-- | Split list of modules into /exposed/ modules and /other/ modules for given library.+-- __First__ element of pair represents /exposed/ modules.+-- __Second__ element of paris represents /other/ modules.+splitOnExposedAndOther :: Library+ -> [HSE.Module l]+ -> ([HSE.Module l], [HSE.Module l])+splitOnExposedAndOther Library{..} =+ partition ((`elem` exposedModules) . Cabal.fromString . getModuleTitle)++-- | Returns list of absolute paths to all modules inside given target.+modulePaths :: Path Abs Dir+ -- ^ Absolute path to project directory+ -> BuildInfo+ -- ^ 'BuildInfo' for given target+ -> Either [ModuleName] FilePath+ -- ^ Modules for Library and path for others+ -> IO [Path Abs File]+modulePaths packagePath BuildInfo{..} extra = do+ let (cur, others) = partition (== ".") hsSourceDirs+ case (cur, others) of+ (_here, []) -> collectModulesHere+ ([] , paths) -> collectModulesThere paths+ (_here, paths) -> liftA2 (++) collectModulesHere (collectModulesThere paths)+ where+ modulesToPaths :: [ModuleName] -> IO [Path Rel File]+ modulesToPaths = mapM (parseRelFile . (++ ".hs") . toFilePath)++ targetModulePaths :: IO [Path Rel File]+ targetModulePaths = case extra of+ Left modules -> modulesToPaths $ otherModules ++ modules+ Right path -> liftA2 (:) (parseRelFile path) (modulesToPaths otherModules)++ addDir :: Path Abs Dir -> [Path Rel File] -> [Path Abs File]+ addDir dir = map (dir </>)++ collectModulesHere :: IO [Path Abs File]+ collectModulesHere = do+ paths <- targetModulePaths+ let packagePaths = addDir packagePath paths+ keepExistingModules packagePaths++ collectModulesThere :: [FilePath] -> IO [Path Abs File]+ collectModulesThere dirs = do+ dirPaths <- mapM parseRelDir dirs+ modPaths <- targetModulePaths+ concatForM dirPaths $ \dir ->+ keepExistingModules $ addDir (packagePath </> dir) modPaths++ keepExistingModules :: [Path Abs File] -> IO [Path Abs File]+ keepExistingModules = filterM doesFileExist
+ src/Importify/Cabal/Package.hs view
@@ -0,0 +1,60 @@+-- | Utility functions to work with 'GenericPackageDescription' and+-- other miscellaneous stuff in .cabal files.++module Importify.Cabal.Package+ ( extractFromTargets+ , packageDependencies+ , readCabal+ ) where++import Universum hiding (fromString)++import Distribution.Package (Dependency (..), unPackageName)+import Distribution.PackageDescription (Benchmark (benchmarkBuildInfo),+ BuildInfo (..), CondTree,+ Executable (..),+ GenericPackageDescription (..),+ Library (..),+ TestSuite (testBuildInfo),+ condTreeData)+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Verbosity (normal)++-- | Parse 'GenericPackageDescription' from given path to .cabal file.+readCabal :: MonadIO m => FilePath -> m GenericPackageDescription+readCabal = liftIO . readPackageDescription normal++dependencyName :: Dependency -> String+dependencyName (Dependency name _) = unPackageName name++-- | Retrieve list of unique names for all package dependencies inside+-- library, all executables, all test suites and all benchmarks for a+-- given package.+packageDependencies :: GenericPackageDescription -> [String]+packageDependencies = ordNub+ . concatMap (map dependencyName . targetBuildDepends)+ . allBuildInfos++allBuildInfos :: GenericPackageDescription -> [BuildInfo]+allBuildInfos = extractFromTargets libBuildInfo+ buildInfo+ testBuildInfo+ benchmarkBuildInfo++-- | Extract some uniform data from every target if it's present.+extractFromTargets :: (Library -> r) -- ^ 'Library' extractor+ -> (Executable -> r) -- ^ 'Executable' extractor+ -> (TestSuite -> r) -- ^ 'TestSuite' extractor+ -> (Benchmark -> r) -- ^ 'Benchmakr' extractor+ -> GenericPackageDescription -- ^ Package+ -> [r] -- ^ List of results collected from each target+extractFromTargets fromLib fromExe fromTst fromBnc GenericPackageDescription{..} =+ concat+ [ maybe [] (one . fromLib . condTreeData) condLibrary+ , mapTargets fromExe condExecutables+ , mapTargets fromTst condTestSuites+ , mapTargets fromBnc condBenchmarks+ ]++mapTargets :: (t -> r) -> [(s, CondTree v c t)] -> [r]+mapTargets extractor = map (extractor . condTreeData . snd)
+ src/Importify/Cabal/Target.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}++-- | Functions to retrieve and store mapping from modules to their+-- targets and extensions.++module Importify.Cabal.Target+ ( -- * Maps from modules paths to cache parts+ ExtensionsMap+ , ModulesMap++ -- * Target types+ , ModulesBundle (..)+ , TargetId (..)++ -- * Utilities to extract targets+ , extractTargetBuildInfo+ , extractTargetsMap+ , packageExtensions+ , packageTargets+ , targetIdDir+ ) where++import Universum hiding (fromString)++import Data.Aeson (FromJSON (parseJSON), FromJSONKey (fromJSONKey),+ FromJSONKeyFunction (FromJSONKeyTextParser), ToJSON (toJSON),+ ToJSONKey (toJSONKey), Value (String), object, withObject, withText, (.:), (.=))+import Data.Aeson.Types (Parser, toJSONKeyText)+import Data.Hashable (Hashable)+import Distribution.ModuleName (ModuleName)+import Distribution.PackageDescription (Benchmark (..), BenchmarkInterface (..), BuildInfo (..),+ CondTree, Executable (..), GenericPackageDescription (..),+ Library (..), TestSuite (..), TestSuiteInterface (..),+ condTreeData)+#if MIN_VERSION_Cabal(2,0,0)+import Distribution.Types.UnqualComponentName (UnqualComponentName, unUnqualComponentName)+#endif++import Language.Haskell.Exts (prettyExtension)+import Path (Abs, Dir, File, Path, fromAbsFile)++import Importify.Cabal.Extension (buildInfoExtensions)+import Importify.Cabal.Module (modulePaths)++import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T (split)++-- | Mapping from module path to its package and module name.+type ModulesMap = HashMap FilePath ModulesBundle -- cached globally+type TargetsMap = HashMap FilePath TargetId -- not cached+type ExtensionsMap = HashMap TargetId [String] -- cached per project package++data TargetId = LibraryId+ | ExecutableId !Text+ | TestSuiteId !Text+ | BenchmarkId !Text+ deriving (Show, Eq, Generic)++instance Hashable TargetId++instance ToJSON TargetId where+ toJSON = String . targetIdDir++instance ToJSONKey TargetId where+ toJSONKey = toJSONKeyText targetIdDir++-- | Directory name for corresponding target.+targetIdDir :: TargetId -> Text+targetIdDir LibraryId = "library"+targetIdDir (ExecutableId exeName) = "executable@" <> exeName+targetIdDir (TestSuiteId testName) = "test-suite@" <> testName+targetIdDir (BenchmarkId benchName) = "benchmark@" <> benchName++instance FromJSON TargetId where+ parseJSON = withText "targetId" targetIdParser++instance FromJSONKey TargetId where+ fromJSONKey = FromJSONKeyTextParser targetIdParser++targetIdParser :: Text -> Parser TargetId+targetIdParser targetText = do+ let targetName = T.split (== '@') targetText+ case targetName of+ ["library"] -> pure LibraryId+ ["executable", exeName] -> pure $ ExecutableId exeName+ ["test-suite", testName] -> pure $ TestSuiteId testName+ ["benchmark", benchName] -> pure $ BenchmarkId benchName+ _ -> fail $ "Unexpected target: " ++ toString targetText++-- | All data for given module. This is needed to locate all required+-- information about module by its path.+data ModulesBundle = ModulesBundle+ { mbPackage :: !Text -- ^ Module package, like @importify-1.0@+ , mbModule :: !String -- ^ Full module name, like @Importify.Main@+ , mbTarget :: !TargetId -- ^ Target of module+ } deriving (Show, Eq)++instance ToJSON ModulesBundle where+ toJSON ModulesBundle{..} = object+ [ "package" .= mbPackage+ , "module" .= mbModule+ , "target" .= mbTarget+ ]++instance FromJSON ModulesBundle where+ parseJSON = withObject "ModulesBundle" $ \obj -> do+ mbPackage <- obj .: "package"+ mbModule <- obj .: "module"+ mbTarget <- obj .: "target"+ pure ModulesBundle{..}++-- | Extract every 'TargetId' for given project description.+packageTargets :: GenericPackageDescription -> [TargetId]+packageTargets GenericPackageDescription{..} =+ concat+ [ maybe [] (const [LibraryId]) condLibrary+ , targetMap ExecutableId condExecutables+ , targetMap TestSuiteId condTestSuites+ , targetMap BenchmarkId condBenchmarks+ ]+ where+#if MIN_VERSION_Cabal(2,0,0)+ targetMap tid = map (tid . toText . unUnqualComponentName . fst)+#else+ targetMap tid = map (tid . toText . fst)+#endif++-- | Extracts 'BuildInfo' for given 'TargetId'.+extractTargetBuildInfo+ :: TargetId+ -> GenericPackageDescription+ -> Maybe BuildInfo+extractTargetBuildInfo LibraryId = fmap (libBuildInfo . condTreeData) . condLibrary+extractTargetBuildInfo (ExecutableId name) =+ findTargetBuildInfo buildInfo name . condExecutables+extractTargetBuildInfo (TestSuiteId name) =+ findTargetBuildInfo testBuildInfo name . condTestSuites+extractTargetBuildInfo (BenchmarkId name) =+ findTargetBuildInfo benchmarkBuildInfo name . condBenchmarks++#if MIN_VERSION_Cabal(2,0,0)+findTargetBuildInfo :: (target -> info)+ -> Text+ -> [(UnqualComponentName, CondTree v c target)]+ -> Maybe info+findTargetBuildInfo toInfo name =+ fmap (toInfo . condTreeData . snd)+ . find ((== name) . toText . unUnqualComponentName . fst)+#else+findTargetBuildInfo :: (target -> info)+ -> Text+ -> [(String, CondTree v c target)]+ -> Maybe info+findTargetBuildInfo toInfo name = fmap (toInfo . condTreeData . snd)+ . find ((== name) . toText . fst)+#endif++-- | Extracts mapping from each package target to its extensions enabled by default.+packageExtensions :: [TargetId] -> GenericPackageDescription -> ExtensionsMap+packageExtensions targetIds desc = mconcat $ mapMaybe targetToExtensions targetIds+ where+ targetToExtensions :: TargetId -> Maybe ExtensionsMap+ targetToExtensions targetId = toMap targetId <$> extractTargetBuildInfo targetId desc++ toMap :: TargetId -> BuildInfo -> ExtensionsMap+ toMap targetId info = one (targetId, map prettyExtension $ buildInfoExtensions info)++-- | This function extracts 'ModulesMap' from given package by given+-- full path to project root directory.+extractTargetsMap :: Path Abs Dir -> GenericPackageDescription -> IO TargetsMap+extractTargetsMap projectPath GenericPackageDescription{..} = do+ libTM <- libMap+ exeTMs <- exeMaps+ testTMs <- testMaps+ benchTMs <- benchMaps++ return $ HM.unions $ libTM : exeTMs ++ testTMs ++ benchTMs+ where+ projectPaths :: BuildInfo -> Either [ModuleName] FilePath -> IO [Path Abs File]+ projectPaths = modulePaths projectPath++ libPaths :: Library -> IO [Path Abs File]+ libPaths Library{..} = projectPaths libBuildInfo (Left exposedModules)++ exePaths :: Executable -> IO [Path Abs File]+ exePaths Executable{..} = projectPaths buildInfo (Right modulePath)++ testPaths :: TestSuite -> IO [Path Abs File]+ testPaths TestSuite{..} = projectPaths testBuildInfo $ case testInterface of+ TestSuiteExeV10 _ path -> Right path+ TestSuiteLibV09 _ name -> Left [name]+ TestSuiteUnsupported _ -> Left []++ benchPaths :: Benchmark -> IO [Path Abs File]+ benchPaths Benchmark{..} = projectPaths benchmarkBuildInfo $ case benchmarkInterface of+ BenchmarkExeV10 _ path -> Right path+ BenchmarkUnsupported _ -> Left []++ libMap :: IO TargetsMap+ libMap = maybe mempty+ ( collectTargetsMap libPaths+ LibraryId+ . condTreeData)+ condLibrary++ exeMaps :: IO [TargetsMap]+ exeMaps = collectTargetsListMaps condExecutables+ ExecutableId+ (collectTargetsMap exePaths)++ testMaps :: IO [TargetsMap]+ testMaps = collectTargetsListMaps condTestSuites+ TestSuiteId+ (collectTargetsMap testPaths)++ benchMaps :: IO [TargetsMap]+ benchMaps = collectTargetsListMaps condBenchmarks+ BenchmarkId+ (collectTargetsMap benchPaths)+++-- | Generalized 'TargetsMap' collector for executables, testsuites and+-- benchmakrs of package.+#if MIN_VERSION_Cabal(2,0,0)+collectTargetsListMaps :: [(UnqualComponentName, CondTree v c target)]+ -> (Text -> TargetId)+ -> (TargetId -> target -> IO TargetsMap)+ -> IO [TargetsMap]+collectTargetsListMaps treeList idConstructor mapBundler =+ forM treeList $ \(name, condTree) ->+ mapBundler (idConstructor $ toText $ unUnqualComponentName name)+ (condTreeData condTree)+#else+collectTargetsListMaps :: [(String, CondTree v c target)]+ -> (Text -> TargetId)+ -> (TargetId -> target -> IO TargetsMap)+ -> IO [TargetsMap]+collectTargetsListMaps treeList idConstructor mapBundler =+ forM treeList $ \(name, condTree) ->+ mapBundler (idConstructor $ toText name) $ condTreeData condTree+#endif++collectTargetsMap :: (target -> IO [Path Abs File])+ -> TargetId+ -> target+ -> IO TargetsMap+collectTargetsMap modulePathsExtractor targetId target = do+ pathsToModules <- modulePathsExtractor target+ return $ constructModulesMap (map fromAbsFile pathsToModules)+ where+ constructModulesMap :: [FilePath] -> TargetsMap+ constructModulesMap = HM.fromList . map (, targetId)
+ src/Importify/Environment.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module contains enrinment for @importify cache@ command+-- which is running inside @ReaderT env IO@ monad.++module Importify.Environment+ ( -- * Base monad for @importify cache@ command+ RIO (..)++ -- * Environment for @importify cache@ command+ , CacheEnvironment (..)+ , HasGhcIncludeDir+ , HasPathToImportify+ , HasSaveSources+ , ghcIncludeDir+ , pathToImportify+ , pathToSymbols+ , saveSources++ -- * Runner for cache commend+ , runCache+ ) where++import Universum++import Lens.Micro.Platform (SimpleGetter, makeLensesWith, to)+import Path (Abs, Dir, Path, (</>))+import Path.IO (getCurrentDir)++import Extended.Lens.TH (fieldsVerboseLensRules)+import Importify.Path (doInsideDir, importifyPath, symbolsPath)+import Importify.Stack (ghcIncludePath, stackProjectRoot)++-- | 'ReaderT' + 'IO' monad described here:+-- https://www.fpcomplete.com/blog/2017/07/the-rio-monad+newtype RIO env a = RIO+ { runRIO :: ReaderT env IO a+ } deriving ( Functor, Applicative, Monad, MonadIO+ , MonadReader env, MonadThrow, MonadCatch, MonadMask)++-- | Environment for @importify cache@ command.+data CacheEnvironment = CacheEnvironment+ { -- | Path to local @.importify@ folder+ _pathToImportify :: !(Path Abs Dir)++ -- | Path to GHC .h files+ , _ghcIncludeDir :: !(Maybe (Path Abs Dir))++ -- | 'True' if unpacked sources should be stored locally as well+ , _saveSources :: !Bool+ }++makeLensesWith fieldsVerboseLensRules ''CacheEnvironment++type HasPathToImportify env = HasPolyPathToImportify env (Path Abs Dir)+type HasGhcIncludeDir env = HasPolyGhcIncludeDir env (Maybe (Path Abs Dir))+type HasSaveSources env = HasPolySaveSources env Bool++-- | Getter of @~\/path\/to\/project\/.importify\/symbols@ folder.+pathToSymbols :: HasPathToImportify env => SimpleGetter env (Path Abs Dir)+pathToSymbols = pathToImportify.to (</> symbolsPath)++-- | Run @importify cache@ command. This function takes current+-- project directory and searches for ghc include path.+runCache :: Bool -> RIO CacheEnvironment () -> IO ()+runCache _saveSources cacheAction = do+ projectRoot <- runMaybeT stackProjectRoot+ case projectRoot of+ Nothing -> return () -- error is reported inside 'stackProjectRoot'+ Just projectRootPath -> doInsideDir projectRootPath cacheRunner+ where+ cacheRunner :: IO ()+ cacheRunner = do+ projectPath <- getCurrentDir+ let _pathToImportify = projectPath </> importifyPath+ _ghcIncludeDir <- runMaybeT ghcIncludePath+ usingReaderT CacheEnvironment{..} $ runRIO cacheAction
+ src/Importify/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Importify/Main/Cache.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-- | Contains implementation of @importify cache@ command.++module Importify.Main.Cache+ ( importifyCacheList+ , importifyCacheProject+ ) where++import Universum++import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy as LBS (writeFile)+import qualified Data.HashMap.Strict as HM++import Distribution.PackageDescription (BuildInfo (includeDirs),+ GenericPackageDescription)+import Fmt (listF, (+|), (+||), (|+), (||+))+import Language.Haskell.Exts (Module, ModuleName (..), SrcSpanInfo)+import Language.Haskell.Names (writeSymbols)+import Lens.Micro.Platform (to)+import Path (Abs, Dir, File, Path, fromAbsDir,+ fromAbsFile, parseAbsFile, parseRelDir,+ parseRelFile, (</>))+import Path.IO (doesDirExist, ensureDir, removeDirRecur)+import Turtle (shell)++import Extended.System.Wlog (printDebug, printInfo, printWarning)+import Importify.Cabal (ModulesBundle (..), ModulesMap,+ TargetId (LibraryId),+ buildInfoExtensions,+ extractTargetBuildInfo,+ extractTargetsMap, packageDependencies,+ packageExtensions, packageTargets,+ readCabal, targetIdDir,+ withHarmlessExtensions)+import Importify.Environment (CacheEnvironment, HasGhcIncludeDir,+ HasPathToImportify, RIO, ghcIncludeDir,+ pathToImportify, pathToSymbols,+ saveSources)+import Importify.ParseException (ModuleParseException, reportErrorsIfAny,+ setMpeFile)+import Importify.Path (decodeFileOrMempty, doInsideDir,+ extensionsPath, findCabalFile,+ modulesFile, modulesPath, symbolsPath)+import Importify.Preprocessor (parseModuleWithPreprocessor)+import Importify.Resolution (resolveModules)+import Importify.Stack (LocalPackages (..), QueryPackage (..),+ RemotePackages (..), pkgName,+ stackListDependencies,+ stackListPackages, upgradeWithVersions)+import Importify.Syntax (getModuleTitle)++-- | This function takes list of explicitly specified dependencies+-- with versions and caches only them under @.importify@ folder inside+-- current directory ignoring .cabal file for project. This function+-- doesn't update mapping from module paths.+importifyCacheList :: NonEmpty Text -> RIO CacheEnvironment ()+importifyCacheList explicitDependencies = do+ printInfo "Using explicitly specified list of dependencies for caching..."+ importifyPath <- view pathToImportify+ doInsideDir importifyPath $+ () <$ cacheDependenciesWith identity+ unpackCacher+ (toList explicitDependencies)++-- | Caches packages information into local .importify directory by+-- reading this information from @<package-name>.cabal@ file.+importifyCacheProject :: RIO CacheEnvironment ()+importifyCacheProject = do+ (localPackages@(LocalPackages locals), remotePackages) <- stackListPackages+ if null locals+ then printWarning "No packages found :( This could happen due to next reasons:\n\+ \ 1. Not running from project root directory.\n\+ \ 2. 'stack query' command failure.\n\+ \ 3. Our failure in parsing 'stack query' output."+ else cacheProject localPackages remotePackages++cacheProject :: LocalPackages -> RemotePackages -> RIO CacheEnvironment ()+cacheProject (LocalPackages locals) (RemotePackages remotes) = do+ localDescriptions <- mapM localPackageDescription locals+ hackageDependencies <- extractHackageDependencies localDescriptions+ (locals ++ remotes)++ importifyPath <- view pathToImportify+ doInsideDir importifyPath $ do+ -- 1. Unpack hackage dependencies then cache them+ printInfo $ "Caching total "+|length hackageDependencies|++ " dependencies from Hackage: "+|listF hackageDependencies|+""+ hackageMaps <- cacheDependenciesWith identity+ unpackCacher+ hackageDependencies++ -- 2. Unpack all remote non-hackage dependencies (e.g. from GitHub)+ remoteMaps <- cacheDependenciesWith pkgName+ remoteCacher+ remotes++ -- 3. Unpack finally all local packages+ localMaps <- forM locals $ \localPackage -> do+ printInfo $ "Caching package: " <> pkgName localPackage+ cachePackage (qpPath localPackage)+ (pkgName localPackage)+ True++ updateModulesMap $ HM.unions localMaps+ `HM.union` HM.unions remoteMaps+ `HM.union` HM.unions hackageMaps++localPackageDescription :: MonadIO m => QueryPackage -> m GenericPackageDescription+localPackageDescription QueryPackage{..} = do+ Just cabalPath <- findCabalFile qpPath+ let cabalFile = fromAbsFile cabalPath+ readCabal cabalFile++extractHackageDependencies :: MonadIO m+ => [GenericPackageDescription]+ -> [QueryPackage]+ -> m [Text]+extractHackageDependencies descriptions (map pkgName -> nonHackagePackages) = do+ libVersions <- stackListDependencies+ let versifier = upgradeWithVersions libVersions+ . map toText+ . packageDependencies+ let dependencies = concatMap versifier descriptions++ let uniqueDependencies = sort+ $ filter (`notElem` nonHackagePackages)+ $ hashNub dependencies++ return uniqueDependencies++-- | Collect cache of list of given dependencies. If given dependency+-- is already cached then it's ignored and debug message is printed.+cacheDependenciesWith :: forall d env .+ (d -> Text)+ -- ^ How to get dependency name?+ -> (d -> RIO env ModulesMap)+ -- ^ How to cache dependency (unpack for StackDependency)+ -> [d]+ -- ^ List of dependencies that should be cached+ -> RIO env [ModulesMap]+cacheDependenciesWith dependencyName dependencyResolver = go+ where+ go :: [d] -> RIO env [ModulesMap]+ go [] = return []+ go (d:ds) = do+ let depName = dependencyName d+ isAlreadyCached depName >>= \case+ True -> printDebug (depName|+" is already cached") *> go ds+ False -> liftM2 (:) (dependencyResolver d) (go ds)++ isAlreadyCached :: Text -> RIO env Bool+ isAlreadyCached libName = do+ libraryPath <- parseRelDir $ toString libName+ let libSymbolsPath = symbolsPath </> libraryPath+ doesDirExist libSymbolsPath++-- | This function is passed to 'cacheDependenciesWith' for Hackage dependencies.+unpackCacher :: Text -> RIO CacheEnvironment ModulesMap+unpackCacher libName = do+ _exitCode <- shell ("stack unpack " <> libName) empty++ packagePath <- parseRelDir $ toString libName+ unpackedPackagePath <- view $ pathToImportify.to (</> packagePath)+ packageModules <- cachePackage unpackedPackagePath libName False++ -- TODO: use bracket here+ unlessM (view saveSources) $ removeDirRecur packagePath++ pure packageModules++-- | This function is passed to 'cacheDependenciesWith' for 'RemotePackages'.+remoteCacher :: (HasPathToImportify env, HasGhcIncludeDir env)+ => QueryPackage+ -> RIO env ModulesMap+remoteCacher package = do+ let packageName = pkgName package+ printInfo $ "Caching remote package: " <> packageName+ cachePackage (qpPath package) packageName False++-- | Find .cabal file by given path to package and then collect 'ModulesMap'.+cachePackage :: (HasPathToImportify env, HasGhcIncludeDir env)+ => Path Abs Dir -- ^ Path to package+ -> Text -- ^ Package name+ -> Bool -- ^ Is package itself is caching+ -> RIO env ModulesMap+cachePackage packagePath libName isWorkingProject = do+ -- finding path to unpacked package .cabal file+ mCabalFileName <- findCabalFile packagePath+ let cabalFileName = fromMaybe (error $ "No .cabal file inside: " <> libName)+ mCabalFileName++ packageCabalDesc <- readCabal $ fromAbsFile cabalFileName+ createPackageCache packageCabalDesc+ packagePath+ libName+ isWorkingProject++-- | Creates @./.impority/symbols/<package> folder where all symbols+-- for given library stored. This function used for both library packages+-- and project package itself.+createPackageCache :: (HasPathToImportify env, HasGhcIncludeDir env)+ => GenericPackageDescription+ -- ^ Package descriptions+ -> Path Abs Dir+ -- ^ Path to package root+ -> Text+ -- ^ Package name with version+ -> Bool+ -- ^ True if project itself is caching now+ -> RIO env ModulesMap+createPackageCache+ packageCabalDesc+ packagePath+ packageName+ isWorkingProject+ = do+ -- Creates ./.importify/symbols/<package>/ directory+ packageNamePath <- parseRelDir (toString packageName)+ packageCachePath <- view $ pathToSymbols.to (</> packageNamePath)+ ensureDir packageCachePath++ -- Maps from full path to target and from target to list of extensions+ targetsMap <- liftIO $ extractTargetsMap packagePath packageCabalDesc++ let targetIds = if isWorkingProject+ then packageTargets packageCabalDesc+ else [LibraryId]++ -- Cache and store extensions only for working project inside package directory+ when isWorkingProject $ do+ let extensionsMap = packageExtensions targetIds packageCabalDesc+ let pathToExtensions = packageCachePath </> extensionsPath+ liftIO $ LBS.writeFile (fromAbsFile pathToExtensions)+ $ encodePretty extensionsMap++ let moduleToTargetPairs = HM.toList targetsMap+ concatForM targetIds $ \targetId -> do+ let thisTargetModules = map fst+ $ filter ((== targetId) . snd) moduleToTargetPairs+ targetPaths <- mapM parseAbsFile thisTargetModules++ -- TODO: implement Buildable for targetId+ let targetInfo = fromMaybe (error $ "No such target: "+||targetId||+"")+ $ extractTargetBuildInfo targetId packageCabalDesc++ (errors, targetModules) <- parseTargetModules packagePath+ targetPaths+ targetInfo+ let targetDirectory = targetIdDir targetId+ liftIO $ reportErrorsIfAny errors (packageName <> ":" <> targetDirectory)++ targetPath <- parseRelDir $ toString targetDirectory+ let packageTargetPath = packageCachePath </> targetPath+ ensureDir packageTargetPath++ let moduleToPathMap = HM.fromList $ map (first getModuleTitle) targetModules+ let resolvedModules = resolveModules $ map fst targetModules+ fmap HM.fromList $ forM resolvedModules $ \( ModuleName () moduleTitle+ , resolvedSymbols) -> do+ modSymbolsPath <- parseRelFile $ moduleTitle ++ ".symbols"+ let moduleCachePath = packageTargetPath </> modSymbolsPath++ -- creates ./.importify/symbols/<package>/<Module.Name>.symbols+ liftIO $ writeSymbols (fromAbsFile moduleCachePath) resolvedSymbols++ let modulePath = fromMaybe (error $ "Unknown module: "+|moduleTitle|+"")+ $ HM.lookup moduleTitle moduleToPathMap+ let bundle = ModulesBundle packageName moduleTitle targetId+ pure (fromAbsFile modulePath, bundle)++parseTargetModules :: HasGhcIncludeDir env+ => Path Abs Dir -- ^ Path like @~/.../.importify/containers-0.5@+ -> [Path Abs File] -- ^ Paths to modules+ -> BuildInfo -- ^ BuildInfo of current target+ -> RIO env ( [ModuleParseException]+ , [(Module SrcSpanInfo, Path Abs File)]+ )+parseTargetModules packagePath pathsToModules targetInfo = do+ -- get include directories for cpphs+ includeDirPaths <- mapM parseRelDir $ includeDirs targetInfo+ let pkgIncludeDirs = map (fromAbsDir . (packagePath </>)) includeDirPaths++ ghcDir <- view ghcIncludeDir+ let includeDirs = pkgIncludeDirs ++ toList (fmap fromAbsDir ghcDir)+ let extensions = withHarmlessExtensions $ buildInfoExtensions targetInfo++ let moduleParser path = do+ parseRes <- liftIO $+ parseModuleWithPreprocessor extensions+ includeDirs+ path+ return $ bimap (setMpeFile $ fromAbsFile path) -- Update error+ (, path) -- Update result+ parseRes++ partitionEithers <$> mapM moduleParser pathsToModules++updateModulesMap :: MonadIO m => ModulesMap -> m ()+updateModulesMap newCachedModules = do+ existingImportsMap <- decodeFileOrMempty modulesPath return+ let mergedMaps = newCachedModules `HM.union` existingImportsMap+ liftIO $ LBS.writeFile modulesFile $ encodePretty mergedMaps
+ src/Importify/Main/File.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Contains implementation of @importify file@ command.++module Importify.Main.File+ ( OutputOptions (..)+ , importifyFileOptions+ , importifyFileContent+ ) where++import Universum++import Fmt (fmt, (+|), (|+))+import Language.Haskell.Exts (Comment (..), Extension, ImportDecl, Module (..), ModuleHead,+ ModuleName (..), SrcSpanInfo, ann, exactPrint, parseExtension,+ parseFileContentsWithComments)+import Language.Haskell.Exts.Parser (ParseMode (..), defaultParseMode)+import Language.Haskell.Names (Environment, Scoped, annotate, loadBase, readSymbols)+import Language.Haskell.Names.Imports (annotateImportDecls, importTable)+import Language.Haskell.Names.SyntaxUtils (getModuleName)+import Path (Abs, Dir, File, Path, Rel, fromAbsFile, fromRelFile, parseRelDir, parseRelFile, (</>))+import Path.IO (doesDirExist, getCurrentDir)++import Extended.System.Wlog (printError, printNotice)+import Importify.Cabal (ExtensionsMap, ModulesBundle (..), ModulesMap, TargetId, targetIdDir)+import Importify.ParseException (eitherParseResult, setMpeFile)+import Importify.Path (decodeFileOrMempty, doInsideDir, extensionsPath, importifyPath, lookupToRoot,+ modulesPath, symbolsPath)+import Importify.Pretty (printLovelyImports)+import Importify.Resolution (collectUnusedImplicitImports, collectUnusedSymbolsBy, hidingUsedIn,+ isKnownImport, removeImplicitImports, removeUnusedQualifiedImports,+ symbolUsedIn)+import Importify.Syntax (importSlice, switchHidingImports, unscope)+import Importify.Tree (UnusedHidings (UnusedHidings), UnusedSymbols (UnusedSymbols), removeImports)++import qualified Data.Foldable as Foldable (toList)+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M++-- | This data type dictates how output of @importify@ should be+-- outputed.+data OutputOptions = ToConsole -- ^ Print to console+ | InPlace -- ^ Change file in-place+ | ToFile FilePath -- ^ Print to specified file+ deriving (Show)++newtype ImportifyFileException = IFE Text++-- | Run @importify file@ command with given options.+importifyFileOptions :: OutputOptions -> FilePath -> IO ()+importifyFileOptions options srcFile = do+ srcPath <- parseRelFile srcFile+ foundRoot <- lookupToRoot (doesDirExist . (</> importifyPath)) srcPath+ case foundRoot of+ Nothing ->+ printError "Directory '.importify' is not found. Either cache for project \+ \is not created or not running from project directory."+ Just (rootDir, srcFromRootPath) -> do+ curDir <- getCurrentDir+ importifyResult <- doInsideDir rootDir (importifyFileContent $ curDir </> srcFromRootPath)+ handleOptions importifyResult+ where+ handleOptions :: Either ImportifyFileException Text -> IO ()+ handleOptions (Left (IFE msg)) = printError msg+ handleOptions (Right modifiedSrc) = case options of+ ToConsole -> putText modifiedSrc+ InPlace -> writeFile srcFile modifiedSrc+ ToFile to -> writeFile to modifiedSrc++-- | Return result of @importify file@ command.+importifyFileContent :: Path Abs File -> IO (Either ImportifyFileException Text)+importifyFileContent srcPath = do+ let srcFile = fromAbsFile srcPath++ modulesMap <- readModulesMap+ extensions <- readExtensions srcPath modulesMap++ whenNothing_ (HM.lookup (fromAbsFile srcPath) modulesMap) $+ printNotice $ "File '"+|srcFile|+"' is not cached: new file or caching error"++ src <- readFile srcFile+ let parseResult = eitherParseResult+ $ parseFileContentsWithComments (defaultParseMode { extensions = extensions })+ $ toString src++ case parseResult of+ Left exception -> return $ Left $ IFE $ setMpeFile srcFile exception |+ ""+ Right (ast,comments) -> importifyAst src modulesMap comments ast++importifyAst :: Text+ -> ModulesMap+ -> [Comment]+ -> Module SrcSpanInfo+ -> IO (Either ImportifyFileException Text)+importifyAst src modulesMap comments ast@(Module _ _ _ imports _) =+ Right <$> case importSlice imports of+ Nothing -> return src+ Just (start, end) -> do+ let codeLines = lines src+ let (preamble, rest) = splitAt (start - 1) codeLines+ let (impText, decls) = splitAt (end - start + 1) rest++ environment <- loadEnvironment modulesMap+ let newImports = removeUnusedImports ast imports environment+ let printedImports = printLovelyImports start end comments impText newImports++ return $ unlines preamble+ <> unlines printedImports+ <> unlines decls+importifyAst _ _ _ _ = return $ Left $ IFE "Module wasn't parsed correctly"++readModulesMap :: IO ModulesMap+readModulesMap = decodeFileOrMempty (importifyPath </> modulesPath) pure++readExtensions :: Path Abs File -> ModulesMap -> IO [Extension]+readExtensions srcPath modulesMap =+ case HM.lookup (fromAbsFile srcPath) modulesMap of+ Nothing -> return []+ Just ModulesBundle{..} -> do+ packagePath <- parseRelDir $ toString mbPackage+ projectPath <- getCurrentDir+ let pathToExtensions = projectPath+ </> importifyPath+ </> symbolsPath+ </> packagePath+ </> extensionsPath++ let lookupExtensions = fromMaybe [] . getExtensions mbTarget+ decodeFileOrMempty @ExtensionsMap+ pathToExtensions+ (return . lookupExtensions)++getExtensions :: TargetId -> ExtensionsMap -> Maybe [Extension]+getExtensions targetId = fmap (map parseExtension) . HM.lookup targetId++loadEnvironment :: ModulesMap -> IO Environment+loadEnvironment modulesMap = do+ baseEnvironment <- loadBase++ let moduleBundles = HM.elems modulesMap+ packages <- forM moduleBundles $ \ModulesBundle{..} -> do+ packagePath <- parseRelDir $ toString mbPackage+ symbolsFilePath <- parseRelFile $ mbModule ++ ".symbols"+ targetPath <- parseRelDir $ toString $ targetIdDir mbTarget+ let pathToSymbols = importifyPath+ </> symbolsPath+ </> packagePath+ </> targetPath+ </> symbolsFilePath+ moduleSymbols <- readSymbols (fromRelFile pathToSymbols)+ pure (ModuleName () mbModule, moduleSymbols)++ return $ M.union baseEnvironment (M.fromList packages)++-- | Remove all unused entities in given module from given list of imports.+-- Algorithm performs next steps:+-- -1. Load environment+-- 0. Collect annotations for module and imports.+-- 1. Remove unused implicit imports.+-- 2. Remove unused symbols from explicit list.+-- 3. Remove unused hidings from explicit lists.+-- 4. Remove unused qualified imports.+removeUnusedImports+ :: Module SrcSpanInfo -- ^ Module where symbols should be removed+ -> [ImportDecl SrcSpanInfo] -- ^ Imports from module+ -> Environment+ -> [ImportDecl SrcSpanInfo]+removeUnusedImports ast imports environment = do+ -- return exports to search for qualified imports there later+ let (annotations, moduleHead) = annotateModule ast environment++ let symbolTable = importTable environment ast+ let hidingTable = importTable environment $ switchHidingImports ast+ let annotatedDecls = annotateImportDecls (getModuleName ast) environment imports++ -- ordNub needed because name can occur as Qual and as UnQual+ -- but we don't care about qualification+ let unusedCollector = ordNub ... collectUnusedSymbolsBy+ let unusedSymbols = unusedCollector (`symbolUsedIn` annotations) symbolTable+ let unusedHidings = unusedCollector (`hidingUsedIn` annotations) hidingTable+ let unusedImplicits = collectUnusedImplicitImports (`symbolUsedIn` annotations)+ $ filter (isKnownImport environment) annotatedDecls++ -- Remove all collected info from imports+ let withoutUnusedImplicits = removeImplicitImports unusedImplicits+ annotatedDecls+ let withoutUnusedSymbols = map unscope+ $ removeImports (UnusedSymbols unusedSymbols)+ (UnusedHidings unusedHidings)+ withoutUnusedImplicits+ let withoutUnusedQuals = removeUnusedQualifiedImports withoutUnusedSymbols+ moduleHead+ annotations+ unusedImplicits++ withoutUnusedQuals++-- | Annotates module but drops import annotations because they can contain GlobalSymbol+-- annotations and collectUnusedSymbols later does its job by looking for GlobalSymbol+annotateModule :: Module SrcSpanInfo+ -> Environment+ -> ([Scoped SrcSpanInfo], Maybe (ModuleHead SrcSpanInfo))+annotateModule ast environment =+ let (Module l mhead mpragmas _mimports mdecls) = annotate environment ast+ in (Foldable.toList (Module l mhead mpragmas [] mdecls), fmap unscope mhead)
+ src/Importify/ParseException.hs view
@@ -0,0 +1,51 @@+-- | This module contains data type for parsing exception and pretty+-- formatting of such exceptions.++module Importify.ParseException+ ( ModuleParseException (..)+ , eitherParseResult+ , reportErrorsIfAny+ , setMpeFile+ ) where++import Universum++import Fmt (Builder, blockListF, build, indentF, (+|), (|+))+import Language.Haskell.Exts (ParseResult (..), SrcLoc (srcFilename),+ prettyPrint)++import Extended.Data.Str (charWrap, wordWrap)+import Extended.System.Wlog (printWarning)++data ModuleParseException = MPE !SrcLoc !String+ deriving (Show)++instance Exception ModuleParseException+instance Buildable ModuleParseException where+ build (MPE loc reason) = "Location:\n"+ +| indentF 4 (build $ charWrap 80 $ prettyPrint loc)+ |+ "Reason:\n"+ +| indentF 4 (build $ wordWrap 80 reason)+ |+ ""++-- | Updates file name of error location. Sometimes error location+-- looks like @- Location: : -1: -1@ which is not very helpful.+setMpeFile :: FilePath -> ModuleParseException -> ModuleParseException+setMpeFile modulePath (MPE loc msg) = MPE (loc {srcFilename = modulePath}) msg++-- | Converts 'ParseResult' into 'Either' making error look pretty.+eitherParseResult :: ParseResult res+ -> Either ModuleParseException res+eitherParseResult (ParseOk res) = Right res+eitherParseResult (ParseFailed loc reason) = Left $ MPE loc reason++-- | Pretty printing 'NonEmpty' list of errors in really nice way.+prettyParseErrors :: Text -> NonEmpty ModuleParseException -> Text+prettyParseErrors libName exceptions =+ "Next errors occured during caching of package: "+|libName|+"\n"+ +| indentF 4 (blockListF exceptions) |+ ""++-- | Prints parse errors if list of errors is not empty.+reportErrorsIfAny :: [ModuleParseException] -> Text -> IO ()+reportErrorsIfAny exceptions libName = whenNotNull exceptions $+ printWarning . prettyParseErrors libName
+ src/Importify/Path.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}++-- | This module contains common utilities for working with importify cache.++module Importify.Path+ ( -- * Predefined directories+ importifyDir+ , importifyPath+ , extensionsFile+ , extensionsPath+ , modulesFile+ , modulesPath+ , symbolsDir+ , symbolsPath+ , testDataPath++ -- * Utility functions to work with files and directories+ , decodeFileOrMempty+ , doInsideDir+ , findCabalFile+ , lookupToRoot+ ) where++import Universum++import Data.Aeson (FromJSON, eitherDecodeStrict)+import Fmt ((+|), (+||), (|+), (||+))+import Path (Abs, Dir, File, Path, Rel, dirname, fromAbsDir, fromAbsFile, fromRelDir, fromRelFile,+ parent, reldir, relfile, toFilePath, (</>))+import Path.IO (doesFileExist, ensureDir, getCurrentDir, listDir)+import System.FilePath (takeExtension)+import Turtle (cd, pwd)++import Extended.System.Wlog (printNotice, printWarning)++import qualified Data.ByteString as BS (readFile)++importifyPath :: Path Rel Dir+importifyPath = [reldir|.importify/|]++-- | Path to file that stores mapping from module names to their packages.+modulesPath :: Path Rel File+modulesPath = [relfile|modules|]++symbolsPath :: Path Rel Dir+symbolsPath = [reldir|symbols/|]++-- | Path to golden tests.+testDataPath :: Path Rel Dir+testDataPath = [reldir|test/test-data/|]++-- | Path to JSON-encoded Map from target to its list of default extensions.+extensionsPath :: Path Rel File+extensionsPath = [relfile|extensions|]++importifyDir, extensionsFile, modulesFile, symbolsDir :: FilePath+importifyDir = fromRelDir importifyPath+extensionsFile = fromRelFile extensionsPath+modulesFile = fromRelFile modulesPath+symbolsDir = fromRelDir symbolsPath++-- | Returns relative path to cabal file under given directory.+findCabalFile :: MonadIO m => Path Abs Dir -> m $ Maybe $ Path Abs File+findCabalFile projectPath = do+ (_, projectFiles) <- listDir projectPath+ return $ find isCabalFile projectFiles++isCabalFile :: Path Abs File -> Bool+isCabalFile = (== ".cabal") . takeExtension . fromAbsFile++-- | Create given directory and perform given action inside it.+doInsideDir :: (MonadIO m, MonadMask m) => Path Abs Dir -> m a -> m a+doInsideDir dir action = do+ thisDirectory <- pwd+ bracket_ (do ensureDir dir+ cd $ fromString $ fromAbsDir dir)+ (cd thisDirectory)+ action++-- | Walk up till root while unpure predicate is 'False'. Returns+-- absolute path to directory where predicate is 'True' and suffix of+-- current directory prepended to given file.+lookupToRoot :: (Path Abs Dir -> IO Bool)+ -> Path Rel File+ -> IO (Maybe (Path Abs Dir, Path Rel File))+lookupToRoot predicate relativeFile = do+ currentDir <- getCurrentDir+ pathLoop currentDir relativeFile+ where+ pathLoop :: Path Abs Dir -> Path Rel File -> IO (Maybe (Path Abs Dir, Path Rel File))+ pathLoop directory file = do+ predicateIsTrue <- predicate directory+ if predicateIsTrue then+ return $ Just (directory, file)+ else if parent directory == directory then -- fixpoint reached+ return Nothing+ else do+ let parentDir = parent directory+ let thisDir = dirname directory+ pathLoop parentDir (thisDir </> file)++-- | Tries to read file and then 'decode' it. If either of two phases+-- fails then 'mempty' returned and warning is printed to console.+decodeFileOrMempty :: forall t m f b .+ (FromJSON t, Monoid m, MonadIO f)+ => Path b File -- ^ Path to json data+ -> (t -> f m) -- ^ Action from decoded value+ -> f m+decodeFileOrMempty file onDecodedContent = do+ isFileExist <- doesFileExist file++ if isFileExist then+ eitherDecodeStrict <$> liftIO (BS.readFile $ toFilePath file) >>= \case+ Right value -> onDecodedContent value+ Left msg -> do+ let warning = "File '"+||file||+"' decoded incorrectly because of: "+|msg|+""+ mempty <$ printWarning warning+ else do+ let msg = "File '"+||file||++ "' doesn't exist: caching first time or previous caching failed"+ mempty <$ printNotice msg
+ src/Importify/Preprocessor.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++-- | This module contains functions for parsing /Haskell/ modules also+-- dealing with @-XCPP@ extension in files.++module Importify.Preprocessor+ ( parseModuleWithPreprocessor+ ) where++import Universum++import Language.Haskell.Exts (Extension, Module, ModulePragma (OptionsPragma),+ ParseMode (extensions), SrcSpanInfo, Tool (GHC), defaultParseMode,+ noLoc)+import Language.Haskell.Exts.CPP (CpphsOptions (includes), defaultCpphsOptions,+ parseFileWithCommentsAndCPP)+import Path (Abs, File, Path, fromAbsFile, (-<.>))+import Path.IO (removeFile)++import Importify.ParseException (ModuleParseException (MPE), eitherParseResult)+import Importify.Syntax (modulePragmas)++import qualified Autoexporter (mainWithArgs)++-- | Parse module after preproccessing this module with possibly+-- custom preprocessor. It first calls parsing with CPP, then reads+-- @OPTIONS_GHC@ to handle custom preprocessors. Now only @autoexporter@+-- supported among all custom preprocessors.+parseModuleWithPreprocessor+ :: [Extension] -- ^ List of extensions from .cabal file+ -> [FilePath] -- ^ Filenames of .h files to include+ -> Path Abs File -- ^ Path to module+ -> IO $ Either ModuleParseException $ Module SrcSpanInfo+parseModuleWithPreprocessor extensions includeFiles pathToModule =+ join (errorForcer <$> parseModuleAfterCPP extensions includeFiles pathToModule)+ `catch`+ (fmap Left . cppHandler) >>= \case+ err@(Left _exception) -> return err+ mdl@(Right parsedModule) -> case autoexportedArgs parsedModule of+ Nothing -> return mdl+ Just autoArgs -> do+ let modulePath = fromAbsFile pathToModule+ outputFilePath <- pathToModule -<.> ".auto"+ let preprocessorArgs = [modulePath, modulePath, fromAbsFile outputFilePath]+ Autoexporter.mainWithArgs (preprocessorArgs ++ autoArgs)+ parseModuleAfterCPP extensions includeFiles outputFilePath+ <* removeFile outputFilePath+ where+ -- This forcer is used because without it @cppHandler@ below doesn't catch exception.+ errorForcer res = evaluateWHNF (show res :: String) >> return res+ {- [IMRF-91]: This exception handler was introduced because+ of error in filelock-0.1.0.1 package:++ importify: #error No backend is available+ in /home/fenx/programming/haskell/serokell/importify/.importify+ /filelock-0.1.0.1/System/FileLock.hs at line 44 col 1+ CallStack (from HasCallStack):+ error, called at ./Language/Preprocessor/Cpphs/CppIfdef.hs:113:21 in+ cpphs-1.20.8-87uHpRVbMaP4k1m97GGc18:Language.Preprocessor.Cpphs.CppIfdef+ -}+ cppHandler :: SomeException -> IO ModuleParseException+ cppHandler = return . MPE noLoc . show++-- | Parse 'Module' by given 'Path' with given 'Extension's converting+-- parser errors into human readable text. Some additional handling is+-- required because @haskell-src-exts@ can't handle @-XCPP@.+parseModuleAfterCPP :: [Extension] -- ^ List of extensions from .cabal file+ -> [FilePath] -- ^ Filenames of .h files to include+ -> Path Abs File -- ^ Path to module+ -> IO $ Either ModuleParseException $ Module SrcSpanInfo+parseModuleAfterCPP cabalExtensions includeFiles pathToModule =+ second fst . eitherParseResult+ <$> parseFileWithCommentsAndCPP (defaultCpphsOptions {includes = includeFiles})+ (defaultParseMode {extensions = cabalExtensions})+ (fromAbsFile pathToModule)++autoexportedArgs :: forall l. Module l -> Maybe [String]+autoexportedArgs = safeHead . mapMaybe autoexporterPragma . modulePragmas+ where+ autoexporterPragma :: ModulePragma l -> Maybe [String]+ autoexporterPragma pragma = do+ OptionsPragma _ tool args <- Just pragma+ GHC <- tool+ "-F":"-pgmF":"autoexporter":autoArgs <- Just $ words $ toText args+ pure $ map toString autoArgs
+ src/Importify/Pretty.hs view
@@ -0,0 +1,71 @@+-- | This module contains functions to print imports+-- preserving original formatting.++module Importify.Pretty+ ( printLovelyImports+ ) where++import Universum++import Control.Arrow ((&&&))+import Data.Text (strip)+import Language.Haskell.Exts (Comment (..), ImportDecl (..), SrcSpan (..), SrcSpanInfo (..),+ exactPrint, startLine)+import Language.Haskell.Exts.Syntax (Annotated (..))++import Importify.Syntax (stripEndLineComment)++import qualified Data.IntMap.Strict as IM++-- | This function takes range of origin text for import and+-- AST of imports without unused entinties and then converts+-- import declarations into list of lines that should be printed.+printLovelyImports :: Int+ -> Int+ -> [Comment]+ -> [Text]+ -> [ImportDecl SrcSpanInfo]+ -> [Text]+printLovelyImports start end comments importsText importDecls =+ let -- map ImportDecl into (Int, [Text]) -- index of starting line to lines of text+ indexedImportLines = map (importStartLine &&& exactPrintImport comments) importDecls+ importsMap = IM.fromList indexedImportLines++ -- find empty and single comment lines+ indexedTextLines = zip [start..end] importsText+ emptyOrCommentLines = filter (null . strip . stripEndLineComment . snd) indexedTextLines++ -- add empty and single comment lines to result map+ importsMapWithExtraLines = foldl' (\dict (i,l) -> IM.insert i [l] dict)+ importsMap+ emptyOrCommentLines++ -- collect all values and concat them; order is guaranteed by IntMap+ resultLines = concat $ IM.elems importsMapWithExtraLines+ in resultLines++importStartLine :: ImportDecl SrcSpanInfo -> Int+importStartLine = srcSpanStartLine . srcInfoSpan . importAnn++exactPrintImport :: [Comment] -> ImportDecl SrcSpanInfo -> [Text]+exactPrintImport allComments importDecl = dropWhile null+ $ lines+ $ toText+ $ importText ++ endComments+ where+ importText = exactPrint importDecl (filter commentOnLine allComments)++ -- exactPrint stops printing comments after the import statement is finished, so print those manually.+ -- This would be much easier if Language.Haskell.Exts.ExactPrint exported more stuff+ endComments = printComments+ $ filter (\(Comment _ (SrcSpan _ sl _ _ ec) _) -> ec > importEndPos && sl == curLine)+ allComments+ printComments = intercalate " " . map ((" " ++) . printComment)+ printComment (Comment multi _ s) = if multi+ then "{-" ++ s ++ "-}"+ else "--" ++ s++ curLine = (startLine . ann) importDecl+ importEndPos = (srcSpanEndColumn . srcInfoSpan . ann) importDecl+ commentSpan (Comment _ srcSpan _) = srcSpan+ commentOnLine = (== curLine) . srcSpanStartLine . commentSpan
+ src/Importify/Resolution.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Importify/Resolution/Explicit.hs view
@@ -0,0 +1,73 @@+-- | Resolvers for removing symbols from explicit import lists.++module Importify.Resolution.Explicit+ ( collectUnusedSymbolsBy+ , resolveModules+ , symbolUsedIn+ ) where++import Universum++import Data.Data (Data)+import qualified Data.Map.Strict as M++import Language.Haskell.Exts (Module, ModuleName (..))+import Language.Haskell.Names (NameInfo (Export, GlobalSymbol, RecPatWildcard),+ Scoped, Symbol (..), resolve,+ symbolModule)+import Language.Haskell.Names.GlobalSymbolTable (Table)++import Importify.Syntax (anyAnnotation)+++-- | Checks if 'Symbol' is used inside annotations. This function+-- needed to remove unused imports.+symbolUsedIn :: Symbol -> [Scoped l] -> Bool+symbolUsedIn symbol = anyAnnotation used+ where+ used :: NameInfo l -> Bool++ -- Constructors are special because the whole type should be+ -- considered used if one of its constructors is used+ used (GlobalSymbol global@(Constructor smodule _sname stype) _) =+ symbol == global ||+ (symbolName symbol == stype && symbolModule symbol == smodule)++ -- Symbol used as selectors; same as constuctors+ used (GlobalSymbol global@(Selector smodule _sname stype _scons) _) =+ symbol == global ||+ (symbolName symbol == stype && symbolModule symbol == smodule)++ -- The symbol is used itself+ used (GlobalSymbol global _) = symbol == global++ -- Symbol is used as a part of export declaration+ used (Export symbols) = symbol `elem` symbols++ -- Symbol used as wildcard record+ used (RecPatWildcard symbols) = symbol `elem` symbols++ -- Other symbols+ used _ = False++-- | Collect symbols unused in annotations.+collectUnusedSymbolsBy+ :: (Symbol -> Bool) -- ^ 'True' iff 'Symbol' is used+ -> Table -- ^ Mapping from imported names to their symbols+ -> [Symbol] -- ^ Returns list of unused symbols from 'Table'+collectUnusedSymbolsBy isUsed table = do+ -- 1. For every pair (entity, its symbols) in Table+ (_, importedSymbols) <- M.toList table++ -- 2. And for every entity with same name+ symbol <- importedSymbols++ -- 3. Check whether this symbol used or not+ guard $ not $ isUsed symbol++ -- 4. If not found ⇒ unused+ pure symbol++-- | Gather all symbols for given list of 'Module's.+resolveModules :: (Data l, Eq l) => [Module l] -> [(ModuleName (), [Symbol])]+resolveModules modules = M.toList $ resolve modules mempty
+ src/Importify/Resolution/Hiding.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Name resolvers for @hiding@ imports.++module Importify.Resolution.Hiding+ ( hidingUsedIn+ ) where++import Universum++import Language.Haskell.Exts (Name)+import Language.Haskell.Names (NameInfo (Export, GlobalSymbol), Scoped,+ Symbol (..))++import Importify.Syntax (anyAnnotation)++-- | Checks if given 'Symbol' is used in module annotations. This+-- function performs comparison by ignoring module names because we want+-- to remove @hiding@ by calling this function.+hidingUsedIn :: Symbol -> [Scoped l] -> Bool+hidingUsedIn symbol = anyAnnotation used+ where+ used :: NameInfo l -> Bool+ used (GlobalSymbol global _) = lossyCompare symbol global+ used (Export symbols) = any (lossyCompare symbol) symbols+ used _ = False++lossyCompare :: Symbol -> Symbol -> Bool+lossyCompare (Fun name1) (Fun name2) = name1 == name2+lossyCompare (Dat symb1) (Dat symb2) = modulelessEq symb1 symb2+lossyCompare _ _ = False++-- | Compares if two symbols are equal ignoring 'symbolModule'+-- field. Used to remove imports from @hiding@ sections.+modulelessEq :: Symbol -> Symbol -> Bool+modulelessEq this other = this { symbolModule = symbolModule other } == other++----------------------------------------------------------------------------+-- Patterns for conveninet comparison+----------------------------------------------------------------------------++funPattern :: Symbol -> Maybe (Name ())+funPattern Value{..} = Just symbolName+funPattern Method{..} = Just symbolName+funPattern Selector{..} = Just symbolName+funPattern _ = Nothing++datPattern :: Symbol -> Maybe Symbol+datPattern symb = case funPattern symb of+ Nothing -> Just symb+ Just _ -> Nothing++pattern Fun :: Name () -> Symbol+pattern Fun name <- (funPattern -> Just name)++pattern Dat :: Symbol -> Symbol+pattern Dat symb <- (datPattern -> Just symb)
+ src/Importify/Resolution/Implicit.hs view
@@ -0,0 +1,44 @@+-- | Resolvers to remove implicit imports.++module Importify.Resolution.Implicit+ ( collectUnusedImplicitImports+ , isKnownImport+ , removeImplicitImports+ ) where++import Universum++import qualified Data.Map.Strict as M++import Language.Haskell.Exts (ImportDecl (..), ModuleName (..))+import Language.Haskell.Names (Environment, Symbol)++import Importify.Resolution.Explicit (collectUnusedSymbolsBy)+import Importify.Syntax (InScoped, getImportModuleName,+ importNamesWithTables, isImportImplicit)++-- | Collect names of unused implicit imports.+collectUnusedImplicitImports :: (Symbol -> Bool)+ -> [InScoped ImportDecl]+ -> [ModuleName ()]+collectUnusedImplicitImports isUsed imports =+ let implicitImports = filter isImportImplicit imports+ nameWithTable = importNamesWithTables implicitImports+ isImportUnused = null . collectUnusedSymbolsBy (not . isUsed)+ unusedImports = map fst $ filter (isImportUnused . snd) nameWithTable+ in unusedImports++-- | Checks if module symbols were cached. We don't want to remove+-- unknown imports we just want to not touch them.+isKnownImport :: Environment -> ImportDecl l -> Bool+isKnownImport env decl = M.member (getImportModuleName decl) env++-- | Remove all implicit import declarations specified by given list+-- of module names.+removeImplicitImports :: [ModuleName ()]+ -> [ImportDecl l]+ -> [ImportDecl l]+removeImplicitImports names = filter notImplicitOrUnused+ where+ notImplicitOrUnused imp = not (isImportImplicit imp)+ || getImportModuleName imp `notElem` names
+ src/Importify/Resolution/Qualified.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Utilities to remove unused qualified imports++module Importify.Resolution.Qualified+ ( removeUnusedQualifiedImports+ ) where++import Universum++import Data.List (partition)++import Language.Haskell.Exts (ImportDecl (..), ModuleHead (..),+ ModuleName (..), QName (..))+import Language.Haskell.Names (NameInfo (GlobalSymbol), Scoped)+import Language.Haskell.Names.SyntaxUtils (dropAnn)++import Extended.Data.Bool ((==>))+import Importify.Syntax (getImportModuleName, isInsideExport,+ scopedNameInfo, scopedNameInfo)++-- | Remove unused @qualified as@ imports, i.e. in one of the next form:+-- @+-- import qualified Data.List+-- import qualified Data.List as L+-- import Data.List as L+-- @+-- This function ignores imports with explicit import lists because it+-- is running after stage where symbols from explicit list removed.+removeUnusedQualifiedImports :: [ImportDecl l]+ -> Maybe (ModuleHead l)+ -> [Scoped l]+ -> [ModuleName ()] -- ^ Unused @import A as B@+ -> [ImportDecl l]+removeUnusedQualifiedImports imports moduleHead annotations unusedImplicits =+ let (possiblyUnused, others) = partition (possiblyUnusedImport unusedImplicits) imports++ isImportNeeded name = isInsideExport moduleHead name+ || isInsideModule annotations name++ byModuleName = maybe True isImportNeeded+ . fmap dropAnn+ . qualifiedName++ neededQualified = filter byModuleName possiblyUnused+ in neededQualified ++ others++possiblyUnusedImport :: [ModuleName ()] -> ImportDecl l -> Bool+possiblyUnusedImport unusedImplicits decl = isNothing (importSpecs decl)+ && isNotImplicitUnused+ where+ isNotImplicitUnused = (isJust (importAs decl) && not (importQualified decl))+ ==> getImportModuleName decl `elem` unusedImplicits++-- | For given import collect qualified name.+-- Qualified names gathered using next scheme:+-- @+-- import A ⇒ Nothing+-- import qualified B ⇒ Just B+-- import qualified C as X ⇒ Just X+-- import D as Y ⇒ Just Y+-- @+-- Used later to determine whether empty @qualified@ import needed or not.+qualifiedName :: ImportDecl l -> Maybe (ModuleName l)+qualifiedName ImportDecl{ importAs = as@(Just _) } = as+qualifiedName ImportDecl{ importQualified = True, .. } = Just importModule+qualifiedName _ = Nothing++isInsideModule :: forall l. [Scoped l] -> ModuleName () -> Bool+isInsideModule annotations moduleName = any isNameUsed annotations+ where+ isNameUsed :: Scoped l -> Bool+ isNameUsed (scopedNameInfo -> nameInfo) = case nameInfo of+ GlobalSymbol _ (Qual _ usedName _) -> moduleName == usedName+ _ -> False
+ src/Importify/Stack.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Utilities which allows to use @stack@ tools for different+-- dependencies stuff.++module Importify.Stack+ ( QueryPackage (..)+ , LocalPackages (..)+ , RemotePackages (..)++ , ghcIncludePath+ , pkgName+ , stackListDependencies+ , stackListPackages+ , stackProjectRoot+ , upgradeWithVersions+ ) where++import Universum++import Data.List (partition)+import Data.Yaml (FromJSON (parseJSON), Parser, Value (Object), decodeEither',+ prettyPrintParseException, withObject, (.:))+import Path (Abs, Dir, Path, PathException, dirname, fromAbsDir, mkRelDir, parent, parseAbsDir,+ (</>))+import Path.IO (doesDirExist)+import System.FilePath (splitPath)+import Turtle (Line, Shell, inproc, lineToText, linesToText, need)++import Extended.System.Wlog (printWarning)++import qualified Control.Foldl as Fold (head, list)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Turtle (fold)++shStack :: [Text] -> Shell Line+shStack args = do+ inNix <- inNixShell+ inproc "stack" (if inNix then "--nix" : args else args) empty++-- | Checks if running in nix shell+inNixShell :: MonadIO m => m Bool+inNixShell = do+ ns <- need "IN_NIX_SHELL"+ pure $ ns == Just "1"++pathArgs, rootArgs, depsArgs :: [Text]+pathArgs = ["path", "--compiler-bin"]+rootArgs = ["path", "--project-root"]+depsArgs = ["list-dependencies", "--test", "--bench"]++-- | This function finds path to directory where @include@ for ghc lies.+-- Filepath looks like this:+-- @+-- ~/.stack/programs/x86_64-linux/ghc-8.0.2/lib/ghc-8.0.2/include+-- @+-- This function needed to tell dependencies about files like @"MachDeps.h"@.+--+-- TODO: use GHC path from project?+ghcIncludePath :: MaybeT IO (Path Abs Dir)+ghcIncludePath = do+ ghcBinLine <- MaybeT $ Turtle.fold (shStack pathArgs) Fold.head++ -- ghcBinText ≡ /home/user/.stack/programs/x86_64-linux/ghc-8.0.2/bin+ ghcBinText <- parseAbsDir $ toString $ lineToText ghcBinLine+ let ghcProgram = parent ghcBinText -- w/o bin+ let ghcName = dirname ghcProgram -- ≡ ghc-8.0.2++ -- ghcInclude ≡ /home/user/.stack/programs/x86_64-linux/ghc-8.0.2/lib/ghc-8.0.2/include+ let ghcIncludeDir = ghcProgram+ </> $(mkRelDir "lib/")+ </> ghcName+ </> $(mkRelDir "include/")++ guardM $ doesDirExist ghcIncludeDir+ return ghcIncludeDir++-- | Acquires project using @stack path --project-root@ command.+stackProjectRoot :: MaybeT IO (Path Abs Dir)+stackProjectRoot = do+ projectRootLine <- MaybeT $ Turtle.fold (shStack rootArgs) Fold.head+ let projectRoot = lineToText projectRootLine+ if ".stack/global-project" `T.isSuffixOf` projectRoot then+ printWarning "importify was executed outside of project" *> empty+ else case eitherParseRoot projectRoot of+ Left exception -> printWarning (show exception) *> empty+ Right projectRootPath -> return projectRootPath+ where+ eitherParseRoot :: Text -> Either SomeException (Path Abs Dir)+ eitherParseRoot = parseAbsDir . toString++-- | Extract all dependencies with versions using+-- @stack list-dependencies@ shell command.+stackListDependencies :: MonadIO m => m (HashMap Text Text)+stackListDependencies = do+ dependencies <- Turtle.fold (shStack depsArgs) Fold.list+ let wordifyDeps = map (words . lineToText) dependencies+ let pairifyDeps = pairifyList wordifyDeps+ return $ HM.fromList pairifyDeps+ where+ pairifyList :: [[a]] -> [(a,a)]+ pairifyList [] = []+ pairifyList ([x,y]:xs) = (x,y) : pairifyList xs+ pairifyList (_:xs) = pairifyList xs++-- | Takes mapping from package names to their versions and list of+-- packages adding version to each package which is inside dictionary.+upgradeWithVersions :: HashMap Text Text -> [Text] -> [Text]+upgradeWithVersions versions = go+ where+ go [] = []+ go (lib:libs) = case HM.lookup lib versions of+ Nothing -> lib : go libs+ Just version -> lib <> "-" <> version : go libs++-- | Queries list of all local packages for project. If some errors+-- occur then warning is printed into console and empty list returned.+stackListPackages :: forall m . (MonadIO m, MonadCatch m)+ => m (LocalPackages, RemotePackages)+stackListPackages = do+ pkgsYaml <- linesToText <$> Turtle.fold (shStack ["query"]) Fold.list+ let parseRes = decodeEither' $ encodeUtf8 pkgsYaml+ case parseRes of+ Left exception -> do+ printWarning $ toText $ prettyPrintParseException exception+ return mempty+ Right (StackQueryResult packages) -> do+ localPackages <- mapM toPackage packages `catch` parseErrorHandler+ let (locals, remotes) = partition (isLocalPackage . qpPath) localPackages+ return (LocalPackages locals, RemotePackages remotes)+ where+ toPackage :: (Text, (FilePath, Text)) -> m QueryPackage+ toPackage (qpName, (path, qpVersion)) = do+ qpPath <- parseAbsDir path+ return QueryPackage{..}++ parseErrorHandler :: PathException -> m [QueryPackage]+ parseErrorHandler exception =+ [] <$ printWarning ("'stack query' exception: " <> show exception)++ isLocalPackage :: Path Abs Dir -> Bool+ isLocalPackage = notElem ".stack-work/" . splitPath . fromAbsDir++-- | This data type represents package returned by @stack query@ command.+data QueryPackage = QueryPackage+ { qpName :: Text -- ^ @importify@+ , qpPath :: Path Abs Dir -- ^ @\/home\/user\/importify\/@+ , qpVersion :: Text -- ^ 1.0+ } deriving (Eq, Show)++-- | Show full name of 'QueryPackage' with version.+pkgName :: QueryPackage -> Text+pkgName QueryPackage{..} = qpName <> "-" <> qpVersion++-- | Local subpackages from exactly this project.+newtype LocalPackages = LocalPackages [QueryPackage]+ deriving (Eq, Monoid)++-- | Remote packages, from GitHub or other locations.+newtype RemotePackages = RemotePackages [QueryPackage]+ deriving (Eq, Monoid)++newtype StackQueryResult = StackQueryResult [(Text, (FilePath, Text))]+ deriving Show++instance FromJSON StackQueryResult where+ parseJSON = withObject "stack query" $ \obj -> do+ Just (Object locals) <- pure $ HM.lookup "locals" obj+ packages <- forM locals $ withObject "package" $ \pkgObj -> do+ pkgPath :: FilePath <- pkgObj .: "path"+ pkgVersion :: Text <- pkgObj .: "version"+ pure (pkgPath, pkgVersion)+ pure $ StackQueryResult $ HM.toList packages
+ src/Importify/Syntax.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Importify/Syntax/Import.hs view
@@ -0,0 +1,101 @@+-- | Haskell AST utilities to work with @import@ section.++module Importify.Syntax.Import+ ( getImportModuleName+ , importNamesWithTables+ , importSlice+ , isImportImplicit+ , switchHidingImports+ ) where++import Universum++import qualified Data.List.NonEmpty as NE+import Language.Haskell.Exts (Extension (DisableExtension),+ ImportDecl (..),+ ImportSpecList (..),+ KnownExtension (ImplicitPrelude),+ Module (..), ModuleName,+ ModuleName (..),+ ModulePragma (LanguagePragma),+ Name (Ident), SrcSpan (..),+ SrcSpanInfo (..), combSpanInfo,+ noSrcSpan, prettyExtension)+import Language.Haskell.Names (NameInfo (Import))+import Language.Haskell.Names.GlobalSymbolTable (Table)++import Importify.Syntax.Module (isInsideExport)+import Importify.Syntax.Scoped (InScoped, pullScopedInfo)++-- | Returns module name for 'ImportDecl' with annotation erased.+getImportModuleName :: ImportDecl l -> ModuleName ()+getImportModuleName ImportDecl{..} = () <$ importModule++-- | Returns 'True' iff import has next form:+-- @+-- import Module.Name+-- import Module.Name as Other.Name+-- import Module.Name hiding (smth)+-- @+isImportImplicit :: ImportDecl l -> Bool+isImportImplicit ImportDecl{ importQualified = True } = False+isImportImplicit ImportDecl{ importSpecs = Nothing } = True+isImportImplicit ImportDecl{ importSpecs = Just (ImportSpecList _ True _) } = True+isImportImplicit _ = False++-- | This function returns name of import disregard to its+-- qualification, how this module should be referenced, i.e. like this:+-- @+-- import <whatever> A ⇒ A+-- import <whatever> B as X ⇒ X+-- @+importReferenceName :: ImportDecl l -> ModuleName ()+importReferenceName ImportDecl{ importAs = Nothing, .. } = () <$ importModule+importReferenceName ImportDecl{ importAs = Just name } = () <$ name++-- | Keep only hiding imports making them non-hiding. This function+-- needed to collect unused hiding imports because @importTable@ doesn't+-- track information about hiding imports.+switchHidingImports :: Module SrcSpanInfo -> Module SrcSpanInfo+switchHidingImports (Module ml mhead mpragmas mimports mdecls) =+ Module ml+ mhead+ ( LanguagePragma noSrcSpan+ [ Ident noSrcSpan+ $ prettyExtension+ $ DisableExtension ImplicitPrelude+ ]+ : mpragmas)+ (mapMaybe unhide mimports)+ mdecls+ where+ unhide :: ImportDecl SrcSpanInfo -> Maybe (ImportDecl SrcSpanInfo)+ unhide decl = do+ ImportSpecList l isHiding imports <- importSpecs decl+ guard isHiding+ guard $ not $ isInsideExport mhead (importReferenceName decl)+ pure $ decl { importSpecs = Just $ ImportSpecList l False imports }++switchHidingImports m = m++-- | Collect mapping from import name to to list of symbols it exports.+importNamesWithTables :: [InScoped ImportDecl] -> [(ModuleName (), Table)]+importNamesWithTables = map (getImportModuleName &&& getImportedSymbols)+ where+ getImportedSymbols :: InScoped ImportDecl -> Table+ getImportedSymbols = fromImportInfo . pullScopedInfo++ fromImportInfo :: NameInfo l -> Table+ fromImportInfo (Import dict) = dict+ fromImportInfo _ = mempty++-- | Returns pair of line numbers — first and last line of import section+-- if any import is in list.+importSlice :: [ImportDecl SrcSpanInfo] -> Maybe (Int, Int)+importSlice [] = Nothing+importSlice [ImportDecl{..}] = Just $ startAndEndLines importAnn+importSlice (x:y:xs) = Just $ startAndEndLines+ $ combSpanInfo (importAnn x) (importAnn $ NE.last (y :| xs))++startAndEndLines :: SrcSpanInfo -> (Int, Int)+startAndEndLines (SrcSpanInfo SrcSpan{..} _) = (srcSpanStartLine, srcSpanEndLine)
+ src/Importify/Syntax/Module.hs view
@@ -0,0 +1,64 @@+-- | Syntax utilities to work with modules and their names.++module Importify.Syntax.Module+ ( getModuleTitle+ , isInsideExport+ , modulePragmas+ ) where++import Universum++import Language.Haskell.Exts (ExportSpec (EModuleContents),+ ExportSpecList (..), Module (..),+ ModuleHead (..), ModuleName,+ ModuleName (..), ModulePragma)+import Language.Haskell.Names.SyntaxUtils (dropAnn, getModuleName)++{- TODO: this function used earlier, it works, but is not used anymore+ I'll keep it in case we need it again.++-- | Returns module name of the source file.+-- We can't parse the whole file to get it because default extensions are not available yet+-- so this method uses 'NonGreedy' parsing to parse only module head.+getSourceModuleName :: Text -> String+getSourceModuleName src =+ let parseResult :: ParseResult (NonGreedy (PragmasAndModuleName SrcSpanInfo))+ parseResult = parse $ toString src+ NonGreedy (PragmasAndModuleName _ _pragmas maybeModuleName) =+ fromParseResult parseResult+ ModuleName _ modNameStr =+ fromMaybe (error "File doesn't have `module' declaration") maybeModuleName+ in modNameStr+-}++-- | Get name of module by dropping annonation.+getModuleNameId :: ModuleName l -> String+getModuleNameId (ModuleName _ id) = id++-- | Returns name of 'Module' as a 'String'.+getModuleTitle :: Module l -> String+getModuleTitle = getModuleNameId . getModuleName++-- | Returns 'True' iff given 'ModuleName' is inside export list.+isInsideExport :: Maybe (ModuleHead l) -> ModuleName () -> Bool+isInsideExport moduleHead moduleName = moduleName `elem` exportedModules moduleHead++-- | Extracts list of module names exported with @module A@ way.+exportedModules :: Maybe (ModuleHead l) -> [ModuleName ()]+exportedModules moduleHead = qualifiedModuleNames+ where+ exports = do+ ModuleHead _ _ _ maybeExports <- moduleHead+ maybeExports++ qualifiedModuleNames :: [ModuleName ()]+ qualifiedModuleNames = do+ ExportSpecList _ specs <- maybe [] one exports+ EModuleContents _ eModule <- specs+ pure $ dropAnn eModule++-- | Extract all 'ModulePragma's from 'Module'.+modulePragmas :: Module l -> [ModulePragma l]+modulePragmas (Module _ _ pragmas _ _) = pragmas+modulePragmas (XmlPage _ _ pragmas _ _ _ _) = pragmas+modulePragmas (XmlHybrid _ _ pragmas _ _ _ _ _ _) = pragmas
+ src/Importify/Syntax/Scoped.hs view
@@ -0,0 +1,34 @@+-- | Utility functions to work with 'Scoped' data type from+-- @haskell-names@ library.++module Importify.Syntax.Scoped+ ( InScoped+ , anyAnnotation+ , pullScopedInfo+ , scopedNameInfo+ , unscope+ ) where++import Universum++import Language.Haskell.Exts (Annotated (ann), SrcSpanInfo (..))+import Language.Haskell.Names (NameInfo, Scoped (..))++-- | Short wrapper for types annotated by @Scoped SrcSpanInfo@.+-- For example, use @InScoped ImportDecl@ instead of @ImportDecl (Scoped SrcSpanInfo)@.+type InScoped t = t (Scoped SrcSpanInfo)++-- | Retrive 'NameInfo' from 'Scoped'.+scopedNameInfo :: Scoped l -> NameInfo l+scopedNameInfo (Scoped info _) = info++-- | Retrive 'NameInfo' from something annotated by 'Scoped'.+pullScopedInfo :: Annotated ast => ast (Scoped l) -> NameInfo l+pullScopedInfo = scopedNameInfo . ann++-- | Drop 'Scoped' annotation from 'Functor' type.+unscope :: Functor f => f (Scoped l) -> f l+unscope = fmap $ \case Scoped _ l -> l++anyAnnotation :: (NameInfo l -> Bool) -> [Scoped l] -> Bool+anyAnnotation used = any used . map scopedNameInfo
+ src/Importify/Syntax/Text.hs view
@@ -0,0 +1,41 @@+-- | Different text utilities.++module Importify.Syntax.Text+ ( stripEndLineComment+ , debugAST -- TODO: move into Extended.Debug*+ , debugLabel -- TODO: move into Extended.Debug*+ ) where++import Universum++import qualified Data.Text as T+import Fmt (fmt, padLeftF)+import Text.Pretty.Simple (pShow)++-- | This functions strips out trailing single line comment.+stripEndLineComment :: Text -> Text+stripEndLineComment line = case T.breakOnAll "--" line of+ [] -> line+ ((stripped,_):_) -> stripped++-- | Helper function to debug different parts of AST processing.+{-# WARNING debugAST "'debugAST' remains in code" #-}+debugAST :: Show a => Text -> a -> IO ()+debugAST header msg = do+ let preamble = "-------------------- // " <> header <> " // --------------------\n"+ putText $ (preamble <>)+ $ unlines+ $ zipWith (\i line -> lineNumber i <> ": " <> line) [1..]+ $ lines+ $ toText+ $ pShow msg+ where+ lineNumber :: Int -> Text+ lineNumber = fmt . padLeftF 4 ' ' -- padding 4 should be enough (no bigger 9999)++-- | Helper function to print labels to discover error position.+{-# WARNING debugLabel "'debugLabel' remains in code" #-}+debugLabel :: Text -> IO ()+debugLabel label = do+ let surroundedLabel = "##################### " <> label <> " #####################"+ putText surroundedLabel
+ src/Importify/Tree.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE ViewPatterns #-}++module Importify.Tree+ ( UnusedHidings (..)+ , UnusedSymbols (..)+ , removeImports+ ) where++import Universum++import Data.Generics.Aliases (mkT)+import Data.Generics.Schemes (everywhere)+import Data.List (partition)+import Extended.Data.List (removeAtMultiple)+import Language.Haskell.Exts (CName, ImportDecl (..), ImportSpec (..),+ ImportSpecList (..), Name (..), Namespace (..),+ SrcSpanInfo (..))+import Language.Haskell.Names (NameInfo (..), Scoped (..), Symbol)++import Importify.Syntax (InScoped, pullScopedInfo)++-- | @newtype@ wrapper for list of unused symbols.+newtype UnusedSymbols = UnusedSymbols { getUnusedSymbols :: [Symbol] }++-- | @newtype@ wrapper for list of unused symbols from @hiding@.+newtype UnusedHidings = UnusedHidings { getUnusedHidings :: [Symbol] }++-- | Remove a list of identifiers from 'ImportDecl's.+-- Next algorithm is used:+--+-- 1. Remove all identifiers inside specified list of types.+-- If list becomes empty then only type left.+-- @+-- import Module.Name (Type (HERE)) ⇒ import Module.Name (Type)+-- @+--+-- 2. Traverse every 'ImportSpec's and check matching with symbols.+-- @+-- import Module.Name (Type (something), HERE) ⇒ import Module.Name (Type (something))+-- @+--+-- 3. Translate empty imports into implicit import.+-- @+-- import Module.Name () ⇒ import Module.Name+-- @+--+-- 4. Remove all implicit imports preserving only initially implicit or empty.+removeImports :: UnusedSymbols -- ^ List of symbols which should be removed+ -> UnusedHidings -- ^ List of hidings which should be removed+ -> [InScoped ImportDecl] -- ^ Imports to be purified+ -> [InScoped ImportDecl]+removeImports (UnusedSymbols symbols) (UnusedHidings hidings) decls =+ (volatileImports ++)+ $ cleanDecls+ $ everywhere (mkT traverseToClean)+ $ everywhere (mkT $ traverseToRemove hidings True)+ $ everywhere (mkT $ traverseToRemove symbols False)+ $ everywhere (mkT $ traverseToRemoveThing symbols) decls+ where+ volatileImports = filter isVolatileImport decls++-- | Returns 'True' if the import is of either of the forms:+-- @+-- import Foo ()+-- import Foo+-- @+--+isVolatileImport :: InScoped ImportDecl -> Bool+isVolatileImport ImportDecl{ importSpecs = Just (ImportSpecList _ _ []) } = True+isVolatileImport ImportDecl{ importSpecs = Nothing } = True+isVolatileImport _ = False++-- | Traverses 'ImportDecl's to remove symbols from 'IThingWith' specs.+traverseToRemoveThing :: [Symbol]+ -> InScoped ImportSpec+ -> InScoped ImportSpec+traverseToRemoveThing+ symbols+ (IThingWith (Scoped ni srcSpan@SrcSpanInfo{..}) name cnames)+ =+ case newCnames of+ [] -> IAbs (toScope emptySpan) (NoNamespace $ toScope emptySpan) name+ _ -> IThingWith (toScope newSpanInfo) name newCnames+ where+ emptySpan :: SrcSpanInfo+ emptySpan = SrcSpanInfo srcInfoSpan []++ toScope :: SrcSpanInfo -> Scoped SrcSpanInfo+ toScope = Scoped ni++ (newCnames, newSpanInfo) = removeSrcSpanInfoPoints isCNameNotInSymbols+ cnames+ srcSpan++ isCNameNotInSymbols :: InScoped CName -> Bool+ isCNameNotInSymbols (pullScopedInfo -> GlobalSymbol symbol _) = symbol `notElem` symbols+ isCNameNotInSymbols _ = False+traverseToRemoveThing _ spec = spec++-- | Traverses 'ImportSpecList' to remove identifiers from those lists.+traverseToRemove :: [Symbol] -- ^+ -> Bool+ -> InScoped ImportSpecList+ -> InScoped ImportSpecList+traverseToRemove symbols+ yes'CleanIt+ specList@(ImportSpecList (Scoped ni oldSpanInfo) isHiding specs)+ | isHiding == yes'CleanIt = newSpecs+ | otherwise = specList+ where+ (neededSpecs, newSpanInfo) = removeSrcSpanInfoPoints (isSpecNeeded symbols)+ specs+ oldSpanInfo++ newSpecs = ImportSpecList (Scoped ni newSpanInfo)+ isHiding+ neededSpecs++-- | Removes 'SrcSpanInfo' points of deleted elements.+removeSrcSpanInfoPoints :: (a -> Bool) -- ^ Keep entitity?+ -> [a] -- ^ List of entities+ -> SrcSpanInfo -- ^ Span info with points+ -> ([a], SrcSpanInfo) -- ^ Kept entities and info w/o points+removeSrcSpanInfoPoints shouldKeepEntity entities SrcSpanInfo{..} =+ let indexedEntities = zip [1..] entities+ (neededEntities, unusedEntities) = partition (shouldKeepEntity . snd)+ indexedEntities+ pointsCount = length srcInfoPoints+ unusedIds = filter (< pointsCount) -- don't remove index of ')'+ $ map fst unusedEntities+ newPoints = removeAtMultiple unusedIds srcInfoPoints+ in (map snd neededEntities, SrcSpanInfo srcInfoSpan newPoints)++-- | Returns 'False' if 'ImportSpec' is not needed.+isSpecNeeded :: [Symbol] -> InScoped ImportSpec -> Bool+isSpecNeeded symbols (IVar _ name) = isNameNeeded name symbols+isSpecNeeded symbols (IAbs _ _ name) = isNameNeeded name symbols+isSpecNeeded symbols (IThingAll _ name) = isNameNeeded name symbols+isSpecNeeded symbols (IThingWith _ name []) = isNameNeeded name symbols+isSpecNeeded _ (IThingWith _ _ (_:_)) = True -- Do not remove if cnames list is not empty++-- | Returns 'False' if 'Name' is not needed. On top level+-- elements inside 'ImportSpec' annotated by 'ImportPart'. But+-- this constructor contains list of symbols. So it's needed if+-- at least one element inside list is needed.+isNameNeeded :: InScoped Name -> [Symbol] -> Bool+isNameNeeded (pullScopedInfo -> ImportPart symbols) unusedSymbols =+ any (`notElem` unusedSymbols) symbols+isNameNeeded _ _ =+ True++-- | Traverses 'ImportDecl's to remove empty non-@hiding@ import specs.+traverseToClean :: InScoped ImportDecl -> InScoped ImportDecl+traverseToClean decl@ImportDecl{ importSpecs = Just (ImportSpecList _ False []) } =+ decl { importSpecs = Nothing }+traverseToClean decl = decl++-- | First remove all imports with no lists and then remove+-- 'ImportSpecList' from empty @hiding@ imports.+cleanDecls :: [InScoped ImportDecl] -> [InScoped ImportDecl]+cleanDecls = map removeHidingList . filter isDeclNeeded+ where+ removeHidingList :: InScoped ImportDecl -> InScoped ImportDecl+ removeHidingList decl@ImportDecl{ importSpecs = Just (ImportSpecList _ True []) } =+ decl { importSpecs = Nothing }+ removeHidingList decl = decl++ isDeclNeeded :: InScoped ImportDecl -> Bool+ isDeclNeeded = isJust . importSpecs
+ test/GGenerator.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This executable generated .golden tests for importify.++module Main where++import Universum++import Path (Abs, Dir, File, Path, fileExtension, fromAbsFile, (-<.>))+import Path.IO (listDirRecur, removeFile)++import Importify.Main (importifyFileContent)+import Importify.Path (testDataPath)++main :: IO ()+main = do+ arguments <- getArgs+ case arguments of+ ["--clean"] -> cleanGoldenExamples+ ["--force"] -> generateGoldenTests+ [] -> generateGoldenTestsPrompt+ _ -> putText "Incorrect arguments!"++findByExtension :: MonadIO m => String -> Path b Dir -> m [Path Abs File]+findByExtension ext path = filter ((== ext) . fileExtension) . snd+ <$> listDirRecur path++findGoldenFiles :: MonadIO m => Path b Dir -> m [Path Abs File]+findGoldenFiles = findByExtension "golden"++cleanGoldenExamples :: MonadIO m => m ()+cleanGoldenExamples = do+ goldenExamples <- findGoldenFiles testDataPath+ mapM_ removeFile goldenExamples++findHaskellFiles :: MonadIO m => Path b Dir -> m [Path Abs File]+findHaskellFiles = findByExtension ".hs"++writeBinaryFile :: MonadIO m => Path Abs File -> Text -> m ()+writeBinaryFile = writeFile . fromAbsFile++generateGoldenTestsPrompt :: IO ()+generateGoldenTestsPrompt = do+ putText "> Are you sure want to generate new golden examples? [y/N]"+ getLine >>= \case+ "y" -> generateGoldenTests+ _ -> putText "Aborting generation"++generateGoldenTests :: IO ()+generateGoldenTests = do+ testCaseFiles <- findHaskellFiles testDataPath+ forM_ testCaseFiles $ \testCasePath -> do+ Right modifiedSrc <- importifyFileContent testCasePath+ goldenPath <- testCasePath -<.> "golden"+ writeBinaryFile goldenPath modifiedSrc
+ test/hspec/Runner.hs view
@@ -0,0 +1,29 @@+module Main where++import Universum++import Data.List (partition)+import System.Environment (withArgs)+import System.Wlog (infoPlus)++import Test.Hspec (hspec)++import Extended.System.Wlog (initImportifyLogger)+import Importify.Environment (runCache)+import Importify.Main (importifyCacheProject)++import qualified Test.Cache+import qualified Test.File++main :: IO ()+main = do+ (cacheArgs, hspecArgs) <- splitCmdOptions <$> getArgs+ initImportifyLogger infoPlus+ when (null cacheArgs) $ runCache False importifyCacheProject++ withArgs hspecArgs $ hspec $ do+ Test.Cache.modulesMapSpec+ Test.File.spec++splitCmdOptions :: [String] -> ([String], [String])+splitCmdOptions = partition (== "--no-cache")
+ test/hspec/Test/Cache.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Tests for @importify cache@ command.++module Test.Cache+ ( modulesMapSpec+ ) where++import Universum++import qualified Data.HashMap.Strict as HM+import Lens.Micro.Platform (at, (?=))+import Path (fromAbsFile, mkRelFile, (</>))+import Path.IO (getCurrentDir)++import Test.Hspec (Spec, describe, it, runIO, shouldSatisfy)++import Importify.Cabal (ModulesBundle (..), ModulesMap, TargetId (..))+import Importify.Path (decodeFileOrMempty, importifyPath, modulesPath)++-- | 'Spec' for modules mapping.+modulesMapSpec :: Spec+modulesMapSpec = do+ testMap <- runIO createTestModulesMap+ cacheMap <- runIO $ decodeFileOrMempty (importifyPath </> modulesPath) return+ describe "cache:targets map" $+ it "Test map is subset of cache" $+ testMap `shouldSatisfy` (`subsetOf` cacheMap)++createTestModulesMap :: IO ModulesMap+createTestModulesMap = do+ curDir <- getCurrentDir+ let withDir path = fromAbsFile $ curDir </> path+ return $ executingState mempty $ do+ at (withDir $(mkRelFile "src/Importify/Path.hs")) ?= -- Simple file from library+ ModulesBundle "importify-1.0" "Importify.Path" LibraryId+ at (withDir $(mkRelFile "src/Importify/Main.hs")) ?= -- autoexported file+ ModulesBundle "importify-1.0" "Importify.Main" LibraryId+ at (withDir $(mkRelFile "src/Extended/Data/List.hs")) ?= -- file from other-modules+ ModulesBundle "importify-1.0" "Extended.Data.List" LibraryId+ at (withDir $(mkRelFile "app/Main.hs")) ?= -- Main file from executable+ ModulesBundle "importify-1.0" "Main" (ExecutableId "importify")+ at (withDir $(mkRelFile "app/Options.hs")) ?= -- other file from executable+ ModulesBundle "importify-1.0" "Options" (ExecutableId "importify")+ at (withDir $(mkRelFile "test/hspec/Runner.hs")) ?= -- Main file for tests+ ModulesBundle "importify-1.0" "Main" (TestSuiteId "importify-test")+ at (withDir $(mkRelFile "test/hspec/Test/File.hs")) ?= -- Other file from tests+ ModulesBundle "importify-1.0" "Test.File" (TestSuiteId "importify-test")+++-- | @testMap `subsetOf` cacheMap@ returns 'True' iff all entries from+-- @testMap@ are in @biggerMap@.+subsetOf :: ModulesMap -> ModulesMap -> Bool+testMap `subsetOf` cacheMap = all isInCacheMap (HM.toList testMap)+ where+ isInCacheMap :: (FilePath, ModulesBundle) -> Bool+ isInCacheMap (path, bundle) = (== Just bundle) $ HM.lookup path cacheMap
+ test/hspec/Test/File.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Tests for @importify file@ command.++module Test.File+ ( spec+ ) where++import Universum++import Data.List (sort)+import Path (Abs, Dir, File, Path, Rel, dirname, fileExtension,+ filename, fromRelDir, fromRelFile, fromAbsFile, mkRelFile,+ (-<.>), (</>))+import Path.IO (listDir)+import System.Wlog (Severity)++import Test.Hspec (Spec, describe, it, runIO, shouldBe, xit)++import Importify.Main (importifyFileContent)+import Importify.Path (testDataPath)++spec :: Spec+spec = do+ (testFolders, _) <- runIO $ listDir testDataPath+ describe "file:unused" $+ mapM_ (makeTestGroup . (testDataPath </> ) . dirname) testFolders+++makeTestGroup :: Path Rel Dir -> Spec+makeTestGroup testCasesPath = do+ (_, testDirPaths) <- runIO $ listDir testCasesPath+ let testHsOnly = sort+ $ filter ((== ".hs") . fileExtension) testDirPaths++ describe ("subfolder: " ++ fromRelDir (dirname testCasesPath)) $+ mapM_ makeTest testHsOnly++makeTest :: Path Abs File -> Spec+makeTest testCasePath = do+ (result, expected) <- runIO $ loadTestData testCasePath+ let testType = if filename testCasePath `elem` pendingTests then xit else it+ testType (fromRelFile $ filename testCasePath) $ result `shouldBe` expected++pendingTests :: [Path Rel File]+pendingTests = [ $(mkRelFile "01-ImportBothUsedQualified.hs") -- Importify can't modify source yet+ ]++loadTestData :: Path Abs File -> IO (Text, Text)+loadTestData testCasePath = do+ goldenExamplePath <- testCasePath -<.> ".golden"++ goldenExampleSrc <- readFile (fromAbsFile goldenExamplePath)+ Right importifiedSrc <- importifyFileContent testCasePath++ return (importifiedSrc, goldenExampleSrc)