module System.Console.CmdLib.Record where
import System.Console.CmdLib.Attribute
import System.Console.CmdLib.Command
import System.Console.GetOpt
import Data.Data
import Data.List( nub, elemIndex )
import Control.Monad.State( evalState, get, put, State, execState )
import Data.Maybe( fromMaybe, fromJust )
import System.Exit
import System.Console.CmdLib.Flag
append :: forall a. (Data a) => a -> a -> a
append a = any <+< list
where any = const a
list :: (Typeable b) => b -> [String]
list = (++(fromJust $ cast a)) . fromJust . cast
data (Attributes rec) => Record rec = Record rec String deriving Eq
instance (Eq rec, Eq (Record rec), Data rec, Attributes rec) => FlagType (Record rec) where
type Folded (Record rec) = rec
flag_attrkey (Record _ f) = KeyF (typeOf (undefined :: rec)) f
flag_list = [ Record undefined field |
field <- nub $ concatMap constrFields
(dataTypeConstrs $ dataTypeOf (undefined :: rec)) ]
flag_type f@(Record rec field) attr =
fixup $ optionType [gmapQi idx dataTypeOf x] [gmapQi idx typeOf x]
where constr = head [ ctor | ctor <- dataTypeConstrs $ dataTypeOf rec
, field `elem` constrFields ctor ]
idx = fromMaybe (error $ "BUG: Getting type of nonexistent field " ++ field) $
elemIndex field $ constrFields constr
x :: rec = fromConstr constr
fixup BooleanOption | False <- invertible attr = SimpleOption
fixup x = x
flag_defaults attr = map setfield flag_list
where setdef :: forall a. (Data a) => Record rec -> a
setdef flag = defvalue $ attrs flag attr
setfield flag@(Record _ field) rec = setField field rec (setdef flag)
flag_attrs (Record _ name) = (attrFun $ attributes (undefined :: rec))
(KeyF (typeOf (undefined :: rec)) name) %+
long (hyphenate name) %+ defaults
flag_value (Record _ field) folded = getField field folded
flag_set (Record _ field) v = \x -> setField field x (errcast v)
where errcast :: (Typeable a, Typeable b) => a -> b
errcast x = case cast x of
Just x -> x
Nothing -> error "BUG: flag_set in Record used with wrong value type"
flag_parse f@(Record _ field) str v = setField field v (readFlag (undefined :: rec) str)
flag_args f@(Record flag field) attr = case flag_type (Record flag field) attr of
BooleanOption -> OptArg setoptional ""
OptionalArgument -> OptArg setoptional ""
RequiredArgument -> ReqArg setlist ""
SimpleOption -> NoArg $ flag_set f True
where set str v = setField field v (readFlag (undefined :: rec) str)
setlist str v = setField field v (append (readFlag (undefined :: rec) str) (flag_value f v))
setoptional str = set (fromMaybe "" str)
flag_empty _ = fromConstr $ head $ dataTypeConstrs $ dataTypeOf (undefined :: rec)
class (Data cmd) => RecordCommand cmd where
run' :: cmd -> [String] -> IO ()
rec_options :: cmd -> AttributeMap Key
rec_options _ = EmptyMap
mode_summary :: cmd -> String
mode_summary _ = ""
mode_help :: cmd -> String
mode_help _ = ""
data RecordMode cmd = RecordMode { rec_cmdname :: String
, rec_initial :: Constr }
deriving (Typeable)
instance (Eq cmd, Eq (Record cmd), RecordCommand cmd, Data cmd, Attributes cmd)
=> Command (RecordMode cmd) (Record cmd) where
cmdname = rec_cmdname
run _ = run'
summary cmd = mode_summary $ (fromConstr $ rec_initial cmd :: cmd)
help cmd = mode_help $ (fromConstr $ rec_initial cmd :: cmd)
options cmd = rec_options ctor %% available %% everywhere disable
where available = [ (KeyF (typeOf (undefined :: cmd)) opt, [enable])
| opt <- constrFields $ rec_initial cmd]
ctor = (fromConstr $ rec_initial cmd :: cmd)
cmd_flag_empty cmd = fromConstr $ rec_initial cmd
recordCommands :: forall cmd. (Eq cmd, Eq (Record cmd), Data cmd, RecordCommand cmd, Attributes cmd)
=> cmd -> [CommandWrap]
recordCommands _ = go $ dataTypeConstrs $ dataTypeOf (undefined :: cmd)
where go = map $ CommandWrap . rec_cmd
rec_cmd :: Constr -> RecordMode cmd
rec_cmd x = RecordMode { rec_cmdname = nameFromConstr x
, rec_initial = x }
setField :: forall rec a. (Data rec) => String -> rec -> (forall b. (Data b) => b) -> rec
setField field current value = evalState (gmapM subst current) (constrFields $ toConstr current)
where subst :: Data x => x -> State [String] x
subst f = do x:xs <- get
put xs
if x == field then return value else return f
data Imp = Imp Int (forall a. (Typeable a) => a)
getField :: forall rec a. (Data rec, Typeable a) => String -> rec -> a
getField field value = case execState (gmapM find value) (Imp 0 (error "")) of Imp _ v -> v
where idx = elemIndex field $ constrFields (toConstr value)
find :: Data x => x -> State Imp x
find f = do Imp i val <- get
if (Just i == idx) then put $ Imp (i + 1) (errcast f)
else put $ Imp (i + 1) val
return $ error "find"
errcast :: forall a b. (Typeable a, Typeable b) => a -> b
errcast = fromMaybe (error $ "BUG: getField used with wrong type on " ++ field) . cast
dispatchR :: forall cmd f. (Eq cmd, Eq (Record cmd), Attributes cmd, RecordCommand cmd,
Command (RecordMode cmd) f,
Folded f ~ cmd) => [DispatchOpt] -> [String] -> IO cmd
dispatchR dopt opts = dispatch' die dopt (recordCommands (undefined :: cmd)) opts >>= \c -> case c of
Nothing -> exitWith ExitSuccess >> return undefined
Just (CommandWrap x, opts') -> execute' x opts' >>= \c -> case c of
Just (command, opts') -> case (cast command) of
Just comm -> return comm
Nothing -> execute x opts' >> exitWith ExitSuccess >> return undefined
Nothing -> exitWith ExitSuccess >> return undefined
executeR :: forall cmd. (Eq cmd, Eq (Record cmd), Attributes cmd, RecordCommand cmd)
=> cmd -> [String] -> IO cmd
executeR cmd opts = execute' cmd' opts >>= \c -> case c of
Just (command, _) -> return command
Nothing -> exitWith ExitSuccess >> return undefined
where cmd' = RecordMode (nameFromConstr $ toConstr cmd) (toConstr cmd)