libhbb-0.4.0.0: src/LibHbbCli.hs

{-# OPTIONS -Wall #-}

module Main where

import           Language.Haskell.HBB.TestModes.ApplyTTree
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.Exit (exitFailure)
import           System.IO


usageStr :: String
usageStr = unlines
    ["Usage:"
    ,"libhbb-cli [-g ghcOpt ...] locate                     <filename> <line> <column>"
    ,"libhbb-cli [-g ghcOpt ...] inline       <inline-opts> <filename> <line> <column> [<line> <column>]"
    ,"libhbb-cli [-g ghcOpt ...] smart-inline [--adapt-ind] <filename> <line> <column> [<line> <column>]"
    ,"libhbb-cli [-g ghcOpt ...] occurrences-of             <filename> <line> <column> [<filename> ...]"
    ,"libhbb-cli [-g ghcOpt ...] exprtype                   <filename> <expression>"
    ,"libhbb-cli                 apply-to [-q] <function of type string to string> <string>"
    ,""
    ,"<inline-opts> is short for [--adapt-ind|--print-context|--with-color]"
    ,"(there are further modes for testing and development only documented in the sources)"]
    --
    -- Moreover libhbb-cli supports following integration and test modes:
    --
    -- libhbb-cli apply-ttree

data OperationMode = ModeInline InlineOptions
                   | ModeSmartInline
                   | ModeSmartInlineAdaptInd
                   | 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 (("--adapt-ind"    :rest),ops) = takeOptions (rest,(ops { adaptToTargetEnv = AdaptIndToTargetEnv }))
takeOptions x@(_,_)                        = x

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

    -- 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
        -- The following mode is for integration and testing and not documented
        -- by the API:
        (_ ,["apply-ttree"])                 -> testModeApplyTTree defaultApplyTTreeArgs                     >>= putStr
        -- These modes are 'productive' modes:
        (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr   . showOccurrencesOfResult
        (_ ,["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,occFile,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
                                ("--adapt-ind":f:sl:sc:el:ec:[]) -> return (ModeSmartInlineAdaptInd,f,(BufLoc (read sl::Int) (read sc::Int)),
                                                                                               (Just $ BufLoc (read el::Int) (read ec::Int)))
                                ("--adapt-ind":f:sl:sc:[])       -> return (ModeSmartInlineAdaptInd,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)
                                (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              occFile loc1 maybeLoc2 >>= putStrLn  . showInlineResult
                ModeSmartInline         -> smartinline ghcOptions IgnoreIndOfTargetEnv occFile loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString
                ModeSmartInlineAdaptInd -> smartinline ghcOptions AdaptIndToTargetEnv  occFile loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString
                ModeLocate              -> locate      ghcOptions                  occFile loc1           >>= putStrLn  . showLocateResult