module System.Console.CmdLib.ADTs where
import System.Console.CmdLib.Attribute
import System.Console.CmdLib.Flag
import System.Console.GetOpt
import Control.Exception ( throw, evaluate )
import Data.Data
import Data.Generics.Aliases( extB )
import Data.Maybe( fromMaybe )
newtype (Attributes adt) => ADT adt = ADT adt deriving Eq
instance (Eq (ADT adt), Attributes adt, Data adt) => FlagType (ADT adt) where
type Folded (ADT adt) = [adt]
flag_attrkey (ADT x) = KeyC $ toConstr x
flag_empty _ = []
flag_fold _ flags defs = flags' ++ [ f | f <- defs, toConstr f `notElem` map toConstr flags' ]
where flags' = foldr ($) [] flags
flag_type (ADT flag) _ = optionType (gmapQ dataTypeOf flag) (gmapQ typeOf flag)
flag_list = [ ADT $ fromConstr x | x <- dataTypeConstrs $ dataTypeOf (undefined :: adt) ]
flag_defaults attr initial = [ setdef f | ADT f <- flag_list, length (gmapQ typeOf f) == 1,
enabled (attr $ ADT f) ] ++ initial
where setdef :: adt -> adt
setdef f = fromConstrB (if required (attr $ ADT f)
then throw RequiredArgException
else defvalue $ attrs (ADT f) attr) (toConstr f)
flag_attrs (ADT flag) = (attrFun $ attributes flag) (KeyC $ toConstr flag) %+
long (nameFromConstr $ toConstr flag) %+
defaults
flag_set (ADT flag) v = (fromConstrB ((error "flag_set" `extB` v) ()) (toConstr flag) :)
flag_parse (ADT flag) str = (fromConstrB (readFlag (undefined :: adt) str) (toConstr flag) :)
flag_eval (ADT flag) folded = case [ f | f <- folded, toConstr f == toConstr flag ] of
(x:_) -> gmapM evaluate x >> return ()
[] -> return ()
flag_args (ADT flag) attr = case flag_type (ADT flag) attr of
BooleanOption -> OptArg addoptional ""
OptionalArgument -> OptArg addoptional ""
RequiredArgument -> ReqArg add ""
SimpleOption -> NoArg (flag:)
where reify :: Data a => String -> a
reify y = fromConstrB (readFlag (undefined :: adt) y) (toConstr flag)
add x = (reify x :)
addoptional x = (reify (fromMaybe "" x) :)