diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Stephen Hicks 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Language/Sh/Arithmetic.hs b/Language/Sh/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Arithmetic.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE CPP #-} +module Language.Sh.Arithmetic ( runMathParser ) where + +-- This doesn't depend on any expansion at all... +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language +import Text.ParserCombinators.Parsec.Expr +import qualified Text.ParserCombinators.Parsec.Token as P + +import Data.Bits ( shiftL, shiftR, complement, xor, (.&.), (.|.) ) +import Data.List ( unionBy ) +import Data.Maybe ( fromMaybe ) + +import Debug.Trace ( trace ) + +import Language.Sh.Compat ( on ) + +type SS = [(String,String)] +type SI = [(String,Int)] + +type AP a = CharParser SS a -- just keep this state... - update when we can + +data Term = Literal SI Int | Variable String | Error String + deriving ( Show ) + +runMathParser :: SS -> String -> Either String (Int,SI) +runMathParser subs s = case runParser exprSubs (subs) "" s of + Left err -> Left $ show err + Right x -> Right x + +joinS :: Eq a => [(a,b)] -> [(a,b)] -> [(a,b)] +joinS = unionBy ((==) `on` fst) + +mapS :: (b -> c) -> [(a,b)] -> [(a,c)] +mapS f = map $ \(a,b)->(a,f b) + +-- after a buildExprParser, we'll check the new assignments and make them... + +exprSubs :: AP (Int,SI) +exprSubs = do e <- expr + --e <- parens (string "1+2") >> return (Literal [] 3) + --string "(1+2)" + --let e = Literal [] 3 + eof + case e of + Literal subs i -> return (i,subs) + Variable s -> do ss <- getState + let val = fromMaybe "0" $ lookup s ss + case runMathParser ss val of + Left err -> fail err + Right (i,si) -> return (i,si) + Error err -> fail err + +lexer :: P.TokenParser st +lexer = P.makeTokenParser $ + emptyDef {identLetter = alphaNum <|> char '_' + , opStart = oneOf [] -- no nonreserved operators + , opLetter = oneOf [] + , reservedOpNames= ["++","+","--","-","*","/","%","^" + ,"|","||","&","&&","<<",">>" + ,"<","<=",">",">=","==","=","!=","!","~" + ,"?",":" + ,"+=","-=","*=","/=","%=","|=","&=" + ,"^=","<<=",">>="] + } + +parens = P.parens lexer -- what is P? +whiteSpace = P.whiteSpace lexer +hexadecimal = P.hexadecimal lexer +decimal = P.decimal lexer +reservedOp = P.reservedOp lexer +identifier = P.identifier lexer + +natural = do n <- octal <|> decimal <|> hexadecimal + whiteSpace + return n + where octal = do char '0' + bo 0 + bo n = do d <- oneOf "01234567" "octal digit" + return $ 8*n + read [d] + <|> return n + +mapT :: (Int -> Int) -> Term -> Term +mapT _ (Error err) = Error err +mapT _ (Variable v) = Error $ "impossible: unexpanded variable: "++v +mapT f (Literal s i) = Literal s $ f i + +mapT2 :: (Int -> Int -> Int) -> Term -> Term -> Term +mapT2 _ (Error err) _ = Error err +mapT2 _ (Variable v) _ = Error $ "impossible: unexpanded variable: "++v +mapT2 _ _ (Error err) = Error err +mapT2 _ _ (Variable v) = Error $ "impossible: unexpanded variable: "++v +mapT2 f (Literal s1 i1) (Literal s2 i2) = Literal (s1 `joinS` s2) $ f i1 i2 + +expr1 :: AP Term +expr1 = buildExpressionParser table1 term + -- "expression" + +expr2 :: AP Term -- here's where we get the ternary operator +expr2 = try (do eIf <- expr1 + reservedOp "?" + eThen <- expr1 + reservedOp ":" + eElse <- expr1 + ss <- getState + case expand ss eIf of + Error err -> return $ Error err + Literal si i -> return $ if (i/=0) then expandWith ss si eThen + else expandWith ss si eElse + ) <|> expr1 + where expandWith ss si t = case expand (mapS show si `joinS` ss) t of + Error err -> Error err + Literal si' i -> Literal (si `joinS` si') i + +expr :: AP Term +expr = buildExpressionParser table2 expr2 -- short circuit + +term :: AP Term +term = parens expr + <|> fmap (Literal [] . fromIntegral) natural + <|> fmap Variable identifier + "simple expression" + +-- Type depends on which parsec we're using... +table1 :: OperatorTable Char SS Term +#ifdef HAVE_PARSEC_POSTFIX +table1 = [ [postfix "++" $ postinc (+1), postfix "--" $ postinc (+(-1))] + , [prefix "+" $ e1 id, prefix "-" $ e1 negate] + , [prefix "++" $ preinc (+1), prefix "--" $ preinc (+(-1))] +#else +table1 = [ [prefix "+" $ e1 id, prefix "-" $ e1 negate] +#endif + , [prefix "~" $ e1 complement,prefix "!" $ e1 $ b2i . not . i2b] + , [binary "*" $ e2 (*), binary "/" $ e2 div, binary "%" $ e2 mod] + , [binary "+" $ e2 (+), binary "-" $ e2 (-)] + , [binary "<<" $ e2 shiftL, binary ">>" $ e2 shiftR] + , [binary "<" $ e2 $ b2i .: (<), binary "<=" $ e2 $ b2i .: (<=) + ,binary ">" $ e2 $ b2i .: (>), binary ">=" $ e2 $ b2i .: (>=) + ,binary "==" $ e2 $ b2i .: (==), binary "!=" $ e2 $ b2i .: (/=)] + , [binary "&" $ e2 (.&.)] + , [binary "^" $ e2 xor] + , [binary "|" $ e2 (.|.)] + , [binary "&&" $ e2 $ b2 (&&)] + , [binary "||" $ e2 $ b2 (||)] ] + where e1 :: (Int -> Int) -> AP (Term -> Term) + e1 f = do ss <- getState + return $ mapT f . expand ss + e2 :: (Int -> Int -> Int) -> AP (Term -> Term -> Term) + e2 f = do ss <- getState + return $ \t1 t2 -> mapT2 f (expand ss t1) (expand ss t2) + b2 :: (Bool -> Bool -> Bool) -> Int -> Int -> Int + b2 f i j = b2i $ f (i2b i) (i2b j) + i2b i = if i==0 then False else True + b2i b = if b then 1 else 0 + (.:) f g a b = f $ g a b -- (c -> d) -> (a -> b -> c) -> a -> b -> d + ro name = try (reservedOp name >> notFollowedBy (char '=')) + binary name fun = Infix (ro name >> fun) AssocLeft + prefix name fun = Prefix (reservedOp name >> fun) +#ifdef HAVE_PARSEC_POSTFIX + postfix name fun = Postfix (ro name >> fun) +#endif + +expand :: SS -> Term -> Term +expand _ (Error err) = Error err +expand _ (Literal s i) = Literal s i +expand subs (Variable name) = + case lookup name subs of + Nothing -> Literal [] 0 + Just s -> case runMathParser subs s of + Left err -> Error err + Right (i,si) -> Literal si i + +postinc,preinc :: (Int -> Int) -> AP (Term -> Term) +postinc f = assignReturn $ \i -> (f i,i) +preinc f = assignReturn $ \i -> (f i,f i) + +assignReturn' :: SS -> SI -> (Int -> (Int,Int)) -> (Term -> Term) +assignReturn' ss si f = ar + where ar (Error err) = Error err + ar (Literal _ i) = Error $ "assignment to non-variable: "++show i + ar (Variable v) = let val = fromMaybe "0" $ lookup v ss + in case runMathParser ss val of + Left err -> Error err + Right (i,si') -> + let (ass,ret) = f i + si'' = [(v,ass)] `joinS` si' `joinS` si + in Literal si'' ret + +assignReturn :: (Int -> (Int,Int)) -> AP (Term -> Term) +assignReturn f = do ss <- getState + return $ assignReturn' ss [] f + +assignReturn2 :: (Int -> Int -> Int) -> AP (Term -> Term -> Term) +assignReturn2 f = ar `fmap` getState + where ar ss t t' = let t'' = expand ss t' + in case t'' of + Error err -> Error err + Literal si j -> + assignReturn' ss si (\i -> (f i j,f i j)) t + +-- In between these: the ternary operator... + +--table2 :: OperatorTable Char SS Int +table2 = [ [op "=" $ flip const, op "*=" (*), op "/=" div + ,op "%=" mod, op "+=" (+), op "-=" (-)] + , [op "<<=" shiftL, op ">>=" shiftR + ,op "&=" (.&.), op "^=" xor, op "|=" (.|.)] ] + where a2 :: (Int -> Int -> Int) -> AP (Term -> Term -> Term) + a2 = assignReturn2 + op name fun = Infix (reservedOp name >> a2 fun) AssocLeft + -- a2's first Term MUST be a string... (else "assignment to non-variable") + + + +-- operators: +-- endTok = (`elem` " \t\r\n()+*-/%^|&") diff --git a/Language/Sh/Compat.hs b/Language/Sh/Compat.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Compat.hs @@ -0,0 +1,12 @@ +module Language.Sh.Compat ( on, (<=<) ) where + +-- |This module just defines functions that aren't in ghc-6.6. +-- Once 6.6 falls out of debian stable, we can switch to just importing +-- them from base. For this reason, we mustn't expose this module! + +-- |This is in Data.Function, starting in 6.8 +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +on f g a a' = g a `f` g a' + +(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c +(<=<) g f a = f a >>= g diff --git a/Language/Sh/Expansion.hs b/Language/Sh/Expansion.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Expansion.hs @@ -0,0 +1,295 @@ +-- |This is the expansion module. It provides an interface for a monad +-- in which expansions can happen, and then defines the expansions. + +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(..) ) -- , Glob, GlobChar(..) ) + +import Language.Sh.Arithmetic ( runMathParser ) + +data ExpansionFunctions m = ExpansionFunctions { + getAllEnv :: m [(String,String)], + setEnv :: String -> String -> m (), + homeDir :: String -> m (Maybe String), -- default: return . Just + expandGlob :: Word -> m [FilePath], + commandSub :: [Command] -> m String, + positionals :: m [String] -- maybe we want to just have getEnv...? + } + +-- |This is a private monad we use to pass around the functions... +type Exp m = ReaderT (ExpansionFunctions m) m + +-- |And here's the easiest way to use them... +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 + +-- |Helper functions to define these accessors +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) + + +-- |This is a default function that basically treats globs as literals. +noGlobExpansion :: Monad m => Word -> m [String] +noGlobExpansion _ = return [] +{- +noGlobExpansion :: (Monad m,Functor m) => Word -> m [String] +noGlobExpansion x = do s <- nge x + return [s] + where nge [] = return [] + nge (Lit c:gs) = (c:) `fmap` nge gs + nge (One:gs) = ('?':) `fmap` nge gs + nge (Many:gs) = ('*':) `fmap` nge gs + nge (OneOf cs:gs) = (\s->'[':cs++']':s) `fmap` nge gs + nge (NoneOf cs:gs) = (\s->"[^"++cs++']':s) `fmap` nge gs +-} + +-- |We have one main sticking point here... in the case of @A=*@, we want +-- to use expandWord, and do the glob expansion. In the case of @>*@, we +-- want to /try/ the glob expansion and then given an error in the case +-- that we get multiple hits. We could make one more expansion function? +-- (expandNoAmbiguousGlob?) +expand :: (Monad m,Functor m) => ExpansionFunctions m -> [Word] -> m [String] +expand fs ws = runReaderT (expandE ws) fs + + +-- |Test: A=1\ \ * --> A=1 ... -> so it's getting expand'ed/joined, and not +-- expandWord'ed. For now, we'll leave globs out of this function, but it +-- seems like maybe the only use is in redirects, so then we can make this +-- the one that doesn't allow ambiguity. Also, we know that glob expansion +-- comes after field splitting... (B=\ \ ; A=2$B*) +-- Tricky: A="3$B*"; echo $A --> looks silly, but echo "$A"... +expandWord :: (Monad m,Functor m) => ExpansionFunctions m -> Word -> m String +expandWord fs w = runReaderT (expandWordE w) fs + +-- |This is a version of expandWord that doesn't deal with globs or remove +-- quotes! It's currently only used in case statements. +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 <=< + +-- |First step: tilde expansion. +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 -- don't need other case + +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 + +-- |Parameter expansion +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 -- if w then use that as message... + Nothing -> fail $ n++": undefined or null" + Just v' -> return v' + '+' -> return $ maybe mempty (const w) v + '#' -> do r <- expand' w -- expandPatternE + return $ fromStr q $ removePrefix c r $ toStr v + '%' -> do r <- expand' w -- expandPatternE + 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 + --e _ x = fail $ "Expansion "++show x++" not yet implemented" + removeNewlines = reverse . dropWhile (`elem`"\r\n") . reverse + toStr = removeQuotes . fromMaybe [] -- ${@#...} should map over words + fromStr = quoteLiteral -- but it's technically undefined so no worry + +-- crap - need to fully expand all letters...? + +arithExpand :: Monad m => String -> Exp m String +arithExpand s = fmap show $ doMath s + +-- This doesn't work with ++ and -- operators.....? +-- there's no postfix in parsec2... (but we could do it by hand in term parser) +-- this is a bit broken maybe... +-- plan: first clean up any unexpected tokens (\, #, etc) after +-- an initial expansion run. +-- maybe do real passes of group-words, expand, repeat...? +-- what to do with variables...? +-- dash has a much simpler arithexp than bash.. in particular, +-- a=5+10 +-- echo $((++a)) +-- echo $((a)) -- even this fails in dash... +-- echo $((2*$a*4)) -- 50 in both... $-expansion comes first +-- echo $((2*a*4)) -- 120 in bash... so this expansion is LATER +-- b=c +-- c=10 +-- echo $((++b)) +-- ------> dash doesn't even support ++ at all...! + +{- +expandLetters :: String -> Exp m String +expandLetters [] = return [] +expandLetters cs | not $ null name = do e <- fromMaybe "" `fmap` getEnv name + return $ expandLetters $ + name:expandLetters rest + | otherwise = do let (a,b) = break endTok cs + (a',b') = span endTok cs + rest <- expandLetters b' + return $ a'++a''++rest + where (name,rest) = spanName cs + spanName (x:xs) | isAlpha x || x=='_' = let (c,rest)=span isANU xs + in (x:c,rest) + spanName xs = ([],xs) -- not a name + isANU x = isAlphaNum x || x=='_' + endTok = (`elem` " \t\r\n()+-*/%^|&<>=!~?:") -- lots of operators... +-} + +-- one possibility: perform all expansions by encasing first in parens? +-- BUT... a=\(; b=\); echo $(($a 5+10$b*2)) works in both shells... + +-- |Helper functions... +setEnvW :: (Monad m,Functor m) => String -> Word -> Exp m () -- set a variable +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 + +-- |Helper function for 'getSpecial'. +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 + +-- |Helper function for expansions... The @Bool@ argument is for +-- whether or not we're quoted. +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 [] + +-- |Use @$IFS@ to split fields. +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" + +-- |This always returns a LitWord. +removeQuotes :: Word -> String +removeQuotes [] = "" +removeQuotes (SplitField:xs) = removeQuotes xs -- IFS should already be here +removeQuotes (Quote _:xs) = removeQuotes xs +removeQuotes (Quoted x:xs) = removeQuotes $ x:xs +removeQuotes (Expand _:xs) = undefined -- shouldn't happen +removeQuotes (Literal c:xs) = c:removeQuotes xs + +-- *Math-parsing +-- |We use a stateful parser, keeping track of all the current expansions, +-- as well as all the new assignments we need to make... +-- How can we do the ternary operator with parsec...? its slowness makes +-- it at least somewhat tractable... +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 + +--- diff --git a/Language/Sh/Glob.hs b/Language/Sh/Glob.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Glob.hs @@ -0,0 +1,191 @@ +{-# 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] + _ -> [] diff --git a/Language/Sh/Map.hs b/Language/Sh/Map.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Map.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, + FlexibleInstances #-} + +module Language.Sh.Map ( ExpressionMapperM(..), ExpressionMapper(..) ) where + +import Language.Sh.Syntax +import Control.Monad ( ap ) + +concatMapM :: (Monad m,Functor m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f = fmap concat . mapM f + +-- |I'm lazy and think these look a lot nicer than all the @`fmap`@s and +-- @`ap`@s and @mapM@s all over the place. I've stolen these more or +-- less from 'Control.Applicative' and 'Control.Arrow'. +(<$>) :: Functor m => (a -> b) -> m a -> m b +(<$>) = fmap +(<*>) :: Monad m => m (a -> b) -> m a -> m b +(<*>) = ap +(<>) :: Monad m => (a -> m b) -> [a] -> m [b] +(<>) = mapM +(><>) :: (Monad m,Functor m) => (a -> m [b]) -> [a] -> m [b] +(><>) = concatMapM +(<***>) :: Monad m => (a -> m c) -> (b -> m d) -> (a,b) -> m (c,d) +(<***>) f g (a,b) = do a' <- f a + b' <- g b + return (a',b') +infixl 4 <$>,<*> +infixl 7 <>,><> +infixr 3 <***> + + +-- |The idea here is to prevent duplicating code needlessly. +-- We could go even more extreme and make a third parameter, but +-- then we have WAY too many instances, and they all depend on +-- every other one anyway... +-- class Applicative a => ExpressionMapper a f t where +-- mapSh :: f -> t -> a t + +class (Monad m,Functor m) => ExpressionMapperM m f | f -> m where + mapCommandsM :: f -> [Command] -> m [Command] + mapCommandsM = defaultMapCommandsM + defaultMapCommandsM :: f -> [Command] -> m [Command] + defaultMapCommandsM f = mapM $ mapCommandM f + + mapCommandM :: f -> Command -> m Command + mapCommandM = defaultMapCommandM + defaultMapCommandM :: f -> Command -> m Command + defaultMapCommandM f (Synchronous l) = Synchronous <$> mapListM f l + defaultMapCommandM f (Asynchronous l) = Asynchronous <$> mapListM f l + + mapListM :: f -> AndOrList -> m AndOrList + mapListM = defaultMapListM + defaultMapListM :: f -> AndOrList -> m AndOrList + defaultMapListM f (Singleton p) = Singleton <$> mapPipelineM f p + defaultMapListM f (l :&&: p) = (:&&:) <$> mapListM f l + <*> mapPipelineM f p + defaultMapListM f (l :||: p) = (:||:) <$> mapListM f l + <*> mapPipelineM f p + + mapPipelineM :: f -> Pipeline -> m Pipeline + mapPipelineM = defaultMapPipelineM + defaultMapPipelineM :: f -> Pipeline -> m Pipeline + defaultMapPipelineM f (Pipeline ps) = Pipeline <$> mapStatementM f <> ps + defaultMapPipelineM f (BangPipeline ps) = BangPipeline <$> + mapStatementM f <> ps + + -- do we want mapStatementsM? + mapStatementM :: f -> Statement -> m Statement + mapStatementM = defaultMapStatementM + defaultMapStatementM :: f -> Statement -> m Statement + defaultMapStatementM f (Statement ws rs as) + = Statement <$> mapWordM f <> ws -- plural? + <*> mapRedirM f <> rs <*> mapAssignmentM f <> as + defaultMapStatementM f (OrderedStatement ts) + = OrderedStatement <$> mapTermsM f ><> ts + defaultMapStatementM f (Compound c rs) + = Compound <$> mapCompoundM f c <*> mapRedirM f <> rs + defaultMapStatementM f (FunctionDefinition s c rs) + = FunctionDefinition s <$> mapCompoundM f c <*> mapRedirM f <> rs + + mapCompoundM :: f -> CompoundStatement -> m CompoundStatement + mapCompoundM = defaultMapCompoundM + defaultMapCompoundM :: f -> CompoundStatement -> m CompoundStatement + defaultMapCompoundM f (For s ss cs') = For s <$> mapWordM f <> ss + <*> mapCommandsM f cs' + defaultMapCompoundM f (While cond code) = While <$> mapCommandsM f cond + <*> mapCommandsM f code + defaultMapCompoundM f (Until cond code) = Until <$> mapCommandsM f cond + <*> mapCommandsM f code + defaultMapCompoundM f (If cond thn els) + = If <$> mapCommandsM f cond <*> mapCommandsM f thn + <*> mapCommandsM f els + defaultMapCompoundM f (Case expr cases) + = Case <$> mapWordM f expr + <*> ((mapWordM f <>) <***> mapCommandsM f) <> cases + defaultMapCompoundM f (Subshell cs) = Subshell <$> mapCommandsM f cs + defaultMapCompoundM f (BraceGroup cs) = BraceGroup <$> mapCommandsM f cs + + mapTermsM :: f -> Term -> m [Term] + mapTermsM = defaultMapTermsM + defaultMapTermsM :: f -> Term -> m [Term] + defaultMapTermsM f t = replicate 1 <$> mapTermM f t + + mapTermM :: f -> Term -> m Term + mapTermM = defaultMapTermM + defaultMapTermM :: f -> Term -> m Term + defaultMapTermM f (TWord w) = TWord <$> mapWordM f w + defaultMapTermM f (TRedir r) = TRedir <$> mapRedirM f r + defaultMapTermM f (TAssignment a) = TAssignment <$> mapAssignmentM f a + + mapWordM :: f -> Word -> m Word + mapWordM = defaultMapWordM + defaultMapWordM :: f -> Word -> m Word + defaultMapWordM f = concatMapM $ mapLexemesM f + + mapLexemesM :: f -> Lexeme -> m [Lexeme] + mapLexemesM = defaultMapLexemesM + defaultMapLexemesM :: f -> Lexeme -> m [Lexeme] + defaultMapLexemesM f l = replicate 1 <$> mapLexemeM f l + + mapLexemeM :: f -> Lexeme -> m Lexeme + mapLexemeM = defaultMapLexemeM + defaultMapLexemeM :: f -> Lexeme -> m Lexeme + defaultMapLexemeM f (Quoted lexeme) = Quoted <$> mapLexemeM f lexeme + defaultMapLexemeM f (Expand xp) = Expand <$> mapExpansionM f xp + defaultMapLexemeM _ lexeme = return lexeme + + mapExpansionM :: f -> Expansion -> m Expansion + mapExpansionM = defaultMapExpansionM + defaultMapExpansionM :: f -> Expansion -> m Expansion + defaultMapExpansionM f (ModifiedExpansion s c b w) + = ModifiedExpansion s c b <$> mapWordM f w + defaultMapExpansionM f (CommandSub cs) = CommandSub <$> mapCommandsM f cs + defaultMapExpansionM f (Arithmetic w) = Arithmetic <$> mapWordM f w + defaultMapExpansionM _ expansion = return expansion + + mapAssignmentM :: f -> Assignment -> m Assignment + mapAssignmentM = defaultMapAssignmentM + defaultMapAssignmentM :: f -> Assignment -> m Assignment + defaultMapAssignmentM f (s:=w) = (s:=) <$> mapWordM f w + + mapRedirM :: f -> Redir -> m Redir + mapRedirM = defaultMapRedirM + defaultMapRedirM :: f -> Redir -> m Redir + defaultMapRedirM f (n:>w) = (n:>) <$> mapWordM f w + defaultMapRedirM f (n:>|w) = (n:>|) <$> mapWordM f w + defaultMapRedirM f (n:>>w) = (n:>>) <$> mapWordM f w + defaultMapRedirM f (n:<>w) = (n:<>) <$> mapWordM f w + defaultMapRedirM f (n: mapWordM f w + defaultMapRedirM f (Heredoc n c w) = (Heredoc n c) <$> mapWordM f w + defaultMapRedirM _ redir = return redir + +instance (Monad m,Functor m) => ExpressionMapperM m (Command -> m Command) + where mapCommandM f c = defaultMapCommandM f =<< f c + +instance (Monad m,Functor m) => ExpressionMapperM m (AndOrList -> m AndOrList) + where mapListM f l = defaultMapListM f =<< f l + +instance (Monad m,Functor m) => ExpressionMapperM m (Pipeline -> m Pipeline) + where mapPipelineM f p = defaultMapPipelineM f =<< f p + +instance (Monad m,Functor m) => ExpressionMapperM m (Statement -> m Statement) + where mapStatementM f s = defaultMapStatementM f =<< f s + +instance (Monad m,Functor m) + => ExpressionMapperM m (CompoundStatement -> m CompoundStatement) + where mapCompoundM f s = defaultMapCompoundM f =<< f s + +instance (Monad m,Functor m) => ExpressionMapperM m (Word -> m Word) + where mapWordM f w = defaultMapWordM f =<< f w + +instance (Monad m,Functor m) => ExpressionMapperM m (Lexeme -> m Lexeme) + where mapLexemeM f l = defaultMapLexemeM f =<< f l + +instance (Monad m,Functor m) => ExpressionMapperM m (Lexeme -> m [Lexeme]) + where mapLexemesM f l = f =<< defaultMapLexemeM f l + +instance (Monad m,Functor m) => ExpressionMapperM m (Expansion -> m Expansion) + where mapExpansionM f x = defaultMapExpansionM f =<< f x + +instance (Monad m,Functor m) => ExpressionMapperM m (Assignment -> m Assignment) + where mapAssignmentM f a = defaultMapAssignmentM f =<< f a + +instance (Monad m,Functor m) => ExpressionMapperM m (Redir -> m Redir) + where mapRedirM f r = defaultMapRedirM f =<< f r + +($$) = ($) +(!) = map +(>!) = concatMap +(***) f g (a,b) = (f a,g b) +infixl 0 $$ +infixl 7 !, >! +infixr 3 *** + +class ExpressionMapper f where + mapCommands :: f -> [Command] -> [Command] + mapCommands = defaultMapCommands + defaultMapCommands :: f -> [Command] -> [Command] + defaultMapCommands f = map $ mapCommand f + + mapCommand :: f -> Command -> Command + mapCommand = defaultMapCommand + defaultMapCommand :: f -> Command -> Command + defaultMapCommand f (Synchronous l) = Synchronous $ mapList f l + defaultMapCommand f (Asynchronous l) = Asynchronous $ mapList f l + + mapList :: f -> AndOrList -> AndOrList + mapList = defaultMapList + defaultMapList :: f -> AndOrList -> AndOrList + defaultMapList f (Singleton p) = Singleton $ mapPipeline f p + defaultMapList f (l :&&: p) = mapList f l :&&: mapPipeline f p + defaultMapList f (l :||: p) = mapList f l :||: mapPipeline f p + + mapPipeline :: f -> Pipeline -> Pipeline + mapPipeline = defaultMapPipeline + defaultMapPipeline :: f -> Pipeline -> Pipeline + defaultMapPipeline f (Pipeline ps) = Pipeline $ mapStatement f ! ps + defaultMapPipeline f (BangPipeline ps) = BangPipeline $ + mapStatement f ! ps + + -- do we want mapStatementsM? + mapStatement :: f -> Statement -> Statement + mapStatement = defaultMapStatement + defaultMapStatement :: f -> Statement -> Statement + defaultMapStatement f (Statement ws rs as) + = Statement $$ mapWord f ! ws -- plural? + $$ mapRedir f ! rs $$ mapAssignment f ! as + defaultMapStatement f (OrderedStatement ts) + = OrderedStatement $ mapTerms f >! ts + defaultMapStatement f (Compound c rs) + = Compound $$ mapCompound f c $$ mapRedir f ! rs + defaultMapStatement f (FunctionDefinition s c rs) + = FunctionDefinition s $$ mapCompound f c $$ mapRedir f ! rs + + mapCompound :: f -> CompoundStatement -> CompoundStatement + mapCompound = defaultMapCompound + defaultMapCompound :: f -> CompoundStatement -> CompoundStatement + defaultMapCompound f (For s ss cs') = For s $$ mapWord f ! ss + $$ mapCommands f cs' + defaultMapCompound f (While cond code) = While $$ mapCommands f cond + $$ mapCommands f code + defaultMapCompound f (Until cond code) = Until $$ mapCommands f cond + $$ mapCommands f code + defaultMapCompound f (If cond thn els) + = If $$ mapCommands f cond $$ mapCommands f thn $$ mapCommands f els + defaultMapCompound f (Case expr cases) + = Case $$ mapWord f expr $$ ((mapWord f !) *** mapCommands f) ! cases + defaultMapCompound f (Subshell cs) = Subshell $ mapCommands f cs + defaultMapCompound f (BraceGroup cs) = BraceGroup $ mapCommands f cs + + mapTerms :: f -> Term -> [Term] + mapTerms = defaultMapTerms + defaultMapTerms :: f -> Term -> [Term] + defaultMapTerms f t = [mapTerm f t] + + mapTerm :: f -> Term -> Term + mapTerm = defaultMapTerm + defaultMapTerm :: f -> Term -> Term + defaultMapTerm f (TWord w) = TWord $ mapWord f w + defaultMapTerm f (TRedir r) = TRedir $ mapRedir f r + defaultMapTerm f (TAssignment a) = TAssignment $ mapAssignment f a + + mapWord :: f -> Word -> Word + mapWord = defaultMapWord + defaultMapWord :: f -> Word -> Word + defaultMapWord f = concatMap $ mapLexemes f + + mapLexemes :: f -> Lexeme -> [Lexeme] + mapLexemes = defaultMapLexemes + defaultMapLexemes :: f -> Lexeme -> [Lexeme] + defaultMapLexemes f l = [mapLexeme f l] + + mapLexeme :: f -> Lexeme -> Lexeme + mapLexeme = defaultMapLexeme + defaultMapLexeme :: f -> Lexeme -> Lexeme + defaultMapLexeme f (Quoted lexeme) = Quoted $ mapLexeme f lexeme + defaultMapLexeme f (Expand xp) = Expand $ mapExpansion f xp + defaultMapLexeme _ lexeme = lexeme + + mapExpansion :: f -> Expansion -> Expansion + mapExpansion = defaultMapExpansion + defaultMapExpansion :: f -> Expansion -> Expansion + defaultMapExpansion f (ModifiedExpansion s c b w) + = ModifiedExpansion s c b $ mapWord f w + defaultMapExpansion f (CommandSub cs) = CommandSub $ mapCommands f cs + defaultMapExpansion f (Arithmetic w) = Arithmetic $ mapWord f w + defaultMapExpansion _ expansion = expansion + + mapAssignment :: f -> Assignment -> Assignment + mapAssignment = defaultMapAssignment + defaultMapAssignment :: f -> Assignment -> Assignment + defaultMapAssignment f (s:=w) = s := mapWord f w + + mapRedir :: f -> Redir -> Redir + mapRedir = defaultMapRedir + defaultMapRedir :: f -> Redir -> Redir + defaultMapRedir f (n:>w) = n :> mapWord f w + defaultMapRedir f (n:>|w) = n :>| mapWord f w + defaultMapRedir f (n:>>w) = n :>> mapWord f w + defaultMapRedir f (n:<>w) = n :<> mapWord f w + defaultMapRedir f (n: Command) + where mapCommand f c = defaultMapCommand f $ f c + +instance ExpressionMapper (AndOrList -> AndOrList) + where mapList f l = defaultMapList f $ f l + +instance ExpressionMapper (Pipeline -> Pipeline) + where mapPipeline f p = defaultMapPipeline f $ f p + +instance ExpressionMapper (Statement -> Statement) + where mapStatement f s = defaultMapStatement f $ f s + +instance ExpressionMapper (CompoundStatement -> CompoundStatement) + where mapCompound f s = defaultMapCompound f $ f s + +instance ExpressionMapper (Word -> Word) + where mapWord f w = defaultMapWord f $ f w + +instance ExpressionMapper (Lexeme -> Lexeme) + where mapLexeme f l = defaultMapLexeme f $ f l + +instance ExpressionMapper (Lexeme -> [Lexeme]) + where mapLexemes f l = f $ defaultMapLexeme f l + +instance ExpressionMapper (Expansion -> Expansion) + where mapExpansion f x = defaultMapExpansion f $ f x + +instance ExpressionMapper (Assignment -> Assignment) + where mapAssignment f a = defaultMapAssignment f $ f a + +instance ExpressionMapper (Redir -> Redir) + where mapRedir f r = defaultMapRedir f $ f r diff --git a/Language/Sh/Parser.hs b/Language/Sh/Parser.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Parser.hs @@ -0,0 +1,586 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- |Here we use the stuff defined in the AST and Parsec modules +-- to parse things. + +module Language.Sh.Parser ( parse, hereDocsComplete ) where + +import Language.Sh.Parser.Internal +import Language.Sh.Parser.Parsec +import Language.Sh.Syntax +import Language.Sh.Map + +import Language.Sh.Compat ( (<=<) ) + +import Text.ParserCombinators.Parsec.Error ( ParseError ) +import Text.ParserCombinators.Parsec ( choice, manyTill, eof, many1, + skipMany, optional, + (<|>), (), many, try, count, + sepBy1, notFollowedBy, lookAhead, + getInput, setInput, runParser + ) +import Control.Monad ( unless, when, liftM2, ap, guard ) +import Data.List ( (\\) ) +import Data.Char ( isDigit ) +import Data.Maybe ( isJust, catMaybes ) + +import Debug.Trace ( trace ) + +-- We don't actually really need Parsec3 - could adapt that Parsec2 source... +-- Also, this should maybe be a debug switch...? +-- ifdef HAVE_PARSEC3 +-- include "Language/Sh/Parser/safemany.h" +-- endif + +data WordContext = NormalContext | ParameterContext | HereEndContext + deriving ( Enum, Ord, Eq ) + +delimiters :: WordContext -> String +delimiters NormalContext = "&|;<>()# \t\r\n" +delimiters ParameterContext = "}" -- don't delimit spaces yet +delimiters HereEndContext = delimiters NormalContext -- "&|;<>()# \t\r\n" + +lookaheadNormalDelimiter :: P () +lookaheadNormalDelimiter = lookAhead $ + oneOf (delimiters NormalContext) >> return () + +cnewline :: P () +cnewline = do newline <|> (do char '#' + skipMany (noneOf "\n\r") + newline <|> eof) "" + spaces + +eatNewlines :: P a -> P a +eatNewlines a = do a' <- a + newlines + return a' + +statement :: P Statement +statement = do aliasOn + choice [try $ do name <- basicName + spaces >> char '(' >> spaces + char ')' <|> unexpectedNoEOF + spaces >> newlines -- optional + FunctionDefinition name + `fmap` compoundStatement + `ap` many redirection + ,Compound `fmap` compoundStatement `ap` many redirection + ,do s <- statementNoSS + case s of -- needed to prevent errors w/ 'many' + OrderedStatement [] -> fail "empty statement" + s -> return s + ] + +-- Once we know we don't have a subshell... +-- We could probably wrap these into one function, since there's a fair +-- amount of repitition here... +statementNoSS :: P Statement +statementNoSS = do aliasOn + choice [expandAlias >> statementNoSS + ,try $ do a <- assignment + fmap (addAssignment a) statementNoSS + ,try $ do r <- redirection + fmap (addRedirection r) statementNoSS + ,simpleStatement] + +simpleStatement :: P Statement +simpleStatement = choice [expandAlias >> simpleStatement + ,try $ do r <- redirection + fmap (addRedirection r) simpleStatement + ,try $ do w <- word NormalContext + fmap (addWord w) simpleStatement + ,return $ OrderedStatement []] + +expandAlias :: P () -- lookAhead +expandAlias = try $ do (aok,as,ip) <- getAliasInfo + unless aok $ fail "" + a <- many $ noneOf "\\\"'()|&;<> \t\r\n" -- correct set? + case lookup a as of + Nothing -> fail "" + Just s -> injectAlias a s as ip + +-- |We do some weird (scary) stuff here... in particular, we inject +-- the control codes /after/ the first character in the stream, which +-- must have been a delimiter of some sort. This is so that /all/ the +-- sub-expansions that occur here will stack properly and /not/ consume +-- the @Aliases@ token prematurely, thus permanently losing the outermost +-- alias. I.e. +-- $ alias foo="echo "; alias bar=foo +-- $ foo bar bar +-- If we just inject before @i@ then we end up with "echo echo bar", because +-- the bar expands to "foo\CTRL ..." and then the control codes get eaten +-- up when expanding foo, and that's bad. +injectAlias :: String -> String -> [(String,String)] -> Bool -> P () +injectAlias a s as ip = do i <- getInput + let (h,t) = splitAt 1 i + aOn = if isBlank $ last s + then (Ctl (AliasOn True):) + else id -- don't turn /off/ + setInput $ map Chr s ++ + Ctl (IncPos ip):h ++ + Ctl (Aliases as): + -- These next two may be gratuitous + aOn t + setAliasInfo (True,as\\[(a,s)],False) + unless True $ + do l <- getInput + setInput l -- $ trace ("input: "++show l) l + spaces + +pipeline :: P Pipeline +pipeline = (try $ do reservedWord "!" + fmap BangPipeline $ statement `sepBy1` pipe + ) <|> (fmap Pipeline $ statement `sepBy1` pipe) + +pipe :: P () +pipe = try $ do char '|' + notFollowedBy $ fmap Chr $ char '|' + spaces + +andorlist :: P AndOrList +andorlist = assocL pipeline (try $ (operator "||" >> return (:||:)) + <|> (operator "&&" >> return (:&&:))) + Singleton + +reservedWord :: String -> P String +reservedWord s = try $ do s' <- string s show s + lookaheadNormalDelimiter <|> eof + spaces + return s' + +reservedWord_ :: String -> P () +reservedWord_ s = reservedWord s >> return () + +isOperator :: String -> Bool +isOperator x = x `elem` [">",">>",">|","<","<>","<<","<<-",">&","<&", + "|","||","&","&&",";",";;","(",")"] + +operator :: String -> P String +operator s = try $ do string s + eof <|> (do c <- lookAhead anyChar + guard $ not $ isOperator $ s++[c]) + spaces + return s + +operator_ :: String -> P () +operator_ s = operator s >> return () + +inClause :: P [Word] +inClause = choice [try $ do optional sequentialSep + reservedWord "do" + return defaultIn + ,do newlines + reservedWord "in" <|> unexpected + ws <- many (word NormalContext) + sequentialSep <|> unexpected + reservedWord "do" <|> unexpected + return ws] + where defaultIn = [[Quoted $ Expand $ SimpleExpansion "@"]] + +cases :: P [([Word],[Command])] +cases = manyTill line $ reservedWord "esac" + where line = do ip <- insideParens + if ip then operator_ "(" <|> unexpected + else optional $ operator_ "(" + pats <- word NormalContext `sepBy1` operator "|" + operator ")" <|> unexpectedNoEOF + (cmds,_) <- commandsTill dsemi + return (pats,cmds) + +dsemi :: P String +dsemi = operator ";;" <|> lookAhead (reservedWord "esac") "`;;' or `esac'" + +-- |Parse any of the compound statements: @if@, @for@, subshells, +-- brace groups, ... +compoundStatement :: P CompoundStatement +compoundStatement = choice [do reservedWord "for" + name <- basicName <|> unexpectedNoEOF + vallist <- inClause + (cs,_) <- commandsTill (reservedWord "done") + return $ For name vallist cs + ,do reservedWord "while" + (cond,_) <- commandsTill $ reservedWord "do" + (code,_) <- commandsTill $ reservedWord "done" + return $ While cond code + ,do reservedWord "until" + (cond,_) <- commandsTill $ reservedWord "do" + (code,_) <- commandsTill $ reservedWord "done" + return $ Until cond code + ,do reservedWord "if" + parseIf -- recursive b/c of elif + ,do reservedWord "case" + expr <- word NormalContext <|> unexpectedNoEOF + newlines + reservedWord "in" <|> unexpected + newlines + what <- cases + return $ Case expr what + ,do operator "(" + openParen + cs <- many command + operator ")" <|> unexpected + closeParen + return $ Subshell cs + ,do reservedWord "{" + (cs,_) <- commandsTill $ reservedWord "}" + return $ BraceGroup cs + ] + +parseIf :: P CompoundStatement +parseIf = do (cond,_) <- commandsTill $ reservedWord "then" + (thn,next) <- commandsTill $ choice [reservedWord "elif" + ,reservedWord "else" + ,reservedWord "fi"] + case next of + "else" -> do (els,_) <- commandsTill $ reservedWord "fi" + return $ If cond thn els + "elif" -> do elif <- parseIf + return $ If cond thn $ compound elif + "fi" -> return $ If cond thn [] + where compound x = [Synchronous $ Singleton $ Pipeline [Compound x []]] + +-- |Here is where we need to be careful about parens, at least once we +-- get to the case statements...? + +-- |Also, we can use 'commandTerminator' to substitute heredocs safely because +-- @<<@ are not allowed in non-command arguments to control structures anyway. +-- Note that this code is duplicated in the code for @case@ statements! +command :: P Command +command = do c <- andorlist "list" + t <- commandTerminator "terminator" + return $ if t then Asynchronous c + else Synchronous c + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM cond job = cond >>= (unless `flip` job) + +readHDs :: P () +readHDs = do hd <- nextHereDoc + case hd of + Just s -> readHD s >> readHDs + Nothing -> return () + +sequentialSep :: P () +sequentialSep = choice [operator ";" >> return () + ,cnewline >> readHDs + ,eof >> closeHereDocs -- ? + ,do unlessM insideParens $ fail "" + lookAhead $ operator ")" + return () + ] + >> newlines + +commandTerminator :: P Bool +commandTerminator = (operator "&" >> newlines >> return True) + <|> (sequentialSep >> return False) + <|> (lookAhead (operator_ ";;") >> return False) + "terminator" + +manyTill' :: P a -> P end -> P ([a],end) +manyTill' p end = scan + where scan = do e <- end + return ([],e) + <|> do x <- p + (xs,e) <- scan + return ((x:xs),e) + +-- |Given a delimiter, parses a heredoc and moves the delimiter off the +-- delimiter list and instead replaces the replacement text onto the +-- 'readHereDocs' list. Note that we want to end with a newline, but it's +-- being read by the "till" parser. Instead, we use a 'wPutStrLn' in the +-- 'Shell' module, rather than attempting to add the newline back in here. + +readHD :: String -> P () +readHD delim = popHereDoc =<< manyTill' (dqLex "\\$`") + (choice [try $ do newline + string delim + newline <|> eof + return True + ,eof >> return False]) + +dqLex :: String -> P Lexeme -- input: chars to escape with '\\' +dqLex escape = choice [do char '\\' + choice [newline >> dqLex escape + ,ql `fmap` oneOf escape + ,return $ ql '\\' + ] + ,Quoted `fmap` expansion + ,ql `fmap` anyChar + ] + +-- |Nothing left after command terminator, so turn all the heredocs into +-- empty @False@s. +closeHereDocs :: P () +closeHereDocs = do hd <- nextHereDoc + case hd of + Nothing -> return () + Just _ -> popHereDoc ([],False) >> closeHereDocs + +-- |How can the many cnewline possibly fail...? If spaces end in something +-- else... So we should move over to gobbling spaces after words, rather +-- than before... +newlines :: P () +newlines = (try (skipMany cnewline) <|> return ()) >> spaces + +-- |Parse a single word. We need to take a @String@ input so that +-- we can conditionally end on certain delimiters, e.g. @}@. +-- Note that #()|&<>; are in fact all allowed inside ${A:- }, so +-- we'll need to take them all as inputs. + +word :: WordContext -> P Word +word context = do ip <- insideParens -- ')' below was '('; only mattered in {} + let del = (if ip then (')':) else id) $ delimiters context + w <- fmap concat $ word' del <:> many (word' $ del\\"#") + spaces + return w + where word' :: String -> P Word + word' s = choice [do char '\\' + try (newline >> return []) <|> + do c <- anyChar + return [Quote '\\',ql c] + ,do char '"' + w <- dqWord + char '"' + return $ Quote '"':w++[Quote '"'] + ,do char '\'' + w <- many $ noneOf "\'" + char '\'' + return $ Quote '\'':map ql w++[Quote '\''] + ,do when (context==HereEndContext) $ fail "" + one expansion + ,do c <- noneOf s + return [Literal c] + ] "word" + +dqWord :: P Word +dqWord = fmap concat $ many $ + choice [do char '\\' + choice [newline >> return [] + ,map ql `fmap` one (oneOf "\\$`\"") + ,return $ [ql '\\'] + ] + ,map Quoted `fmap` one expansion + ,map ql `fmap` one (noneOf "\"") + ] + +-- This needs to reject, e.g. "a " but for some reason "${a }" doesn't fail +isName :: String -> Bool +isName s = case parse' [] (try (only name) <|> only (many1 digit)) s of + Right _ -> True + Left _ -> False + +-- dqWord :: P Word +-- dqWord = manyTill (dqLex "\\$`\"") (char '"') + +-- dqLex :: String -> P Lexeme -- input: chars to escape with \ +-- dqLex escape = choice [do char '\\' +-- choice [newline >> dqLex escape +-- ,ql `fmap` oneOf escape +-- ,return $ ql '\\' +-- ] +-- ,Quoted `fmap` expansion +-- ,ql `fmap` anyChar +-- ] + +-- Technically, we're not saving the \ quotes here....... does this matter? + +expansion :: P Lexeme +expansion = + choice [do char '$' + choice [try $ do n <- name + return $ Expand $ SimpleExpansion n + ,do char '{' + choice [do char '#' + n <- many $ noneOf "}" + char '}' + if isName n + then return $ Expand $ LengthExpansion n + else fatal $ + "${#"++n++"}: bad substitution" + ,try $ do n <- name -- many $ noneOf ":-=?+#%" + -- check isName again...? + (c,op) <- modifier + rest <- word ParameterContext + char '}' <|> (char ')' >> unexEOF) + return $ Expand $ + ModifiedExpansion n op c rest + ,do ip <- insideParens + let p = if ip then (')':) else id + n <- many $ noneOf $ p "}" + char '}' <|> (char ')' >> unexEOF) + if isName n + then return $ Expand $ SimpleExpansion n + else fatal $ "${"++n++ + "}: bad substitution"] + ,do char '(' + openParen + l <- choice [do char '(' + a <- arithmetic -- use parenDepth? + return $ Expand a + ,do c <- commands + char ')' + return $ Expand $ CommandSub c] + closeParen + return l + ,return $ Literal '$' + ] + ,do char '`' + s <- fmap catMaybes $ many $ + escape "`$\\" <|> Just `fmap` noneOf "`" + char '`' + (_,as,_) <- getAliasInfo -- cf. bash: alias foo='`foo`' + case parse' as (only commands) s of + Left err -> fatal $ "command substitution: " + ++ show (unFatal err) + Right cs -> return $ Expand $ CommandSub cs + ] + where unexEOF = fatal "unexpected EOF while looking for matching `}'" + modifier = choice [do c <- zeroOne $ char ':' + op <- oneOf "-=?+" + return (not $ null c,op) + ,do op <- oneOf "#%" + c <- zeroOne $ char op + return (not $ null c,op)] + +arithmetic :: P Expansion +arithmetic = do w <- arithWord =<< getParenDepth + return $ Arithmetic $ ql '(':w + +arithWord :: Int -> P Word +arithWord d0 = aw -- now we can forget about d0 + where aw = do d <- getParenDepth + if d==d0-1 + then (char ')' >> openParen >> return []) + <|> (openParen >> aw') + else aw' + aw' :: P Word + aw' = choice [do char '\\' + choice [newline >> aw' + ,liftM2 (:) (ql `fmap` oneOf "\\$`\"") aw' + ,liftM2 (\c r -> ql '\\':ql c:r) anyChar aw'] + ,do { ex <- expansion; fmap (Quoted ex:) aw' } + ,char '(' >> openParen >> (ql '(':) `fmap` aw' + ,char ')' >> closeParen >> (ql ')':) `fmap` aw -- no ' + ,liftM2 (:) (ql `fmap` anyChar) aw' + ] "arithmetic word" + +{- TEST: +$ alias bar=foo +$ alias foo='echo $(bar)' +$ foo +dash: foo: not found +-} + +escape :: String -> P (Maybe Char) +escape s = char '\\' >> choice [newline >> return Nothing + ,Just `fmap` oneOf s + ,return $ Just '\\'] + +name :: P String +name = count 1 (oneOf "@*#?-$!" <|> digit) <|> + alphaUnder <:> many alphaUnderNum + "name" + +basicName :: P String +basicName = token (alphaUnder <:> many alphaUnderNum) "name" + +assignment :: P Assignment +assignment = do var <- basicName "name" + char '=' + val <- fmap concat $ zeroOne $ word NormalContext + return $ var := val + "assignment" + +redirection :: P Redir +redirection = try (do spaces + d <- many digit + o <- redirOperator + spaces + let fd = if null d then Nothing else Just $ read d + if o `elem` ["<<","<<-"] + then do t <- hereEnd + mkHereDoc o fd t + else do t <- word NormalContext + mkRedir o fd t) + "redirection" + +-- |Parse the heredoc delimiter. Technically this is supposed to be a +-- word, but we don't make certain distinctions that @sh@ does (i.e. @$a@ +-- vs @${a}@), so I think we're better off just using a string... +hereEnd :: P String +hereEnd = token $ fromLit `fmap` word HereEndContext + where fromLit [] = "" + fromLit (Quote _:xs) = fromLit xs + fromLit (Quoted q:xs) = fromLit $ q:xs + fromLit (Literal l:xs) = l:fromLit xs + +commands :: P [Command] +commands = do newlines + many command + +commandsTill :: P String -> P ([Command],String) +commandsTill delim = do rest <- getInput + (c,e) <- manyTill' (eatNewlines command) delim + c' <- expandHereDocs c -- may not be exhaustive...? + return (c',e) + +-- The order is wrong here, since we could put the Redir's either before or +-- after the Word's... We'll need to figure something out to deal with that. +-- Easiest would be to just number them or something, and go through one at +-- a time at the end to "de-number" them. + +unorderStatements :: [Command] -> [Command] +unorderStatements = mapCommands f + where f :: Statement -> Statement + f (OrderedStatement ts) = let (ws,rs,as) = f' ts + in Statement ws rs as + f s = s + f' [] = ([],[],[]) + f' (TWord w:ts) = let (ws,rs,as) = f' ts in (w:ws,rs,as) + f' (TRedir r:ts) = let (ws,rs,as) = f' ts in (ws,r:rs,as) + f' (TAssignment a:ts) = let (ws,rs,as) = f' ts in (ws,rs,a:as) + +expandHereDocs :: [Command] -> P [Command] +expandHereDocs c = unorderStatements `fmap` mapCommandsM f c + where f (i :<< s) = mk i id + f (i :<<- s) = mk i stripTabs + f r = return r + stripTabs [] = [] + stripTabs (Literal n:Literal '\t':rest) + | n `elem` "\n\r" = stripTabs (Literal n:rest) + stripTabs (x:xs) = x:stripTabs xs + mk i f = do mwb <- nextHDReplacement + case mwb of -- do we need the Nothing case? (impossible?) + Just (w,b) -> return $ Heredoc i b (f w) + Nothing -> return $ Heredoc i False [] + +-- here's a smart use of the Monad class...! :-) +hereDocsComplete :: [Command] -> Bool +hereDocsComplete = isJust . mapCommandsM complete + where complete r = case r of + (_:<<_) -> Nothing + (_:<<-_) -> Nothing + Heredoc _ False _ -> Nothing + r -> Just r + +-- |Ensures there's an 'eof' after whatever we parse. +only :: P a -> P a +only p = p >>= (\a -> eof >> return a) + +-- |We need to run the parser occasionally from within, so we provide +-- a simpler interface that does all the mapping, etc, for us. +parse' :: [(String,String)] -> P a -> String -> Either ParseError a +parse' as p s = runParser p (startState as) "" (map Chr s) + +-- |This is the main export here. We take a list of aliases for the +-- environment and a @String@ to parse. The return type is @Right +-- [Command]@ if parsing succeeded and @Left (String,Bool)@ upon +-- failure. The @Bool@ is @True@ when the error was fatal/unrecoverable. +parse :: [(String,String)] -- ^list of alises to expand + -> String -- ^input string + -> Either (String,Bool) [Command] +parse as s = case parse' as (only commands >>= expandHereDocs) s of + Left err -> case getFatal err of + Just f -> Left (f,True) + Nothing -> Left (show err,False) + Right cs -> Right cs diff --git a/Language/Sh/Parser/Internal.hs b/Language/Sh/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Parser/Internal.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE PatternGuards #-} + +module Language.Sh.Parser.Internal where + +import Language.Sh.Parser.Parsec +import Language.Sh.Syntax + +import Data.Char ( isDigit ) +import Text.ParserCombinators.Parsec ( choice ) + +impossible = const undefined + +redirOperator :: P String +redirOperator = token $ choice [do char '>' + choice [char '&' >> return ">&" + ,char '>' >> return ">>" + ,char '|' >> return ">|" + ,return ">"] + ,do char '<' + choice [char '&' >> return "<&" + ,do char '<' + choice [char '-' >> return "<<-" + ,return "<<"] + ,char '>' >> return "<>" + ,return "<"]] + +-- |Takes an operator, maybe an int, and a word target. +mkRedir :: String -> Maybe Int -> Word -> P Redir -- need P for fail +mkRedir _ (Just d) _ | d > 255 = fail $ "file descriptor too large: "++show d +mkRedir op@('<':_) Nothing t = mkRedir op (Just 0) t +mkRedir op@('>':_) Nothing t = mkRedir op (Just 1) t -- defaults +mkRedir "<" (Just s) t = return $ s :< t +mkRedir "<&" (Just s) t | Just t' <- wordToInt t = return $ s :<& t' + | otherwise = fail "bad file descriptor" +mkRedir "<>" (Just s) t = return $ s :<> t +mkRedir ">" (Just s) t = return $ s :> t +mkRedir ">&" (Just s) t | Just t' <- wordToInt t = return $ s :>& t' + | otherwise = fail "bad file descriptor" +mkRedir ">>" (Just s) t = return $ s :>> t +mkRedir ">|" (Just s) t = return $ s :>| t + + +mkHereDoc :: String -> Maybe Int -> String -> P Redir -- queues... +mkHereDoc op Nothing t = mkHereDoc op (Just 0) t +mkHereDoc "<<" (Just s) t = do addHereDoc t + return $ s :<< t +mkHereDoc "<<-" (Just s) t = do addHereDoc t + return $ s :<<- t + +wordToInt :: Word -> Maybe Int +wordToInt w = case fromLiteral w of + Just ds | null $ filter (not . isDigit) ds -> Just $ read ds + _ -> Nothing + +addAssignment :: Assignment -> Statement -> Statement +addAssignment a (Statement ws rs as) = Statement ws rs (a:as) +addAssignment a (OrderedStatement ts) = OrderedStatement (TAssignment a:ts) +addAssignment _ (Compound _ _) = impossible "cannot add assignment to Compound" + +addWord :: Word -> Statement -> Statement +addWord w (Statement ws rs as) = Statement (w:ws) rs as +addWord w (OrderedStatement ts) = OrderedStatement (TWord w:ts) +addWord _ (Compound _ _) = impossible "cannot add word to Compound" + +addRedirection :: Redir -> Statement -> Statement +addRedirection r (Statement ws rs as) = Statement ws (r:rs) as +addRedirection r (OrderedStatement ts) = OrderedStatement (TRedir r:ts) +addRedirection r (Compound c rs) = Compound c (r:rs) + +fromLiteral :: Word -> Maybe String +fromLiteral [] = Just [] +fromLiteral (Literal c:cs) = fmap (c:) $ fromLiteral cs +fromLiteral _ = Nothing + +ql :: Char -> Lexeme +ql = Quoted . Literal diff --git a/Language/Sh/Parser/Parsec.hs b/Language/Sh/Parser/Parsec.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Parser/Parsec.hs @@ -0,0 +1,296 @@ +-- |Here we define the interface to 'Parsec', resulting in a +-- 'GenParser' type that behaves much like a stateful 'CharParser', +-- but with the added abstraction of dealing with aliases. + +module Language.Sh.Parser.Parsec where + +import Text.ParserCombinators.Parsec ( GenParser, getState, setState, + tokenPrim, count, (<|>), (), + skipMany, many, eof, + getInput, setInput ) +import Text.ParserCombinators.Parsec.Pos ( updatePosChar ) +import Text.ParserCombinators.Parsec.Error ( ParseError, Message(..), + errorMessages, errorPos, + newErrorMessage ) +import Data.Char ( isUpper, isLower, isAlpha, isAlphaNum, + isDigit, isHexDigit, isOctDigit ) +import Data.Monoid ( Monoid, mappend ) +import Data.Maybe ( listToMaybe ) +import Control.Monad ( unless, when ) +import Debug.Trace ( trace ) + +import Language.Sh.Syntax ( Word ) + +-- |Generalized @Char@. +data MChar = Ctl Control | Chr Char + +instance Show MChar where + show (Ctl (AliasOn b)) = "AliasOn "++show b + show (Ctl (Aliases s)) = "Aliases "++show s + show (Ctl (IncPos b)) = "IncPos "++show b + show (Chr c) = show c + +-- |We need to intersperse control codes with the @Char@s. These +-- will have monadic actions, but will not affect the 'uncons'. +data Control = AliasOn Bool + | Aliases [(String,String)] + | IncPos Bool -- ^turn on/off SourcePos counting. + +-- instance Show Control where show _ = "" + +-- |Much-reduced state to keep track of. +data ParserState = PS { aliasOK :: Bool + , aliases :: [(String,String)] + , incPos :: Bool + , parenDepth :: Int + , hereDocs :: [String] + , readHereDocs :: [(Word,Bool)] } + +type P = GenParser MChar ParserState + +startState :: [(String,String)] -> ParserState +startState as = PS True as True 0 [] [] + +modify :: (ParserState -> ParserState) -> P () +modify f = setState =<< fmap f getState + +getAliasInfo :: P (Bool, [(String,String)], Bool) +getAliasInfo = fmap (\(PS a b c _ _ _) -> (a,b,c)) getState + +setAliasInfo :: (Bool, [(String,String)], Bool) -> P () +setAliasInfo (a,b,c) = modify $ \(PS _ _ _ d h h') -> PS a b c d h h' + +insideParens :: P Bool +insideParens = fmap (\s -> parenDepth s > 0) getState + +openParen :: P () +openParen = modify $ \s -> s { parenDepth = parenDepth s+1 } + +closeParen :: P () +closeParen = modify $ \s -> s { parenDepth = parenDepth s-1 } + +getParenDepth :: P Int +getParenDepth = fmap parenDepth getState + +addHereDoc :: String -> P () +addHereDoc d = modify $ \s -> s { hereDocs = hereDocs s ++ [d] } + +nextHereDoc :: P (Maybe String) +nextHereDoc = fmap (listToMaybe . hereDocs) getState + +popHereDoc :: (Word,Bool) -> P () +popHereDoc (w,b) = modify $ \s -> s { hereDocs = drop 1 $ hereDocs s + , readHereDocs = readHereDocs s ++ [(w,b)] } + +nextHDReplacement :: P (Maybe (Word,Bool)) +nextHDReplacement = do rhd <- readHereDocs `fmap` getState + case rhd of + (next:rest) -> do modify $ + \s -> s { readHereDocs = rest } + return $ Just next + [] -> return Nothing + +fatal :: String -> P a +fatal = fail . ('!':) + +getFatal :: ParseError -> Maybe String +getFatal e = listToMaybe $ filter (not . null) $ map isFatal $ errorMessages e + where isFatal (Message ('!':s)) = s + isFatal _ = "" + +unFatal :: ParseError -> ParseError +unFatal e = case getFatal e of + Just s -> newErrorMessage (Message s) (errorPos e) + Nothing -> e + +-- fatal :: String -> P a +-- fatal err = do modify $ \s -> s { fatalError = True } +-- fail err + +-- isFatal :: P Bool +-- isFatal = fmap fatalError getState + +-- |This is a useful combinator. +infixl 3 <++>, <:> +(<++>) :: Monoid w => GenParser i s w -> GenParser i s w -> GenParser i s w +a <++> b = do w <- a + w' <- b + return $ w `mappend` w' + +(<:>) :: GenParser i s a -> GenParser i s [a] -> GenParser i s [a] +a <:> b = do w <- a + w' <- b + return $ w:w' + +tr :: Show a => String -> P a -> P a +tr s p = do a <- p + return $ trace (s++": "++show a) a +--catMany :: Show a => P [a] -> P [a] +--catMany = fmap concat . many . tr "catMany" + +-- * Here we re-implement much of Text.Parsec.Char +oneOf :: [Char] -> P Char +oneOf cs = satisfy' ("oneOf: "++show cs) (\c -> elem c cs) + +noneOf :: [Char] -> P Char +noneOf cs = satisfy' ("noneOf: "++show cs) (\c -> not (elem c cs)) + +spaces :: P () +spaces = skipMany space "white space" + +space :: P Char +space = satisfy' ("space") isBlank "space" + +space_ :: P () +space_ = space >> return () + +isBlank :: Char -> Bool +isBlank = (`elem` " \t") + +one :: P a -> P [a] +one = sequence . replicate 1 + +zeroOne :: P a -> P [a] +zeroOne p = one p <|> return [] + +newline :: P () -- how does this affect SourcePos? +newline = (count 1 (char '\n') >> zeroOne (char '\r') >> return ()) <|> + (count 1 (char '\r') >> zeroOne (char '\n') >> return ()) + "newline" + +tab :: P Char +tab = char '\t' "tab" + +upper :: P Char +upper = satisfy isUpper "uppercase letter" + +lower :: P Char +lower = satisfy isLower "lowercase letter" + +alphaNum :: P Char +alphaNum = satisfy' "alphaNum" isAlphaNum "letter or digit" + +alphaUnder :: P Char +alphaUnder = satisfy' "alphaUnder" (\c -> isAlpha c || c=='_') "letter or underscore" + +alphaUnderNum :: P Char +alphaUnderNum = satisfy' "alphaUnderNum" (\c -> isAlphaNum c || c=='_') + "letter, number, or underscore" + +letter :: P Char +letter = satisfy' "alpha" isAlpha "letter" + +digit :: P Char +digit = satisfy' "digit" isDigit "digit" + +hexDigit :: P Char +hexDigit = satisfy' "hexDigit" isHexDigit "hexadecimal digit" + +octDigit :: P Char +octDigit = satisfy' "octDigit" isOctDigit "octal digit" + +char :: Char -> P Char +char c = satisfy' ("char: "++show c) (==c) show [c] + +anyChar :: P Char +anyChar = satisfy' "anyChar" (const True) + +satisfy' :: String -> (Char -> Bool) -> P Char +-- satisfy' m f = satisfy'' True $ trace m f +satisfy' _ = satisfy'' False + +-- |This is where all the real work is done... we just make sure +-- to always call everything in terms of @satisfy@ now. +-- This seems to be a bit broken... I think we need to read +-- the @Ctl@ tokens immediately along with anything else, so that +-- @Consumed@ will be accurate... + +-- The other option, I guess, would be to use a type +-- @data MChar = MChar [Control] Char@ +-- and then just stack the control codes on either the space or else +-- the next eligible letter. + +satisfy = satisfy'' False + +-- This is for debugging... +satisfy'' :: Bool -> (Char -> Bool) -> P Char +satisfy'' v f = do ip <- incPos `fmap` getState + let update = if ip then updatePosChar else const + c <- tokenPrim showToken (nextpos update) test + unless (isBlank c) $ modify $ \s -> s { aliasOK = False } + runCtls v + return c + where showToken (Chr c) = show c + nextpos u p (Chr c) _ = u p c + test (Chr c) = if f c then Just c else Nothing + +runCtls :: Bool -> P () +runCtls v = getInput >>= run >>= setInput + where run [] = return [] + run (Ctl a:xs) = act a >> run xs + run xs = return xs + act (AliasOn b) = modify $ t "AliasOn" b $ \s -> s { aliasOK = b } + act (Aliases as) = modify $ t "Aliases" as $ \s -> s { aliases = as } + act (IncPos b) = modify $ t "IncPos" b $ \s -> s { incPos = b } + t s x = if v then trace (s++": "++show x) else id + +-- From the source, it appears the state gets threaded through <|> correctly. +-- i.e. (setState ... >> fail ...) <|> (return ()) +-- -> doesn't change the state (since that's bound up with reading) + +aliasOn :: P () +aliasOn = modify $ \s -> s { aliasOK = True } + +string :: String -> P String +string [] = return [] +string (c:cs) = do c <- char c + fmap (c:) $ string cs -- errors should work correctly... + +schar :: Char -> P Char +schar c = do x <- char c + spaces + return x + +-- *More general functions + +assocL :: P a -> P (b -> a -> b) -> (a -> b) -> P b +assocL p op single = do x <- p + rest $ single x + where rest x = do f <- op + y <- p + rest (f x y) + <|> return x + +getInput' :: P String +getInput' = do ts <- getInput + return $ concatMap f ts + where f (Chr c) = [c] + f _ = [] + +tok :: Char -> String +tok c | c `elem` "\n\r" = "newline" + | otherwise = [c] + +-- |Parse spaces afterwards +token :: P a -> P a +token p = do p' <- p + spaces + return p' + +unexpectedToken :: P a +unexpectedToken = do s <- getInput' + when (null s) $ err '\n' + err (head s) + where err c = fatal $ "syntax error near unexpected token `"++tok c++"'" + +putBack :: Char -> P () +--putBack c = setInput =<< ((Chr c:) `fmap` getInput) +putBack c = do i <- getInput + setInput $ Chr c:trace ("putting back a "++[c]++": "++show i) i + +-- |This version allows a newline/eof without being fatal. +unexpected :: P a +unexpected = (anyChar >>= putBack >> unexpectedToken) <|> fail "" + +unexpectedNoEOF :: P a +unexpectedNoEOF = unexpected diff --git a/Language/Sh/Syntax.hs b/Language/Sh/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Syntax.hs @@ -0,0 +1,102 @@ +-- |Here we define the /complete/ abstract syntax tree for +-- simple and compound statements. + +module Language.Sh.Syntax where + +-- *The statement level and above +data Command = Synchronous AndOrList + | Asynchronous AndOrList + deriving ( Show ) +data AndOrList = Singleton Pipeline + | AndOrList :&&: Pipeline + | AndOrList :||: Pipeline + deriving ( Show ) +data Pipeline = Pipeline [Statement] -- explicit type-level non-null? + | BangPipeline [Statement] + deriving ( Show ) +data Term = TWord Word + | TRedir Redir + | TAssignment Assignment -- internal only + deriving ( Show ) +data Statement = Statement [Word] [Redir] [Assignment] + | Compound CompoundStatement [Redir] + | FunctionDefinition String CompoundStatement [Redir] + | OrderedStatement [Term] -- internal only + deriving ( Show ) +data CompoundStatement = For String [Word] [Command] + | While [Command] [Command] + | Until [Command] [Command] + | If [Command] [Command] [Command] -- etc... + | Case Word [([Word],[Command])] + | Subshell [Command] + | BraceGroup [Command] + deriving ( Show ) + +-- *The word level and below +type Word = [Lexeme] +data Lexeme = Literal Char | Quote Char + | Expand Expansion | Quoted Lexeme + | SplitField -- this one should never come from parsing + deriving ( Show ) + +-- data ExpansionType = SimpleExpansion | LengthExpansion +-- | OneParameterExpansion String Word +-- | TwoParameterExpansion String Word Word +-- data Expansion = ParameterExpansion ExpansionType String +-- | CommandSub [Command] +-- | Arithmetic Word +-- deriving ( Show ) + +-- |An expansion. The first three are all variable expansions. The +-- 'ModifiedExpansion' in particular also keeps track of which operation +-- it is to perform. The 'Char' can be any of @"-+=?#%"@ and the 'Bool' +-- says whether it was paired with a @':'@ in the case of the first four +-- or doubled in the case of the latter two. This isn't a very good +-- data structure, but I hesitate to add 12 more algebraic types, one for +-- each type of expansion. It would be elegant to use a function +-- parameter here, but then we lose our data-ness and it makes it difficult +-- to be @Show@. We could use a data class that has functions and is +-- also @Show@ and can be pretty-printed, and this would allow arbitrary +-- generalizability, but do we really want this? It needs to be parsed +-- anyway. The other question is the @bash@ extensions: do we parse for +-- @/@ or should it be an error? Is there a way to prevent it optionally? +data Expansion = SimpleExpansion String + | ModifiedExpansion String Char Bool Word + | LengthExpansion String + | CommandSub [Command] + | Arithmetic Word + deriving ( Show ) +data Redir = Int :> Word -- tests show that expansions don't lose spaces + | Int :>| Word -- i.e. $ A='abc def' + | Int :>& Int -- $ echo 1 > $A # target is 'abc def' + | Int :>> Word + | Int :<> Word + | Int :< Word + | Int :<& Int + | Int :<< String + | Int :<<- String + | Heredoc Int Bool Word -- ^filled in version...? + deriving ( Show ) +data Assignment = String := Word + deriving ( Show ) + +--data GlobChar = Lit Char | One | Many | OneOf String | NoneOf String +--type Glob = [GlobChar] + +{- Heredoc test: +$ a=$(echo -e '\t\ta') +$ echo "$a" +-e a +$ a=$(echo '\t\ta') +$ echo "$a" + a +$ cat < $a +> EOF + a +$ cat <<-EOF +> $a +> EOF + a +-----> so tab removal occurs at parse time, NOT at expansion time +-} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/language-sh.cabal b/language-sh.cabal new file mode 100644 --- /dev/null +++ b/language-sh.cabal @@ -0,0 +1,38 @@ +name: language-sh +version: 0.0.3 +synopsis: A package for parsing shell scripts +description: + Language.Sh is a collection of modules for parsing and + manipulating expressions in shell grammar. + This is part of a larger project, shsh. + Please note that the API is somewhat unstable until we + reach version 1.0. + +category: Language +license: BSD3 +license-file: LICENSE +author: Stephen Hicks +maintainer: Stephen Hicks +homepage: http://code.haskell.org/shsh/ +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Language.Sh.Arithmetic + Language.Sh.Expansion + Language.Sh.Glob + Language.Sh.Map + Language.Sh.Parser + Language.Sh.Syntax + other-modules: Language.Sh.Parser.Internal + Language.Sh.Parser.Parsec + Language.Sh.Compat + build-depends: base < 4 && >=3, + directory >= 1.0 && < 1.1, + filepath >= 1.1 && < 1.2, + mtl >= 1.1 && < 1.2, + parsec >= 2.1 && < 3, + pcre-light >= 0.2 && < 0.4 + extensions: CPP + ghc-options: -threaded + cpp-options: -DHAVE_PARSEC_POSTFIX