🚜 📰 [IMRF-102] Refactor common parts of importify commands

app/Main.hs

@@ -11,24 +11,24 @@ module Main where
 
 import           Universum
 
-import           Extended.System.Wlog  (initImportifyLogger)
-import           Importify.Environment (runCache)
-import           Importify.Main        (OutputOptions, importifyCacheList,
-                                        importifyCacheProject, importifyRemoveWithOptions,
-                                        importifyToExplicitWithOptions)
+import           Extended.System.Wlog    (initImportifyLogger)
+import           Importify.Environment   (runCache)
+import           Importify.Main          (importifyCacheList, importifyCacheProject,
+                                          importifyRemoveUnused, importifyToExplicit)
+import           Importify.OutputOptions (OutputOptions)
 
-import           Options               (CabalCacheOptions (..), Command (..),
-                                        ImportifyCliArgs (..), SingleFileOptions (..),
-                                        coLoggingSeverity, parseOptions)
+import           Options                 (CabalCacheOptions (..), Command (..),
+                                          ImportifyCliArgs (..), SingleFileOptions (..),
+                                          coLoggingSeverity, parseOptions)
 
 main :: IO ()
 main = do
     ImportifyCliArgs{..} <- parseOptions
     initImportifyLogger (coLoggingSeverity icaCommon)
     case icaCommand of
         CabalCache   ccOpts -> buildCabalCache ccOpts
-        RemoveUnused sfOpts -> runCommand importifyRemoveWithOptions     sfOpts
-        ToExplicit   sfOpts -> runCommand importifyToExplicitWithOptions sfOpts
+        RemoveUnused sfOpts -> runCommand importifyRemoveUnused sfOpts
+        ToExplicit   sfOpts -> runCommand importifyToExplicit   sfOpts
 
 buildCabalCache :: CabalCacheOptions -> IO ()
 buildCabalCache CabalCacheOptions{..} =

app/Options.hs

@@ -14,14 +14,15 @@ module Options
 
 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 qualified Prelude             (show)
-import           System.Wlog         (Severity (Info))
-
-import           Importify.Main      (OutputOptions (..))
+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 qualified Prelude                 (show)
+import           System.Wlog             (Severity (Info))
+
+import           Importify.OutputOptions (OutputOptions (..))
 
 data ImportifyCliArgs = ImportifyCliArgs
     { icaCommon  :: !CommonOptions

importify.cabal

@@ -23,6 +23,7 @@ source-repository head
 library
   hs-source-dirs:      src
   exposed-modules:
+                       Importify.Bracket
                        Importify.Cabal
                            Importify.Cabal.Extension
                            Importify.Cabal.Module
@@ -31,9 +32,9 @@ library
                        Importify.Environment
                        Importify.Main
                            Importify.Main.Cache
-                           Importify.Main.OutputOptions
                            Importify.Main.RemoveUnused
                            Importify.Main.ToExplicit
+                       Importify.OutputOptions
                        Importify.ParseException
                        Importify.Path
                        Importify.Preprocessor
@@ -98,6 +99,7 @@ library
                        OverloadedStrings
                        PartialTypeSignatures
                        RecordWildCards
+                       TypeApplications
 
 executable importify
   hs-source-dirs:      app

safe_importify.sh

@@ -1,4 +1,4 @@
 #!/usr/bin/env bash
 
 cp "$1" module_backup
-./importify file -i "$1"
+./importify remove -i "$1"

src/Importify/Bracket.hs

@@ -0,0 +1,145 @@
+-- | This module contains functions which wrap @importify@ commands.
+
+module Importify.Bracket
+       ( ImportifyArguments     (..)
+       , ImportifyFileException (..)
+       , ImportifyResult
+       , importifyOptionsBracket
+       , importifyPathBracket
+       , loadEnvironment
+       ) where
+
+import           Universum
+
+import qualified Data.HashMap.Strict                as HM
+import qualified Data.Map                           as M
+
+import           Fmt                                (fmt, (+|), (|+))
+import           Language.Haskell.Exts              (Comment (..), Extension,
+                                                     Module (..),
+                                                     ModuleName (..), SrcSpanInfo,
+                                                     exactPrint, parseExtension,
+                                                     parseFileContentsWithComments)
+import           Language.Haskell.Exts.Parser       (ParseMode (..), defaultParseMode)
+import           Language.Haskell.Names             (Environment,
+                                                     loadBase, readSymbols)
+import           Path                               (Abs,      File, Path,
+                                                     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.OutputOptions
+import           Importify.ParseException           (eitherParseResult, setMpeFile)
+import           Importify.Path                     (decodeFileOrMempty, doInsideDir,
+                                                     extensionsPath, importifyPath,
+                                                     lookupToRoot, modulesPath,
+                                                     symbolsPath)
+
+-- | Type that represents exception occurred during @importify@ command.
+newtype ImportifyFileException = IFE Text
+
+-- | Convenient type alias for return result of @importify file@ command.
+type ImportifyResult = Either ImportifyFileException Text
+
+-- | Bracket for every command which process file.
+importifyOptionsBracket :: (Path Abs File -> IO ImportifyResult)
+                        -> OutputOptions
+                        -> FilePath
+                        -> IO ()
+importifyOptionsBracket importify 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 $ importify $ curDir </> srcFromRootPath
+            handleOptions importifyResult
+  where
+    handleOptions :: Either ImportifyFileException Text -> IO ()
+    handleOptions (Left (IFE msg))    = printError msg
+    handleOptions (Right modifiedSrc) = printWithOutputOptions options modifiedSrc
+
+-- | All needed data for @importify@ command which processes one file.
+data ImportifyArguments = ImportifyArguments
+    { importifyArgumentsAst        :: !(Module SrcSpanInfo)
+    , importifyArgumentsModulesMap :: !ModulesMap
+    , importifyArgumentsSrc        :: !Text
+    , importifyArgumentsComments   :: ![Comment]
+    } deriving (Show)
+
+-- | Runs given action over parsed AST.
+importifyPathBracket :: (ImportifyArguments -> IO ImportifyResult)
+                     -> Path Abs File
+                     -> IO ImportifyResult
+importifyPathBracket importify 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) -> importify ImportifyArguments
+                                    { importifyArgumentsAst        = ast
+                                    , importifyArgumentsModulesMap = modulesMap
+                                    , importifyArgumentsSrc        = src
+                                    , importifyArgumentsComments   = comments
+                                    }
+
+-- | Reads 'ModulesMap' from @.importify/modules@.
+readModulesMap :: IO ModulesMap
+readModulesMap = decodeFileOrMempty (importifyPath </> modulesPath) pure
+
+readExtensions :: Path Abs File -> ModulesMap -> IO [Extension]
+readExtensions srcPath modulesMap = do
+    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)