{-# LANGUAGE ScopedTypeVariables, GADTs, MultiParamTypeClasses, FunctionalDependencies,
FlexibleInstances, UndecidableInstances, OverlappingInstances, DeriveDataTypeable,
FlexibleContexts #-}moduleSystem.Console.CmdLib.CommandwhereimportSystem.Console.CmdLib.AttributeimportSystem.Console.CmdLib.FlagimportSystem.Console.GetOptimportData.TypeableimportData.List(sort)importData.Char(toLower)importData.Maybe(fromJust,isNothing)importControl.Monad(when)importSystem.IO(hPutStrLn,stderr)importSystem.Exit-- | How to process options for a command. See "optionStyle" for details.dataOptionStyle=Permuted|NonPermuted|NoOptionsderivingEq-- | A class that describes a single (sub)command. The @cmd@ type parameter is-- just for dispatch (and the default command name is derived from this type's-- name, but this can be overriden). It could be an empty data decl as far as-- this library is concerned, although you may choose to store information in-- it.---- To parse the commandline for a given command, see "execute". The basic usage-- can look something like this:---- > data Flag = Summary | Unified Bool | LookForAdds Bool-- > instance ADTFlag Flag-- >-- > [...]-- >-- > data Whatsnew = Whatsnew deriving Typeable-- >-- > instance Command Whatsnew (ADT Flag) where-- > options _ = enable <% Summary +% Unified +% LookForAdds-- > summary _ = "Create a patch from unrecorded changes."-- >-- > run _ f opts = do putStrLn $ "Record."-- > putStrLn $ "Options: " ++ show f-- > putStrLn $ "Non-options: " ++ show optsclass(Typeablecmd,FlagTypeflag)=>Commandcmdflag|cmd->flagwhere-- | An "Attribute" mapping for flags provided by the @flag@ type parameter.options::cmd->AttributeMapKeyoptions_=EmptyMap-- | Set this to True if the command is a supercommand (i.e. expects another-- subcommand). Defaults to False. Supercommands can come with their own-- options, which need to appear between the supercommand and its-- subcommand. Any later options go to the subcommand. The "run" (and-- "description") method of a supercommand should use "dispatch" and-- "helpCommands" respectively (on its list of subcommands) itself.supercommand::cmd->Boolsupercommand_=False-- | How to process options for this command. "NoOptions" disables option-- processing completely and all arguments are passed in the [String]-- parameter to "run". "Permuted" collects everything that looks like an-- option (starts with a dash) and processes it. The non-option arguments are-- filtered and passed to run like above. Finally, "NonPermuted" only-- processes options until a first non-option argument is encountered. The-- remaining arguments are passed unchanged to run.optionStyle::cmd->OptionStyleoptionStyle_=Permuted-- | The handler that actually runs the command. Gets the @setup@ value as-- folded from the processed options (see "Combine") and a list of non-option-- arguments.run::cmd->Foldedflag->[String]->IO()runcmd__=die$"BUG: Command "++cmdnamecmd++" not implemented."-- | Provides the commands' short synopsis.synopsis::cmd->Stringsynopsis_=""-- | Provides a short (one-line) description of the command. Used in help-- output.summary::cmd->Stringsummary_=""help::cmd->Stringhelp_=""-- | The name of the command. Normally derived automatically from @cmd@, but-- may be overriden.cmdname::cmd->Stringcmdnamec=maptoLower$reverse.takeWhile(/='.').reverse.show$typeOfc-- | A convenience "undefined" of the command, for use with "Commands".cmd::cmdcmd=undefinedcmd_flag_empty::cmd->Foldedflagcmd_flag_empty_=flag_empty(undefined::flag)cmdoptions::(Commandcmdflag)=>cmd->(Key->[Attribute])cmdoptions=attrFun.optionshelpOptions::forallcmdf.Commandcmdf=>cmd->StringhelpOptionscmd=unlines$[x|x<-[summarycmd,syncmd,helpcmd],not$nullx]++optswherecmd_attrs::f->[Attribute]cmd_attrs=cmdoptionscmd.flag_attrkeysync|null(synopsisc)=""|otherwise="Usage: "++synopsiscopts|nullopts'=[]|otherwise="":map(uncurryusageInfo)opts'opts'=[(grp++":",getopt)|(grp,getopt@(_:_))<-helpDescrMergeSuffix$attrFun(cmd_attrs%%flag_attrs)]helpCommandsx=concat$maponexwhereone(CommandWrapc)=" "++pad(cmdnamec)++" "++summaryc++"\n"one(CommandGroupnamel)="\n"++name++":\n"++helpCommandslpadstr=(take15$str++replicate15' ')++" "execute'::forallcmdf.(Commandcmdf)=>cmd->[String]->IO(Maybe(Foldedf,[String]))execute'cmdopts|"--help"`elem`opts&&not(supercommandcmd)=printHelpcmd>>returnNothing|("--help":_)<-opts=printHelpcmd>>returnNothing|NoOptions<-optionStylecmd=return$Just(foldr($)(cmd_flag_emptycmd)defaults,opts)|otherwise=docaseerrsof[]->dosequence_[setglobal(attrsf)(flag_valuefflags')|f<-flag_list]return$Just(flags',opts'filtered)_->die(concaterrs)>>returnNothingwheregetopts=optDescrattrsorder=ifsupercommandcmd||(optionStylecmd==NonPermuted)thenRequireOrderelsePermute(flags,opts',errs)=getOptordergetoptsoptsflags'=foldr($)(cmd_flag_emptycmd)(positions'++extras++reverseflags++defaults)extras::[Foldedf->Foldedf]extras=[ifextra(attrsf)thenflag_setfopts'filteredelseid|f::f<-flag_list,enabled$attrsf]positions=[(f,n)|f<-flag_list,enabled$attrsf,Justn<-[positional$attrsf]]positions'=[if(lengthopts'>n)thenflag_parsef(opts'!!n)elseid|(f,n)<-positions]opts'filtered=removemanyopts'(reverse$sort$mapsndpositions)removemanyl(n:ns)=removemany(removeln)nsremovemanyl[]=lremoveln=let(a,b)=splitAtnlin(a++drop1b)defaults::[Foldedf->Foldedf]defaults=flag_defaultsattrscmd_attrs::f->[Attribute]cmd_attrs=cmdoptionscmd.flag_attrkeyattrs::f->[Attribute]attrs=attrFun(cmd_attrs%%flag_attrs)-- | Parse options for and execute a single command (see "Command"). May be-- useful for programs that do not need command-based "dispatch", but still-- make use of the "Command" class to describe themselves. Handles @--help@-- internally. You can use this as the entrypoint if your application is-- non-modal (i.e. it has no subcommands).execute::forallcmdf.(Commandcmdf)=>cmd->[String]->IO()executecmdopts=execute'cmdopts>>=\f->casefofJust(flags,opts')->runcmdflagsopts'Nothing->return()classCommandsawheretoCommands::a->[CommandWrap]dataCommandWrapwhereCommandWrap::(Commandaf,Typeable(Foldedf))=>a->CommandWrapCommandGroup::String->[CommandWrap]->CommandWrapinstanceCommandsCommandWrapwheretoCommands=(:[])instanceCommands[CommandWrap]wheretoCommands=idinstance(Commandcf,Typeable(Foldedf))=>CommandscwheretoCommandsc=[CommandWrapc]-- | Chain commands into a list suitable for "dispatch" and "helpCommands". E.g.:---- > dispatch (Command1 %: Command2 %: Command3) opts(%:)::(Commandsa,Commandsb)=>a->b->[CommandWrap]a%:b=toCommandsa++toCommandsbcommandGroup::(Commandsa)=>String->a->[CommandWrap]commandGroupsl=[CommandGroups(toCommandsl)]-- TODO: disambiguation, hidden commands (aliases)findCommand::String->[CommandWrap]->MaybeCommandWrapfindCommandkey(c@(CommandWrapcmd):comms)|key==cmdnamecmd=Justc|otherwise=findCommandkeycommsfindCommandkey(CommandGroup_comms:comms')|Justc<-findCommandkeycomms=Justc|otherwise=findCommandkeycomms'findCommand_[]=NothingprintHelpc=putStr$helpOptionscprintCommandscomms=putStr$helpCommandscommsdispatch'::[DispatchOpt]->[CommandWrap]->[String]->IO(Maybe(CommandWrap,[String]))dispatch'doptcomms'args=caseargsof[]|isNothingdef->dieHelp"Command required."|otherwise->return$Just(fromJustdef,[])("--help":_)->printCommandscomms>>returnNothing(cmd:args')->casefindCommandcmdcommsofNothing->casedefofNothing->dieHelp$"No such command "++cmdJustx->return$Just(x,args)Justx->return$Just(x,args')wherecomms|null[()|NoHelp<-dopt]=HelpCommandcomms%:comms'|otherwise=comms'dieHelpmsg=printCommandscomms>>diemsg>>returnNothingdef|(DefaultCommandn:_)<-[o|o@(DefaultCommand_)<-dopt]=Justn|otherwise=NothingdataDispatchOpt=NoHelp|DefaultCommandCommandWrapnoHelp=NoHelpdefaultCommand::(Commandfx,Typeable(Foldedx))=>f->DispatchOptdefaultCommand=DefaultCommand.CommandWrap-- | Given a list of commands (see @"%:"@) and a list of commandline arguments,-- dispatch on the command name, parse the commandline options (see "execute")-- and transfer control to the command. This function also implements the-- @help@ pseudocommand.dispatch::[DispatchOpt]->[CommandWrap]->[String]->IO()dispatchdoptcommsopts=dispatch'doptcommsopts>>=\c->casecofNothing->return()Just(CommandWrapc,opts')->executecopts'-- | Helper for dying with an error message (nicely, at least compared to-- "fail" in IO).die::String->IOadiemsg=dohPutStrLnstderr("FATAL: "++trimmsg)exitWith(ExitFailure1)return(error"unreachable")wheretrimmsg|lastmsg=='\n'=trim$initmsg|otherwise=msgdataHelpCommand=HelpCommand[CommandWrap]derivingTypeableinstanceCommandHelpCommand()wherecmdname_="help"synopsis_="help [command]"summary_="show help for a command or commands overview"run(HelpCommandcomms)_args=caseargsof[]->printCommandscomms(cmd:_)->casefindCommandcmdcommsofNothing->printCommandscomms>>die("No such command "++cmd)Just(CommandWrapcomm)->printHelpcomm