language-sh-0.0.3: Language/Sh/Glob.hs
{-# LANGUAGE CPP #-}
module Language.Sh.Glob ( expandGlob, matchPattern,
removePrefix, removeSuffix ) where
import Control.Monad.Trans ( MonadIO, liftIO )
import Control.Monad.State ( runState, put )
import Data.Char ( ord, chr )
import Data.List ( isPrefixOf, partition )
import Data.Maybe ( isJust, listToMaybe )
import System.Directory ( getCurrentDirectory )
import System.FilePath ( pathSeparator, isPathSeparator, isExtSeparator )
import Text.Regex.PCRE.Light.Char8 ( Regex, compileM, match, ungreedy )
import Language.Sh.Syntax ( Lexeme(..), Word )
-- we might get a bit fancier if older glob libraries will support
-- a subset of what we want to do...?
#ifdef HAVE_GLOB
import System.FilePath.Glob ( tryCompile, globDir, factorPath )
#endif
expandGlob :: MonadIO m => Word -> m [FilePath]
#ifdef HAVE_GLOB
expandGlob w = case mkGlob w of
Nothing -> return []
Just g -> case tryCompile g of
Right g' -> liftIO $
do let (dir,g'') = factorPath g'
liftIO $ putStrLn $ show (dir,g'')
hits <- globDir [g''] dir
return $ head $ fst $ hits
_ -> return []
#else
expandGlob = const $ return []
#endif
-- By the time this is called, we should only have quotes and quoted
-- literals to worry about. In the event of finding an unquoted glob
-- char (and if the glob matches) we'll automatically remove quotes, etc.
-- (since the next stage is, after all, quote removal).
mkGlob :: Word -> Maybe String
mkGlob w = case runState (mkG w) False of
(s,True) -> Just s
_ -> Nothing
where mkG [] = return []
mkG (Literal '[':xs) = case mkClass xs of
Just (g,xs') -> fmap (g++) $ mkG xs'
Nothing -> fmap ((mkLit '[')++) $ mkG xs
mkG (Literal '*':Literal '*':xs) = mkG $ Literal '*':xs
mkG (Literal '*':xs) = put True >> fmap ('*':) (mkG xs)
mkG (Literal '?':xs) = put True >> fmap ('?':) (mkG xs)
mkG (Literal c:xs) = fmap (mkLit c++) $ mkG xs
mkG (Quoted (Literal c):xs) = fmap (mkLit c++) $ mkG xs
mkG (Quoted q:xs) = mkG $ q:xs
mkG (Quote _:xs) = mkG xs
mkLit c | c `elem` "[*?<" = ['[',c,']']
| otherwise = [c]
-- This is basically gratuitously copied from Glob's internals.
mkClass :: Word -> Maybe (String,Word)
mkClass xs = let (range, rest) = break (isLit ']') xs
in if null rest then Nothing
else if null range
then let (range', rest') = break (isLit ']') (tail rest)
in if null rest' then Nothing
else do x <- cr' range'
return (x,tail rest')
else do x <- cr' range
return (x,tail rest)
where cr' s = Just $ "["++movedash (filter (not . isQuot) s)++"]"
isLit c x = case x of { Literal c' -> c==c'; _ -> False }
isQuot x = case x of { Quote _ -> True; _ -> False }
quoted c x = case x of Quoted (Quoted x) -> quoted c $ Quoted x
Quoted (Literal c') -> c==c'
_ -> False
movedash s = let (d,nd) = partition (quoted '-') s
bad = null d || (isLit '-' $ head $ reverse s)
in map fromLexeme $ if bad then nd else nd++d
fromLexeme x = case x of { Literal c -> c; Quoted q -> fromLexeme q }
{-
expandGlob :: MonadIO m => Word -> m [FilePath]
expandGlob w = case mkGlob w of
Nothing -> return []
Just g -> case G.unPattern g of
(G.PathSeparator:_) -> liftIO $
do hits <- G.globDir [g] "/" -- unix...?
let ps = [pathSeparator]
return $ head $ fst $ hits
_ -> liftIO $
do cwd <- getCurrentDirectory
hits <- G.globDir [g] cwd
let ps = [pathSeparator]
return $ map (removePrefix $ cwd++ps) $
head $ fst $ hits
where removePrefix pre s | pre `isPrefixOf` s = drop (length pre) s
| otherwise = s
-}
-- Two issues: we can deal with them here...
-- 1. if glob starts with a dirsep then we need to go relative to root...
-- (what about in windows?)
-- 2. if not, then we should remove the absolute path from the beginning of
-- the results (should be easy w/ a map)
{-
-- This is a sort of default matcher, but needn't be used...
matchGlob :: MonadIO m => Glob -> m [FilePath]
matchGlob g = matchG' [] $ splitDir return $ do -- now we're in the list monad...
where d = splitDir g
splitDir (c:xs) | ips c = []:splitDir (dropWhile ips xs)
splitDir xs = filter (not . null) $
filter (not . all ips) $
groupBy ((==) on ips) xs
ips x = case x of { Lit c -> isPathSeparator c; _ -> False }
-}
----------------------------------------------------------------------
-- This is copied from above, but it's used separately for non-glob --
-- pattern matching. Maybe we'll combine them someday. --
----------------------------------------------------------------------
match' :: Regex -> String -> Maybe String
match' regex s = listToMaybe =<< match regex s []
matchPattern :: Word -> String -> Bool
matchPattern w s = case mkRegex False False "^" "$" w of
Just r -> isJust $ match r s []
Nothing -> fromLit w == s
removePrefix :: Bool -- ^greediness
-> Word -- ^pattern
-> String -- ^haystack
-> String
removePrefix g n h = case mkRegex g False "^" "" n of
Just r -> case match' r h of
Just m -> drop (length m) h
Nothing -> h
Nothing -> if l `isPrefixOf` h
then drop (length l) h
else h
where l = fromLit n
removeSuffix :: Bool -- ^greediness
-> Word -- ^pattern
-> String -- ^haystack
-> String
removeSuffix g n h = case mkRegex g True "^" "" n of
Just r -> case match' r hr of
Just m -> reverse $ drop (length m) hr
Nothing -> h
Nothing -> if l `isPrefixOf` hr
then reverse $ drop (length l) hr
else h
where l = reverse $ fromLit n
hr = reverse h
mkRegex :: Bool -- ^greedy?
-> Bool -- ^reverse? (before adding pre/suff)
-> String -- ^prefix
-> String -- ^suffix
-> Word -- ^pattern
-> Maybe Regex
mkRegex g r pre suf w
= case runState (mkG w) False of
(s,True) -> mk' $ concat $ affix $ (if r then reverse else id) s
_ -> Nothing
where mkG [] = return []
mkG (Literal '[':xs) = case mkClass xs of
Just (g,xs') -> fmap (g:) $ mkG xs'
Nothing -> fmap ((mkLit '['):) $ mkG xs
mkG (Literal '*':Literal '*':xs) = mkG $ Literal '*':xs
mkG (Literal '*':xs) = put True >> fmap (".*":) (mkG xs)
mkG (Literal '?':xs) = put True >> fmap (".":) (mkG xs)
mkG (Literal c:xs) = fmap (mkLit c:) $ mkG xs
mkG (Quoted (Literal c):xs) = fmap (mkLit c:) $ mkG xs
mkG (Quoted q:xs) = mkG $ q:xs
mkG (Quote _:xs) = mkG xs
mkLit c | c `elem` "[](){}|^$.*+?\\" = ['\\',c]
| otherwise = [c]
affix s = pre:s++[suf]
mk' s = case compileM s (if g then [] else [ungreedy]) of
Left _ -> Nothing
Right regex -> Just regex
fromLit :: Word -> String
fromLit = concatMap $ \l -> case l of Literal c -> [c]
Quoted q -> fromLit [q]
_ -> []