{-# LANGUAGE CPP #-}
-- File created: 2008-03-23 20:18:32

-- |The main monad used internally, and what it stores.
module Coadjute.CoData
   ( CoData, asks, runCoData
   , CoadjuteData ( coArgs
                  , coUserArgs
                  , coVerbosity
                  , coForceDB
                  , coForceNoDB
                  , coForceNoHash
                  , coDBExists
                  , coParallel
                  , coParallelOpt
                  )
   , coUsingDB
   , dbFileName
   , Verbosity(..)
   , ParallelOpt(..)
   , io, MonadIO
   ) where

import Control.Arrow             (first, second)
import Control.Monad             (foldM, when)
import Control.Monad.Reader      (ReaderT, runReaderT, asks)
import Control.Monad.Trans       (MonadIO, liftIO)
import Data.List                 (nub, partition)
import qualified Data.Set as Set
import System.Console.GetOpt
import System.Directory          (doesFileExist)
import System.Environment        (getArgs, getProgName)
import System.Exit               (exitWith, ExitCode(..))
import System.IO                 (hPutStrLn, stderr)
import Text.Printf               (printf)
import Text.PrettyPrint.HughesPJ (renderStyle, style, Style(..), fsep, text)
import Text.Regex.DFA

import Coadjute.Util.Misc (mread)

dbFileName :: FilePath
dbFileName = ".coadjute.db"

versionString :: String
versionString = "0.0.1"

getHelpString :: IO String
getHelpString = do
   pn <- getProgName
   return . flip usageInfo (optDesc undefined) . unlines . map prettify $
      [ printf "Usage: %s [-dqvDH] [-p[N]] [USERARGS...]" pn
      , ""
      , "Apply the build rules specified in the Adjutant to construct build\
         tasks. Then run those tasks which are necessary. Any USERARGS are\
         passed through to the tasks."
      , ""
      , printf "If a database (%s) exists, it is used by default unless -D is\
                passed."
               dbFileName
      ]
 where
   prettify = renderStyle (style {lineLength = 80, ribbonsPerLine = 1})
            . fsep . map text . words

type CoData = ReaderT CoadjuteData IO

runCoData :: CoData a -> IO a
runCoData co = do
   dbExists <- doesFileExist dbFileName

   helpString <- getHelpString
   args <- getArgs
   let (opts,[],otherOpt,_) = getOpt' (ReturnInOrder (handleNonOpt helpString))
                                      (optDesc helpString)
                                      args

   let (helpRequests, userOpts) = partition isHelp otherOpt

   let initialMsgs = if null helpRequests then [] else [(helpString,True)]
       defaultData =
          CoadjuteData
            { coArgs        = Set.fromList args
            , coUserArgs    = userOpts
            , coVerbosity   = Normal
            , coDBExists    = dbExists
            , coForceDB     = False
            , coForceNoDB   = False
            , coForceNoHash = False
            , coParallel    = False
            , coParallelOpt = Uncapped
            }
       (coData,msgs) = foldl (\cd optFunc -> optFunc cd)
                             (defaultData,initialMsgs)
                             opts

   when (not.null $ msgs) . io $ do
      anyErr <- foldM (\a (s,err) ->
                          if err
                             then hPutStrLn stderr s >> return True
                             else  putStrLn        s >> return a
                      ) False (nub.reverse $ msgs)
      exitWith (if anyErr then ExitFailure 1 else ExitSuccess)

   runReaderT co coData

data CoadjuteData = CoadjuteData
   { coArgs        :: Set.Set String
   , coUserArgs    :: [String]
   , coVerbosity   :: Verbosity
   , coDBExists    :: Bool
   , coForceDB     :: Bool
   , coForceNoDB   :: Bool -- double negatives result, but this way one can
   , coForceNoHash :: Bool -- think in terms of command line options
   , coParallel    :: Bool
   , coParallelOpt :: ParallelOpt
   }

type OptionData = (CoadjuteData, [(String,Bool)])

coUsingDB :: CoadjuteData -> Bool
coUsingDB d = coForceDB d || (coDBExists d && not (coForceNoDB d))

data Verbosity   = Quiet | Normal | Verbose | VeryVerbose deriving (Eq, Ord)
data ParallelOpt =
   Capped Int | Uncapped
#ifdef __GLASGOW_HASKELL__
   | Processor
#endif

optDesc :: String -> [OptDescr (OptionData -> OptionData)]
optDesc helpString = map (\(Option s l d msg) -> Option s l d (prettify msg))
   [ Option "V" ["version"]
      (NoArg$ second ((versionString,True):))
      "Output version string and exit."

   , Option "h" ["help"]
      (NoArg$ second ((helpString,True):))
      "Output this help string and exit."

   , Option "v" ["verbose"]
      (noArg$ \o@(CoadjuteData {coVerbosity = v}) ->
         o { coVerbosity =
            if v == Verbose || v == VeryVerbose
               then VeryVerbose
               else Verbose }
      )
      "Verbose output. Specify twice for more verbosity."

   , Option "q" ["quiet"]
      (noArg$ \o -> o {coVerbosity = Quiet})
      "Quiet output."

   , Option "p" ["parallel"]
      (flip OptArg "N" $ \ma (o,s) ->
         let o'    = o { coParallel = True }
             err m = "Invalid parallel count, expected integer: '" ++ m ++ "'"
          in case ma of
                  Nothing -> (o' { coParallelOpt = Uncapped },s)
                  Just a  ->
                     let mn = mread a
                      in case mn of
                              Nothing -> (o', (err a,False) : s)
                              Just 1  -> (o, s)
                              Just n  ->
                                 (o' { coParallelOpt =
                                    case compare n 0 of
#ifdef __GLASGOW_HASKELL__
                                         LT -> Processor
#else
                                         LT -> Capped (abs n)
#endif
                                         GT -> Capped n
                                         EQ -> Uncapped }, s))
      ("Perform tasks in parallel, up to N at a time. If N is negative, the "++
#ifdef __GLASGOW_HASKELL__
       "number of OS threads (i.e. the +RTS -N setting) is used."++
#else
       "absolute value is used."++
#endif
       " If N is zero or not given, the number of simultaneous tasks will\
        not be limited. If N is 1, the argument is ignored.")

   , Option "d" ["use-db"]
      (noArg$ \o -> o {coForceDB = True})
      ("Use a database, creating one if it doesn't exist. If one does\
        exist, it is used by default.")

   , Option "D" ["no-use-db"]
      (noArg$ \o -> o {coForceNoDB = True})
      "Don't use a database even if one exists."

   , Option "H" ["no-hashing"]
      (noArg$ \o -> o {coForceNoHash = True})
      "Use timestamps, instead of hashes in the database. The database will\
       be used only to store USERARGS specified for storage in the Adjutant."
   ]
 where
   -- like NoArg and OptArg, but works inside OptionData
   noArg = NoArg . first

   prettify = renderStyle (style {lineLength = 80}) . fsep . map text . words

helpRegex :: Regex
helpRegex =
   makeRegexOpts CompOption { caseSensitive = False, multiline = False }
                 defaultExecOpt
                 "^(--?|/)([?]|h(e?lp)?)$"

isHelp :: String -> Bool
isHelp = matchTest helpRegex

handleNonOpt :: String -> String -> OptionData -> OptionData
handleNonOpt helpString opt (cd,s) =
   if isHelp opt
      then (cd, (helpString,True):s)
      else (cd { coUserArgs = opt : coUserArgs cd }, s)

-- |A convenience.
io :: (MonadIO m) => IO a -> m a
io = liftIO