diff --git a/Nemesis b/Nemesis --- a/Nemesis +++ b/Nemesis @@ -12,6 +12,7 @@ , "manifest" , "main" , "nemesis-tmp.*" + , "dist" ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +2013.6.16 +--------- + +* add Glob dependency +* remove binary version as it's not 'simple' + + 2009.10.7 --------- diff --git a/nemesis.cabal b/nemesis.cabal --- a/nemesis.cabal +++ b/nemesis.cabal @@ -1,25 +1,41 @@ Name: nemesis -Version: 2013.6.13 +Version: 2013.6.16 Build-type: Simple -Synopsis: a Rake like task management tool -Description: smart per project code snippets +Synopsis: a task management tool for Haskell +Description: Organize common shell tasks into a meaningful tree like structure with dependency tracking License: BSD3 License-file: LICENSE Author: Jinjing Wang Maintainer: Jinjing Wang Build-Depends: base -Cabal-version: >= 1.2 +Cabal-version: >= 1.6 category: Web homepage: http://github.com/nfjinjing/nemesis -data-files: readme.md, changelog.md, known-issues.md, Nemesis +data-files: readme.md + , changelog.md + , known-issues.md + , Nemesis + , test/N1.hs + , test/N2.hs + , test/N3.hs + +source-repository head + type: git + location: https://github.com/nfjinjing/nemesis.git + library ghc-options: -Wall - build-depends: base >= 4 && < 100, old-time, time, mtl, process, containers, air >= 2011.6.19 - , dlist - , filepath - , transformers + build-depends: base >= 4 && < 100 + , time + , mtl + , process + , containers + , air + , dlist + , Glob + , directory hs-source-dirs: src/ exposed-modules: @@ -29,20 +45,5 @@ other-modules: System.Nemesis.Util - System.FilePath.Glob - System.FilePath.Glob.Primitive - System.FilePath.Glob.Base - System.FilePath.Glob.Directory - System.FilePath.Glob.Match - System.FilePath.Glob.Simplify - System.FilePath.Glob.Utils - + -Executable nemesis - build-depends: base >= 4 && < 100, mtl, process, containers, data-default, directory, air >= 2011.6.19 - - hs-source-dirs: src/ - main-is: System/Nemesis/Runner.hs - other-modules: System.Nemesis.Util - System.Nemesis.DSL - diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -1,25 +1,27 @@ -Nemesis: a rake like task management tool for haskell +Nemesis: a task management tool for Haskell ===================================================== Demo ---- - nemesis = do + import System.Nemesis.Env + main = run $ do + clean [ "**/*.hi" , "**/*.o" , "manifest" ] - - task "dist" - do + + task "dist" $ do sh "cabal clean" sh "cabal configure" sh "cabal sdist" task "i" (sh "ghci -isrc src/System/Nemesis.hs") - task "manifest" - do + task "manifest" $ do sh "find . | grep 'hs$' > manifest" Tutorial @@ -32,14 +34,17 @@ ### DSL -Put the following code into a file named `Nemesis` +Create a file named `Nemesis` - nemesis = do + import System.Nemesis.Env + import Air.Env ((-)) + import Prelude hiding ((-)) - -- desc is optional, it gives some description to the task that follows + main = run - do + + -- desc is optional, it gives some description to the task + -- task syntax: task "keyword: space seperated dependencies" io-action desc "Hunter attack macro" - - -- syntax: task "keyword: dependencies" io-action task "attack: pet-attack auto-attack" (putStrLn "attack macro done!") desc "Pet attack" @@ -56,14 +61,14 @@ ### Run -run `nemesis` +`runghc Nemesis` attack Hunter attack macro auto-attack Auto attack mark Hunter's mark pet-attack Pet attack -run `nemesis attack` +`runghc Nemesis attack` casting hunter's mark pet attack @@ -73,73 +78,39 @@ ### Namespace -Suppose you have the following tasks +Create namespaces for tasks with the keyword `namespace` - nemesis = do + import System.Nemesis.Env + import Air.Env ((-)) + import Prelude hiding ((-)) + + main = run - do namespace "eat" - do task "bread: salad" - putStrLn "eating bread" - task "salad: /drink/coke" - putStrLn "nice salad" + task "salad: /drink/coke" - putStrLn "eating salad" namespace "drink" - do task "coke" - putStrLn "drinking coke" -then +Namespaces are referenced as path components. - nemesis bread => - .nemesis: bread does not exist! +`runghc Nemesis bread` + + Nemesis: bread does not exist! - nemesis eat/bread => +`runghc Nemesis eat/bread` + drinking coke - nice salad + eating salad eating bread + Hints ----- -* Please add `.nemesis` to `.gitignore` or equivalents. -* alias `nemesis` to something sweeter, e.g. `n` - -Advance usage -------------- - -### Use LANGUAGE pragma - -Put a `-- Nem` line after the `Langauge` pragma - - {-# LANGUAGE QuasiQuotes #-} - - -- Nem - - nemesis = do - task "i" (sh "ghci -isrc src/System/Nemesis.hs") - -currently the separator `-- Nem` is hard coded - -### Bypass preprocessing, i.e. run as EDSL - -Define `main`, i.e. add `main = run nemesis` in the code. The preprocessor looks for the function `main`, if it's defined, preprocessing is skipped. - -This turns `Nemesis` into an EDSL in Haskell, runnable by `runghc`. - -For example: - - import System.Nemesis.Env - import Air.Env ((-)) - import Prelude hiding ((-)) - - main = run nemesis - - nemesis = do - task "hello" - do - sh "echo 'hello world'" - - -Try: - - runghc Nemesis hello - +* alias `runghc Nemesis` to something sweeter, e.g. `n` diff --git a/src/System/FilePath/Glob.hs b/src/System/FilePath/Glob.hs deleted file mode 100644 --- a/src/System/FilePath/Glob.hs +++ /dev/null @@ -1,74 +0,0 @@ --- File created: 2008-10-10 13:37:42 - --- | A library for globbing: matching patterns against file paths akin to the --- POSIX @glob()@ function. --- --- Pattern syntax is documented by 'compile'. To toggle features at compile --- time, look into 'CompOptions'. To modify matching behaviour, look into --- 'MatchOptions'. --- --- Basic usage examples: --- --- Matching a 'String' pattern against a 'FilePath': --- --- @ --- 'match' ('compile' pattern) filepath --- @ --- --- Matching a 'String' pattern against all paths in the current working --- directory: --- --- @ --- 'glob' pattern --- @ --- --- Matching a 'String' pattern against all paths in a given directory (a --- 'FilePath'): --- --- @ --- 'globDir1' ('compile' pattern) directorypath --- @ --- --- Matching a list of 'String' patterns against all paths in a given directory, --- returning the matches for each pattern as well as the paths not matched by --- any of the patterns: --- --- @ --- 'globDir' (map 'compile' patterns) directorypath --- @ -module System.FilePath.Glob - ( -- * Data type - Pattern - -- * Functions - -- ** Compilation - , compile, decompile, simplify - -- *** Options - , CompOptions(..) - , compileWith, tryCompileWith - -- **** Predefined option sets - , compDefault, compPosix - -- ** Matching - , match - , globDir, globDir1, glob - -- *** Options - , MatchOptions(..) - , matchWith - , globDirWith - -- **** Predefined option sets - , matchDefault, matchPosix - -- ** Miscellaneous - , commonDirectory - ) where - -import System.FilePath.Glob.Base ( Pattern - , CompOptions(..), MatchOptions(..) - , compDefault, compPosix - , matchDefault, matchPosix - , compile, compileWith, tryCompileWith - , decompile - ) -import System.FilePath.Glob.Directory ( globDir, globDirWith, globDir1, glob - , commonDirectory - ) -import System.FilePath.Glob.Match (match, matchWith) -import System.FilePath.Glob.Simplify (simplify) diff --git a/src/System/FilePath/Glob/Base.hs b/src/System/FilePath/Glob/Base.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Base.hs +++ /dev/null @@ -1,629 +0,0 @@ --- File created: 2008-10-10 13:29:26 - -{-# LANGUAGE CPP #-} - -module System.FilePath.Glob.Base - ( Token(..), Pattern(..) - - , CompOptions(..), MatchOptions(..) - , compDefault, compPosix, matchDefault, matchPosix - - , decompile - - , compile - , compileWith, tryCompileWith - , tokenize -- for tests - - , optimize - - , liftP, tokToLower - ) where - -import Control.Arrow (first) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT, runErrorT, throwError) -import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell) -import Control.Exception (assert) -import Data.Char (isDigit, isAlpha, toLower) -import Data.List (find, sortBy) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid, mappend, mempty, mconcat) -import System.FilePath ( pathSeparator, extSeparator - , isExtSeparator, isPathSeparator - ) - -import System.FilePath.Glob.Utils ( dropLeadingZeroes - , isLeft, fromLeft - , increasingSeq - , addToRange, overlap - ) - -#if __GLASGOW_HASKELL__ -import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) -#endif - -data Token - -- primitives - = Literal !Char - | ExtSeparator -- . - | PathSeparator -- / - | NonPathSeparator -- ? - | CharRange !Bool [Either Char (Char,Char)] -- [] - | OpenRange (Maybe String) (Maybe String) -- <> - | AnyNonPathSeparator -- * - | AnyDirectory -- **/ - - -- after optimization only - | LongLiteral !Int String - deriving (Eq) - --- Note: CharRanges aren't converted, because this is tricky in general. --- Consider for instance [@-[], which includes the range A-Z. This would need --- to become [@[a-z]: so essentially we'd need to either: --- --- 1) Have a list of ranges of uppercase Unicode. Check if our range --- overlaps with any of them and if it does, take the non-overlapping --- part and combine it with the toLower of the overlapping part. --- --- 2) Simply expand the entire range to a list and map toLower over it. --- --- In either case we'd need to re-optimize the CharRange—we can't assume that --- if the uppercase characters are consecutive, so are the lowercase. --- --- 1) might be feasible if someone bothered to get the latest data. --- --- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in --- there somewhere. --- --- The current solution is to just check both the toUpper of the character and --- the toLower. -tokToLower :: Token -> Token -tokToLower (Literal c) = Literal (toLower c) -tokToLower (LongLiteral n s) = LongLiteral n (map toLower s) -tokToLower tok = tok - --- |An abstract data type representing a compiled pattern. --- --- Note that the 'Eq' instance cannot tell you whether two patterns behave in --- the same way; only whether they compile to the same 'Pattern'. For instance, --- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal, --- though a @'match'@ will behave the exact same way no matter which 'Pattern' --- is used. -newtype Pattern = Pattern { unPattern :: [Token] } deriving (Eq) - -liftP :: ([Token] -> [Token]) -> Pattern -> Pattern -liftP f (Pattern pat) = Pattern (f pat) - -instance Show Token where - show (Literal c) - | c `elem` "*?[<" || isExtSeparator c - = ['[',c,']'] - | otherwise = assert (not $ isPathSeparator c) [c] - show ExtSeparator = [ extSeparator] - show PathSeparator = [pathSeparator] - show NonPathSeparator = "?" - show AnyNonPathSeparator = "*" - show AnyDirectory = "**/" - show (LongLiteral _ s) = concatMap (show . Literal) s - show (OpenRange a b) = - '<' : fromMaybe "" a ++ "-" ++ - fromMaybe "" b ++ ">" - - -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we - -- just put them at the end. - -- - -- Also, [^x-] was sorted and should not become [^-x]. - show (CharRange b r) = - let f = either (:[]) (\(x,y) -> [x,'-',y]) - (caret,exclamation,fs) = - foldr (\c (ca,ex,ss) -> - case c of - Left '^' -> ("^",ex,ss) - Left '!' -> (ca,"!",ss) - _ -> (ca, ex,(f c ++) . ss) - ) - ("", "", id) - r - (beg,rest) = let s' = fs [] - (x,y) = splitAt 1 s' - in if not b && x == "-" - then (y,x) - else (s',"") - in concat [ "[" - , if b then "" else "^" - , beg, caret, exclamation, rest - , "]" - ] - -instance Show Pattern where - showsPrec d p = showParen (d > 10) $ - showString "compile " . showsPrec (d+1) (decompile p) - -instance Read Pattern where -#if __GLASGOW_HASKELL__ - readPrec = parens . prec 10 $ do - Ident "compile" <- lexP - fmap compile readPrec -#else - readsPrec d = readParen (d > 10) $ \r -> do - ("compile",string) <- lex r - (xs,rest) <- readsPrec (d+1) string - [(compile xs, rest)] -#endif - -instance Monoid Pattern where - mempty = Pattern [] - mappend (Pattern a) (Pattern b) = optimize . Pattern $ (a ++ b) - mconcat = optimize . Pattern . concatMap unPattern - --- |Options which can be passed to the 'tryCompileWith' or 'compileWith' --- functions: with these you can selectively toggle certain features at compile --- time. --- --- Note that some of these options depend on each other: classes can never --- occur if ranges aren't allowed, for instance. - --- We could presumably put locale information in here, too. -data CompOptions = CompOptions - { characterClasses :: Bool -- ^Allow character classes, @[[:...:]]@. - , characterRanges :: Bool -- ^Allow character ranges, @[...]@. - , numberRanges :: Bool -- ^Allow open ranges, @\<...>@. - , wildcards :: Bool -- ^Allow wildcards, @*@ and @?@. - , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@. - - , pathSepInRanges :: Bool - -- ^Allow path separators in character ranges. - -- - -- If true, @a[/]b@ never matches anything (since character ranges can't - -- match path separators); if false and 'errorRecovery' is enabled, - -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory - -- @a[@. - - , errorRecovery :: Bool - -- ^If the input is invalid, recover by turning any invalid part into - -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an - -- error by default (unclosed character range); with 'errorRecovery', the - -- @[@ is turned into a literal match, as though 'characterRanges' were - -- disabled. - } deriving (Show,Read,Eq) - --- |The default set of compilation options: closest to the behaviour of the --- @zsh@ shell, with 'errorRecovery' enabled. --- --- All options are enabled. -compDefault :: CompOptions -compDefault = CompOptions - { characterClasses = True - , characterRanges = True - , numberRanges = True - , wildcards = True - , recursiveWildcards = True - , pathSepInRanges = True - , errorRecovery = True - } - --- |Options for POSIX-compliance, as described in @man 7 glob@. --- --- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled. -compPosix :: CompOptions -compPosix = CompOptions - { characterClasses = True - , characterRanges = True - , numberRanges = False - , wildcards = True - , recursiveWildcards = False - , pathSepInRanges = False - , errorRecovery = True - } - --- |Options which can be passed to the 'matchWith' or 'globDirWith' functions: --- with these you can selectively toggle certain features at matching time. -data MatchOptions = MatchOptions - { matchDotsImplicitly :: Bool - -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths. - - , ignoreCase :: Bool - -- ^Case-independent matching. - - , ignoreDotSlash :: Bool - -- ^Treat @./@ as a no-op in both paths and patterns. - -- - -- (Of course e.g. @../@ means something different and will not be - -- ignored.) - } - --- |The default set of execution options: closest to the behaviour of the @zsh@ --- shell. --- --- Currently identical to 'matchPosix'. -matchDefault :: MatchOptions -matchDefault = matchPosix - --- |Options for POSIX-compliance, as described in @man 7 glob@. --- --- 'ignoreDotSlash' is enabled, the rest are disabled. -matchPosix :: MatchOptions -matchPosix = MatchOptions - { matchDotsImplicitly = False - , ignoreCase = False - , ignoreDotSlash = True - } - --- |Decompiles a 'Pattern' object into its textual representation: essentially --- the inverse of 'compile'. --- --- Note, however, that due to internal optimization, @decompile . compile@ is --- not the identity function. Instead, @compile . decompile@ is. --- --- Be careful with 'CompOptions': 'decompile' always produces a 'String' which --- can be passed to 'compile' to get back the same 'Pattern'. @compileWith --- options . decompile@ is /not/ the identity function unless @options@ is --- 'compDefault'. -decompile :: Pattern -> String -decompile = concatMap show . unPattern - ------------------------------------------- --- COMPILATION ------------------------------------------- - - --- |Compiles a glob pattern from its textual representation into a 'Pattern' --- object. --- --- For the most part, a character matches itself. Recognized operators are as --- follows: --- --- [@?@] Matches any character except path separators. --- --- [@*@] Matches any number of characters except path separators, --- including the empty string. --- --- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can --- be specified by separating the endpoints with a @\'-'@. @\'-'@ or --- @']'@ can be matched by including them as the first character(s) --- in the list. Never matches path separators: @[\/]@ matches --- nothing at all. Named character classes can also be matched: --- @[:x:]@ within @[]@ specifies the class named @x@, which matches --- certain predefined characters. See below for a full list. --- --- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed. --- Note that @[^-x]@ is not the inverse of @[-x]@, but --- the range @[^-x]@. --- --- [@\@] Matches any integer in the range m to n, inclusive. The range may --- be open-ended by leaving out either number: @\"\<->\"@, for --- instance, matches any integer. --- --- [@**/@] Matches any number of characters, including path separators, --- excluding the empty string. --- --- Supported character classes: --- --- [@[:alnum:\]@] Equivalent to @\"0-9A-Za-z\"@. --- --- [@[:alpha:\]@] Equivalent to @\"A-Za-z\"@. --- --- [@[:blank:\]@] Equivalent to @\"\\t \"@. --- --- [@[:cntrl:\]@] Equivalent to @\"\\0-\\x1f\\x7f\"@. --- --- [@[:digit:\]@] Equivalent to @\"0-9\"@. --- --- [@[:graph:\]@] Equivalent to @\"!-~\"@. --- --- [@[:lower:\]@] Equivalent to @\"a-z\"@. --- --- [@[:print:\]@] Equivalent to @\" -~\"@. --- --- [@[:punct:\]@] Equivalent to @\"!-\/:-\@[-`{-~\"@. --- --- [@[:space:\]@] Equivalent to @\"\\t-\\r \"@. --- --- [@[:upper:\]@] Equivalent to @\"A-Z\"@. --- --- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@. --- --- Note that path separators (typically @\'/\'@) have to be matched explicitly --- or using the @**/@ pattern. In addition, extension separators (typically --- @\'.\'@) have to be matched explicitly at the beginning of the pattern or --- after any path separator. --- --- If a system supports multiple path separators, any one of them will match --- any of them. For instance, on Windows, @\'/\'@ will match itself as well as --- @\'\\\'@. --- --- Error recovery will be performed: erroneous operators will not be considered --- operators, but matched as literal strings. Such operators include: --- --- * An empty @[]@ or @[^]@ or @[!]@ --- --- * A @[@ or @\<@ without a matching @]@ or @>@ --- --- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen --- --- So, e.g. @[]@ will match the string @\"[]\"@. -compile :: String -> Pattern -compile = compileWith compDefault - --- |Like 'compile', but recognizes operators according to the given --- 'CompOptions' instead of the defaults. --- --- If an error occurs and 'errorRecovery' is disabled, 'error' will be called. -compileWith :: CompOptions -> String -> Pattern -compileWith opts = either error id . tryCompileWith opts - --- |A safe version of 'compileWith'. --- --- If an error occurs and 'errorRecovery' is disabled, the error message will --- be returned in a 'Left'. -tryCompileWith :: CompOptions -> String -> Either String Pattern -tryCompileWith opts = fmap optimize . tokenize opts - -tokenize :: CompOptions -> String -> Either String Pattern -tokenize opts = fmap Pattern . sequence . go - where - err _ c cs | errorRecovery opts = Right (Literal c) : go cs - err s _ _ = [Left s] - - go :: String -> [Either String Token] - go [] = [] - go ('?':cs) | wcs = Right NonPathSeparator : go cs - go ('*':cs) | wcs = - case cs of - '*':p:xs | rwcs && isPathSeparator p - -> Right AnyDirectory : go xs - _ -> Right AnyNonPathSeparator : go cs - - go ('[':cs) | crs = let (range,rest) = charRange opts cs - in case range of - Left s -> err s '[' cs - r -> r : go rest - - go ('<':cs) | ors = - let (range, rest) = break (=='>') cs - in if null rest - then err "compile :: unclosed <> in pattern" '<' cs - else case openRange range of - Left s -> err s '<' cs - r -> r : go (tail rest) - go (c:cs) - | isPathSeparator c = Right PathSeparator : go cs - | isExtSeparator c = Right ExtSeparator : go cs - | otherwise = Right (Literal c) : go cs - - wcs = wildcards opts - rwcs = recursiveWildcards opts - crs = characterRanges opts - ors = numberRanges opts - --- where a > b can never match anything; this is not considered an error -openRange :: String -> Either String Token -openRange ['-'] = Right $ OpenRange Nothing Nothing -openRange ('-':s) = - case span isDigit s of - (b,"") -> Right $ OpenRange Nothing (openRangeNum b) - _ -> Left $ "compile :: bad <>, expected number, got " ++ s -openRange s = - case span isDigit s of - (a,"-") -> Right $ OpenRange (openRangeNum a) Nothing - (a,'-':s') -> - case span isDigit s' of - (b,"") -> Right $ OpenRange (openRangeNum a) (openRangeNum b) - _ -> Left $ "compile :: bad <>, expected number, got " ++ s' - _ -> Left $ "compile :: bad <>, expected number followed by - in " ++ s - -openRangeNum :: String -> Maybe String -openRangeNum = Just . dropLeadingZeroes - -type CharRange = [Either Char (Char,Char)] - -charRange :: CompOptions -> String -> (Either String Token, String) -charRange opts zs = - case zs of - y:ys | y `elem` "^!" -> - case ys of - -- [!-#] is not the inverse of [-#], it is the range ! through - -- # - '-':']':xs -> (Right (CharRange False [Left '-']), xs) - '-' :_ -> first (fmap (CharRange True )) (start zs) - xs -> first (fmap (CharRange False)) (start xs) - _ -> first (fmap (CharRange True )) (start zs) - where - start :: String -> (Either String CharRange, String) - start (']':xs) = run $ char ']' xs - start ('-':xs) = run $ char '-' xs - start xs = run $ go xs - - run :: ErrorT String (Writer CharRange) String - -> (Either String CharRange, String) - run m = case runWriter.runErrorT $ m of - (Left err, _) -> (Left err, []) - (Right rest, cs) -> (Right cs, rest) - - go :: String -> ErrorT String (Writer CharRange) String - go ('[':':':xs) | characterClasses opts = readClass xs - go ( ']':xs) = return xs - go ( c:xs) = - if not (pathSepInRanges opts) && isPathSeparator c - then throwError "compile :: path separator within []" - else char c xs - go [] = throwError "compile :: unclosed [] in pattern" - - char :: Char -> String -> ErrorT String (Writer CharRange) String - char c ('-':x:xs) = - if x == ']' - then ltell [Left c, Left '-'] >> return xs - else ltell [Right (c,x)] >> go xs - - char c xs = ltell [Left c] >> go xs - - readClass :: String -> ErrorT String (Writer CharRange) String - readClass xs = let (name,end) = span isAlpha xs - in case end of - ':':']':rest -> charClass name >> go rest - _ -> ltell [Left '[',Left ':'] >> go xs - - charClass :: String -> ErrorT String (Writer CharRange) () - charClass name = - -- The POSIX classes - -- - -- TODO: this is ASCII-only, not sure how this should be extended - -- Unicode, or with a locale as input, or something else? - case name of - "alnum" -> ltell [digit,upper,lower] - "alpha" -> ltell [upper,lower] - "blank" -> ltell blanks - "cntrl" -> ltell [Right ('\0','\x1f'), Left '\x7f'] - "digit" -> ltell [digit] - "graph" -> ltell [Right ('!','~')] - "lower" -> ltell [lower] - "print" -> ltell [Right (' ','~')] - "punct" -> ltell punct - "space" -> ltell spaces - "upper" -> ltell [upper] - "xdigit" -> ltell [digit, Right ('A','F'), Right ('a','f')] - _ -> - throwError ("compile :: unknown character class '" ++name++ "'") - - digit = Right ('0','9') - upper = Right ('A','Z') - lower = Right ('a','z') - punct = map Right [('!','/'), (':','@'), ('[','`'), ('{','~')] - blanks = [Left '\t', Left ' '] - spaces = [Right ('\t','\r'), Left ' '] - - ltell = lift . tell - - ------------------------------------------- --- OPTIMIZATION ------------------------------------------- - - -optimize :: Pattern -> Pattern -optimize = liftP (fin . go) - where - fin [] = [] - - -- Literals to LongLiteral - -- Has to be done here: we can't backtrack in go, but some cases might - -- result in consecutive Literals being generated. - -- E.g. "a[b]". - fin (x:y:xs) | isLiteral x && isLiteral y = - let (ls,rest) = span isLiteral xs - in fin $ LongLiteral (length ls + 2) - (foldr (\(Literal a) -> (a:)) [] (x:y:ls)) - : rest - - -- concatenate LongLiterals - -- Has to be done here because LongLiterals are generated above. - -- - -- So one could say that we have one pass (go) which flattens everything as - -- much as it can and one pass (fin) which concatenates what it can. - fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) = - fin $ LongLiteral (l1+l2) (s1++s2) : xs - - fin (LongLiteral l s : Literal c : xs) = - fin $ LongLiteral (l+1) (s++[c]) : xs - - fin (LongLiteral 1 s : xs) = Literal (head s) : fin xs - - fin (Literal c : LongLiteral l s : xs) = - fin $ LongLiteral (l+1) (c:s) : xs - - fin (x:xs) = x : fin xs - - go [] = [] - go (x@(CharRange _ _) : xs) = - case optimizeCharRange x of - x'@(CharRange _ _) -> x' : go xs - x' -> go (x':xs) - - -- -> a - go (OpenRange (Just a) (Just b):xs) - | a == b = LongLiteral (length a) a : go xs - - -- -> [a-b] - -- a and b are guaranteed non-null - go (OpenRange (Just [a]) (Just [b]):xs) - | b > a = go $ CharRange True [Right (a,b)] : xs - - go (x:xs) = - case find ($ x) compressors of - Just c -> let (compressed,ys) = span c xs - in if null compressed - then x : go ys - else go (x : ys) - Nothing -> x : go xs - - compressors = [isStar, isStarSlash, isAnyNumber] - - isLiteral (Literal _) = True - isLiteral _ = False - isStar AnyNonPathSeparator = True - isStar _ = False - isStarSlash AnyDirectory = True - isStarSlash _ = False - isAnyNumber (OpenRange Nothing Nothing) = True - isAnyNumber _ = False - -optimizeCharRange :: Token -> Token -optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs - where - -- [/] is interesting, it actually matches nothing at all - -- [.] can be Literalized though, just don't make it into an ExtSeparator so - -- that it doesn't match a leading dot - fin True [Left c] | not (isPathSeparator c) = Literal c - fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator - fin b x = CharRange b x - - go [] = [] - - go (x@(Left c) : xs) = - case xs of - [] -> [x] - y@(Left d) : ys - -- [aaaaa] -> [a] - | c == d -> go$ Left c : ys - | d == succ c -> - let (ls,rest) = span isLeft xs -- start from y - (catable,others) = increasingSeq (map fromLeft ls) - range = (c, head catable) - - in -- three (or more) Lefts make a Right - if null catable || null (tail catable) - then x : y : go ys - -- [abcd] -> [a-d] - else go$ Right range : map Left others ++ rest - - | otherwise -> x : go xs - - Right r : ys -> - case addToRange r c of - -- [da-c] -> [a-d] - Just r' -> go$ Right r' : ys - Nothing -> x : go xs - - go (x@(Right r) : xs) = - case xs of - [] -> [x] - Left c : ys -> - case addToRange r c of - -- [a-cd] -> [a-d] - Just r' -> go$ Right r' : ys - Nothing -> x : go xs - - Right r' : ys -> - case overlap r r' of - -- [a-cb-d] -> [a-d] - Just o -> go$ Right o : ys - Nothing -> x : go xs -optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error" - -sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] -sortCharRange = sortBy cmp - where - cmp (Left a) (Left b) = compare a b - cmp (Left a) (Right (b,_)) = compare a b - cmp (Right (a,_)) (Left b) = compare a b - cmp (Right (a,_)) (Right (b,_)) = compare a b diff --git a/src/System/FilePath/Glob/Directory.hs b/src/System/FilePath/Glob/Directory.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Directory.hs +++ /dev/null @@ -1,299 +0,0 @@ --- File created: 2008-10-16 12:12:50 - -module System.FilePath.Glob.Directory - ( globDir, globDirWith, globDir1, glob - , commonDirectory - ) where - -import Control.Arrow (first, second) -import Control.Monad (forM) -import qualified Data.DList as DL -import Data.DList (DList) -import Data.List ((\\)) -import System.Directory ( doesDirectoryExist, getDirectoryContents - , getCurrentDirectory - ) -import System.FilePath ( (), takeDrive, splitDrive - , extSeparator, isExtSeparator - , pathSeparator, isPathSeparator - ) - -import System.FilePath.Glob.Base ( Pattern(..), Token(..) - , MatchOptions, matchDefault - , compile - ) -import System.FilePath.Glob.Match (matchWith) -import System.FilePath.Glob.Utils ( getRecursiveContents - , nubOrd - , pathParts - , partitionDL - ) - -import System.IO.Error (catchIOError) - --- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory --- --- We store the number of PathSeparators that Dir and AnyDir were followed by --- so that "foo////*" can match "foo/bar" but return "foo////bar". It's the --- exact number for convenience: () doesn't add a path separator if one is --- already there. This way, '\(Dir n _) -> replicate n pathSeparator "bar"' --- results in the correct amount of slashes. -data TypedPattern - = Any Pattern -- pattern - | Dir Int Pattern -- pattern/ - | AnyDir Int Pattern -- pattern**/ - deriving Show - --- |Matches each given 'Pattern' against the contents of the given 'FilePath', --- recursively. The result pair\'s first component contains the matched paths, --- grouped for each given 'Pattern', and the second contains all paths which --- were not matched by any 'Pattern'. The results are not in any defined order. --- --- The given directory is prepended to all the matches: the returned paths are --- all valid from the point of view of the current working directory. --- --- If multiple 'Pattern's match a single 'FilePath', that path will be included --- in multiple groups. --- --- Two 'FilePath's which can be canonicalized to the same file (e.g. @\"foo\"@ --- and @\"./foo\"@) may appear separately if explicit matching on paths --- beginning with @\".\"@ is done. Looking for @\".*/*\"@, for instance, will --- cause @\"./foo\"@ to return as a match but @\"foo\"@ to not be matched. --- --- This function is different from a simple 'filter' over all the contents of --- the directory: the matching is performed relative to the directory, so that --- for instance the following is true: --- --- > fmap (head.fst) (globDir [compile "*"] dir) == getDirectoryContents dir --- --- (With the exception that that glob won't match anything beginning with @.@.) --- --- If the given 'FilePath' is @[]@, 'getCurrentDirectory' will be used. --- --- If the given 'Pattern' starts with a drive (as defined by --- 'System.FilePath'), it is not relative to the given directory and the --- 'FilePath' parameter is completely ignored! Similarly, if the given --- 'Pattern' starts with a path separator, only the drive part of the --- 'FilePath' is used. On Posix systems these behaviours are equivalent: --- 'Pattern's starting with @\/@ work relative to @\/@. On Windows, 'Pattern's --- starting with @\/@ or @\\@ work relative only to the drive part of the --- 'FilePath' and 'Pattern's starting with absolute paths ignore the --- 'FilePath'. --- --- Note that in some cases results outside the given directory may be returned: --- for instance the @.*@ pattern matches the @..@ directory. --- --- Any results deeper than in the given directory are enumerated lazily, using --- 'unsafeInterleaveIO'. --- --- Directories without read permissions are returned as entries but their --- contents, of course, are not. -globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) -globDir = globDirWith matchDefault - --- |Like 'globDir', but applies the given 'MatchOptions' instead of the --- defaults when matching. -globDirWith :: MatchOptions -> [Pattern] -> FilePath - -> IO ([[FilePath]], [FilePath]) -globDirWith _ [] dir = do - dir' <- if null dir then getCurrentDirectory else return dir - c <- getRecursiveContents dir' - return ([], DL.toList c) - -globDirWith opts pats@(_:_) dir = do - results <- mapM (\p -> globDir'0 opts p dir) pats - - let (matches, others) = unzip results - allMatches = DL.toList . DL.concat $ matches - allOthers = DL.toList . DL.concat $ others - - return ( map DL.toList matches - , nubOrd allOthers \\ allMatches - ) - --- |A convenience wrapper on top of 'globDir', for when you only have one --- 'Pattern' you care about. Returns only the matched paths. -globDir1 :: Pattern -> FilePath -> IO [FilePath] -globDir1 p = fmap (head . fst) . globDir [p] - --- |The simplest IO function. Finds matches to the given pattern in the current --- working directory. Takes a 'String' instead of a 'Pattern' to avoid the need --- for a call to 'compile', simplifying usage further. --- --- Can also be seen as a convenience wrapper on top of 'globDir1', for when you --- want to work in the current directory or have a pattern referring to an --- absolute path. -glob :: String -> IO [FilePath] -glob = flip globDir1 "" . compile - -globDir'0 :: MatchOptions -> Pattern -> FilePath - -> IO (DList FilePath, DList FilePath) -globDir'0 opts pat dir = do - let (pat', drive) = driveSplit pat - dir' <- case drive of - Just "" -> fmap takeDrive getCurrentDirectory - Just d -> return d - Nothing -> if null dir then getCurrentDirectory else return dir - globDir' opts (separate pat') dir' - -globDir' :: MatchOptions -> [TypedPattern] -> FilePath - -> IO (DList FilePath, DList FilePath) -globDir' opts pats@(_:_) dir = do - entries <- getDirectoryContents dir `catchIOError` const (return []) - - results <- forM entries $ \e -> matchTypedAndGo opts pats e (dir e) - - let (matches, others) = unzip results - - return (DL.concat matches, DL.concat others) - -globDir' _ [] dir = - -- We can only get here from matchTypedAndGo getting a [Dir _]: it means the - -- original pattern had a trailing PathSeparator. Reproduce it here. - return (DL.singleton (dir ++ [pathSeparator]), DL.empty) - -matchTypedAndGo :: MatchOptions - -> [TypedPattern] - -> FilePath -> FilePath - -> IO (DList FilePath, DList FilePath) - --- (Any p) is always the last element -matchTypedAndGo opts [Any p] path absPath = - if matchWith opts p path - then return (DL.singleton absPath, DL.empty) - else doesDirectoryExist absPath >>= didn'tMatch path absPath - -matchTypedAndGo opts (Dir n p:ps) path absPath = do - isDir <- doesDirectoryExist absPath - if isDir && matchWith opts p path - then globDir' opts ps (absPath ++ replicate n pathSeparator) - else didn'tMatch path absPath isDir - -matchTypedAndGo opts (AnyDir n p:ps) path absPath = do - if path `elem` [".",".."] - then didn'tMatch path absPath True - else do - isDir <- doesDirectoryExist absPath - let m = matchWith opts (unseparate ps) - unconditionalMatch = - null (unPattern p) && not (isExtSeparator $ head path) - p' = Pattern (unPattern p ++ [AnyNonPathSeparator]) - - case unconditionalMatch || matchWith opts p' path of - True | isDir -> do - contents <- getRecursiveContents - (absPath ++ replicate n pathSeparator) - return $ - -- foo**/ should match foo/ and nothing below it - -- relies on head contents == absPath - if null ps - then (DL.singleton $ DL.head contents, DL.tail contents) - else partitionDL (any m . pathParts) contents - - True | m path -> return (DL.singleton absPath, DL.empty) - _ -> didn'tMatch path absPath isDir - -matchTypedAndGo _ _ _ _ = error "Glob.matchTypedAndGo :: internal error" - --- To be called when a pattern didn't match a path: given the path and whether --- it was a directory, return all paths which didn't match (i.e. for a file, --- just the file, and for a directory, everything inside it). -didn'tMatch :: FilePath -> FilePath -> Bool - -> IO (DList FilePath, DList FilePath) -didn'tMatch path absPath isDir = (fmap $ (,) DL.empty) $ - if isDir - then if path `elem` [".",".."] - then return DL.empty - else getRecursiveContents absPath - else return$ DL.singleton absPath - -separate :: Pattern -> [TypedPattern] -separate = go DL.empty . unPattern - where - go gr [] | null (DL.toList gr) = [] - go gr [] = [Any (pat gr)] - go gr (PathSeparator:ps) = slash gr Dir ps - go gr ( AnyDirectory:ps) = slash gr AnyDir ps - go gr ( p:ps) = go (gr `DL.snoc` p) ps - - pat = Pattern . DL.toList - - slash gr f ps = let (n,ps') = first length . span isSlash $ ps - in f (n+1) (pat gr) : go DL.empty ps' - - isSlash PathSeparator = True - isSlash _ = False - -unseparate :: [TypedPattern] -> Pattern -unseparate = Pattern . foldr f [] - where - f (AnyDir n p) ts = u p ++ AnyDirectory : replicate n PathSeparator ++ ts - f ( Dir n p) ts = u p ++ PathSeparator : replicate n PathSeparator ++ ts - f (Any p) ts = u p ++ ts - - u = unPattern - --- Note that we consider "/foo" to specify a drive on Windows, even though it's --- relative to the current drive. --- --- Returns the [TypedPattern] of the Pattern (with the drive dropped if --- appropriate) and, if the Pattern specified a drive, a Maybe representing the --- drive to use. If it's a Just "", use the drive of the current working --- directory. -driveSplit :: Pattern -> (Pattern, Maybe FilePath) -driveSplit = check . split . unPattern - where - -- We can't just use something like commonDirectory because of Windows - -- drives being possibly longer than one "directory", like "//?/foo/bar/". - -- So just take as much as possible. - split (LongLiteral _ l : xs) = first (l++) (split xs) - split ( Literal l : xs) = first (l:) (split xs) - split (PathSeparator : xs) = first (pathSeparator:) (split xs) - split ( ExtSeparator : xs) = first ( extSeparator:) (split xs) - split xs = ([],xs) - - -- The isPathSeparator check is interesting in two ways: - -- - -- 1. It's correct to return simply Just "" because there can't be more than - -- one path separator if splitDrive gave a null drive: "//x" is a shared - -- "drive" in Windows and starts with the root "drive" in Posix. - -- - -- 2. The 'head' is safe because we have not (null d) && null drive. - check (d,ps) - | null d = (Pattern ps, Nothing) - | not (null drive) = (dirify rest ps, Just drive) - | isPathSeparator (head rest) = (Pattern ps, Just "") - | otherwise = (dirify d ps, Nothing) - where - (drive, rest) = splitDrive d - - dirify path = Pattern . (comp path++) - - comp s = let (p,l) = foldr f ([],[]) s in if null l then p else ll l p - where - f c (p,l) | isExtSeparator c = (ExtSeparator : ll l p, []) - | isPathSeparator c = (PathSeparator : ll l p, []) - | otherwise = (p, c:l) - - ll l p = if null l then p else LongLiteral (length l) l : p - --- |Factors out the directory component of a 'Pattern'. Useful in conjunction --- with 'globDir'. --- --- Preserves the number of path separators: @commonDirectory (compile --- \"foo\/\/\/bar\")@ becomes @(\"foo\/\/\/\", compile \"bar\")@. -commonDirectory :: Pattern -> (FilePath, Pattern) -commonDirectory = second unseparate . splitP . separate - where - splitP pt@(Dir n p:ps) = - case fromConst DL.empty (unPattern p) of - Just d -> first ((d ++ replicate n pathSeparator) ) (splitP ps) - Nothing -> ("", pt) - - splitP pt = ("", pt) - - fromConst d [] = Just (DL.toList d) - fromConst d (Literal c :xs) = fromConst (d `DL.snoc` c) xs - fromConst d (ExtSeparator :xs) = fromConst (d `DL.snoc` extSeparator) xs - fromConst d (LongLiteral _ s:xs) = fromConst (d `DL.append`DL.fromList s) xs - fromConst _ _ = Nothing diff --git a/src/System/FilePath/Glob/Match.hs b/src/System/FilePath/Glob/Match.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Match.hs +++ /dev/null @@ -1,157 +0,0 @@ --- File created: 2008-10-10 13:29:03 - -module System.FilePath.Glob.Match (match, matchWith) where - -import Control.Exception (assert) -import Data.Char (isDigit, toLower, toUpper) -import Data.Monoid (mappend) -import System.FilePath (isPathSeparator, isExtSeparator) - -import System.FilePath.Glob.Base ( Pattern(..), Token(..) - , MatchOptions(..), matchDefault - , tokToLower - ) -import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts) - --- |Matches the given 'Pattern' against the given 'FilePath', returning 'True' --- if the pattern matches and 'False' otherwise. -match :: Pattern -> FilePath -> Bool -match = matchWith matchDefault - --- |Like 'match', but applies the given 'MatchOptions' instead of the defaults. -matchWith :: MatchOptions -> Pattern -> FilePath -> Bool -matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f) - where - lcPath = if ignoreCase opts then map toLower else id - lcPat = if ignoreCase opts then map tokToLower else id - --- begMatch takes care of some things at the beginning of a pattern or after /: --- - . needs to be matched explicitly --- - ./foo is equivalent to foo (for any number of /) --- --- .*/foo still needs to match ./foo though, and it won't match plain foo; --- special case that one --- --- and .**/foo should /not/ match ../foo; more special casing --- --- (All of the above is modulo options, of course) -begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool -begMatch _ (ExtSeparator:AnyDirectory:_) (x:y:_) - | isExtSeparator x && isExtSeparator y = False - -begMatch opts (ExtSeparator:PathSeparator:pat) s | ignoreDotSlash opts = - begMatch opts (dropWhile isSlash pat) s - where - isSlash PathSeparator = True - isSlash _ = False - -begMatch opts pat (x:y:s) - | dotSlash && dotStarSlash = match' opts pat' s - | ignoreDotSlash opts && dotSlash = begMatch opts pat s - where - dotSlash = isExtSeparator x && isPathSeparator y - (dotStarSlash, pat') = - case pat of - ExtSeparator:AnyNonPathSeparator:PathSeparator:rest -> (True, rest) - _ -> (False, pat) - -begMatch opts pat s = - if not (null s) && isExtSeparator (head s) && not (matchDotsImplicitly opts) - then case pat of - ExtSeparator:pat' -> match' opts pat' (tail s) - _ -> False - else match' opts pat s - -match' _ [] s = null s -match' _ (AnyNonPathSeparator:s) "" = null s -match' _ _ "" = False -match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs -match' o ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' o xs cs -match' o (NonPathSeparator:xs) (c:cs) = - not (isPathSeparator c) && match' o xs cs - -match' o (PathSeparator :xs) (c:cs) = - isPathSeparator c && begMatch o xs (dropWhile isPathSeparator cs) - -match' o (CharRange b rng :xs) (c:cs) = - let rangeMatch r = - either (== c) (`inRange` c) r || - -- See comment near Base.tokToLower for an explanation of why we - -- do this - if ignoreCase o - then either (== toUpper c) (`inRange` toUpper c) r - else False - in not (isPathSeparator c) && - any rangeMatch rng == b && - match' o xs cs - -match' o (OpenRange lo hi :xs) path = - let - (lzNum,cs) = span isDigit path - num = dropLeadingZeroes lzNum - numChoices = - tail . takeWhile (not.null.snd) . map (flip splitAt num) $ [0..] - in if null lzNum - then False -- no digits - else - -- So, given the path "123foo" what we've got is: - -- cs = "foo" - -- num = "123" - -- numChoices = [("1","23"),("12","3")] - -- - -- We want to try matching x against each of 123, 12, and 1. - -- 12 and 1 are in numChoices already, but we need to add (num,"") - -- manually. - any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs)) - ((num,"") : numChoices) - -match' o again@(AnyNonPathSeparator:xs) path@(c:cs) = - match' o xs path || (if isPathSeparator c then False else match' o again cs) - -match' o again@(AnyDirectory:xs) path = - let parts = pathParts (dropWhile isPathSeparator path) - matches = any (match' o xs) parts || any (match' o again) (tail parts) - in if null xs && not (matchDotsImplicitly o) - -- **/ shouldn't match foo/.bar, so check that remaining bits don't - -- start with . - then all (not.isExtSeparator.head) (init parts) && matches - else matches - -match' o (LongLiteral len s:xs) path = - let (pre,cs) = splitAt len path - in pre == s && match' o xs cs - --- Does the actual open range matching: finds whether the third parameter --- is between the first two or not. --- --- It does this by keeping track of the Ordering so far (e.g. having --- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34) --- and aborting if a String "runs out": a longer string is automatically --- greater. --- --- Assumes that the input strings contain only digits, and no leading zeroes. -inOpenRange :: Maybe String -> Maybe String -> String -> Bool -inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ - where - go Nothing Nothing _ _ _ = True -- no bounds - go (Just []) _ [] LT _ = False -- lesser than lower bound - go _ (Just []) _ _ GT = False -- greater than upper bound - go _ (Just []) (_:_) _ _ = False -- longer than upper bound - go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound - go _ _ [] _ _ = True - - go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh = - let ordl' = ordl `mappend` compare c l - ordh' = ordh `mappend` compare c h - in go (Just ls) (Just hs) cs ordl' ordh' - - go Nothing (Just (h:hs)) (c:cs) _ ordh = - let ordh' = ordh `mappend` compare c h - in go Nothing (Just hs) cs GT ordh' - - go (Just (l:ls)) Nothing (c:cs) ordl _ = - let ordl' = ordl `mappend` compare c l - in go (Just ls) Nothing cs ordl' LT - - -- lower bound is shorter: s is greater - go (Just []) hi s _ ordh = go Nothing hi s GT ordh diff --git a/src/System/FilePath/Glob/Primitive.hs b/src/System/FilePath/Glob/Primitive.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Primitive.hs +++ /dev/null @@ -1,57 +0,0 @@ --- File created: 2009-01-17 - --- |A number of primitives from which complete 'Pattern's may be constructed. --- --- Using this together with the functions provided by the 'Monoid' instance of --- 'Pattern' allows for direct manipulation of 'Pattern's beyond what can be --- done with just the 'compile' family of functions. And of course you don't --- have to go via 'String's if you use these. -module System.FilePath.Glob.Primitive - ( literal - , singleWildcard, wildcard, recursiveWildcard - , charRange, numberRange - ) where - -import System.FilePath (isPathSeparator, isExtSeparator) - -import System.FilePath.Glob.Base (Pattern(..), Token(..), optimize) - --- |A 'Pattern' which matches the given 'String' literally. --- --- Handles any embedded path and extension separators. -literal :: String -> Pattern -literal = optimize . Pattern . map f - where - f c | isPathSeparator c = PathSeparator - | isExtSeparator c = ExtSeparator - | otherwise = Literal c - --- |Matches any single character except a path separator: corresponds to the --- @?@ operator. -singleWildcard :: Pattern -singleWildcard = Pattern [NonPathSeparator] - --- |Matches any number of characters up to a path separator: corresponds to the --- @*@ operator. -wildcard :: Pattern -wildcard = Pattern [AnyNonPathSeparator] - --- |Matches any number of characters including path separators: corresponds to --- the @**/@ operator. -recursiveWildcard :: Pattern -recursiveWildcard = Pattern [AnyDirectory] - --- |Matches a single character if it is within the (inclusive) range in any --- 'Right' or if it is equal to the character in any 'Left'. Corresponds to the --- @[]@, @[^]@ and @[!]@ operators. --- --- If the given 'Bool' is 'False', the result of the match is inverted: the --- match succeeds if the character does /not/ match according to the above --- rules. -charRange :: Bool -> [Either Char (Char,Char)] -> Pattern -charRange b rs = optimize $ Pattern [CharRange b rs] - --- |Matches a number in the given range, which may be open, half-open, or --- closed. Corresponds to the @\<\>@ operator. -numberRange :: Maybe Integer -> Maybe Integer -> Pattern -numberRange a b = Pattern [OpenRange (fmap show a) (fmap show b)] diff --git a/src/System/FilePath/Glob/Simplify.hs b/src/System/FilePath/Glob/Simplify.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Simplify.hs +++ /dev/null @@ -1,42 +0,0 @@ --- File created: 2009-01-30 14:54:14 - -module System.FilePath.Glob.Simplify (simplify) where - -import System.FilePath.Glob.Base (Pattern(..), Token(..), liftP) - --- |Simplifies a 'Pattern' object: removes redundant @\"./\"@, for instance. --- The resulting 'Pattern' matches the exact same input as the original one, --- with some differences: --- --- * The output of 'globDir' will differ: for example, globbing for @\"./\*\"@ --- gives @\"./foo\"@, but after simplification this'll be only @\"foo\"@. --- --- * Decompiling the simplified 'Pattern' will obviously not give the original. --- --- * The simplified 'Pattern' is a bit faster to match with and uses less --- memory, since some redundant data is removed. --- --- For the last of the above reasons, if you're performance-conscious and not --- using 'globDir', you should always 'simplify' after calling 'compile'. -simplify :: Pattern -> Pattern -simplify = liftP (go . pre) - where - -- ./ at beginning -> nothing (any number of /'s) - pre (ExtSeparator:PathSeparator:xs) = pre (dropWhile isSlash xs) - pre xs = xs - - go [] = [] - - -- /./ -> / - go (PathSeparator:ExtSeparator:xs@(PathSeparator:_)) = go xs - - go (x:xs) = - if isSlash x - then let (compressed,ys) = span isSlash xs - in if null compressed - then x : go ys - else go (x : ys) - else x : go xs - - isSlash PathSeparator = True - isSlash _ = False diff --git a/src/System/FilePath/Glob/Utils.hs b/src/System/FilePath/Glob/Utils.hs deleted file mode 100644 --- a/src/System/FilePath/Glob/Utils.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE CPP #-} --- File created: 2008-10-10 13:40:35 - -module System.FilePath.Glob.Utils - ( isLeft, fromLeft - , increasingSeq - , addToRange, inRange, overlap - , dropLeadingZeroes - , pathParts - , nubOrd - , partitionDL - , getRecursiveContents - ) where - -import Control.Monad (foldM) -import Data.List ((\\)) -import qualified Data.DList as DL -import Data.DList (DList) -import qualified Data.Set as Set -import System.Directory (getDirectoryContents) -import System.FilePath ((), isPathSeparator, dropDrive) -import System.IO.Unsafe (unsafeInterleaveIO) - -#if mingw32_HOST_OS -import Data.Bits ((.&.)) -import System.Win32.Types (withTString) -import System.Win32.File (c_GetFileAttributes, fILE_ATTRIBUTE_DIRECTORY) -#else -import Foreign.C.String (withCString) -import Foreign.Marshal.Alloc (allocaBytes) -import System.FilePath - (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator) -import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode) -#endif - - -import System.IO.Error (catchIOError) - -inRange :: Ord a => (a,a) -> a -> Bool -inRange (a,b) c = c >= a && c <= b - --- returns Just (a range which covers both given ranges) or Nothing if they are --- disjoint. --- --- Assumes that the ranges are in the correct order, i.e. (fst x < snd x). -overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a) -overlap (a,b) (c,d) = - if b >= c - then if b >= d - then if a <= c - then Just (a,b) - else Just (c,b) - else if a <= c - then Just (a,d) - else Just (c,d) - else Nothing - -addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a) -addToRange (a,b) c - | inRange (a,b) c = Just (a,b) - | c == pred a = Just (c,b) - | c == succ b = Just (a,c) - | otherwise = Nothing - --- fst of result is in reverse order so that: --- --- If x = fst (increasingSeq (a:xs)), then --- x == reverse [a .. head x] -increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a]) -increasingSeq [] = ([],[]) -increasingSeq (x:xs) = go [x] xs - where - go is [] = (is,[]) - go is@(i:_) (y:ys) = - if y == succ i - then go (y:is) ys - else (is, y:ys) - go _ _ = error "Glob.increasingSeq :: internal error" - -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False - -fromLeft :: Either a b -> a -fromLeft (Left x) = x -fromLeft _ = error "fromLeft :: Right" - -dropLeadingZeroes :: String -> String -dropLeadingZeroes s = - let x = dropWhile (=='0') s - in if null x then "0" else x - --- foo/bar/baz -> [foo/bar/baz,bar/baz,baz] -pathParts :: FilePath -> [FilePath] -pathParts p = p : let d = dropDrive p - in if null d || d == p - then f d - else d : f d - where - f [] = [] - f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs - f (x:xs) = - if isPathSeparator x - then xs : f xs - else f xs - --- Significantly speedier than System.Directory.doesDirectoryExist. -doesDirectoryExist :: FilePath -> IO Bool -#if mingw32_HOST_OS --- This one allocates more memory since it has to do a UTF-16 conversion, but --- that can't really be helped: the below version is locale-dependent. -doesDirectoryExist = flip withTString $ \s -> do - a <- c_GetFileAttributes s - return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0) -#else -doesDirectoryExist s = - allocaBytes sizeof_stat $ \p -> - withCString - (if isDrive s - then addTrailingPathSeparator s - else dropTrailingPathSeparator s) - $ \c -> do - st <- lstat c p - if st == 0 - then fmap s_isdir (st_mode p) - else return False -#endif - -getRecursiveContents :: FilePath -> IO (DList FilePath) -getRecursiveContents dir = - flip catchIOError (\_ -> return $ DL.singleton dir) $ do - - raw <- getDirectoryContents dir - - let entries = map (dir ) (raw \\ [".",".."]) - (dirs,files) <- partitionM doesDirectoryExist entries - - subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs - - return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs) - -partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) -partitionM p_ = foldM (f p_) ([],[]) - where - f p (ts,fs) x = p x >>= \b -> - if b - then return (x:ts, fs) - else return (ts, x:fs) - -partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a) -partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty) - where - f p x (ts,fs) = - if p x - then (DL.cons x ts, fs) - else (ts, DL.cons x fs) - -nubOrd :: Ord a => [a] -> [a] -nubOrd = go Set.empty - where - go _ [] = [] - go set (x:xs) = - if Set.member x set - then go set xs - else x : go (Set.insert x set) xs diff --git a/src/System/Nemesis/Runner.hs b/src/System/Nemesis/Runner.hs deleted file mode 100644 --- a/src/System/Nemesis/Runner.hs +++ /dev/null @@ -1,101 +0,0 @@ -import Control.Monad hiding (join) -import Data.List (find) -import Data.Time.Clock.POSIX -import Prelude () -import System.Environment -import System.Cmd -import System.Directory -import System.Nemesis.Util -import System.Time -import System.Nemesis.DSL -import qualified Prelude as P -import Data.Maybe -import System.Exit - -start, end :: String -start = start_nemesis + start_nemesis_dsl + init_air + init_prelude - where - start_nemesis = "import System.Nemesis (run)\n" - start_nemesis_dsl = "import System.Nemesis.DSL\n" - init_air = "import Air.Light ((-))\n" - init_prelude = "import Prelude hiding ((-))\n" -end = "\nmain = run nemesis\n" - -main :: IO () -main = do - recompile <- should_recompile - when recompile compile - - args <- getArgs - exit_code <- system - "./.nemesis " + args.join " " - - exitWith exit_code - - where - bin = ".nemesis" - should_recompile = do - bin_exists <- doesFileExist bin - if not bin_exists - then return True - else do - bin_stamp <- bin.getModificationTime - src_stamp <- get_src_name >>= getModificationTime - return - bin_stamp P.< src_stamp - - -get_src_name :: IO String -get_src_name = do - dir <- ls "." - return - dir.filter (belongs_to possible_source) .get_name - where - possible_source = ["Nemesis", "nemesis", "Nemesis.hs", "nemesis.hs"] - get_name [] = error "Nemesis does not exist!" - get_name xs = xs.first - -compile :: IO () -compile = do - src_name <- get_src_name - let src_o = src_base_name src_name + ".o" - src_hi = src_base_name src_name + ".hi" - src <- readFile src_name - - let maybe_patch_end = yield_string_if_no_line_starts_with main_src_prefix src end - maybe_patch_start = yield_string_if_no_line_starts_with main_src_prefix src start - - __nem_seperated_header = src.lines.takeWhile (lower > starts_with sep > not) .unlines - __nem_seperated_footer = src.lines.dropWhile (lower > starts_with sep > not) .unlines - - if (maybe_patch_end.isNothing && maybe_patch_start.isNothing && src_name.ends_with ".hs") - then do - sh - "ghc --make -O1 " + src_name + " -o " + bin - rm src_o - rm src_hi - else do - if __nem_seperated_footer.null - then output_tmp - maybe_patch_start.fromMaybe "" + __nem_seperated_header + maybe_patch_end.fromMaybe "" - else output_tmp - __nem_seperated_header + maybe_patch_start.fromMaybe "" + "\n" + __nem_seperated_footer + maybe_patch_end.fromMaybe "" - - sh - "ghc --make -O1 " + tmp_name + " -o " + bin - rm tmp_name - rm tmp_o - rm tmp_hi - - where - - main_src_prefix = "main =" - - sep = "-- nem" - output_tmp = writeFile tmp_name - tmp_name = "nemesis-tmp.hs" - tmp_o = "nemesis-tmp.o" - tmp_hi = "nemesis-tmp.hi" - bin = ".nemesis" - src_base_name s = if s.ends_with ".hs" - then s.reverse.drop 3.reverse - else s - - yield_string_if_no_line_starts_with prefix str yield = case str.lines.find (starts_with prefix) of - Nothing -> Just yield - Just _ -> Nothing - - diff --git a/test/N1.hs b/test/N1.hs new file mode 100644 --- /dev/null +++ b/test/N1.hs @@ -0,0 +1,19 @@ +import System.Nemesis.Env + +main = run $ do + + clean + [ "**/*.hi" + , "**/*.o" + , "manifest" + ] + + task "dist" $ do + sh "cabal clean" + sh "cabal configure" + sh "cabal sdist" + + task "i" (sh "ghci -isrc src/System/Nemesis.hs") + + task "manifest" $ do + sh "find . | grep 'hs$' > manifest" diff --git a/test/N2.hs b/test/N2.hs new file mode 100644 --- /dev/null +++ b/test/N2.hs @@ -0,0 +1,22 @@ +import System.Nemesis.Env +import Air.Env ((-)) +import Prelude hiding ((-)) + +main = run - do + + -- desc is optional, it gives some description to the task + -- task syntax: task "keyword: space seperated dependencies" io-action + desc "Hunter attack macro" + task "attack: pet-attack auto-attack" (putStrLn "attack macro done!") + + desc "Pet attack" + task "pet-attack: mark" - do + sh "echo 'pet attack'" + + desc "Hunter's mark" + task "mark" - do + sh "echo \"casting hunter's mark\"" + + desc "Auto attack" + task "auto-attack" - do + sh "echo 'auto shoot'" diff --git a/test/N3.hs b/test/N3.hs new file mode 100644 --- /dev/null +++ b/test/N3.hs @@ -0,0 +1,15 @@ +import System.Nemesis.Env +import Air.Env ((-)) +import Prelude hiding ((-)) + +main = run - do + + namespace "eat" - do + + task "bread: salad" - putStrLn "eating bread" + task "salad: /drink/coke" - putStrLn "eating salad" + + + namespace "drink" - do + + task "coke" - putStrLn "drinking coke"