{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
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
data OutputOptions = ToConsole
| InPlace
| ToFile FilePath
deriving (Show)
newtype ImportifyFileException = IFE Text
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
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)
removeUnusedImports
:: Module SrcSpanInfo
-> [ImportDecl SrcSpanInfo]
-> Environment
-> [ImportDecl SrcSpanInfo]
removeUnusedImports ast imports environment = do
let (annotations, moduleHead) = annotateModule ast environment
let symbolTable = importTable environment ast
let hidingTable = importTable environment $ switchHidingImports ast
let annotatedDecls = annotateImportDecls (getModuleName ast) environment imports
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
let withoutUnusedImplicits = removeImplicitImports unusedImplicits
annotatedDecls
let withoutUnusedSymbols = map unscope
$ removeImports (UnusedSymbols unusedSymbols)
(UnusedHidings unusedHidings)
withoutUnusedImplicits
let withoutUnusedQuals = removeUnusedQualifiedImports withoutUnusedSymbols
moduleHead
annotations
unusedImplicits
withoutUnusedQuals
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)