{- # OPTIONS_GHC -Wall #-}
{-# LANGUAGE ViewPatterns, PatternGuards, DeriveDataTypeable #-}
module Main where
import System.Console.Haskeline
import Control.Monad.State
import System.Environment
import System.Directory
import CLI.HaskelineTransAdapter ()
import Control.Monad as List (mapM_)
import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(..))
import Data.List
import Data.Maybe (maybeToList)
import Data.Char (toLower)
import qualified Data.Set as S (member, toList, map)
import Data.Set.Extra as Set (Set, toList)
import Language.Haskell.Modules (cleanImports, CleanT, findHsModules, mergeModules, modifyDirs, ModuleName(..), MonadClean, noisily, putDirs, putModule, runCleanT, splitModuleDecls)
import Language.Haskell.Modules.ModuVerse (getNames)
import Language.Haskell.Modules.SourceDirs (getDirs)
import Language.Haskell.Modules.Util.QIO (modifyVerbosity)
import System.Console.Haskeline (completeFilename, CompletionFunc, defaultSettings, getInputLine, InputT, noCompletion, runInputT, setComplete, simpleCompletion)
import System.IO (hPutStrLn, stderr)
import System.Console.CmdArgs
import Control.Lens
import Data.Maybe
import Control.Monad.Reader
import Distribution.PackageDescription (GenericPackageDescription)
import qualified CLI.Cabal as Cabal
import qualified Distribution.Verbosity
import Data.Data
import Data.Foldable(traverse_)
import System.Console.Haskeline.MonadException
import Control.Exception (fromException)
import System.Exit
data HMM = CLI
{ verbosity :: Int,
verbosityCabal :: Int,
caseSensitiveCompletion :: Bool,
cabalFile :: Maybe FilePath,
otherFiles :: [FilePath] }
deriving (Data,Typeable,Show)
defaultHMM = CLI
{ Main.verbosity = fromEnum Loud
&= enumHelp "module-management verbosity" (undefined :: Verbosity)
(Main.verbosity defaultHMM),
verbosityCabal = fromEnum (maxBound :: Distribution.Verbosity.Verbosity)
&= enumHelp "cabal file parser verbosity"
(undefined :: Distribution.Verbosity.Verbosity)
(verbosityCabal defaultHMM),
caseSensitiveCompletion = False
&= help "should completion of module names be case-sensitive?"
&= name "s",
cabalFile = Nothing
&= typFile
&= name "f"
&= help ".cabal file to load. Modules listed there will be loaded\
\ and when modules are split the .cabal file will be updated\
\ when you quit or use the cabalWrite command",
otherFiles = []
&= typFile
&= args }
enumHelp item proxy def =
help ("Level of "++item++". Takes values from " ++
rangeOfBounded (undefined `asTypeOf` proxy) ++
". Default is "++ show def ++ ".")
rangeOfBounded proxy = show (fromEnum (minBound `asTypeOf` proxy))
++ " to "
++ show (fromEnum (maxBound `asTypeOf` proxy))
toEnumBounded :: (Bounded e, Enum e) => Int -> e
toEnumBounded i =
let r | i > iMax = maxBound
| i < iMin = minBound
| otherwise = toEnum i
iMax = fromEnum (maxBound `asTypeOf` r)
iMin = fromEnum (minBound `asTypeOf` r)
in r
main :: IO ()
main = do
conf <- cmdArgs defaultHMM
let args = otherFiles conf
pkgDesc' <-
traverse (Cabal.readPackageDescription (toEnumBounded (verbosityCabal conf)))
(cabalFile conf)
let initState = do
traverse (dir . (".":) . Cabal.getSrcDirs) pkgDesc'
modifyVerbosity $ \ _ -> Main.verbosity conf
let modules0 = args ++ (map moduleNameToStr $ Cabal.getModules =<< maybeToList pkgDesc')
when (not (null modules0)) $ verse modules0
execCmdM :: CmdM a -> IO (Maybe GenericPackageDescription)
execCmdM x = runCleanT
$ flip execStateT pkgDesc'
$ flip runReaderT conf
$ runInputT (setComplete ((lift . lift) `fmap` compl conf) defaultSettings) x
pkgDesc' <- execCmdM $ do
liftCT initState
let step = cli
loop = catch (do step; loop) $ \e @ SomeException {} -> case () of
_ | Just e <- fromException e -> throwIO (e `asTypeOf` ExitSuccess)
| Just (Callback _msg f) <- fromException e -> f loop
_ -> do
liftIO (print e)
loop
loop
-- this gets bypassed when the ExitCode is re-thrown.
-- Should it be run on ExitFailures or just success?
traverse_ (uncurry Cabal.writeGenericPackageDescription)
$ liftM2 (,) (cabalFile conf) pkgDesc'
-- | these versions of quietly and noisily play well with 'lift'
quietly', noisily' :: CmdM a -> CmdM a
quietly' act = do
liftCT (modifyVerbosity (\x -> x - 1))
r <- act
liftCT (modifyVerbosity (+ 1))
return r
noisily' act = do
liftCT (modifyVerbosity (+ 1))
r <- act
liftCT (modifyVerbosity (\x -> x - 1))
return r
compl :: HMM -> CompletionFunc (CleanT IO)
compl conf (xs,ys) | cmd: _ <- words (reverse xs),
matchingCommands <- filter (cmd `isPrefixOf`) commandNames = case matchingCommands of
_:_:_ | Nothing <- stripPrefix " " =<< stripPrefix cmd (reverse xs) ->
return ("", map simpleCompletion matchingCommands)
[] -> return ("", map simpleCompletion commandNames)
[x] | cmd `notElem` commandNames -> return ("", [simpleCompletion x])
| takesModuleNames cmd -> do
ns <- getNames
let complAllModules = map (simpleCompletion . moduleNameToStr) (S.toList ns)
nsLower = S.map (ModuleName . map toLower . moduleNameToStr) ns
transform
| caseSensitiveCompletion conf = id
| nsLower == ns = map toLower
| otherwise = id
return $ case span (/=' ') xs of
(reverse -> cw @ (_:_), rest) ->
case filter (isPrefixOf (transform cw) . transform)
(moduleNameToStr `map` S.toList ns) of
-- this first case isn't really needed: it should do the same as the
-- next case but possibly be more efficient
_ | ModuleName cw `S.member` ns -> (rest, [simpleCompletion cw])
[modName] -> (rest, [simpleCompletion modName])
_ -> (rest, complAllModules)
_ -> (xs, complAllModules)
| otherwise -> completeFilename (xs,ys)
_ -> noCompletion (xs,ys)
compl _ x = noCompletion x
moduleNameToStr :: ModuleName -> String
moduleNameToStr (ModuleName x) = x
takesModuleNames :: String -> Bool
takesModuleNames x = x `elem` ["merge"]
cli :: CmdM ()
cli = cmd . concatMap words . maybeToList =<< getInputLine "> "
type CmdM a = InputT (ReaderT HMM (StateT (Maybe GenericPackageDescription) (CleanT IO))) a
askConf :: CmdM HMM
askConf = lift ask
liftCT :: CleanT IO a -> CmdM a
liftCT = lift . lift . lift
liftS :: StateT (Maybe GenericPackageDescription) (CleanT IO) a -> CmdM a
liftS = lift . lift
cmd :: [String] -> CmdM ()
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 = cmds_ args
data Callback = Callback String (CmdM () -> CmdM ()) deriving (Typeable)
instance Show Callback where
show (Callback x _) = x
instance Exception Callback
commandNames :: [String]
commandNames = concatMap fst (cmds_ undefined)
cmds_ :: [String] -> [([String], CmdM ())]
cmds_ args =
[(["quit", "exit", "bye", ".", "\EOT"], do
liftIO (hPutStrLn stderr "Exiting")
throwIO ExitSuccess),
(["v"], throwIO . Callback "louder" $ \next -> do
liftIO (hPutStrLn stderr "Increasing Verbosity")
noisily' next),
(["q"], throwIO . Callback "quieter" $ \next -> do
liftIO (hPutStrLn stderr "Decreasing Verbosity")
quietly' next),
-- The error message is more helpful
-- (["help"], liftIO (hPutStrLn stderr "help text")),
(["verse"], liftCT (verse args)),
(["clean"], liftCT (clean args)),
(["dir"], liftCT (dir args)),
(["split"], split args),
(["merge"], merge args),
(["cabalPrint"], cabalPrint),
(["cabalRead"], cabalRead args),
(["cabalWrite"], cabalWrite args)]
cabalPrint :: CmdM ()
cabalPrint = do
pkgDesc <- liftS get
liftIO $ putStrLn $ case pkgDesc of
Nothing -> "No cabal file loaded"
Just x -> Cabal.showGenericPackageDescription x
cabalWrite, cabalRead :: [String] -> CmdM ()
cabalWrite [f] = do
pkgDesc <- liftS get
liftIO $ case pkgDesc of
Nothing -> putStrLn "cabalWrite: no cabal file was loaded"
Just x -> Cabal.writeGenericPackageDescription f x
cabalWrite [] = do
conf <- askConf
case cabalFile conf of
Nothing -> liftIO $ putStrLn "Usage: cabalWrite <file.cabal>"
Just f -> cabalWrite [f] -- goto previous case
cabalWrite _ = liftIO $ putStrLn "Usage: cabalWrite <file.cabal>"
cabalRead [f] = throwIO . Callback "cabalRead" $ \next -> do
conf <- askConf
pd <- liftIO $ Cabal.readPackageDescription (toEnumBounded (verbosityCabal conf)) f
liftCT $ do
ds <- getDirs
let ds' = Cabal.getSrcDirs pd
unless (null $ ds' \\ ds) $ dir ds'
verse (unModuleName `map` Cabal.getModules pd)
mapInputT (local (\x -> x{ cabalFile = Just f })) next
cabalRead _ = liftIO $ putStrLn "Usage: cabalRead <file.cabal>"
unModuleName :: ModuleName -> String
unModuleName (ModuleName x) = x
verse :: MonadClean m => [String] -> m ()
verse [] =
do modules <- getNames
liftIO $ putStrLn ("Usage: verse <pathormodule1> <pathormodule2> ...\n" ++
"Add the module or all the modules below a directory to the moduVerse\n" ++
"Currently:\n " ++ showVerse modules)
verse args =
do new <- mapM (liftIO . find) args
List.mapM_ (List.mapM_ putModule) new
modules <- getNames
liftIO (putStrLn $ "moduVerse updated:\n " ++ showVerse modules)
where
find s =
do ms <- liftIO (findHsModules [s])
case ms of
[] -> return [ModuleName s]
_ -> return ms
showVerse :: Set ModuleName -> String
showVerse modules = "[ " ++ intercalate "\n , " (map unModuleName (toList modules)) ++ " ]"
dir :: MonadClean m => [FilePath] -> m ()
dir [] = putDirs []
dir xs =
do modifyDirs (++ xs)
xs' <- getDirs
liftIO (putStrLn $ "sourceDirs updated:\n [ " ++ intercalate "\n , " xs' ++ " ]")
clean :: MonadClean m => [FilePath] -> m ()
clean [] = liftIO $ putStrLn "Usage: clean <modulepath1> <modulepath2> ..."
clean args = cleanImports args >> return ()
split :: [FilePath] -> CmdM ()
split [arg] = do
r <- liftCT (splitModuleDecls arg)
lift (modify (Cabal.update r))
return ()
split _ = liftIO $ putStrLn "Usage: split <modulepath>"
merge :: [String] -> CmdM ()
merge args =
case splitAt (length args - 1) args of
(inputs, [output]) -> do
r <- liftCT $ mergeModules (map ModuleName inputs) (ModuleName output)
liftS (modify (Cabal.update r))
_ -> liftIO $ putStrLn "Usage: merge <inputmodulename1> <inputmodulename2> ... <outputmodulename>"