language-sh (empty) → 0.0.3
raw patch · 12 files changed
+2178/−0 lines, 12 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, mtl, parsec, pcre-light
Files
- LICENSE +27/−0
- Language/Sh/Arithmetic.hs +216/−0
- Language/Sh/Compat.hs +12/−0
- Language/Sh/Expansion.hs +295/−0
- Language/Sh/Glob.hs +191/−0
- Language/Sh/Map.hs +336/−0
- Language/Sh/Parser.hs +586/−0
- Language/Sh/Parser/Internal.hs +76/−0
- Language/Sh/Parser/Parsec.hs +296/−0
- Language/Sh/Syntax.hs +102/−0
- Setup.hs +3/−0
- language-sh.cabal +38/−0
+ LICENSE view
@@ -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.
+ Language/Sh/Arithmetic.hs view
@@ -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()+*-/%^|&")
+ Language/Sh/Compat.hs view
@@ -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
+ Language/Sh/Expansion.hs view
@@ -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++---
+ Language/Sh/Glob.hs view
@@ -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]+ _ -> []
+ Language/Sh/Map.hs view
@@ -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:<w) = (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:<w) = n :< mapWord f w+ defaultMapRedir f (Heredoc n c w) = Heredoc n c $ mapWord f w+ defaultMapRedir _ redir = redir++instance ExpressionMapper (Command -> 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
+ Language/Sh/Parser.hs view
@@ -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
+ Language/Sh/Parser/Internal.hs view
@@ -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
+ Language/Sh/Parser/Parsec.hs view
@@ -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
+ Language/Sh/Syntax.hs view
@@ -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 <<EOF+> $a+> EOF+ a+$ cat <<-EOF+> $a+> EOF+ a+-----> so tab removal occurs at parse time, NOT at expansion time+-}
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ language-sh.cabal view
@@ -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 <sdh33@cornell.edu>+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