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 )
#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
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]
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 }
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
-> Word
-> String
-> 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
-> Word
-> String
-> 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
-> Bool
-> String
-> String
-> Word
-> 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]
_ -> []