module Language.Sh.Expansion ( ExpansionFunctions(..),
noGlobExpansion,
expand, expandWord,
expandPattern ) where
import Control.Monad ( forM_, forM )
import Control.Monad.Reader ( ReaderT, runReaderT, asks )
import Control.Monad.Trans ( lift )
import Data.Char ( isAlphaNum )
import Data.List ( takeWhile, dropWhile, groupBy, intersperse )
import Data.Maybe ( fromMaybe )
import Data.Monoid ( Monoid, mappend, mempty )
import Language.Sh.Compat ( on )
import Language.Sh.Glob ( removePrefix, removeSuffix )
import Language.Sh.Syntax ( Command, Word, Lexeme(..),
Expansion(..) )
import Language.Sh.Arithmetic ( runMathParser )
data ExpansionFunctions m = ExpansionFunctions {
getAllEnv :: m [(String,String)],
setEnv :: String -> String -> m (),
homeDir :: String -> m (Maybe String),
expandGlob :: Word -> m [FilePath],
commandSub :: [Command] -> m String,
positionals :: m [String]
}
type Exp m = ReaderT (ExpansionFunctions m) m
get' :: Monad m => Exp m [(String,String)]
get' = asks getAllEnv >>= lift
get :: Monad m => String -> Exp m (Maybe String)
get s = lookup s `fmap` get'
set :: Monad m => String -> String -> Exp m ()
set s v = use2 setEnv s v
home :: Monad m => String -> Exp m (Maybe String)
home u = use homeDir u
glob :: Monad m => Word -> Exp m [FilePath]
glob g = use expandGlob g
run :: Monad m => [Command] -> Exp m String
run cs = use commandSub cs
pos :: Monad m => Exp m [String]
pos = asks positionals >>= lift
use :: Monad m => (ExpansionFunctions m -> a -> m b) -> a -> Exp m b
use f a = asks f >>= lift . ($a)
use2 :: Monad m => (ExpansionFunctions m -> a -> b -> m c) -> a -> b -> Exp m c
use2 f a b = asks f >>= lift . ($b) . ($a)
noGlobExpansion :: Monad m => Word -> m [String]
noGlobExpansion _ = return []
expand :: (Monad m,Functor m) => ExpansionFunctions m -> [Word] -> m [String]
expand fs ws = runReaderT (expandE ws) fs
expandWord :: (Monad m,Functor m) => ExpansionFunctions m -> Word -> m String
expandWord fs w = runReaderT (expandWordE w) fs
expandPattern :: (Monad m,Functor m) => ExpansionFunctions m -> Word -> m Word
expandPattern fs w = runReaderT (expand' w) fs
expandE :: (Monad m,Functor m) => [Word] -> Exp m [String]
expandE ws = do sf <- splitFields =<< mapM expand' ws
sfs <- forM sf $ \w -> do g <- glob w
return $ if null g
then [w]
else map (map Literal) g
return $ map removeQuotes $ concat sfs
expandWordE :: (Monad m,Functor m) => Word -> Exp m String
expandWordE w = fmap removeQuotes $ expand' w
expand' :: (Monad m,Functor m) => Word -> Exp m Word
expand' = expandParams <=< expandTilde
f <=< g = \a -> g a >>= f
infixr 1 <=<
expandTilde :: (Monad m,Functor m) => Word -> Exp m Word
expandTilde w = let (lit,rest) = span isLiteral w
in case (fromLit lit) of
'~':s -> exp s rest
_ -> return w
where exp s r | '/' `elem` s = do let (user,path) = break (=='/') s
dir <- homedir user
return $ map Literal (dir++"/"++path) ++ r
exp s [] = do dir <- homedir s
return $ map Literal dir
exp s r = return $ map Literal s ++ r
isLiteral (Literal _) = True
isLiteral _ = False
fromLit [] = []
fromLit (Literal c:xs) = c:fromLit xs
homedir :: (Monad m,Functor m) => String -> Exp m String
homedir "" = fromMaybe ("~") `fmap` get "HOME"
homedir user = fromMaybe ("~"++user) `fmap` home user
quote :: Bool -> Word -> Word
quote True = map Quoted
quote False = id
quoteLiteral :: Bool -> String -> Word
quoteLiteral q = quote q . map Literal
expandParams :: (Monad m,Functor m) => Word -> Exp m Word
expandParams = expandWith e
where e q (SimpleExpansion n) = getEnvQ q n
e q (LengthExpansion n) = do v <- getEnvQ q n
return $ quoteLiteral q $
show $ length v
e q (ModifiedExpansion n o c w)
= do v <- getEnvQC q c n
case o of
'-' -> return $ fromMaybe w v
'=' -> case v of
Nothing -> do setEnvW n w
return w
Just v' -> return v'
'?' -> case v of
Nothing -> fail $ n++": undefined or null"
Just v' -> return v'
'+' -> return $ maybe mempty (const w) v
'#' -> do r <- expand' w
return $ fromStr q $ removePrefix c r $ toStr v
'%' -> do r <- expand' w
return $ fromStr q $ removeSuffix c r $ toStr v
e q (CommandSub cs) = (quoteLiteral q . removeNewlines) `fmap` run cs
e q (Arithmetic w) = fmap (quoteLiteral q) $
arithExpand =<< expandWordE w
removeNewlines = reverse . dropWhile (`elem`"\r\n") . reverse
toStr = removeQuotes . fromMaybe []
fromStr = quoteLiteral
arithExpand :: Monad m => String -> Exp m String
arithExpand s = fmap show $ doMath s
setEnvW :: (Monad m,Functor m) => String -> Word -> Exp m ()
setEnvW s w = do v <- expandWordE w
set s v
getEnvQC :: Monad m => Bool -> Bool -> String -> Exp m (Maybe Word)
getEnvQC q c n = do v <- getSpecial q n
case v of
Nothing -> return Nothing
Just [] -> if c then return Nothing
else return $ Just []
Just v' -> return $ Just v'
getEnvQ :: Monad m => Bool -> String -> Exp m Word
getEnvQ q n = fromMaybe [] `fmap` getEnvQC q False n
getSpecial :: Monad m => Bool -> String -> Exp m (Maybe Word)
getSpecial q "@" = getAtStar q $ (++[SplitField]) . map Literal
getSpecial q "*" = getAtStar q $ quoteLiteral q
getSpecial q "#" = (Just . quoteLiteral q.show.length) `fmap` pos
getSpecial q n = fmap (quoteLiteral q) `fmap` get n
getAtStar :: Monad m => Bool -> (String -> Word) -> Exp m (Maybe Word)
getAtStar q c2l = do ps <- map (quoteLiteral q) `fmap` pos
fs <- (c2l . take 1) `fmap` getIFS
return $ if null ps
then Nothing
else Just $ concat $ intersperse fs ps
expandWith :: Monad m => (Bool -> Expansion -> Exp m Word)
-> Word -> Exp m Word
expandWith f (Expand x:xs) = do x' <- f False x
xs' <- expandWith f xs
return $ x' ++ xs'
expandWith f (Quoted (Expand x):xs) = do x' <- f True x
xs' <- expandWith f xs
return $ x' ++ xs'
expandWith f (x:xs) = do fmap (x:) $ expandWith f xs
expandWith _ [] = return []
splitFields :: Monad m => [Word] -> Exp m [Word]
splitFields w = do ifs <- getIFS
let f SplitField = True
f (Literal c) = c `elem` ifs
f _ = False
split = filter (any (not . f)) . (groupBy ((==) `on` f))
return $ concatMap split w
getIFS :: Monad m => Exp m String
getIFS = fmap (fromMaybe " \t\r\n") $ get "IFS"
removeQuotes :: Word -> String
removeQuotes [] = ""
removeQuotes (SplitField:xs) = removeQuotes xs
removeQuotes (Quote _:xs) = removeQuotes xs
removeQuotes (Quoted x:xs) = removeQuotes $ x:xs
removeQuotes (Expand _:xs) = undefined
removeQuotes (Literal c:xs) = c:removeQuotes xs
doMath :: Monad m => String -> Exp m Int
doMath s = do subs <- get'
case runMathParser subs s of
Left err -> fail err
Right (r,ss) -> do forM_ ss $ \(n,v) -> set n $ show v
return r