{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

-- | This module takes the result of Capture, and deals with all the local
--   constraints.
module System.Console.CmdArgs.Implicit.Local(
    local, err,
    Prog_(..), Builtin_(..), Mode_(..), Flag_(..), Fixup(..), isFlag_,
    progHelpOutput, progVersionOutput, progNumericVersionOutput
    ) where

import System.Console.CmdArgs.Implicit.Ann
import System.Console.CmdArgs.Implicit.Type
import System.Console.CmdArgs.Implicit.Reader
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Annotate
import System.Console.CmdArgs.Default
import qualified Data.Generics.Any.Prelude as A

import Control.Monad
import Data.Char
import Data.Generics.Any
import Data.Maybe
import Data.List


data Prog_ = Prog_
    {progModes :: [Mode_]
    ,progSummary :: Maybe [String]
    ,progProgram :: String
    ,progHelp :: String -- only for multiple mode programs
    ,progVerbosityArgs :: (Maybe Builtin_, Maybe Builtin_) -- (verbose, quiet)
    ,progHelpArg :: Maybe Builtin_
    ,progVersionArg :: Maybe Builtin_
    ,progNoAtExpand :: Bool
    } deriving Show
instance Default Prog_ where
    def = Prog_ def def def def def (Just def) (Just def) def

progOutput f x = fromMaybe ["The " ++ progProgram x ++ " program"] $
    (builtinSummary =<< f x) `mplus` progSummary x

progHelpOutput = progOutput progHelpArg
progVersionOutput = progOutput progVersionArg
progNumericVersionOutput x = fmap return $ parseVersion =<< listToMaybe (progVersionOutput x)

-- | Find numbers starting after space/comma, v
parseVersion :: String -> Maybe String
parseVersion xs = listToMaybe
    [y | x <- words $ map (\x -> if x `elem` ",;" then ' ' else x) xs
       , let y = fromMaybe x $ stripPrefix "v" x
       , length (takeWhile isDigit y) >= 1]


data Builtin_ = Builtin_
    {builtinNames :: [String]
    ,builtinExplicit :: Bool
    ,builtinHelp :: Maybe String
    ,builtinGroup :: Maybe String
    ,builtinSummary :: Maybe [String]
    } deriving Show
instance Default Builtin_ where
    def = Builtin_ def def def def def

data Mode_ = Mode_
    {modeFlags_ :: [Flag_]
    ,modeMode :: Mode (CmdArgs Any)
    ,modeDefault :: Bool
    ,modeGroup :: Maybe String
    ,modeExplicit :: Bool
    } deriving Show
instance Default Mode_ where
    def = Mode_ [] (modeEmpty $ error "Mode_ undefined") def def def

data Flag_
    = Flag_
        {flagField :: String
        ,flagFlag :: Flag (CmdArgs Any)
        ,flagExplicit :: Bool
        ,flagGroup :: Maybe String
        ,flagEnum :: Maybe String -- if you are an enum, what is your string value
        ,flagFixup :: Fixup
        }
    | Arg_
        {flagArg_ :: Arg (CmdArgs Any)
        ,flagArgPos :: Maybe Int
        ,flagArgOpt :: Maybe String
        ,flagFixup :: Fixup
        }
      deriving Show
instance Default Flag_ where
    def = Flag_ "" (error "Flag_ undefined") def def def def

newtype Fixup = Fixup (Any -> Any)

instance Default Fixup where def = Fixup id
instance Show Fixup where show _ = "Fixup"

isFlag_ Flag_{} = True
isFlag_ _ = False

withMode x f = x{modeMode = f $ modeMode x}
withFlagArg x f = x{flagArg_ = f $ flagArg_ x}
withFlagFlag x f = x{flagFlag = f $ flagFlag x}

err x y = error $ "System.Console.CmdArgs.Implicit, unexpected " ++ x ++ ": " ++ y
errFlag x y = err ("flag (" ++ x ++ ")") y


local :: Capture Ann -> Prog_
local = prog_ . defaultMissing


---------------------------------------------------------------------
-- CAPTURE THE STRUCTURE

prog_ :: Capture Ann -> Prog_
prog_ (Ann a b) = progAnn a $ prog_ b
prog_ (Many xs) = def{progModes=concatMap mode_ xs, progProgram=prog}
    where prog = map toLower $ typeShell $ fromCapture $ head xs
prog_ x@Ctor{} = prog_ $ Many [x]
prog_ x = err "program" $ show x


mode_ :: Capture Ann -> [Mode_]
mode_ (Ann Ignore _) = []
mode_ (Ann a b) = map (modeAnn a) $ mode_ b
mode_ o@(Ctor x ys) = [withMode def{modeFlags_=flgs} $ \x -> x{modeValue=embed $ fixup $ fromCapture o}]
    where flgs = concat $ zipWith flag_ (fields x) ys
          fixup x = foldl (\x (Fixup f) -> f x) x $ map flagFixup flgs
mode_ x = err "mode" $ show x


flag_ :: String -> Capture Ann -> [Flag_]
flag_ name (Ann Ignore _) = []
flag_ name (Ann a b) = map (flagAnn a) $ flag_ name b
flag_ name (Value x) = let (fix,flg) = value_ name x in [def{flagField=name, flagFlag=remap embed reembed flg, flagFixup=fix}]
flag_ name x@Ctor{} = flag_ name $ Value $ fromCapture x
flag_ name (Many xs) = concatMap (enum_ name) xs
flag_ name x = errFlag name $ show x


enum_ :: String -> Capture Ann -> [Flag_]
enum_ name (Ann Ignore _) = []
enum_ name (Ann a b) = map (flagAnn a) $ enum_ name b
enum_ name (Value x) = [def{flagField=name, flagFlag = flagNone [] (fmap upd) "", flagEnum=Just $ ctor x}]
    where upd v | not (A.isString x) && A.isList x = setField (name, getField name v `A.append` x) v
                | otherwise = setField (name,x) v
enum_ name x@Ctor{} = enum_ name $ Value $ fromCapture x
enum_ name x = errFlag name $ show x


-- Fixup (ends up in modeCheck) and the flag itself
value_ :: String -> Any -> (Fixup, Flag Any)
value_ name x
    | isNothing mty = errFlag name $ show x
    | readerBool ty =
        let f (Right x) = x
            upd b x = setField (name, f $ readerRead ty (getField name x) $ show b) x
        in (fixup, flagBool [] upd "")
    | otherwise =
        let upd s x = fmap (\c -> setField (name,c) x) $ readerRead ty (getField name x) s
        in (fixup, flagReq [] upd (readerHelp ty) "")
    where
        mty = reader x
        ty = fromJust mty
        fixup = Fixup $ \x -> setField (name,readerFixup ty $ getField name x) x


---------------------------------------------------------------------
-- CAPTURE THE ANNOTATIONS

progAnn :: Ann -> Prog_ -> Prog_
progAnn (ProgSummary a) x = x{progSummary=Just $ lines a}
progAnn (ProgProgram a) x = x{progProgram=a}
progAnn ProgVerbosity x = x{progVerbosityArgs=let f sel = Just $ fromMaybe def $ sel $ progVerbosityArgs x in (f fst, f snd)}
progAnn (Help a) x | length (progModes x) > 1 = x{progHelp=a}
progAnn (ProgHelpArg a) x = x{progHelpArg = builtinAnns (progHelpArg x) a}
progAnn (ProgVersionArg a) x = x{progVersionArg = builtinAnns (progVersionArg x) a}
progAnn (ProgVerbosityArgs a b) x = x{progVerbosityArgs=(builtinAnns (Just $ fromMaybe def $ fst $ progVerbosityArgs x) a, builtinAnns (Just $ fromMaybe def $ snd $ progVerbosityArgs x) b)}
progAnn ProgNoAtExpand x = x{progNoAtExpand=True}
progAnn a x | length (progModes x) == 1 = x{progModes = map (modeAnn a) $ progModes x}
progAnn a x = err "program" $ show a


builtinAnns = foldl (flip builtinAnn)

builtinAnn :: Ann -> Maybe Builtin_ -> Maybe Builtin_
builtinAnn _ Nothing = Nothing
builtinAnn Ignore _ = Nothing
builtinAnn Explicit (Just x) = Just x{builtinExplicit=True}
builtinAnn (Name a) (Just x) = Just x{builtinNames=a : builtinNames x}
builtinAnn (Help a) (Just x) = Just x{builtinHelp=Just a}
builtinAnn (GroupName a) (Just x) = Just x{builtinGroup=Just a}
builtinAnn (ProgSummary a) (Just x) = Just x{builtinSummary=Just $ lines a}
builtinAnn a x = err "builtin" $ show a


modeAnn :: Ann -> Mode_ -> Mode_
modeAnn (Help a) x = withMode x $ \x -> x{modeHelp=a}
modeAnn (ModeHelpSuffix a) x = withMode x $ \x -> x{modeHelpSuffix=a}
modeAnn ModeDefault x = x{modeDefault=True}
modeAnn (GroupName a) x = x{modeGroup=Just a}
modeAnn Explicit x = x{modeExplicit=True}
modeAnn (Name a) x = withMode x $ \x -> x{modeNames=a:modeNames x}
modeAnn a x = err "mode" $ show a


flagAnn :: Ann -> Flag_ -> Flag_
flagAnn (FlagType a) x@Arg_{} = withFlagArg x $ \x -> x{argType=a}
flagAnn (FlagType a) x@Flag_{} = withFlagFlag x $ \x -> x{flagType=a}
flagAnn (Help a) x@Flag_{} = withFlagFlag x $ \x -> x{flagHelp=a}
flagAnn (FlagArgPos a) x = toArg x $ Just a
flagAnn FlagArgs x = toArg x Nothing
flagAnn Explicit x@Flag_{} = x{flagExplicit=True}
flagAnn (FlagOptional a) x@Flag_{flagEnum=Nothing,flagFlag=Flag{flagInfo=FlagReq}} = withFlagFlag x $ \x -> x{flagInfo=FlagOpt a}
flagAnn (FlagOptional a) x@Arg_{} = x{flagArgOpt=Just a}
flagAnn (Name a) x@Flag_{} = withFlagFlag x $ \x -> x{flagNames = a : flagNames x}
flagAnn (GroupName a) x@Flag_{} = x{flagGroup=Just a}
flagAnn a x = errFlag (head $ words $ show x) $ show a

toArg :: Flag_ -> Maybe Int -> Flag_
toArg (Flag_ fld x False Nothing Nothing fix) pos
    | null (flagNames x), null (flagHelp x), Just y <- opt $ flagInfo x
    = Arg_ (Arg (flagValue x) (flagType x) (isNothing y)) pos y fix
    where
        opt FlagReq = Just Nothing
        opt (FlagOpt x) = Just (Just x)
        opt (FlagOptRare x) = Just Nothing
        opt _ = Nothing
toArg a _ = errFlag "args/argPos" $ show a