hbb-0.4.0.0: src/HBB.hs
{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import Language.Haskell.HBB.OccurrencesOf
import Language.Haskell.HBB.SmartInline
import Language.Haskell.HBB.ExprType
import Language.Haskell.HBB.ApplyTo
import Language.Haskell.HBB.Inline
import Language.Haskell.HBB.Locate
import Language.Haskell.GhcMod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
import Control.Applicative ((<$>))
import System.Environment (getArgs)
import Control.Exception (SomeException,Exception, Handler(..), ErrorCall(..))
import qualified Control.Exception as E
import System.Directory (doesFileExist)
import Data.Typeable (Typeable)
import LibHBBWrapper
import Data.Version (showVersion)
import System.Exit (exitFailure)
import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
import CoreMonad (liftIO)
import Paths_hbb
import Config (cProjectVersion)
import GHC (GhcMonad,gcatch)
----------------------------------------------------------------
progVersion :: String
progVersion = "hbb version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
ghcOptHelp :: String
ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
usage :: String
usage = progVersion
++ "Usage:\n"
++ " hbb list" ++ ghcOptHelp ++ "[-l] [-d]\n"
++ " hbb lang [-l]\n"
++ " hbb flag [-l]\n"
++ " hbb browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"
++ " hbb check " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
++ " hbb expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
++ " hbb debug " ++ ghcOptHelp ++ "\n"
++ " hbb info " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
++ " hbb type " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ " hbb split " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ " hbb sig " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ " hbb refine" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
++ " hbb auto " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ " hbb find <symbol>\n"
++ " hbb lint [-h opt] <HaskellFile>\n"
++ " ---------- modes supported by libhbb ------------\n"
++ " hbb locate " ++ ghcOptHelp ++ " <HaskellFile> <line-no> <column-no>\n"
++ " hbb inline " ++ ghcOptHelp ++ "[--adapt-ind] <HaskellFile> <line-no> <column-no> [<line-no> <column-no>]\n"
++ " hbb smart-inline " ++ ghcOptHelp ++ "[--adapt-ind] <HaskellFile> <line-no> <column-no> [<line-no> <column-no>]\n"
++ " hbb occurrences-of" ++ ghcOptHelp ++ " <HaskellFile> <line-no> <column-no> [<HaskellFile> ...]\n"
++ " hbb exprtype " ++ ghcOptHelp ++ " <HaskellFile> <expression>\n"
++ " hbb apply-to " ++ ghcOptHelp ++ "[-q] <Function of String to String> <Subject of String>\n"
++ " --- end of modes supported by libhbb ------------\n"
++ " hbb root\n"
++ " hbb doc <module>\n"
++ " hbb boot\n"
++ " hbb version\n"
++ " hbb help\n"
++ "\n"
++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"
++ "It is necessary to maintain backward compatibility.\n"
----------------------------------------------------------------
argspec :: [OptDescr ((Options,HBBOptions) -> (Options,HBBOptions))]
argspec = [ Option "l" ["tolisp"]
(NoArg (\(opts,hbbopts) -> (opts { outputStyle = LispStyle },hbbopts)))
"print as a list of Lisp"
, Option "h" ["hlintOpt"]
(ReqArg (\h (opts,hbbopts) -> (opts { hlintOpts = h : hlintOpts opts },hbbopts)) "hlintOpt")
"hlint options"
, Option "g" ["ghcOpt"]
(ReqArg (\g (opts,hbbopts) -> (opts { ghcUserOptions = g : ghcUserOptions opts },hbbopts)) "ghcOpt")
"GHC options"
, Option "v" ["verbose"]
(NoArg (\(opts,hbbopts) -> (opts { ghcUserOptions = "-v" : ghcUserOptions opts },hbbopts)))
"verbose"
, Option "o" ["operators"]
(NoArg (\(opts,hbbopts) -> (opts { operators = True },hbbopts)))
"print operators, too"
, Option "d" ["detailed"]
(NoArg (\(opts,hbbopts) -> (opts { detailed = True },hbbopts)))
"print detailed info"
, Option "q" ["qualified","quiet"]
(NoArg (\(opts,hbbopts) -> (opts { qualified = True },hbbopts { quietApplyTo = True })))
"show qualified names / suppress warning (quiet) in mode apply-to"
, Option "b" ["boundary"]
(ReqArg (\s (opts,hbbopts) -> (opts { lineSeparator = LineSeparator s },hbbopts)) "sep")
"specify line separator (default is Nul string)"
, Option [] ["adapt-ind"]
(NoArg (\(opts,hbbopts) -> (opts,hbbopts { adaptInd = AdaptIndToTargetEnv })))
"Adapt the indentation of non-first lines to the (possibly higher) ind of the target environment"
]
parseArgs :: [OptDescr ((Options,HBBOptions) -> (Options,HBBOptions))] -> [String] -> ((Options,HBBOptions), [String])
parseArgs spec argv
= case O.getOpt Permute spec argv of
(o,n,[] ) -> (foldr id (defaultOptions,defaultHBBOptions) o, n)
(_,_,errs) -> E.throw (CmdArg errs)
----------------------------------------------------------------
main :: IO ()
main = flip E.catches handlers $ do
-- #if __GLASGOW_HASKELL__ >= 611
hSetEncoding stdout utf8
-- #endif
args <- getArgs
let ((opt,hbbopts),cmdArg) = parseArgs argspec args
let cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1
cmdArg2 = cmdArg !. 2
cmdArg3 = cmdArg !. 3
cmdArg4 = cmdArg !. 4
cmdArg5 = cmdArg !. 5
remainingArgs = tail cmdArg
-- (re)ad (M)ay(b)e
reMb :: Read a => Int -> Maybe a
reMb n | length remainingArgs >= n = Just (read $ head $ drop (n-1) remainingArgs)
reMb _ = Nothing
-- (b)etween (Args)
bArgs :: Int -> Int -> a -> a
bArgs mn mx f | n >= mn && n <= mx = f
where n = length remainingArgs
bArgs _ _ _ = E.throw (ArgumentsMismatch cmdArg0)
(res, _) <- runGhcModT opt $ case cmdArg0 of
"list" -> modules
"lang" -> languages
"flag" -> flags
"browse" -> concat <$> mapM browse remainingArgs
"check" -> checkSyntax remainingArgs
"expand" -> expandTemplate remainingArgs
"debug" -> debugInfo
"info" -> bArgs 3 3 info cmdArg1 cmdArg3
"type" -> bArgs 4 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
"split" -> bArgs 4 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> bArgs 4 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
"refine" -> bArgs 5 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
"auto" -> bArgs 4 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)
"find" -> bArgs 1 1 $ findSymbol cmdArg1
"lint" -> bArgs 1 1 $ withFile lint cmdArg1
-- The type Option to specify command line arguments is a ghc-mod
-- specific type which is passed to the ghc-mod-specific GhcMonad
-- instance. This forces 'hbb' to pass the options explicitely.
"inline" -> bArgs 3 5 $ hbb_inline hbbopts cmdArg1 (read cmdArg2) (read cmdArg3) (reMb 4) (reMb 5)
"smart-inline" -> bArgs 3 5 $ hbb_smartinline hbbopts cmdArg1 (read cmdArg2) (read cmdArg3) (reMb 4) (reMb 5)
"locate" -> bArgs 3 3 $ hbb_locate cmdArg1 (read cmdArg2) (read cmdArg3)
"occurrences-of"-> bArgs 3 999 $ hbb_occursof cmdArg1 (read cmdArg2) (read cmdArg3) (drop 3 remainingArgs)
"exprtype" -> bArgs 2 2 $ hbb_exprtype cmdArg1 cmdArg2
"apply-to" -> bArgs 2 2 $ hbb_applyto hbbopts cmdArg1 cmdArg2
"root" -> rootInfo
"doc" -> bArgs 1 1 $ pkgDoc cmdArg1
"dumpsym" -> dumpSymbol
"boot" -> boot
"version" -> return progVersion
"help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd)
case res of
Right s -> putStr s
Left (GMENoMsg) ->
hPutStrLn stderr "Unknown error"
Left (GMEString msg) ->
hPutStrLn stderr msg
Left (GMECabalConfigure msg) ->
hPutStrLn stderr $ "cabal configure failed: " ++ show msg
Left (GMECabalFlags msg) ->
hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg
Left (GMEProcess cmd msg) ->
hPutStrLn stderr $
"launching operating system process `"++c++"` failed: " ++ show msg
where c = unwords cmd
where
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
handleThenExit handler e = handler e >> exitFailure
handler1 :: ErrorCall -> IO ()
handler1 = print -- for debug
handler2 :: GHCModError -> IO ()
handler2 SafeList = printUsage
handler2 (ArgumentsMismatch cmd) = do
hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"
printUsage
handler2 (NoSuchCommand cmd) = do
hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"
printUsage
handler2 (CmdArg errs) = do
mapM_ (hPutStr stderr) errs
printUsage
handler2 (FileNotExist file) = do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
withFile cmd file = do
exist <- liftIO $ doesFileExist file
if exist
then cmd file
else E.throw (FileNotExist file)
xs !. idx
| length xs <= idx = E.throw SafeList
| otherwise = xs !! idx