libhbb-0.3.0.0: src/HBBSimpleCLI.hs

{-# OPTIONS -Wall #-}

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.Locate
import           Language.Haskell.HBB.Inline
import qualified Data.ByteString.Lazy.Char8 as LB
import           System.Console.GetOpt as O
import           System.Environment (getArgs)
import           System.Directory (getCurrentDirectory)
import           System.Exit (exitFailure)
import           System.IO


usageStr :: String
usageStr = unlines
    ["Usage:"
    ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] locate                                      <filename> <line> <column>"
    ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] inline       [--print-context|--with-color] <filename> <line> <column> [<line> <column>]"
    ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline                                <filename> <line> <column> [<line> <column>]"
    ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of                              <filename> <line> <column> [<filename> ...]"
    ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype                                    <filename> <expression>"
    ,"hbb-simple-cli                             apply-to [-q] <function of type string to string> <string>"]

data OperationMode = ModeInline        InlineOptions
                   | ModeSmartInline
                   | ModeLocate
                      
-- | This function is responsible to parse the optional parameters (called
-- options). If there is a parameter that doesn't match an option this function
-- stops and returns its accumulated result. The extraneous arguments then will
-- be the description of the file and the line.
takeOptions :: ([String],InlineOptions) -> ([String],InlineOptions)
takeOptions (("--print-context":rest),ops) = takeOptions (rest,(ops { showContext     = True }))
takeOptions (("--with-color"   :rest),ops) = takeOptions (rest,(ops { showAnsiColored = True }))
takeOptions x@(_,_)                        = x

main :: IO ()
main = do
    programArgs <- getArgs

    cwd <- getCurrentDirectory

    -- First we want to filter out the options that GHC needs
    let (ghcOptions,otherArgs) = 
            let optdescr :: [OptDescr String]
                optdescr = [Option ['g'] [] (ReqArg id "ghc-option") "options passed to ghc"]
            in  case O.getOpt RequireOrder optdescr programArgs of
                (_,_,(_:_)) -> error "Wrong usage of ghc-specific options (every -g must be followed by a GHC option)"
                (g,o,[]   ) -> (g,o)

        putApplyToResult :: Bool -> (String,Maybe String) -> IO ()
        putApplyToResult False        (res,Just wa) = do hPutStr stderr wa 
                                                         hPutStrLn stderr "> "
                                                         hPutStrLn stderr "> Pass the flag '-q' to suppress this warning!"
                                                         putApplyToResult False (res,Nothing)
        putApplyToResult True         (res,Just wa) = hPutStr stderr wa >> putApplyToResult True (res,Nothing)
        putApplyToResult _            (res,Nothing) =  putStr res

    case (ghcOptions,otherArgs) of
        (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr   . (showOccurrencesOfResult cwd)
        (_ ,["exprtype",f,expr])             -> exprtype      ghcOptions f expr                              >>= putStrLn . showExprTypeResult
        ([],["apply-to","-q",f,str ])        -> applyTo       True       f str                               >>= putApplyToResult True
        ([],["apply-to",     f,str ])        -> applyTo       False      f str                               >>= putApplyToResult False
        (_ ,("apply-to":_))                  -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)"
        _ -> do
            (opMode,occFilename,loc1,maybeLoc2) <- do
                    case otherArgs of
                        ["locate"      ,f,l,c] -> return (ModeLocate     ,f,(BufLoc (read l::Int) (read c::Int)),Nothing)
                        ("smart-inline":rest)  -> 
                            case rest of
                                (f:sl:sc:el:ec:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),
                                                                         (Just $ BufLoc (read el::Int) (read ec::Int)))
                                (f:sl:sc:[])       -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)
                                _                  -> do putStrLn "Invalid parameters."
                                                         putStrLn usageStr; exitFailure
                        ("inline":rest) -> do
                            let (locspec,options) = takeOptions (rest,defaultInlineOptions)
                            case locspec of
                                (f:sl:sc:el:ec:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),
                                                                            (Just $ BufLoc (read el::Int) (read ec::Int)))
                                (f:sl:sc:[])       -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)
                                _                  -> do putStrLn "Invalid parameters."
                                                         putStrLn usageStr; exitFailure
                        _                          -> do putStrLn usageStr; exitFailure
            case opMode of
                ModeInline options -> inline      ghcOptions options  occFilename loc1 maybeLoc2 >>= putStrLn  . showInlineResult
                ModeSmartInline    -> smartinline ghcOptions          occFilename loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString
                ModeLocate         -> locate      ghcOptions          occFilename loc1           >>= putStrLn  . (showLocateResult cwd)