{-# 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