diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -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 diff --git a/importify.cabal b/importify.cabal new file mode 100644 --- /dev/null +++ b/importify.cabal @@ -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 +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 diff --git a/src/Extended/Data/Bool.hs b/src/Extended/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Extended/Data/Bool.hs @@ -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 ==> diff --git a/src/Extended/Data/List.hs b/src/Extended/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Extended/Data/List.hs @@ -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..] diff --git a/src/Extended/Data/Str.hs b/src/Extended/Data/Str.hs new file mode 100644 --- /dev/null +++ b/src/Extended/Data/Str.hs @@ -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 diff --git a/src/Extended/Lens/TH.hs b/src/Extended/Lens/TH.hs new file mode 100644 --- /dev/null +++ b/src/Extended/Lens/TH.hs @@ -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 diff --git a/src/Extended/System/Wlog.hs b/src/Extended/System/Wlog.hs new file mode 100644 --- /dev/null +++ b/src/Extended/System/Wlog.hs @@ -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 diff --git a/src/Importify/Cabal.hs b/src/Importify/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Cabal.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Importify/Cabal/Extension.hs b/src/Importify/Cabal/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Cabal/Extension.hs @@ -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 + ]) diff --git a/src/Importify/Cabal/Module.hs b/src/Importify/Cabal/Module.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Cabal/Module.hs @@ -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 diff --git a/src/Importify/Cabal/Package.hs b/src/Importify/Cabal/Package.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Cabal/Package.hs @@ -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) diff --git a/src/Importify/Cabal/Target.hs b/src/Importify/Cabal/Target.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Cabal/Target.hs @@ -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) diff --git a/src/Importify/Environment.hs b/src/Importify/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Environment.hs @@ -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 diff --git a/src/Importify/Main.hs b/src/Importify/Main.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Importify/Main/Cache.hs b/src/Importify/Main/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Main/Cache.hs @@ -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 @.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/ 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// 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//.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 diff --git a/src/Importify/Main/File.hs b/src/Importify/Main/File.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Main/File.hs @@ -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) diff --git a/src/Importify/ParseException.hs b/src/Importify/ParseException.hs new file mode 100644 --- /dev/null +++ b/src/Importify/ParseException.hs @@ -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 diff --git a/src/Importify/Path.hs b/src/Importify/Path.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Path.hs @@ -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 diff --git a/src/Importify/Preprocessor.hs b/src/Importify/Preprocessor.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Preprocessor.hs @@ -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 diff --git a/src/Importify/Pretty.hs b/src/Importify/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Pretty.hs @@ -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 diff --git a/src/Importify/Resolution.hs b/src/Importify/Resolution.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Resolution.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Importify/Resolution/Explicit.hs b/src/Importify/Resolution/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Resolution/Explicit.hs @@ -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 diff --git a/src/Importify/Resolution/Hiding.hs b/src/Importify/Resolution/Hiding.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Resolution/Hiding.hs @@ -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) diff --git a/src/Importify/Resolution/Implicit.hs b/src/Importify/Resolution/Implicit.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Resolution/Implicit.hs @@ -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 diff --git a/src/Importify/Resolution/Qualified.hs b/src/Importify/Resolution/Qualified.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Resolution/Qualified.hs @@ -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 diff --git a/src/Importify/Stack.hs b/src/Importify/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Stack.hs @@ -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 diff --git a/src/Importify/Syntax.hs b/src/Importify/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Syntax.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Importify/Syntax/Import.hs b/src/Importify/Syntax/Import.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Syntax/Import.hs @@ -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 A ⇒ A +-- import 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) diff --git a/src/Importify/Syntax/Module.hs b/src/Importify/Syntax/Module.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Syntax/Module.hs @@ -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 diff --git a/src/Importify/Syntax/Scoped.hs b/src/Importify/Syntax/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Syntax/Scoped.hs @@ -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 diff --git a/src/Importify/Syntax/Text.hs b/src/Importify/Syntax/Text.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Syntax/Text.hs @@ -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 diff --git a/src/Importify/Tree.hs b/src/Importify/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Importify/Tree.hs @@ -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 diff --git a/test/GGenerator.hs b/test/GGenerator.hs new file mode 100644 --- /dev/null +++ b/test/GGenerator.hs @@ -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 diff --git a/test/hspec/Runner.hs b/test/hspec/Runner.hs new file mode 100644 --- /dev/null +++ b/test/hspec/Runner.hs @@ -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") diff --git a/test/hspec/Test/Cache.hs b/test/hspec/Test/Cache.hs new file mode 100644 --- /dev/null +++ b/test/hspec/Test/Cache.hs @@ -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 diff --git a/test/hspec/Test/File.hs b/test/hspec/Test/File.hs new file mode 100644 --- /dev/null +++ b/test/hspec/Test/File.hs @@ -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)