Merge pull request #4 from YusukeHosonuma/improve

Author: YusukeHosonuma

README.md

@@ -4,11 +4,13 @@ A CLI tool that auto-fix module name of .hs files from the definition of `packag
 
 ```bash
 $ cd <stack-project-root>
-$ fix-module # Warning: This command will overwrite .hs files
+$ fix-module           # Warning: This command will overwrite .hs files
+$ fix-module --verbose # With verbose log
 ```
 
 ## TODO
-- [ ] Support `.cabal`
+- [ ] Add support to `.cabal`.
+- [ ] Auto-fix import. (undecided)
 
 ## Installation
 

app/Main.hs

@@ -1,7 +1,9 @@
 module Main where
 
+import           Control.Exception
 import           Control.Monad
-import           FixModule
+import           Control.Monad.Trans.Reader
+import           FixModule.Module
 import           System.Directory
 import           System.Environment
 import           System.Exit
@@ -10,17 +12,25 @@ main :: IO ()
 main = do
     args <- getArgs
     when ("--version" `elem` args) printVersion
+    let verbose = "--verbose" `elem` args
     exist <- doesFileExist "package.yaml"
     unless exist exitPackageYamlNotFound
     pwd <- getCurrentDirectory
-    fixModule pwd  -- TODO: 例外処理
+    runReaderT (fixModule pwd) (Env verbose) `catch` reportException
 
 printVersion :: IO ()
 printVersion = do
-    putStrLn "fix-module 0.1.0.0"
+    putStrLn "fix-module 0.1.0"
     exitSuccess
 
 exitPackageYamlNotFound :: IO ()
 exitPackageYamlNotFound = do
-    putStrLn "package.yaml is not found. (not support .cabal yet)"
+    putStrLn "A package.yaml is not found. (Not support .cabal yet)"
     exitFailure
+
+reportException :: SomeException -> IO ()
+reportException e = do
+    putStrLn "Fatal error.\n"
+    putStrLn $ "[Cause]\n" ++ displayException e ++ "\n"
+    putStrLn "Please report issue when reproducible."
+    putStrLn "https://github.com/YusukeHosonuma/fix-module/issues/new"

fix-module.cabal

@@ -25,7 +25,6 @@ source-repository head
 
 library
   exposed-modules:
-      FixModule
       FixModule.Module
       FixModule.Package
   other-modules:
@@ -38,6 +37,7 @@ library
     , extra
     , filepath
     , text
+    , transformers
     , unordered-containers
     , yaml
   default-language: Haskell2010
@@ -53,6 +53,7 @@ executable fix-module
       base >=4.7 && <5
     , directory
     , fix-module
+    , transformers
   default-language: Haskell2010
 
 test-suite fix-module-test
@@ -69,4 +70,5 @@ test-suite fix-module-test
     , process
     , tasty
     , tasty-hunit
+    , transformers
   default-language: Haskell2010

package.yaml

@@ -29,6 +29,7 @@ library:
   - extra
   - filepath
   - text
+  - transformers
   - unordered-containers
   - yaml
 
@@ -44,6 +45,7 @@ executables:
     dependencies:
     - fix-module
     - directory
+    - transformers
 
 tests:
   fix-module-test:
@@ -56,6 +58,7 @@ tests:
     - -Wall
     dependencies:
     - fix-module
+    - process
     - tasty
     - tasty-hunit
-    - process
+    - transformers

src/FixModule.hs

@@ -1,38 +1,49 @@
-module FixModule.Module (fixModuleRecursive)  where
+module FixModule.Module
+    ( fixModule
+    , Env (..)
+    ) where
 
 import           Control.Monad
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Reader
 import           Data.List
+import           FixModule.Package
 import           System.Directory
 import           System.FilePath.Posix
 import           System.IO.Extra
 
 type ModuleName = String
 
-fixModuleRecursive :: FilePath -> IO ()
+newtype Env = Env { isVerbose :: Bool }
+
+fixModule :: FilePath -> ReaderT Env IO ()
+fixModule rootDir = do
+    dirs <- lift lookupSourceDirs
+    verbose $ "Found source-diretories:\n" ++ unlines (map ("- " <>) dirs)
+    mapM_ (fixModuleRecursive . (rootDir </>)) dirs
+
+fixModuleRecursive :: FilePath -> ReaderT Env IO ()
 fixModuleRecursive rootDir = do
-    ps <- findHaskellFilePathes rootDir
+    ps <- lift $ findHaskellFilePathes rootDir
     mapM_ (fixModuleFile rootDir) ps
 
 --------------------------------------------------------------------------------
 
-findHaskellFilePathes :: FilePath -> IO [FilePath]
-findHaskellFilePathes path = do
-    xs <- map (path </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents path
-    let hsFiles = filter (".hs" `isExtensionOf`) xs
-    dirs <- filterM doesDirectoryExist xs
-    subHsFiles <- concat <$> mapM findHaskellFilePathes dirs
-    return $ hsFiles ++ subHsFiles
-
-fixModuleFile :: FilePath -> FilePath -> IO ()
+fixModuleFile :: FilePath -> FilePath -> ReaderT Env IO ()
 fixModuleFile rootDir target = do
     let mName = moduleName rootDir target
-    valid <- isValidModule mName target
+    valid <- lift $ isValidModule mName target
     if valid
         then
-            putStrLn $ "Skip: " ++ target -- verbose に対応
+            verbose $ "[skip] " ++ target
         else do
-            updateFileWith target (fixModuleContent mName)
-            putStrLn $ "Done: " ++ target
+            lift $ updateFileWith target (fixModuleContent mName)
+            verbose $ "[done] " ++ target
+
+verbose :: String -> ReaderT Env IO ()
+verbose s = do
+    v <- asks isVerbose
+    when v $ lift $ putStrLn s
 
 fixModuleContent :: ModuleName -> String -> String
 fixModuleContent mName = unlines . map (fixModuleLine mName) . lines
@@ -85,6 +96,14 @@ moduleName root filePath =
 
 --------------------------------------------------------------------------------
 
+findHaskellFilePathes :: FilePath -> IO [FilePath]
+findHaskellFilePathes path = do
+    xs <- map (path </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents path
+    let hsFiles = filter (".hs" `isExtensionOf`) xs
+    dirs <- filterM doesDirectoryExist xs
+    subHsFiles <- concat <$> mapM findHaskellFilePathes dirs
+    return $ hsFiles ++ subHsFiles
+
 updateFileWith :: FilePath -> (String -> String) -> IO ()
 updateFileWith fp f = do
     contents <- readFile' fp

src/FixModule/Module.hs

@@ -5,13 +5,14 @@ module Main where
 import Test.Tasty
 import Test.Tasty.HUnit
 import System.Process
-import FixModule
+import FixModule.Module
 import Control.Exception
+import Control.Monad.Trans.Reader
 
 main :: IO ()
 main = defaultMain $
     testCase "fixModule" $ do
-        fixModule "./test-asset"
+        runReaderT (fixModule "./test-asset") $ Env True -- enable `--verbose `
         callCommand "stack build --stack-yaml ./test-asset/stack.yaml"
             `catch`   (\(e :: SomeException) -> assertFailure $ displayException e)
             `finally` callCommand "git checkout HEAD ./test-asset" -- clean-up