{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-}moduleDevelopment.Shake.Internal.FilePattern(-- * Primitive API, as exposedFilePattern ,(?== ),(<//> ),-- * General API, used by other people.filePattern ,-- * Optimisation opportunitiessimple ,(?==* ),-- * Multipattern file rulescompatible ,extract ,substitute ,-- * Accelerated searchingWalk (..),walk ,-- * Testing onlyinternalTest ,isRelativePath ,isRelativePattern )whereimportDevelopment.Shake.Internal.Errors importSystem.FilePath(isPathSeparator)importData.List.ExtraimportControl.MonadimportData.CharimportData.MaybeimportSystem.Info.Extra-- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax-- and semantics of 'FilePattern' see '?=='.---- Most 'normaliseEx'd 'FilePath' values are suitable as 'FilePattern' values which match-- only that specific file. On Windows @\\@ is treated as equivalent to @\/@.---- You can write 'FilePattern' values as a literal string, or build them-- up using the operators 'Development.Shake.FilePath.<.>', 'Development.Shake.FilePath.</>'-- and 'Development.Shake.<//>'. However, beware that:---- * On Windows, use 'Development.Shake.FilePath.<.>' from "Development.Shake.FilePath" instead of from-- "System.FilePath" - otherwise @\"\/\/*\" \<.\> exe@ results in @\"\/\/*\\\\.exe\"@.---- * If the second argument of 'Development.Shake.FilePath.</>' has a leading path separator (namely @\/@)-- then the second argument will be returned.typeFilePattern =Stringinfixr5<//> -- | Join two 'FilePattern' values by inserting two @\/@ characters between them.-- Will first remove any trailing path separators on the first argument, and any leading-- separators on the second.---- > "dir" <//> "*" == "dir//*"(<//>)::FilePattern ->FilePattern ->FilePattern a <//> b =dropWhileEndisPathSeparatora ++"//"++dropWhileisPathSeparatorb ----------------------------------------------------------------------- PATTERNSdataPat =Lit String-- ^ foo|Star -- ^ /*/|Skip -- ^ //|Skip1 -- ^ //, but must be at least 1 element|Stars String[String]String-- ^ *foo*, prefix (fixed), infix floaters, suffix-- e.g. *foo*bar = Stars "" ["foo"] "bar"deriving(Show,Eq,Ord)fromLit::Pat ->MaybeStringfromLit (Lit x )=Justx fromLit_=NothingdataLexeme =Str String|Slash |SlashSlash lexer::FilePattern ->[Lexeme ]lexer ""=[]lexer(x1 :x2 :xs )|isPathSeparatorx1 ,isPathSeparatorx2 =SlashSlash :lexer xs lexer(x1 :xs )|isPathSeparatorx1 =Slash :lexer xs lexerxs =Str a :lexer b where(a ,b )=breakisPathSeparatorxs -- | Parse a FilePattern. All optimisations I can think of are invalid because they change the extracted expressions.parse::FilePattern ->[Pat ]parse =f FalseTrue.lexer where-- str = I have ever seen a Str go past (equivalent to "can I be satisfied by no paths")-- slash = I am either at the start, or my previous character was Slashf str slash =\x ->casex of[]->[Lit ""|slash ]Str "**":xs ->Skip :f TrueFalsexs Str x :xs ->parseLit x :f TrueFalsexs SlashSlash :Slash :xs |notstr ->Skip1 :f str Truexs SlashSlash :xs ->Skip :f str Falsexs Slash :xs ->[Lit ""|notstr ]++f str Truexs parseLit::String->Pat parseLit "*"=Star parseLitx =casesplit(=='*')x of[x ]->Lit x pre :xs |Just(mid ,post )<-unsnocxs ->Stars pre mid post _->Lit ""internalTest::IO()internalTest =doletx # y =when(parse x /=y )$fail$show("FilePattern.internalTest",x ,parse x ,y )""# [Lit ""]"x"# [Lit "x"]"/"# [Lit "",Lit ""]"x/"# [Lit "x",Lit ""]"/x"# [Lit "",Lit "x"]"x/y"# [Lit "x",Lit "y"]"//"# [Skip ]"**"# [Skip ]"//x"# [Skip ,Lit "x"]"**/x"# [Skip ,Lit "x"]"x//"# [Lit "x",Skip ]"x/**"# [Lit "x",Skip ]"x//y"# [Lit "x",Skip ,Lit "y"]"x/**/y"# [Lit "x",Skip ,Lit "y"]"///"# [Skip1 ,Lit ""]"**/**"# [Skip ,Skip ]"**/**/"# [Skip ,Skip ,Lit ""]"///x"# [Skip1 ,Lit "x"]"**/x"# [Skip ,Lit "x"]"x///"# [Lit "x",Skip ,Lit ""]"x/**/"# [Lit "x",Skip ,Lit ""]"x///y"# [Lit "x",Skip ,Lit "y"]"x/**/y"# [Lit "x",Skip ,Lit "y"]"////"# [Skip ,Skip ]"**/**/**"# [Skip ,Skip ,Skip ]"////x"# [Skip ,Skip ,Lit "x"]"x////"# [Lit "x",Skip ,Skip ]"x////y"# [Lit "x",Skip ,Skip ,Lit "y"]"**//x"# [Skip ,Skip ,Lit "x"]-- | Optimisations that may change the matched expressionsoptimise::[Pat ]->[Pat ]optimise (Skip :Skip :xs )=optimise $Skip :xs optimise(Skip :Star :xs )=optimise $Skip1 :xs optimise(Star :Skip :xs )=optimise $Skip1 :xs optimise(x :xs )=x :optimise xs optimise[]=[]-- | A 'FilePattern' that will only match 'isRelativePath' values.isRelativePattern::FilePattern ->BoolisRelativePattern ('*':'*':xs )|[]<-xs =True|x :_<-xs ,isPathSeparatorx =TrueisRelativePattern_=False-- | A non-absolute 'FilePath'.isRelativePath::FilePath->BoolisRelativePath (x :_)|isPathSeparatorx =FalseisRelativePath(x :':':_)|isWindows,isAlphax =FalseisRelativePath_=True-- | Given a pattern, and a list of path components, return a list of all matches-- (for each wildcard in order, what the wildcard matched).match::[Pat ]->[String]->[[String]]match (Skip :xs )(y :ys )=map("":)(match xs (y :ys ))++match (Skip1 :xs )(y :ys )match(Skip1 :xs )(y :ys )=[(y ++"/"++r ):rs |r :rs <-match (Skip :xs )ys ]match(Skip :xs )[]=map("":)$match xs []match(Star :xs )(y :ys )=map(y :)$match xs ys match(Lit x :xs )(y :ys )=concat$[match xs ys |x ==y ]++[match xs (y :ys )|x =="."]match(x @Stars {}:xs )(y :ys )|Justrs <-matchStars x y =map(rs ++)$match xs ys match[][]=[[]]match__=[]matchOne::Pat ->String->BoolmatchOne (Lit x )y =x ==y matchOnex @Stars {}y =isJust$matchStars x y matchOneStar _=TruematchOnep _=throwImpure $errorInternal $"unreachablePattern, matchOne "++showp -- Only return the first (all patterns left-most) valid star matchingmatchStars::Pat ->String->Maybe[String]matchStars (Stars pre mid post )x =dox <-stripPrefixpre x x <-ifnullpost thenJustx elsestripSuffixpost x stripInfixes mid x wherestripInfixes []x =Just[x ]stripInfixes(m :ms )x =do(a ,x )<-stripInfixm x (a :)<$>stripInfixes ms x matchStarsp _=throwImpure $errorInternal $"unreachablePattern, matchStars "++showp -- | Match a 'FilePattern' against a 'FilePath', There are three special forms:---- * @*@ matches an entire path component, excluding any separators.---- * @\/\/@ matches an arbitrary number of path components, including absolute path-- prefixes.---- * @**@ as a path component matches an arbitrary number of path components, but not-- absolute path prefixes.-- Currently considered experimental.---- Some examples:---- * @test.c@ matches @test.c@ and nothing else.---- * @*.c@ matches all @.c@ files in the current directory, so @file.c@ matches,-- but @file.h@ and @dir\/file.c@ don't.---- * @\/\/*.c@ matches all @.c@ files anywhere on the filesystem,-- so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @\/path\/to\/file.c@ all match,-- but @file.h@ and @dir\/file.h@ don't.---- * @dir\/*\/*@ matches all files one level below @dir@, so @dir\/one\/file.c@ and-- @dir\/two\/file.h@ match, but @file.c@, @one\/dir\/file.c@, @dir\/file.h@-- and @dir\/one\/two\/file.c@ don't.---- Patterns with constructs such as @foo\/..\/bar@ will never match-- normalised 'FilePath' values, so are unlikely to be correct.(?==)::FilePattern ->FilePath->Bool(?== )p =caseoptimise $parse p of[x ]|x ==Skip ||x ==Skip1 ->ifrp thenisRelativePath elseconstTruep ->letf =not.null.match p .splitisPathSeparatorinifrp then(\x ->isRelativePath x &&f x )elsef whererp =isRelativePattern p (?==*)::[FilePattern ]->FilePath->Bool(?==* )ps =\x ->any($x )vs wherevs =map(?== )ps -- | Like '?==', but returns 'Nothing' on if there is no match, otherwise 'Just' with the list-- of fragments matching each wildcard. For example:---- @-- 'filePattern' \"**\/*.c\" \"test.txt\" == Nothing-- 'filePattern' \"**\/*.c\" \"foo.c\" == Just [\"",\"foo\"]-- 'filePattern' \"**\/*.c\" \"bar\/baz\/foo.c\" == Just [\"bar\/baz/\",\"foo\"]-- @---- Note that the @**@ will often contain a trailing @\/@, and even on Windows any-- @\\@ separators will be replaced by @\/@.filePattern::FilePattern ->FilePath->Maybe[String]filePattern p =\x ->ifeq x thenJust$ex x elseNothingwhereeq =(?== )p ex =extract p ----------------------------------------------------------------------- MULTIPATTERN COMPATIBLE SUBSTITUTIONSspecials::FilePattern ->[Pat ]specials =concatMapf .parse wheref Lit {}=[]fStar =[Star ]fSkip =[Skip ]fSkip1 =[Skip ]f(Stars _xs _)=replicate(lengthxs +1)Star -- | Is the pattern free from any * and //.simple::FilePattern ->Boolsimple =null.specials -- | Do they have the same * and // counts in the same ordercompatible::[FilePattern ]->Boolcompatible []=Truecompatible(x :xs )=all((==)(specials x ).specials )xs -- | Extract the items that match the wildcards. The pair must match with '?=='.extract::FilePattern ->FilePath->[String]extract p =letpat =parse p in\x ->casematch pat (splitisPathSeparatorx )of[]|p ?== x ->throwImpure $errorInternal $"extract with "++showp ++" and "++showx |otherwise->error$"Pattern "++showp ++" does not match "++x ++", when trying to extract the FilePattern matches"ms :_->ms -- | Given the result of 'extract', substitute it back in to a 'compatible' pattern.---- > p '?==' x ==> substitute (extract p x) p == xsubstitute::[String]->FilePattern ->FilePathsubstitute oms oxs =intercalate"/"$concat$snd$mapAccumLf oms (parse oxs )wheref ms (Lit x )=(ms ,[x ])f(m :ms )Star =(ms ,[m ])f(m :ms )Skip =(ms ,split m )f(m :ms )Skip1 =(ms ,split m )fms (Stars pre mid post )=(ms2 ,[concat$pre :zipWith(++)ms1 (mid ++[post ])])where(ms1 ,ms2 )=splitAt(lengthmid +1)ms f__=error$"Substitution failed into pattern "++showoxs ++" with "++show(lengthoms )++" matches, namely "++showoms split =linesBy(=='/')----------------------------------------------------------------------- EFFICIENT PATH WALKING-- | Given a list of files, return a list of things I can match in this directory-- plus a list of subdirectories and walks that apply to them.-- Use WalkTo when the list can be predicted in advancedataWalk =Walk ([String]->([String],[(String,Walk )]))|WalkTo ([String],[(String,Walk )])walk::[FilePattern ]->(Bool,Walk )walk ps =(any(\p ->isEmpty p ||not(null$match p [""]))ps2 ,f ps2 )whereps2 =map(filter(/=Lit ".").optimise .parse )ps f (nubOrd->ps )|Justfin <-mapMfromLit fin ,Justnxt <-mapM(\(a ,b )->(,f b )<$>fromLit a )nxt =WalkTo (fin ,nxt )|otherwise=Walk $\xs ->(iffinStar thenxs elsefilter(\x ->any(`matchOne `x )fin )xs ,[(x ,f ys )|x <-xs ,letys =concat[b |(a ,b )<-nxt ,matchOne a x ],not$nullys ])wherefinStar =Star `elem`fin fin =nubOrd$mapMaybefinal ps nxt =groupSort$concatMapnext ps next::[Pat ]->[(Pat ,[Pat ])]next (Skip1 :xs )=[(Star ,Skip :xs )]next(Skip :xs )=(Star ,Skip :xs ):next xs next(x :xs )=[(x ,xs )|not$nullxs ]next[]=[]final::[Pat ]->MaybePat final (Skip :xs )=ifisEmpty xs thenJustStar elsefinal xs final(Skip1 :xs )=ifisEmpty xs thenJustStar elseNothingfinal(x :xs )=ifisEmpty xs thenJustx elseNothingfinal[]=NothingisEmpty =all(==Skip )