{-# OPTIONS_GHC -Wall #-}
module Main where
import Control.Monad.Trans (MonadIO(liftIO))
import Data.List (intercalate, isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.Set (Set, union, toList, empty, size, unions, singleton)
import Language.Haskell.Exts.Syntax (ModuleName(ModuleName))
import Language.Haskell.Modules (runMonadClean, cleanImports, splitModuleDecls, mergeModules,
modifyModuVerse, modifySourceDirs)
import Language.Haskell.Modules.Internal (getParams, Params(..))
import Language.Haskell.Modules.Params (MonadClean)
import Language.Haskell.Modules.Util.QIO (noisily, quietly)
import Language.Haskell.Modules.Util.Test (findModules)
import System.IO (stdin, stderr, hGetLine, hPutStr, hPutStrLn)
main :: IO ()
main = runMonadClean (noisily cli)
cli :: MonadClean m => m ()
cli = liftIO (hPutStr stderr " > " >> hGetLine stdin) >>= cmd . words
cmd :: MonadClean m => [String] -> m ()
cmd [] = cli
cmd (s : args) =
case filter (any (== s) . fst) cmds of
[(_, f)] -> f
-- No exact matches - look for prefix matches
[] -> case filter (any (isPrefixOf s) . fst) cmds of
[(_, f)] -> f
[] -> liftIO (hPutStrLn stderr $
show s ++ " invalid - expected " ++ intercalate ", " (concatMap fst cmds)) >> cli
xs -> liftIO (hPutStrLn stderr $
show s ++ " ambiguous - expected " ++ intercalate ", " (concatMap fst xs)) >> cli
_ -> error $ "Internal error - multiple definitions for " ++ show s
where
cmds =
[(["quit", "exit", "bye", "."], liftIO (hPutStrLn stderr "Exiting")),
(["v"], liftIO (hPutStrLn stderr "Increasing verbosity level") >> noisily cli),
(["q"], liftIO (hPutStrLn stderr "Decreasing verbosity level") >> quietly cli),
(["help"], liftIO (hPutStrLn stderr "help text") >> cli),
(["verse"], verse args >> cli),
(["clean"], clean args >> cli),
(["dir"], dir args >> cli),
(["split"], split args >> cli),
(["merge"], merge args >> cli)]
unModuleName :: ModuleName -> String
unModuleName (ModuleName x) = x
verse :: MonadClean m => [String] -> m ()
verse [] =
do modules <- getParams >>= return . moduVerse
liftIO $ hPutStrLn stderr ("Usage: verse <pathormodule1> <pathormodule2> ...\n" ++
"Add the module or all the modules below a directory to the moduVerse\n" ++
"Currently:\n " ++ showVerse (fromMaybe empty modules))
verse args =
do new <- mapM (liftIO . find) args
modifyModuVerse (union (unions new))
modules <- getParams >>= return . moduVerse
liftIO (hPutStrLn stderr $ "moduVerse updated:\n " ++ showVerse (fromMaybe empty modules))
where
find :: String -> IO (Set ModuleName)
find s =
do ms <- liftIO (findModules s)
case size ms of
0 -> return (singleton (ModuleName s))
_ -> return ms
showVerse :: Set ModuleName -> String
showVerse modules = "[ " ++ intercalate "\n , " (map unModuleName (toList modules)) ++ " ]"
dir :: MonadClean m => [FilePath] -> m ()
dir [] = modifySourceDirs (const [])
dir xs =
do modifySourceDirs (++ xs)
xs' <- getParams >>= return . sourceDirs
liftIO (hPutStrLn stderr $ "sourceDirs updated:\n [ " ++ intercalate "\n , " xs' ++ " ]")
clean :: MonadClean m => [FilePath] -> m ()
clean [] = liftIO $ hPutStrLn stderr "Usage: clean <modulepath1> <modulepath2> ..."
clean args = mapM_ cleanImports args
split :: MonadClean m => [String] -> m ()
split [arg] = splitModuleDecls (ModuleName arg)
split _ = liftIO $ hPutStrLn stderr "Usage: split <modulename>"
merge :: MonadClean m => [String] -> m ()
merge args =
case splitAt (length args - 1) args of
(inputs, [output]) -> mergeModules (map ModuleName inputs) (ModuleName output) >> return ()
_ -> liftIO $ hPutStrLn stderr "Usage: merge <inputmodulename1> <inputmodulename2> ... <outputmodulename>"