{- Handle Options

   Options:

    --prime      model for starting points [uniform]
    --error      error model [uniform,gradient,..]
    --terminator termination condition [sigma..]
    --model      shortcut for useful combinations [sanger|454|solexa]

 -}

module Options where

import System.Environment (getArgs)
import System.Exit (exitWith,ExitCode(..))
import System.Console.GetOpt
import System.IO
import Data.List (unfoldr)
import Control.Monad (when)
import Bio.Sequence

import UnfoldMut
import Sanger
import R454

version, usagemsg :: String
version = "0.0"
usagemsg = "Usage: simseq [options] FILE.."

data Opts = Opts { primer :: Primer
                 , errmod :: [Mutator]
                 , term   :: Terminator
                 }

getOpts :: IO (Opts,[Sequence])
getOpts = do
  (opt1,fs,err) <- getArgs >>= (return . getOpt Permute options)
  opts <- parseargs opt1
  when (not $ null err) (error $ usage err)
  when (forceOpts opts) (error "Impossible!")
  ss <- if null fs then hReadFasta stdin
        else return . concat =<< mapM readFasta fs
  return (opts, ss)
      where
        forceOpts (Opts x y z) = x `seq` y `seq` z `seq` False

parseargs :: [Opts -> IO Opts] -> IO Opts
parseargs args = foldl (>>=) (return defaultopts) args

usage :: [String] -> String
usage errs = usageInfo (concat errs ++ usagemsg) options

------------------------------------------------------------

options :: [OptDescr (Opts -> IO Opts)]
options = [ Option [] ["primer"] (ReqArg (setPrimer . processArgs) "p")
                 ("Model for initiating sequencing "++show (map fst primers))
          , Option [] ["error"] (ReqArg (setMutator . processArgs) "e")
                 ("Error model "++show (map fst mutators))
          , Option [] ["terminator"] (ReqArg (setTerm . processArgs) "t")
                 ("Termination condition "++show (map fst terminators))
          , Option [] ["model"] (ReqArg (setModel . processArgs) "m")
                 ("Shortcut for useful combinations "++show (map fst models))
          , Option ['h'] ["help"] (ReqArg help "option") ("Help with 'option'")
          ]

defaultopts :: Opts
defaultopts = Opts (error "no primer specified")
                   (error "no error model specified")
                   (error "no terminator specified")

help :: String -> Opts -> IO Opts
help arg _ = do putStrLn usagemsg
                case arg of
                     "primer"     -> list "specifies when sequence generation starts" primers
                     "error"      -> list "adds an error model for sequence generation" mutators
                     "terminator" -> list "specifies when sequence generation terminates" terminators
                     "model"      -> list "specifies a complete model including primer, error model, and terminator" models
                     _  -> putStrLn ("  "++arg++": no such option")
                exitWith ExitSuccess

    where list str tbl = putStrLn ("  "++arg ++ ": "++str++"\n  Valid alternatives are: "++unwords (map fst tbl))


------------------------------------------------------------

-- | Break a string argument representing a function and arguments
--   into components.  Syntax is func:arg1,arg2,..
processArgs :: String -> (String,[String])
processArgs ss = let (fn,as) = break (==':') ss
                 in (fn,splitStr ',' as)

splitStr :: Char -> String -> [String]
splitStr c = unfoldr (\s -> if null s then Nothing
                                      else let (x,y) = break (==c) (drop 1 s)
                                           in Just (x,y))

------------------------------------------------------------
-- Lookup tables for selecting the desired behavior
------------------------------------------------------------

notfound :: String -> [(String,a)] -> String -> String
notfound what whats which = "'"++which++"': no such "++what++".\n"++
           "Available "++what++"s are: "++ (unwords $ map fst whats)

setPrimer :: (String,[String]) -> Opts -> IO Opts
setPrimer (prim,args) (Opts _ m t) = return (Opts p m t)
   where p = maybe (error $ notfound "primer" primers prim)
             (\f -> f args) (lookup prim primers)

primers :: [(String,[String]->Primer)]
primers     = [("uniform",p_uniform)]
-- help text? "uniform:n,p","select n random starting points, with probability p of forward direction, 1-p or reverse"

------------------------------------------------------------

setTerm :: (String,[String]) -> Opts -> IO Opts
setTerm (trm,args) (Opts p m _) = return (Opts p m t)
   where t = maybe (error $ notfound "terminator" terminators trm)
             (\f -> f args) (lookup trm terminators)

terminators :: [(String,[String]->Terminator)]
terminators =
  [("sigma",\args -> case args of
                       [s,w] -> \ (MS _ _ l) -> sigma (read s) (read w) $ fromIntegral l
                       _     -> error "terminator 'sigma' needs two arguments")
  ]

------------------------------------------------------------

setMutator :: (String,[String]) -> Opts -> IO Opts
setMutator (mut,args) (Opts p m t) = return (Opts p m' t)
   where m' = maybe (error $ notfound "mutator" mutators mut)
             (\f -> f args : m) (lookup mut mutators)


mutators :: [(String,[String]->Mutator)]
mutators    = [] -- ("uniform",...)]

------------------------------------------------------------

setModel :: (String,[String]) -> Opts -> IO Opts
setModel (md,args) _  = return (maybe (error $ notfound "model" models md)
         (\f -> case f args of (p,m,t) -> Opts {primer=p,errmod=m,term=t})
         (lookup md models))

models :: [(String,[String]->Model)]
models = [("sanger",sanger)
         ,("stest",\[] -> sanger ["1","1"])
         ,("454",r454)
         ]