module Option where

import qualified Module
import qualified Time
import qualified InOut
import qualified HTTPServer.Option as HTTP

import Shell.Utility.ParseArgument (parseNumber)
import Shell.Utility.Exit (exitFailureMsg)
import Shell.Utility.GetOpt (fmapOptDescr)

import qualified Text.ParserCombinators.Parsec as Parsec

import qualified Paths_live_sequencer as Paths
import qualified System.Console.GetOpt as Opt
import System.Console.GetOpt
          (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), )
import System.Environment (getArgs, getProgName, )

import qualified System.Path as Path
import System.Path.Directory ( getCurrentDirectory )
import System.Path ( (</>), searchPathSeparator, isSearchPathSeparator, )

import qualified System.Exit as Exit

import Control.Monad ( when )

import qualified Data.NonEmpty.Class as NEClass
import qualified Data.NonEmpty as NEList
import Data.Traversable ( forM )
import Data.Bool.HT ( if' )
import Data.List.HT ( chop )


data Option = Option {
        moduleNames :: [Module.Name],
        rawImportPaths :: [Path.AbsRelDir],
        importPaths :: [Path.AbsDir],
        connect :: NEList.T [] Port,
        sequencerName :: String,
        latency :: Double,
        limits :: Limits,
        httpOption :: HTTP.Option
    }

-- the formatted value might look ugly
defltLatencyStr :: String
defltLatencyStr = "0.2"

getDeflt :: IO Option
getDeflt = do
    dataDir <- Paths.getDataDir
    curDir <- getCurrentDirectory
    return $
        Option {
            moduleNames = [],
            importPaths = error "import paths not converted to absolute paths",
            rawImportPaths =
                Path.toAbsRel curDir :
                map
                    ((Path.absRel dataDir </>) . (Path.dir "data" </>) .
                     Path.dir)
                    [ "prelude", "base", "example" ],
            connect = NEList.singleton (Port "inout" (Just []) (Just [])),
            sequencerName = "Rewrite-Sequencer",
            latency = read defltLatencyStr,
            limits = limitsDeflt,
            httpOption = HTTP.deflt
        }


data Port =
    Port {
        portName :: String,
        connectFrom, connectTo :: Maybe [String]
    }


data Limits =
    Limits {
        maxTermSize, maxTermDepth,
        maxReductions,
        maxEvents :: Int,
        eventPeriod :: Time.Milliseconds Integer,
        splitWait :: Time.Milliseconds Integer
    }

limitsDeflt :: Limits
limitsDeflt = Limits {
        maxTermSize = 2000,
        maxTermDepth = 100,
        maxReductions = 1000,
        maxEvents = 150,
        eventPeriod = Time.seconds 1,
        splitWait = Time.seconds 1
    }


{-
Guide for common Linux/Unix command-line options:
  http://www.faqs.org/docs/artu/ch10s05.html
-}
description :: Option -> [ Opt.OptDescr (Option -> IO Option) ]
description deflt =
    Opt.Option ['h'] ["help"]
        (NoArg $ \ _flags -> do
            programName <- getProgName
            putStrLn $
                usageInfo ("Usage: " ++ programName ++ " [OPTIONS] MODULE") $
                description deflt
            Exit.exitSuccess)
        "show options" :
    Opt.Option ['i'] ["import-paths"]
        (flip ReqArg "PATHS" $ \str flags ->
            if null str
              then return $ flags{rawImportPaths = []}
              else
                case mapM Path.parse $ chop isSearchPathSeparator str of
                    Right paths ->
                        return $ flags{rawImportPaths =
                            paths ++ rawImportPaths flags}
                    Left msg -> exitFailureMsg $ "--import-paths: " ++ msg)
        ("if empty: clear import paths\n" ++
         "otherwise: add colon separated import paths,\n" ++
         "default:  " ++
         (case map Path.toString $ rawImportPaths deflt of
            [] -> ""
            x:xs -> unlines $ x : map (("   "++) . (searchPathSeparator:)) xs)) :
    Opt.Option ['p'] ["connect-to"]
        (flip ReqArg "ADDRESS" $ \str flags ->
            case connect flags of
                NEList.Cons port ports ->
                    case connectTo port of
                        Just conns ->
                            return $ flags{connect = NEList.Cons
                                (port{connectTo = Just $ str : conns}) ports}
                        _ ->
                            exitFailureMsg $
                                "cannot connect to " ++ str ++
                                ", since port " ++ portName port ++ " does not allow output")
        ("connect to an ALSA port at startup,\n" ++
         "multiple connections per port are possible") :
    Opt.Option [] ["connect-from"]
        (flip ReqArg "ADDRESS" $ \str flags ->
            case connect flags of
                NEList.Cons port ports ->
                    case connectFrom port of
                        Just conns ->
                            return $ flags{connect = NEList.Cons
                                (port{connectFrom = Just $ str : conns}) ports}
                        _ ->
                            exitFailureMsg $
                                "cannot connect from " ++ str ++
                                ", since port " ++ portName port ++ " does not allow input")
        ("connect from an ALSA port at startup") :
    Opt.Option [] ["new-out-port"]
        (flip ReqArg "PORTNAME" $ \str flags ->
            return $ flags{connect =
                NEClass.cons (Port str Nothing (Just [])) $
                connect flags})
        ("create new ALSA output port and add 16 MIDI channels") :
    Opt.Option [] ["sequencer-name"]
        (flip ReqArg "NAME" $ \str flags ->
            return $ flags{sequencerName = str})
        ("name of the ALSA sequencer client, default " ++
         sequencerName deflt) :
    Opt.Option [] ["latency"]
        (flip ReqArg "SECONDS" $ \str flags ->
            case reads str of
                [(x, "")] ->
                    if' (x<0)
                        (exitFailureMsg "latency must be non-negative") $
                    if' (x>1000)
                        (exitFailureMsg "latency is certainly too large") $
                    return $ flags{latency = x}
                _ -> exitFailureMsg "latency value must be a number")
        ("delay between evaluation and playing,\ndefault " ++
         defltLatencyStr) :
    map (fmapOptDescr $ \update old -> do
             newLimits <- update $ limits old
             return $ old {limits = newLimits})
        (limitsDescription (limits deflt)) ++
    map (fmapOptDescr $ \update old -> do
             newHTTP <- update $ httpOption old
             return $ old {httpOption = newHTTP})
        HTTP.description


limitsDescription :: Limits -> [ Opt.OptDescr (Limits -> IO Limits) ]
limitsDescription deflt =
    Opt.Option [] ["max-term-size"]
        (flip ReqArg "SIZE" $ \str flags ->
            fmap (\p -> flags{maxTermSize = fromInteger p}) $
            parseNumber "term size" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("maximum allowed term size, default " ++
         show (maxTermSize deflt)) :
    Opt.Option [] ["max-term-depth"]
        (flip ReqArg "SIZE" $ \str flags ->
            fmap (\p -> flags{maxTermDepth = fromInteger p}) $
            parseNumber "term depth" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("maximum allowed term depth, default " ++
         show (maxTermDepth deflt)) :
    Opt.Option [] ["max-reductions"]
        (flip ReqArg "NUMBER" $ \str flags ->
            fmap (\p -> flags{maxReductions = fromInteger p}) $
            parseNumber "number of reductions" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("maximum allowed reductions for every list element, default " ++
         show (maxReductions deflt)) :
    Opt.Option [] ["max-events-per-period"]
        (flip ReqArg "NUMBER" $ \str flags ->
            fmap (\p -> flags{maxEvents = fromInteger p}) $
            parseNumber "number of events" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("maximum number of allowed events per period, default " ++
         show (maxEvents deflt)) :
    Opt.Option [] ["event-period"]
        (flip ReqArg "MILLISECONDS" $ \str flags ->
            fmap (\p -> flags{eventPeriod = Time.milliseconds p}) $
            parseNumber "event period" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("period for limitting adjacent events, default " ++
         Time.format (eventPeriod deflt)) :
    Opt.Option [] ["split-wait"]
        (flip ReqArg "MILLISECONDS" $ \str flags ->
            fmap (\p -> flags{splitWait = Time.milliseconds p}) $
            parseNumber "wait duration" (\n -> 0<n && n<1000000000) "positive 30 bit" str)
        ("maximum atomic wait, default " ++
         Time.format (splitWait deflt)) :
    []


get :: IO Option
get = do
    argv <- getArgs
    deflt <- getDeflt
    let (opts, files, errors) =
            getOpt Opt.RequireOrder (description deflt) argv
    when (not $ null errors) $
        exitFailureMsg (init (concat errors))

    dir <- getCurrentDirectory
    parsedOpts <-
        fmap (\o -> o {
                importPaths = map (Path.dynamicMakeAbsolute dir) $ rawImportPaths o
            } ) $
        foldl (>>=) (return deflt) opts

    names <-
        forM files $ \modu ->
            case Parsec.parse InOut.input modu modu of
                Right name -> return name
                Left _ -> exitFailureMsg $ show modu ++ " is not a module name"
    return $ parsedOpts {
        connect = NEList.reverse $ connect parsedOpts,
        moduleNames = names
        }