{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
module System.Console.CmdLib.Flag where

import System.Console.CmdLib.Attribute
import System.Console.GetOpt
import Data.Typeable
import Data.Data

import Data.List.Split( splitOn )
import Data.List( nub, intercalate, isSuffixOf )
import Data.Char( isUpper, toLower )
import Data.Generics.Aliases( extR )
import Data.Generics.Text( gshow )

newtype PathF = PathF String deriving (Typeable, Data)

defaults = [ Default ""
           , Default (0 :: Int)
           , Default False
           , Default ([] :: [Int])
           , Default ([] :: [String])
           , Enabled True ]

data OptionType = SimpleOption | BooleanOption | OptionalArgument | RequiredArgument | BadOption
                deriving Eq

class Attributes a where
  attributes :: a -> AttributeMap Key
  attributes _ = EmptyMap
  readFlag :: Data b => a -> String -> b
  readFlag _ = readCommon

class (Eq flag) => FlagType flag where
  type Folded flag :: *

  flag_attrkey :: flag -> Key
  flag_attrs :: flag -> [Attribute]

  flag_args :: flag -> [Attribute] -> ArgDescr (Folded flag -> Folded flag)
  flag_set :: (Typeable a) => flag -> a -> (Folded flag -> Folded flag)
  flag_parse :: flag -> String -> (Folded flag -> Folded flag)
  flag_value :: (Typeable a) => flag -> Folded flag -> a
  flag_type :: flag -> [Attribute] -> OptionType
  flag_list :: [flag]
  flag_defaults :: (flag -> [Attribute]) -> [Folded flag -> Folded flag]
  flag_defaults _ = []
  flag_empty :: flag -> Folded flag

instance FlagType () where
  type Folded () = ()
  flag_list = []

optionType :: [DataType] -> [TypeRep] -> OptionType
optionType dt t = case (dt, t) of
    ([], []) -> SimpleOption
    ([_], [t]) | typeRepTyCon t == typeRepTyCon (typeOf True) -> BooleanOption
    ([_], [t]) | typeRepTyCon t == typeRepTyCon (typeOf (Just ())) -> OptionalArgument
    ([_], _) -> RequiredArgument
    _ -> BadOption

nonoption attr x
  | True <- extra (attr x) = True
  | Just _ <- positional (attr x) = True
  | otherwise = False

optDescr :: FlagType flag => (flag -> [Attribute]) -> [OptDescr (Folded flag -> Folded flag)]
optDescr attr = concat [ one x | x <- flag_list, enabled $ attr x ]
  where one x = case flag_type x (attr x) of
          BooleanOption -> [ Option [] (invlongs $ attr x) (NoArg $ flag_set x False) ""
                           , Option (shorts $ attr x) (longs $ attr x) (flag_args x (attr x)) ""]
          _ | nonoption attr x -> []
          _ -> [Option (shorts $ attr x) (longs $ attr x) (flag_args x (attr x)) ""]

-- | Controls how to display boolean options in help output: MergePrefix shows
-- --[no-]foo, MergeSuffix shows --foo[=yes|no] and NoMerge shows two lines,
-- first with --foo and help, second with --no-foo (and no further help).
data HelpStyle = MergePrefix | MergeSuffix | NoMerge deriving Eq

helpDescr :: FlagType flag => HelpStyle -> (flag -> [Attribute]) -> [(String, [OptDescr ()])]
helpDescr style attr = [ grp g | g <- nub $ map getgroup
                                      [ attr f | f <- flag_list, enabled $ attr f ] ]
  where one x | BooleanOption <- flag_type x (attr x), NoMerge <- style =
                  [ Option (shorts $ attr x) (longs $ attr x) (args x) (help x)
                  , Option [] (invlongs $ attr x) (NoArg ()) "" ]
              | BooleanOption <- flag_type x (attr x), MergePrefix <- style =
                  [ Option (shorts $ attr x) (ziplongs (longs $ attr x) (invlongs $ attr x))
                           (NoArg ()) (help x) ]
              | nonoption attr x = []
              | otherwise = [Option (shorts $ attr x) (longs $ attr x) (args x) (help x)]
        merge p ns =
             "[" ++ intercalate "/" [ take (length n - length p) n | n <- ns ] ++ "]" ++ p
        ziplongs [] [] = []
        ziplongs (p:ps) ns = merge p (takeWhile (p `isSuffixOf`) ns)
                               : ziplongs ps (dropWhile (p `isSuffixOf`) ns)
        grp g = (g, concat [ one x | x <- flag_list, enabled $ attr x, getgroup (attr x) == g ])
        help x | BooleanOption <- flag_type x (attr x) = summary ++ " (default: " ++ booldef ++ ")"
               | (defvalue $ attr x) /= "" && flag_type x (attr x) /= SimpleOption =
                   summary ++ " (default: " ++ (defvalue $ attr x) ++ ")"
               | otherwise = summary
          where summary = helpattr $ attr x
                booldef = if defvalue $ attr x then "yes" else "no"
        args x = case flag_type x (attr x) of
            BooleanOption | MergeSuffix <- style -> OptArg (const ()) "yes|no"
                          | otherwise -> NoArg ()
            OptionalArgument -> OptArg (const ()) (arghelp $ attr x)
            RequiredArgument -> ReqArg (const ()) (arghelp $ attr x)
            SimpleOption -> NoArg ()

-- | The default parser for option arguments. Handles strings, string lists
-- (always produces single-element list), integers, booleans (@yes|true|1@ vs
-- @no|false|0@), PathF and integer lists (@--foo=1,2,3@).
readCommon :: (Data a) => String -> a
readCommon = (\x -> error $ "readflag: " ++ gshow x)
             <+< string <+< optional string
             <+< int <+< optional int
             <+< bool <+< optional bool
             <+< path <+< optional path
             <+< strlist <+< optional strlist
             <+< list int <+< optional (list int)
    where string = id
          int = read :: String -> Int
          bool b | b `elem` ["yes", "true", "1", ""] = True
                 | b `elem` ["no", "false", "0"] = False
          path = PathF
          strlist = (:[])
          list w str = map w (splitOn "," str)

(<+<) :: (Typeable a, Typeable b, Monad m) => m a -> m b -> m a
(<+<) = extR
infixl 8 <+<

optional _ "" = Nothing
optional f x = Just $ f x

hyphenate (x:xs) | isUpper x = '-' : toLower x : hyphenate xs
                 | otherwise = x : hyphenate xs
hyphenate [] = []

-- | Extract a long option name from an ADT constructor using its name. For
-- @Foo@, you will get @foo@ and on @FooBar@ will get @foo-bar@.
nameFromConstr :: Constr -> String
nameFromConstr ctor = map toLower (take 1 name) ++ hyphenate (drop 1 name)
  where name = showConstr ctor