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)) ""]
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 ()
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 [] = []
nameFromConstr :: Constr -> String
nameFromConstr ctor = map toLower (take 1 name) ++ hyphenate (drop 1 name)
where name = showConstr ctor