{-# LANGUAGE CPP, ScopedTypeVariables #-}-- -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons-- -- This library is free software; you can redistribute it and/or-- modify it under the terms of the GNU Lesser General Public-- License as published by the Free Software Foundation; either-- version 2.1 of the License, or (at your option) any later version.-- -- This library is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU-- Lesser General Public License for more details.-- -- You should have received a copy of the GNU Lesser General Public-- License along with this library; if not, write to the Free Software-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307-- USA-- moduleSystem.Plugins.Utils(Arg,hWrite,mkUnique,hMkUnique,mkUniqueIn,hMkUniqueIn,findFile,mkTemp,mkTempIn,{- internal -}replaceSuffix,outFilePath,dropSuffix,mkModid,changeFileExt,joinFileExt,splitFileExt,isSublistOf,-- :: Eq a => [a] -> [a] -> Booldirname,basename,(</>),(<.>),(<+>),(<>),newer,encode,decode,EncodedString,panic)where#include "../../../config.h"importSystem.Plugins.Env(isLoaded)importSystem.Plugins.Consts(objSuf,hiSuf,tmpDir)-- import qualified System.MkTemp ( mkstemps )importControl.Exception(IOException,catch)importData.CharimportData.ListimportPreludehiding(catch)importSystem.IOimportSystem.Environment(getEnv)importSystem.Directory-- ----------------------------------------------------------------------- some misc types we usetypeArg=String-- ----------------------------------------------------------------------- | useful--panics=ioError(userErrors)-- ----------------------------------------------------------------------- | writeFile for Handles--hWrite::Handle->String->IO()hWritehdlsrc=hPutStrhdlsrc>>hClosehdl>>return()-- ----------------------------------------------------------------------- | mkstemps.---- We use the Haskell version now... it is faster than calling into-- mkstemps(3).---- mkstemps :: String -> Int -> IO (String,Handle)-- mkstemps path slen = do-- m_v <- System.MkTemp.mkstemps path slen-- case m_v of Nothing -> error "mkstemps : couldn't create temp file"-- Just v' -> return v'{-
mkstemps path slen = do
withCString path $ \ ptr -> do
let c_slen = fromIntegral $ slen+1
fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen
name <- peekCString ptr
hdl <- fdToHandle fd
return (name, hdl)
foreign import ccall unsafe "mkstemps" c_mkstemps :: CString -> CInt -> IO Fd
-}-- ----------------------------------------------------------------------- | create a new temp file, returning name and handle.-- bit like the mktemp shell utility--mkTemp::IO(String,Handle)mkTemp=dotmpd<-catch(getEnv"TMPDIR")(\(_::IOException)->returntmpDir)mkTempIntmpdmkTempIn::String->IO(String,Handle)mkTempIntmpd=do-- XXX (tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3(tmpf,hdl)<-openTempFiletmpd"MXXXXX.hs"letmodname=mkModid$dropSuffixtmpfifand$map(\c->isAlphaNumc&&c/='_')modnamethenreturn(tmpf,hdl)elsepanic$"Illegal characters in temp file: `"++tmpf++"'"-- ----------------------------------------------------------------------- | Get a new temp file, unique from those in /tmp, and from those-- modules already loaded. Very nice for merge/eval uses.---- Will run for a long time if we can't create a temp file, luckily-- mkstemps gives us a pretty big search space--mkUnique::IOFilePathmkUnique=do(t,h)<-hMkUniquehCloseh>>returnthMkUnique::IO(FilePath,Handle)hMkUnique=do(t,h)<-mkTempalreadyLoaded<-isLoadedt-- not unique!ifalreadyLoadedthenhCloseh>>removeFilet>>hMkUniqueelsereturn(t,h)mkUniqueIn::FilePath->IOFilePathmkUniqueIndir=do(t,h)<-hMkUniqueIndirhCloseh>>returnthMkUniqueIn::FilePath->IO(FilePath,Handle)hMkUniqueIndir=do(t,h)<-mkTempIndiralreadyLoaded<-isLoadedt-- not unique!ifalreadyLoadedthenhCloseh>>removeFilet>>hMkUniqueIndirelsereturn(t,h)findFile::[String]->FilePath->IO(MaybeFilePath)findFile[]_=returnNothingfindFile(ext:exts)file=doletl=changeFileExtfileextb<-doesFileExistlifbthenreturn$JustlelsefindFileextsfile-- ----------------------------------------------------------------------- some filename manipulation stuff---- | </>, <.> : join two path components--infixr6</>infixr6<.>(</>),(<.>),(<+>),(<>)::FilePath->FilePath->FilePath[]</>b=ba</>b=a++"/"++b[]<.>b=ba<.>b=a++"."++b[]<+>b=ba<+>b=a++" "++b[]<>b=ba<>b=a++b---- | dirname : return the directory portion of a file path-- if null, return "."--dirname::FilePath->FilePathdirnamep=letx=findIndices(=='\\')py=findIndices(=='/')pinifnot$nullxthenifnot$nullythenif(maximumx)>(maximumy)thendirname''\\'pelsedirname''/'pelsedirname''\\'pelsedirname''/'pwheredirname'charapa=casereverse$dropWhile(/=chara)$reversepaof[]->"."pa'->pa'---- | basename : return the filename portion of a path--basename::FilePath->FilePathbasenamep=letx=findIndices(=='\\')py=findIndices(=='/')pinifnot$nullxthenifnot$nullythenif(maximumx)>(maximumy)thenbasename''\\'pelsebasename''/'pelsebasename''\\'pelsebasename''/'pwherebasename'charapa=reverse$takeWhile(/=chara)$reversepa---- drop suffix--dropSuffix::FilePath->FilePathdropSuffixf=reverse.tail.dropWhile(/='.')$reversef---- | work out the mod name from a filepathmkModid::String->StringmkModid=(takeWhile(/='.')).reverse.(takeWhile(\x->('/'/=x)&&('\\'/=x))).reverse------------------------------------------------------------- Code from Cabal ------------------------------------------ | Changes the extension of a file path.changeFileExt::FilePath-- ^ The path information to modify.->String-- ^ The new extension (without a leading period).-- Specify an empty string to remove an existing-- extension from path.->FilePath-- ^ A string containing the modified path information.changeFileExtfpathext=joinFileExtnameextwhere(name,_)=splitFileExtfpath-- | The 'joinFileExt' function is the opposite of 'splitFileExt'.-- It joins a file name and an extension to form a complete file path.---- The general rule is:---- > filename `joinFileExt` ext == path-- > where-- > (filename,ext) = splitFileExt pathjoinFileExt::String->String->FilePathjoinFileExtfpath""=fpathjoinFileExtfpathext=fpath++'.':ext-- | Split the path into file name and extension. If the file doesn\'t have extension,-- the function will return empty string. The extension doesn\'t include a leading period.---- Examples:---- > splitFileExt "foo.ext" == ("foo", "ext")-- > splitFileExt "foo" == ("foo", "")-- > splitFileExt "." == (".", "")-- > splitFileExt ".." == ("..", "")-- > splitFileExt "foo.bar."== ("foo.bar.", "")splitFileExt::FilePath->(String,String)splitFileExtp=casebreak(=='.')fnameof(suf@(_:_),_:pre)->(reverse(pre++fpath),reversesuf)_->(p,[])where(fname,fpath)=breakisPathSeparator(reversep)-- | Checks whether the character is a valid path separator for the host-- platform. The valid character is a 'pathSeparator' but since the Windows-- operating system also accepts a slash (\"\/\") since DOS 2, the function-- checks for it on this platform, too.isPathSeparator::Char->BoolisPathSeparatorch=#if defined(CYGWIN) || defined(__MINGW32__)ch=='/'||ch=='\\'#elsech=='/'#endif-- Code from Cabal end ------------------------------------------------------------------------------------------------- | return the object file, given the .conf file-- i.e. /home/dons/foo.rc -> /home/dons/foo.o---- we depend on the suffix we are given having a lead '.'--replaceSuffix::FilePath->String->FilePathreplaceSuffix[]_=[]-- ?replaceSuffixfsuf=casereverse$dropWhile(/='.')$reversefof[]->f++suf-- no '.' in file namef'->f'++tailsuf---- Normally we create the .hi and .o files next to the .hs files.-- For some uses this is annoying (i.e. true EDSL users don't actually-- want to know that their code is compiled at all), and for hmake-like-- applications. ---- This code checks if "-o foo" or "-odir foodir" are supplied as args-- to make(), and if so returns a modified file path, otherwise it-- uses the source file to determing the path to where the object and-- .hi file will be put.--outFilePath::FilePath->[Arg]->(FilePath,FilePath)outFilePathsrcargs=letobjs=find_oargs-- user sets explicit object pathpaths=find_pargs-- user sets a directory to put stuff inincase()of{_|not(nullobjs)->letobj=lastobjsin(obj,mk_hiobj)|not(nullpaths)->letobj=lastpaths</>mk_o(basenamesrc)in(obj,mk_hiobj)|otherwise->(mk_osrc,mk_hisrc)}whereoutpath="-o"outdir="-odir"mk_his=replaceSuffixshiSufmk_os=replaceSuffixsobjSuffind_o[]=[]find_o(f:f':fs)|f==outpath=[f']|otherwise=find_o$!f':fsfind_o_=[]find_p[]=[]find_p(f:f':fs)|f==outdir=[f']|otherwise=find_p$!f':fsfind_p_=[]---------------------------------------------------------------------------- | is file1 newer than file2?---- needs some fixing to work with 6.0.x series. (is this true?)---- fileExist still seems to throw exceptions on some platforms: ia64 in-- particular.---- invarient : we already assume the first file, 'a', exists--newer::FilePath->FilePath->IOBoolnewerab=doa_t<-getModificationTimeab_exists<-doesFileExistbifnotb_existsthenreturnTrue-- needs compilingelsedob_t<-getModificationTimebreturn(a_t>b_t)-- maybe need recompiling---------------------------------------------------------------------------- | return the Z-Encoding of the string.---- Stolen from GHC. Use -package ghc as soon as possible--typeEncodedString=Stringencode::String->EncodedStringencode[]=[]encode(c:cs)=encode_chc++encodecsunencodedChar::Char->Bool-- True for chars that don't need encodingunencodedChar'Z'=FalseunencodedChar'z'=FalseunencodedCharc=c>='a'&&c<='z'||c>='A'&&c<='Z'||c>='0'&&c<='9'---- Decode is used for user printing.--decode::EncodedString->Stringdecode[]=[]decode('Z':d:rest)|isDigitd=decode_tupledrest|otherwise=decode_upperd:decoderestdecode('z':d:rest)|isDigitd=decode_num_escdrest|otherwise=decode_lowerd:decoderestdecode(c:rest)=c:decoderestdecode_upper,decode_lower::Char->Chardecode_upper'L'='('decode_upper'R'=')'decode_upper'M'='['decode_upper'N'=']'decode_upper'C'=':'decode_upper'Z'='Z'decode_upperch=error$"decode_upper can't handle this char `"++[ch]++"'"decode_lower'z'='z'decode_lower'a'='&'decode_lower'b'='|'decode_lower'c'='^'decode_lower'd'='$'decode_lower'e'='='decode_lower'g'='>'decode_lower'h'='#'decode_lower'i'='.'decode_lower'l'='<'decode_lower'm'='-'decode_lower'n'='!'decode_lower'p'='+'decode_lower'q'='\''decode_lower'r'='\\'decode_lower's'='/'decode_lower't'='*'decode_lower'u'='_'decode_lower'v'='%'decode_lowerch=error$"decode_lower can't handle this char `"++[ch]++"'"-- Characters not having a specific code are coded as z224Udecode_num_esc::Char->[Char]->Stringdecode_num_escdcs=go(digitToIntd)cswheregon(c:rest)|isDigitc=go(10*n+digitToIntc)restgon('U':rest)=chrn:decoderestgo_other=error$"decode_num_esc can't handle this: \""++other++"\""encode_ch::Char->EncodedStringencode_chc|unencodedCharc=[c]-- Common case first-- Constructorsencode_ch'('="ZL"-- Needed for things like (,), and (->)encode_ch')'="ZR"-- For symmetry with (encode_ch'['="ZM"encode_ch']'="ZN"encode_ch':'="ZC"encode_ch'Z'="ZZ"-- Variablesencode_ch'z'="zz"encode_ch'&'="za"encode_ch'|'="zb"encode_ch'^'="zc"encode_ch'$'="zd"encode_ch'='="ze"encode_ch'>'="zg"encode_ch'#'="zh"encode_ch'.'="zi"encode_ch'<'="zl"encode_ch'-'="zm"encode_ch'!'="zn"encode_ch'+'="zp"encode_ch'\''="zq"encode_ch'\\'="zr"encode_ch'/'="zs"encode_ch'*'="zt"encode_ch'_'="zu"encode_ch'%'="zv"encode_chc='z':shows(ordc)"U"decode_tuple::Char->EncodedString->Stringdecode_tupledcs=go(digitToIntd)cswheregon(c:rest)|isDigitc=go(10*n+digitToIntc)restgo0['T']="()"gon['T']='(':replicate(n-1)','++")"go1['H']="(# #)"gon['H']='(':'#':replicate(n-1)','++"#)"go_other=error$"decode_tuple \'"++other++"'"-- ------------------------------------------------------------------------- 'isSublistOf' takes two arguments and returns 'True' iff the first-- list is a sublist of the second list. This means that the first list-- is wholly contained within the second list. Both lists must be-- finite.isSublistOf::Eqa=>[a]->[a]->BoolisSublistOf[]_=TrueisSublistOf_[]=FalseisSublistOfxy@(_:ys)|isPrefixOfxy=True|otherwise=isSublistOfxys