{-# LANGUAGE CPP, ForeignFunctionInterface #-}-- |-- Module : Exec-- Maintainer : darcs-devel@darcs.net-- Stability : experimental-- Portability : portable---- Various utility functions that do not belong anywhere else.moduleDarcs.Utils(ortryrunning,nubsort,breakCommand,showHexLen,maybeGetEnv,formatPath-- * Monads,firstJustIO-- * User prompts,askEnter,askUser,askUserListItem,PromptConfig(..),promptYorn,promptChar-- * Text,getViewer,editFile,runEditor,stripCr-- * Help,environmentHelpEditor,environmentHelpPager-- * Errors and exceptions,catchall,clarifyErrors,prettyException,prettyError,addToErrorLoc-- * Files and directories,getFileStatus,withCurrentDirectory,withUMask-- * Locales,setDarcsEncodings,getSystemEncoding,isUTF8Locale-- * Tree filtering.,filterFilePaths,filterPaths-- * Tree lookup.,treeHas,treeHasDir,treeHasFile,treeHasAnycase)whereimportPreludehiding(catch)importControl.Exception.Extensible(bracket,bracket_,catch,try,IOException,SomeException,Exception(fromException))importControl.Monad(when,forM)importControl.Monad.Error(MonadError)importControl.Monad.State.Strict(gets)importqualifiedData.ByteStringasB(readFile)importqualifiedData.ByteString.Char8asBSCimportData.Char(toUpper,toLower,isSpace)importData.List(group,sort)importData.Maybe(isJust)importForeign.C.String(CString,withCString,peekCString)importForeign.C.Error(throwErrno)importForeign.C.Types(CInt)#ifdef FORCE_CHAR8_ENCODINGimportGHC.IO.Encoding(setFileSystemEncoding,setForeignEncoding,char8)#endifimportStorage.Hashed.AnchoredPath(AnchoredPath(..),Name(..),isPrefix,floatPath)importStorage.Hashed.Monad(withDirectory,fileExists,directoryExists,virtualTreeMonad,currentDirectory,TreeMonad)importqualifiedStorage.Hashed.MonadasHS(exists,tree)importStorage.Hashed.Tree(Tree,listImmediate,findTree)importSystem.Console.Haskeline(runInputT,defaultSettings,getInputLine,getInputChar,outputStr,outputStrLn)importSystem.Directory(doesFileExist)importSystem.Environment(getEnv)importSystem.Exit(ExitCode(..))importSystem.IO.Error(annotateIOError,isUserError,ioeGetErrorString,isDoesNotExistError,ioeGetFileName)importSystem.Posix.Files(getSymbolicLinkStatus,FileStatus)importText.RegeximportDarcs.RepoPath(FilePathLike,getCurrentDirectory,setCurrentDirectory,toFilePath)importDarcs.SignalHandler(catchNonSignal)importExec(execInteractive)importNumeric(showHex)importProgress(withoutProgress)showHexLen::(Integrala,Showa)=>Int->a->StringshowHexLennx=lets=showHexx""inreplicate(n-lengths)' '++saddToErrorLoc::IOException->String->IOExceptionaddToErrorLocioes=annotateIOErrorioesNothingNothingcatchall::IOa->IOa->IOaa`catchall`b=a`catchNonSignal`(\_->b)maybeGetEnv::String->IO(MaybeString)maybeGetEnvs=fmapJust(getEnvs)`catchall`returnNothing-- err can only be isDoesNotExist-- | The firstJustM returns the first Just entry in a list of monadic-- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence-- operator evaluates all monadic members of the list before passing it along-- (i.e. sequence is strict). The firstJustM is lazy in that list member monads-- are only evaluated up to the point where the first Just entry is obtained.firstJustM::Monadm=>[m(Maybea)]->m(Maybea)firstJustM[]=returnNothingfirstJustM(e:es)=e>>=(\v->ifisJustvthenreturnvelsefirstJustMes)-- | The firstJustIO is a slight modification to firstJustM: the entries in the-- list must be IO monad operations and the firstJustIO will silently turn any-- monad call that throws an exception into Nothing, basically causing it to be-- ignored.firstJustIO::[IO(Maybea)]->IO(Maybea)firstJustIO=firstJustM.map(`catchall`returnNothing)clarifyErrors::IOa->String->IOaclarifyErrorsae=a`catch`(\x->fail$unlines[prettyExceptionx,e])prettyException::SomeException->StringprettyExceptione|Justioe<-fromExceptione,isUserErrorioe=ioeGetErrorStringioeprettyExceptione|Justioe<-fromExceptione,isDoesNotExistErrorioe=caseioeGetFileNameioeofJustf->f++" does not exist"Nothing->showeprettyExceptione=showeprettyError::IOError->StringprettyErrore|isUserErrore=ioeGetErrorStringe|otherwise=showe-- | Given two shell commands as arguments, execute the former. The-- latter is then executed if the former failed because the executable-- wasn't found (code 127), wasn't executable (code 126) or some other-- exception occurred. Other failures (such as the user holding ^C)-- do not cause the second command to be tried.ortryrunning::IOExitCode->IOExitCode->IOExitCodea`ortryrunning`b=doret<-tryacaseretof(Right(ExitFailure126))->b-- command not executable(Right(ExitFailure127))->b-- command not found#ifdef WIN32(Right(ExitFailure9009))->b-- command not found by cmd.exe on Windows#endif(Rightx)->returnx-- legitimate success/failure(Left(_::SomeException))->b-- an exceptionwithCurrentDirectory::FilePathLikep=>p->IOa->IOawithCurrentDirectorynamem=bracket(docwd<-getCurrentDirectorywhen(toFilePathname/="")(setCurrentDirectoryname)returncwd)(\oldwd->setCurrentDirectoryoldwd`catchall`return())(constm)foreignimportccallunsafe"umask.h set_umask"set_umask::CString->IOCIntforeignimportccallunsafe"umask.h reset_umask"reset_umask::CInt->IOCIntwithUMask::String->IOa->IOawithUMaskumaskjob=dorc<-withCStringumaskset_umaskwhen(rc<0)(throwErrno"Couldn't set umask")bracket_(return())(reset_umaskrc)job-- | Ask the user for a line of input.askUser::String-- ^ The prompt to display->IOString-- ^ The string the user entered.askUserprompt=withoutProgress$runInputTdefaultSettings$getInputLineprompt>>=maybe(error"askUser: unexpected end of input")return-- | Ask the user to press EnteraskEnter::String-- ^ The prompt to display->IO()askEnterprompt=askUserprompt>>return()-- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing-- the user to choose one of the itemsaskUserListItem::String->[String]->IOStringaskUserListItempromptxs=withoutProgress$runInputTdefaultSettings$dooutputStr.unlines$zipWith(\nx->shown++". "++x)[1::Int..]xsloopwhereloop=doanswer<-getInputLineprompt>>=maybe(error"askUser: unexpected end of input")returncasemaybeReadanswerofJustn|n>0&&n<=lengthxs->return(xs!!(n-1))_->outputStrLn"Invalid response, try again!">>loopmaybeRead::Reada=>String->MaybeamaybeReads=casereadssof[(x,rest)]|allisSpacerest->Justx_->NothingstripCr::String->StringstripCr""=""stripCr"\r"=""stripCr(c:cs)=c:stripCrcs-- | Format a path for screen output, so that the user sees where the path-- begins and ends. Could (should?) also warn about unprintable characters here.formatPath::String->StringformatPathpath="\""++quotepath++"\""wherequote""=""quote(c:cs)=ifc`elem`['\\','"']then'\\':c:quotecselsec:quotecsbreakCommand::String->(String,[String])breakCommands=casewordssof(arg0:args)->(arg0,args)[]->(s,[])nubsort::Orda=>[a]->[a]nubsort=maphead.group.sort-- | @editFile f@ lets the user edit a file which could but does not need to-- already exist. This function returns the exit code from the text editor and a-- flag indicating if the user made any changes.editFile::FilePathLikep=>p->IO(ExitCode,Bool)editFileff=doold_content<-file_contentec<-runEditorfnew_content<-file_contentreturn(ec,new_content/=old_content)wheref=toFilePathfffile_content=doexists<-doesFileExistfifexiststhendocontent<-B.readFilefreturn$JustcontentelsereturnNothingrunEditor::FilePath->IOExitCoderunEditorf=doed<-getEditorexecInteractiveedf`ortryrunning`execInteractive"emacs"f`ortryrunning`execInteractive"emacs -nw"f`ortryrunning`execInteractive"nano"f#ifdef WIN32`ortryrunning`execInteractive"edit"f#endifgetEditor::IOStringgetEditor=getEnv"DARCS_EDITOR"`catchall`getEnv"DARCSEDITOR"`catchall`getEnv"VISUAL"`catchall`getEnv"EDITOR"`catchall`return"vi"environmentHelpEditor::([String],[String])environmentHelpEditor=(["DARCS_EDITOR","DARCSEDITOR","VISUAL","EDITOR"],["To edit a patch description of email comment, Darcs will invoke an","external editor. Your preferred editor can be set as any of the","environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.","If none of these are set, vi(1) is used. If vi crashes or is not","found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are","each tried in turn."])getViewer::IOStringgetViewer=getEnv"DARCS_PAGER"`catchall`getEnv"PAGER"`catchall`return"less"environmentHelpPager::([String],[String])environmentHelpPager=(["DARCS_PAGER","PAGER"],["Darcs will sometimes invoke a pager if it deems output to be too long","to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER","or $PAGER. If neither are set, `less' will be used."])dataPromptConfig=PromptConfig{pPrompt::String,pBasicCharacters::[Char],pAdvancedCharacters::[Char]-- ^ only shown on help,pDefault::MaybeChar,pHelp::[Char]}-- | Prompt the user for a yes or nopromptYorn::[Char]->IOBoolpromptYornp=(=='y')`fmap`promptChar(PromptConfigp"yn"[]Nothing[])promptChar::PromptConfig->IOCharpromptChar(PromptConfigpbasic_chsadv_chsmdhelp_chs)=withoutProgress$runInputTdefaultSettingsloopCharwherechs=basic_chs++adv_chsloopChar=doletchars=setDefault(basic_chs++(ifnulladv_chsthen""else"..."))prompt=p++" ["++chars++"]"++helpStra<-getInputCharprompt>>=maybe(error"promptChar: unexpected end of input")returncase()of_|a`elem`chs->returna|a==' '->maybetryAgainreturnmd|a`elem`help_chs->returna|otherwise->tryAgainhelpStr=casehelp_chsof[]->""(h:_)|nulladv_chs->", or "++(h:" for help: ")|otherwise->", or "++(h:" for more options: ")tryAgain=dooutputStrLn"Invalid response, try again!"loopCharsetDefaults=casemdofNothing->sJustd->map(setUpperd)ssetUpperdc=ifd==cthentoUppercelsec-- | Construct a filter from a list of AnchoredPaths, that will accept any path-- that is either a parent or a child of any of the listed paths, and discard-- everything else.filterPaths::[AnchoredPath]->AnchoredPath->t->BoolfilterPathsfilesp_=any(\x->x`isPrefix`p||p`isPrefix`x)files-- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to-- AnchoredPath).filterFilePaths::[FilePath]->AnchoredPath->t->BoolfilterFilePaths=filterPaths.mapfloatPathgetFileStatus::FilePath->IO(MaybeFileStatus)getFileStatusf=Just`fmap`getSymbolicLinkStatusf`catchall`returnNothingtreeHasAnycase::(MonadErrorem,Functorm,Monadm)=>Treem->FilePath->mBooltreeHasAnycasetreepath=fst`fmap`virtualTreeMonad(existsAnycase$floatPathpath)treeexistsAnycase::(MonadErrorem,Functorm,Monadm)=>AnchoredPath->TreeMonadmBoolexistsAnycase(AnchoredPath[])=returnTrueexistsAnycase(AnchoredPath(Namex:xs))=dodowd<-currentDirectoryJusttree<-gets(flipfindTreewd.HS.tree)letsubs=[AnchoredPath[Namen]|(Namen,_)<-listImmediatetree,BSC.maptoLowern==BSC.maptoLowerx]or`fmap`forMsubs(\path->dofile<-fileExistspathiffilethenreturnTrueelsewithDirectorypath(existsAnycase$AnchoredPathxs))treeHas::(MonadErrorem,Functorm,Monadm)=>Treem->FilePath->mBooltreeHastreepath=fst`fmap`virtualTreeMonad(HS.exists$floatPathpath)treetreeHasDir::(MonadErrorem,Functorm,Monadm)=>Treem->FilePath->mBooltreeHasDirtreepath=fst`fmap`virtualTreeMonad(directoryExists$floatPathpath)treetreeHasFile::(MonadErrorem,Functorm,Monadm)=>Treem->FilePath->mBooltreeHasFiletreepath=fst`fmap`virtualTreeMonad(fileExists$floatPathpath)tree-- | In some environments, darcs requires that certain global GHC library variables that-- control the encoding used in internal translations are set to specific values.---- @setDarcsEncoding@ enforces those settings, and should be called before the-- first time any darcs operation is run, and again if anything else might have-- set those encodings to different values.---- Note that it isn't thread-safe and has a global effect on your program.---- The current behaviour of this function is as follows, though this may-- change in future:---- Encodings are only set on GHC 7.4 and up, on any non-Windows platform.---- Two encodings are set, both to @GHC.IO.Encoding.char8@:-- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@.--setDarcsEncodings::IO()setDarcsEncodings=do#ifdef FORCE_CHAR8_ENCODING-- This is needed for appropriate behaviour from getArgs and from general-- filesystem calls (e.g. getDirectoryContents, readFile, ...)setFileSystemEncodingchar8-- This ensures that foreign calls made by hashed-storage to stat-- filenames returned from getDirectoryContents are translated appropriatelysetForeignEncodingchar8#endifreturn()-- The following functions are copied from the encoding package (BSD3-- licence, by Henning Günther).-- | @getSystemEncoding@ fetches the current encoding from localeforeignimportccall"system_encoding.h get_system_encoding"get_system_encoding::IOCStringgetSystemEncoding::IOStringgetSystemEncoding=doenc<-get_system_encodingpeekCStringenc-- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a-- subset of UTF-8).isUTF8Locale::String->BoolisUTF8LocalecodeName=case(normalizeEncodingcodeName)of-- ASCII"ascii"->True"646"->True"ansi_x3_4_1968"->True"ansi_x3.4_1986"->True"cp367"->True"csascii"->True"ibm367"->True"iso646_us"->True"iso_646.irv_1991"->True"iso_ir_6"->True"us"->True"us_ascii"->True-- UTF-8"utf_8"->True"u8"->True"utf"->True"utf8"->True"utf8_ucs2"->True"utf8_ucs4"->True-- Everything else_->FalsewherenormalizeEncodings=maptoLower$subRegexseps"_"sep=mkRegex"[^0-9A-Za-z]+"