language-bash 0.3.1 → 0.5.0
raw patch · 9 files changed
+1116/−564 lines, 9 files
Files
- language-bash.cabal +6/−4
- src/Language/Bash/Cond.hs +118/−12
- src/Language/Bash/Operator.hs +3/−2
- src/Language/Bash/Parse.hs +36/−41
- src/Language/Bash/Parse/Internal.hs +183/−158
- src/Language/Bash/Parse/Packrat.hs +0/−203
- src/Language/Bash/Parse/Word.hs +359/−0
- src/Language/Bash/Syntax.hs +149/−144
- src/Language/Bash/Word.hs +262/−0
language-bash.cabal view
@@ -1,5 +1,5 @@ name: language-bash-version: 0.3.1+version: 0.5.0 category: Language license: BSD3 license-file: LICENSE@@ -12,7 +12,8 @@ bug-reports: http://github.com/knrafto/language-bash/issues synopsis: Parsing and pretty-printing Bash shell scripts description:- A library for parsing and pretty-printing Bash shell scripts.+ A library for parsing, pretty-printing, and manipulating+ Bash shell scripts. extra-source-files: .gitignore@@ -28,14 +29,15 @@ exposed-modules: Language.Bash.Cond Language.Bash.Parse- Language.Bash.Parse.Builder+ Language.Bash.Parse.Word Language.Bash.Pretty Language.Bash.Syntax+ Language.Bash.Word other-modules: Language.Bash.Operator+ Language.Bash.Parse.Builder Language.Bash.Parse.Internal- Language.Bash.Parse.Packrat build-depends: base >= 4 && < 5,
src/Language/Bash/Cond.hs view
@@ -1,30 +1,43 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE+ DeriveFoldable+ , DeriveFunctor+ , DeriveTraversable+ , OverloadedStrings+ #-} -- | Bash conditional commands. module Language.Bash.Cond ( CondExpr(..) , UnaryOp(..) , BinaryOp(..)+ , parseTestExpr ) where -import Text.PrettyPrint+import Prelude hiding (negate) +import Control.Applicative+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+import Text.Parsec hiding ((<|>), token)+import Text.Parsec.Expr hiding (Operator)+import Text.PrettyPrint hiding (parens)+ import Language.Bash.Operator import Language.Bash.Pretty -- | Bash conditional expressions.-data CondExpr- = Unary UnaryOp String- | Binary String BinaryOp String- | Not CondExpr- | And CondExpr CondExpr- | Or CondExpr CondExpr- deriving (Eq, Read, Show)+data CondExpr a+ = Unary UnaryOp a+ | Binary a BinaryOp a+ | Not (CondExpr a)+ | And (CondExpr a) (CondExpr a)+ | Or (CondExpr a) (CondExpr a)+ deriving (Eq, Read, Show, Functor, Foldable, Traversable) -instance Pretty CondExpr where+instance Pretty a => Pretty (CondExpr a) where pretty = go (0 :: Int) where- go _ (Unary op a) = pretty op <+> text a- go _ (Binary a op b) = text a <+> pretty op <+> text b+ go _ (Unary op a) = pretty op <+> pretty a+ go _ (Binary a op b) = pretty a <+> pretty op <+> pretty b go _ (Not e) = "!" <+> go 2 e go p (And e1 e2) = paren (p > 1) $ go 1 e1 <+> "&&" <+> go 1 e2 go p (Or e1 e2) = paren (p > 0) $ go 0 e1 <+> "||" <+> go 0 e2@@ -99,3 +112,96 @@ instance Pretty BinaryOp where pretty = prettyOperator++-- | A parser over lists of strings.+type Parser = Parsec [String] ()++-- | Parse a token.+token :: (String -> Maybe a) -> Parser a+token = tokenPrim show (\pos _ _ -> pos)++-- | Parse a specific word.+word :: String -> Parser String+word s = token (\t -> if t == s then Just s else Nothing) <?> s++-- | Parse any word.+anyWord :: Parser String+anyWord = token Just++-- | Parse in parentheses.+parens :: Parser a -> Parser a+parens p = word "(" *> p <* word ")"++-- | Parse a nullary expression+nullaryExpr :: Parser (CondExpr String)+nullaryExpr = Unary NonzeroString <$> anyWord++-- | Parse a unary expression.+unaryExpr :: Parser (CondExpr String)+unaryExpr = Unary <$> select word unaryOps <*> anyWord+ <?> "unary expression"+ where+ unaryOps = filter ((`notElem` ["-a", "-o"]) . snd) operatorTable++-- | Parse a standalone unary expression.+standaloneUnaryExpr :: Parser (CondExpr String)+standaloneUnaryExpr = Unary <$> selectOperator word <*> anyWord+ <?> "unary expression"++-- | Parse a binary expression.+binaryExpr :: Parser (CondExpr String)+binaryExpr = Binary <$> anyWord <*> select word binaryOps <*> anyWord+ <?> "binary expression"+ where+ binaryOps = filter ((/= "=~") . snd) operatorTable++-- | Parse a binary @-a@ or @-o@ expression.+binaryAndOrExpr :: Parser (CondExpr String)+binaryAndOrExpr = nullaryExpr <**> andOrOp <*> nullaryExpr+ where+ andOrOp = And <$ word "-a"+ <|> Or <$ word "-o"++-- | Parse a conditional expression.+condExpr :: Parser (CondExpr String)+condExpr = expr+ where+ expr = buildExpressionParser opTable term++ term = parens expr+ <|> unaryExpr+ <|> try binaryExpr+ <|> nullaryExpr++ opTable =+ [ [Prefix (Not <$ word "!")]+ , [Infix (And <$ word "-a") AssocLeft]+ , [Infix (Or <$ word "-o") AssocLeft]+ ]++-- | Parse a conditional expression for the Bash @test@ builtin.+parseTestExpr :: [String] -> Either ParseError (CondExpr String)+parseTestExpr args = parse (testExpr <* eof) "" args+ where+ testExpr = case length args of+ 0 -> fail "no arguments"+ 1 -> oneArg+ 2 -> twoArg+ 3 -> threeArg+ 4 -> fourArg+ _ -> condExpr++ oneArg = nullaryExpr++ twoArg = negate nullaryExpr+ <|> standaloneUnaryExpr++ threeArg = try binaryExpr+ <|> try binaryAndOrExpr+ <|> negate twoArg+ <|> parens nullaryExpr++ fourArg = negate threeArg+ <|> condExpr++ negate p = Not <$ word "!" <*> p
src/Language/Bash/Operator.hs view
@@ -7,7 +7,8 @@ ) where import Control.Applicative-import Text.PrettyPrint hiding (empty)+import Data.Foldable+import Text.PrettyPrint import Language.Bash.Pretty @@ -17,7 +18,7 @@ -- | Select the first element that succeeds from a table. select :: Alternative f => (b -> f c) -> [(a, b)] -> f a-select p = foldr (<|>) empty . map (\(a, b) -> a <$ p b)+select p = asum . map (\(a, b) -> a <$ p b) -- | Select an operator from the 'String' it represents. selectOperator :: (Alternative f, Operator a) => (String -> f c) -> f a
src/Language/Bash/Parse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-} -- | Bash script and input parsing. module Language.Bash.Parse ( parse@@ -16,9 +17,10 @@ import qualified Language.Bash.Cond as Cond import Language.Bash.Operator-import qualified Language.Bash.Parse.Internal as I-import Language.Bash.Parse.Packrat+import Language.Bash.Parse.Internal+import Language.Bash.Pretty import Language.Bash.Syntax+import Language.Bash.Word (Word, fromString, unquote) -- | User state. data U = U { postHeredoc :: Maybe (State D U) }@@ -45,10 +47,6 @@ (?:) :: String -> ParsecT s u m a -> ParsecT s u m a (?:) = flip (<?>) --- | Get the next line of input.-line :: Parser String-line = lookAhead anyChar *> many (satisfy (/= '\n')) <* optional (char '\n')- -- | Parse the next here document. heredoc :: Bool -> String -> Parser String heredoc strip end = "here document" ?: do@@ -67,7 +65,12 @@ s <- getParserState return (h, s) - heredocLines = do+ line = many (satisfy (/= '\n')) <* optional (char '\n')++ heredocLines = [] <$ eof+ <|> nextLine++ nextLine = do l <- process <$> line if l == end then return [] else (l :) <$> heredocLines @@ -105,33 +108,24 @@ <?> "redirection" where normalRedir = do- desc <- optional ioDesc- op <- redirOperator- target <- anyWord- return Redir- { redirDesc = desc- , redirOp = op- , redirTarget = target- }+ redirDesc <- optional ioDesc+ redirOp <- redirOperator+ redirTarget <- anyWord+ return Redir{..} heredocRedir = do- strip <- heredocOperator+ heredocOp <- heredocOperator w <- anyWord- let delim = I.unquote w- h <- heredoc strip delim- return Heredoc- { heredocStrip = strip- , heredocDelim = delim- , heredocDelimQuoted = delim /= w- , hereDocument = h- }-- redirOperator = selectOperator operator- <?> "redirection operator"+ let heredocDelim = unquote w+ heredocDelimQuoted = fromString heredocDelim /= w+ h <- heredoc (heredocOp == HereStrip) heredocDelim+ hereDocument <- if heredocDelimQuoted+ then heredocWord h+ else return (fromString h)+ return Heredoc{..} - heredocOperator = False <$ operator "<<"- <|> True <$ operator "<<-"- <?> "here document operator"+ redirOperator = selectOperator operator <?> "redirection operator"+ heredocOperator = selectOperator operator <?> "here document operator" -- | Skip a list of redirections. redirList :: Parser [Redir]@@ -282,10 +276,7 @@ <* operator ")" <?> "pattern list" - clauseTerm = Break <$ operator ";;"- <|> FallThrough <$ operator ";&"- <|> Continue <$ operator ";;&"- <?> "case clause terminator"+ clauseTerm = selectOperator operator <?> "case clause terminator" -- | Parse a @while@ command. whileCommand :: Parser ShellCommand@@ -361,9 +352,11 @@ , [Infix (Cond.Or <$ operator "||") AssocLeft] ] - condWord = (anyWord <|> anyOperator) `satisfying` (/= "]]") <?> "word"+ condWord = anyWord `satisfying` (/= "]]")+ <|> fromString <$> anyOperator+ <?> "word" - condOperator op = condWord `satisfying` (== op) <?> op+ condOperator op = condWord `satisfying` (== fromString op) <?> op unaryOp = selectOperator condOperator <?> "unary operator" binaryOp = selectOperator condOperator <?> "binary operator"@@ -387,15 +380,17 @@ -- | Parse a function definition. functionDef :: Parser ShellCommand functionDef = functionDef2- </> functionDef1+ <|> functionDef1 <?> "function definition" where- functionDef1 = FunctionDef <$ word "function" <*> anyWord- <* optional functionParens <* newlineList+ functionDef1 = FunctionDef+ <$> try (word "function" *> (prettyText <$> anyWord)+ <* optional functionParens <* newlineList) <*> functionBody - functionDef2 = FunctionDef <$> unreservedWord- <* functionParens <* newlineList+ functionDef2 = FunctionDef+ <$> try ((prettyText <$> unreservedWord)+ <* functionParens <* newlineList) <*> functionBody functionParens = operator "(" <* operator ")"
src/Language/Bash/Parse/Internal.hs view
@@ -1,196 +1,221 @@-{-# LANGUAGE FlexibleContexts #-}--- | Low-level parsers.+{-# LANGUAGE+ FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternGuards+ , RecordWildCards+ #-}+-- | Memoized packrat parsing, inspired by Edward Kmett\'s+-- \"A Parsec Full of Rats\". module Language.Bash.Parse.Internal- ( skipSpace+ ( -- * Packrat parsing+ D+ , pack+ -- * Tokens+ , satisfying+ -- * Whitespace+ , I.skipSpace+ -- * Words+ , anyWord , word- , arith+ , reservedWord+ , unreservedWord+ , assignBuiltin+ , ioDesc , name- , assign+ -- * Operators+ , anyOperator , operator- , unquote+ -- * Assignments+ , assign+ -- * Arithmetic expressions+ , arith+ -- * Here documents+ , heredocWord ) where import Control.Applicative-import Data.Monoid+import Control.Monad+import Data.Function+import Data.Functor.Identity import Text.Parsec.Char-import Text.Parsec.Combinator hiding (optional)-import Text.Parsec.Prim hiding ((<|>), many)-import Text.Parsec.String ()+import Text.Parsec.Combinator hiding (optional)+import Text.Parsec.Error+import Text.Parsec.Prim hiding ((<|>), token)+import Text.Parsec.Pos -import Language.Bash.Parse.Builder (Builder, (<+>))-import qualified Language.Bash.Parse.Builder as B+import qualified Language.Bash.Parse.Word as I+import Language.Bash.Pretty import Language.Bash.Syntax+import Language.Bash.Word --- | @surroundBy p sep@ parses zero or more occurences of @p@, beginning,--- ending, and separated by @sep@.-surroundBy- :: Stream s m t- => ParsecT s u m a- -> ParsecT s u m sep- -> ParsecT s u m [a]-surroundBy p sep = sep *> endBy p sep+-- | A memoized result.+type Result d a = Consumed (Reply d () a) --- | Skip spaces, tabs, and comments.-skipSpace :: Stream s m Char => ParsecT s u m ()-skipSpace = skipMany spaceChar <* optional comment <?> "whitespace"+-- | Build a parser from a field accessor.+rat :: Monad m => (d -> Result d a) -> ParsecT d u m a+rat f = mkPT $ \s0 -> return $+ return . patch s0 <$> f (stateInput s0) where- spaceChar = try (B.string "\\\n")- <|> B.oneOf " \t"-- comment = char '#' *> many (satisfy (/= '\n'))---- | Parse a backslash-escaped sequence.-escape :: Stream s m Char => ParsecT s u m Builder-escape = B.char '\\' <+> B.anyChar---- | Parse a single-quoted string.-singleQuote :: Stream s m Char => ParsecT s u m Builder-singleQuote = B.matchedPair '\'' '\'' empty---- | Parse a double-quoted string.-doubleQuote :: Stream s m Char => ParsecT s u m Builder-doubleQuote = B.matchedPair '"' '"' $ escape <|> backquote <|> dollar---- | Parse an ANSI C string.-ansiQuote :: Stream s m Char => ParsecT s u m Builder-ansiQuote = B.char '$' <+> B.matchedPair '\'' '\'' escape---- | Parse a locale string.-localeQuote :: Stream s m Char => ParsecT s u m Builder-localeQuote = B.char '$' <+> doubleQuote+ patch (State _ _ u) (Ok a (State s p _) err) = Ok a (State s p u) err+ patch _ (Error e) = Error e --- | Parse a backquoted string.-backquote :: Stream s m Char => ParsecT s u m Builder-backquote = B.matchedPair '`' '`' escape+-- | Obtain a result from a stateless parser.+womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a+womp d pos p = fmap runIdentity . runIdentity $+ runParsecT p (State d pos ()) --- | Parse a brace-style parameter expansion, an arithmetic substitution,--- or a command substitution.-dollar :: Stream s m Char => ParsecT s u m Builder-dollar = B.char '$' <+> rest+-- | Run a parser, merging it with another.+reparse :: Stream s m t0 => ParsecT s u m a -> s -> ParsecT t u m a+reparse p input = mkPT $ \s0@(State _ _ u) ->+ (fmap return . patch s0) `liftM` runParserT p u "" input where- rest = braceParameter- <|> try arithSubst- <|> commandSubst- <|> return mempty-- braceParameter = B.matchedPair '{' '}' $- escape- <|> singleQuote- <|> doubleQuote- <|> backquote- <|> dollar+ patch (State _ pos _) (Left e) = Empty (Error (setErrorPos pos e))+ patch s (Right r) = Empty (Ok r s (unknownError s)) - arithSubst = B.string "((" <+> parens <+> B.string "))"+-- | A token.+data Token+ = TWord Word+ | TIODesc IODesc - commandSubst = subst+-- | A stream with memoized results.+data D = D+ { _token :: Result D Token+ , _anyWord :: Result D Word+ , _ioDesc :: Result D IODesc+ , _anyOperator :: Result D String+ , _assign :: Result D Assign+ , _uncons :: Maybe (Char, D)+ } --- | Parse a process substitution.-processSubst :: Stream s m Char => ParsecT s u m Builder-processSubst = B.oneOf "<>" <+> subst+instance Monad m => Stream D m Char where+ uncons = return . _uncons --- | Parse a parenthesized substitution.-subst :: Stream s m Char => ParsecT s u m Builder-subst = B.matchedPair '(' ')' $- subst- <|> B.char '#' <+> B.many (B.satisfy (/= '\n')) <+> B.char '\n'- <|> escape- <|> singleQuote- <|> doubleQuote- <|> backquote- <|> dollar+-- | Create a source from a string.+pack :: SourcePos -> String -> D+pack p s = fix $ \d ->+ let result = womp d p+ _token = result $ do+ t <- I.word+ guard $ not (null t)+ next <- optional (lookAhead anyChar)+ I.skipSpace+ return $ case next of+ Just c | c == '<' || c == '>'+ , Right desc <- parse (descriptor <* eof) "" (prettyText t)+ -> TIODesc desc+ _ -> TWord t+ _anyWord = result $ token >>= \case+ TWord w -> return w+ _ -> empty+ _ioDesc = result $ token >>= \case+ TIODesc desc -> return desc+ _ -> empty+ _anyOperator = result $ I.operator operators <* I.skipSpace+ _assign = result $ I.assign <* I.skipSpace+ _uncons = case s of+ [] -> Nothing+ (x:xs) -> Just (x, pack (updatePosChar p x) xs)+ in D {..} --- | Parse a parenthesized expression.-parens :: Stream s m Char => ParsecT s u m Builder-parens = B.many inner- where- inner = B.matchedPair '(' ')' parens+-- | Parse a value satisfying the predicate.+satisfying+ :: (Stream s m t, Show a)+ => ParsecT s u m a+ -> (a -> Bool)+ -> ParsecT s u m a+satisfying a p = try $ do+ t <- a+ if p t then return t else unexpected (show t) --- | Parse a word part.-wordSpan :: Stream s m Char => ParsecT s u m Builder-wordSpan = mempty <$ try (string "\\\n")- <|> escape- <|> singleQuote- <|> doubleQuote- <|> try ansiQuote- <|> try localeQuote- <|> backquote- <|> dollar- <|> try processSubst+-- | Shell reserved words.+reservedWords :: [Word]+reservedWords =+ [ "!", "[[", "]]", "{", "}"+ , "if", "then", "else", "elif", "fi"+ , "case", "esac", "for", "select", "while", "until"+ , "in", "do", "done", "time", "function"+ ] --- | Parse a word.-word :: Stream s m Char => ParsecT s u m String-word = B.toString <$> B.many wordPart <?> "word"- where- wordPart = wordSpan- <|> B.noneOf " \t\n|&;()<>"+-- | Shell assignment builtins. These builtins can take assignments as+-- arguments.+assignBuiltins :: [Word]+assignBuiltins =+ [ "alias", "declare", "export", "eval"+ , "let", "local", "readonly", "typeset"+ ] --- | Parse an arithmetic expression.-arith :: Stream s m Char => ParsecT s u m String-arith = B.toString <$> parens <?> "arithmetic expression"+-- | All Bash operators.+operators :: [String]+operators =+ [ "(", ")", ";;", ";&", ";;&"+ , "|", "|&", "||", "&&", ";", "&", "\n"+ , "<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"+ , "<<", "<<-"+ ] --- | Parse a name.-name :: Stream s m Char => ParsecT s u m String-name = (:) <$> nameStart <*> many nameLetter- where- nameStart = letter <|> char '_'- nameLetter = alphaNum <|> char '_'+-- | Parse a descriptor.+descriptor :: Stream s m Char => ParsecT s u m IODesc+descriptor = IONumber . read <$> many1 digit+ <|> IOVar <$ char '{' <*> I.name <* char '}' --- | Parse an assignment.-assign :: Stream s m Char => ParsecT s u m Assign-assign = Assign <$> lvalue <*> assignOp <*> rvalue <?> "assignment"- where- lvalue = LValue <$> name <*> optional subscript+-- | Parse a single token.+token :: Monad m => ParsecT D u m Token+token = try (rat _token) <?> "token" - subscript = B.toString <$> B.span '[' ']' wordSpan+-- | Parse any word.+anyWord :: Monad m => ParsecT D u m Word+anyWord = try (rat _anyWord) <?> "word" - assignOp = Equals <$ string "="- <|> PlusEquals <$ string "+="+-- | Parse the given word.+word :: Monad m => Word -> ParsecT D u m Word+word w = anyWord `satisfying` (== w) <?> prettyText w - rvalue = RArray <$ char '(' <*> arrayElems <* char ')'- <|> RValue <$> word+-- | Parse a reversed word.+reservedWord :: Monad m => ParsecT D u m Word+reservedWord = anyWord `satisfying` (`elem` reservedWords) <?> "reserved word" - arrayElems = arrayElem `surroundBy` skipArraySpace+-- | Parse a word that is not reserved.+unreservedWord :: Monad m => ParsecT D u m Word+unreservedWord = anyWord `satisfying` (`notElem` reservedWords)+ <?> "unreserved word" - arrayElem = do- s <- optional (subscript <* char '=')- w <- word- case (s, w) of- (Nothing, "") -> empty- _ -> return (s, w)+-- | Parse an assignment builtin.+assignBuiltin :: Monad m => ParsecT D u m Word+assignBuiltin = anyWord `satisfying` (`elem` assignBuiltins)+ <?> "assignment builtin" - skipArraySpace = char '\n' `surroundBy` skipSpace+-- | Parse a redirection word or number.+ioDesc :: Monad m => ParsecT D u m IODesc+ioDesc = try (rat _ioDesc) <?> "IO descriptor" --- | Parse the longest available operator from a list.-operator :: Stream s m Char => [String] -> ParsecT s u m String-operator ops = go ops <?> "operator"+-- | Parse a variable name.+name :: Monad m => ParsecT D u m String+name = (prettyText <$> unreservedWord) `satisfying` isName <?> "name" where- go xs- | null xs = empty- | "" `elem` xs = try (continue xs) <|> pure ""- | otherwise = continue xs+ isName s = case parse (I.name <* eof) "" (prettyText s) of+ Left _ -> False+ Right _ -> True - continue xs = do- c <- anyChar- (c :) <$> go (prefix c xs)+-- | Parse any operator.+anyOperator :: Monad m => ParsecT D u m String+anyOperator = try (rat _anyOperator) <?> "operator" - prefix c = map tail . filter (\x -> not (null x) && head x == c)+-- | Parse a given operator.+operator :: Monad m => String -> ParsecT D u m String+operator op = anyOperator `satisfying` (== op) <?> op --- | Unquote a word.-unquote :: String -> String-unquote s = case parse unquoteBare s s of- Left _ -> s- Right s' -> B.toString s'- where- unquoteBare = B.many $- try unquoteEscape- <|> try unquoteSingle- <|> try unquoteDouble- <|> try unquoteAnsi- <|> try unquoteLocale- <|> B.anyChar+-- | Parse an assignment.+assign :: Monad m => ParsecT D u m Assign+assign = try (rat _assign) <?> "assignment" - unquoteEscape = char '\\' *> B.anyChar- unquoteSingle = B.span '\'' '\'' empty- unquoteDouble = B.span '\"' '\"' unquoteEscape- unquoteAnsi = char '$' *> B.span '\'' '\'' unquoteEscape- unquoteLocale = char '$' *> unquoteDouble+-- | Parse an arithmetic expression.+arith :: Monad m => ParsecT D u m String+arith = try (string "((") *> I.arith <* string "))" <* I.skipSpace+ <?> "arithmetic expression"++-- | Reparse a here document into a word.+heredocWord :: Monad m => String -> ParsecT s u m Word+heredocWord = reparse I.heredocWord
− src/Language/Bash/Parse/Packrat.hs
@@ -1,203 +0,0 @@-{-# LANGUAGE- FlexibleContexts- , FlexibleInstances- , LambdaCase- , MultiParamTypeClasses- , PatternGuards- , RecordWildCards- #-}--- | Memoized packrat parsing, inspired by Edward Kmett\'s--- \"A Parsec Full of Rats\".-module Language.Bash.Parse.Packrat- ( -- * Packrat parsing- D- , pack- -- * Tokens- , satisfying- -- * Whitespace- , I.skipSpace- -- * Words- , anyWord- , word- , reservedWord- , unreservedWord- , assignBuiltin- , ioDesc- , name- -- * Operators- , anyOperator- , operator- -- * Assignments- , assign- -- * Arithmetic expressions- , arith- ) where--import Control.Applicative-import Control.Monad-import Data.Function-import Data.Functor.Identity-import Text.Parsec.Char-import Text.Parsec.Combinator hiding (optional)-import Text.Parsec.Prim hiding ((<|>), token)-import Text.Parsec.Pos--import qualified Language.Bash.Parse.Internal as I-import Language.Bash.Syntax---- | A memoized result.-type Result d a = Consumed (Reply d () a)---- | Build a parser from a field accessor.-rat :: Monad m => (d -> Result d a) -> ParsecT d u m a-rat f = mkPT $ \s0 -> return $- return . patch s0 <$> f (stateInput s0)- where- patch (State _ _ u) (Ok a (State s p _) err) = Ok a (State s p u) err- patch _ (Error e) = Error e---- | Obtain a result from a stateless parser.-womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a-womp d pos p = fmap runIdentity . runIdentity $- runParsecT p (State d pos ())---- | A token.-data Token- = TWord Word- | TIODesc IODesc---- | A stream with memoized results.-data D = D- { _token :: Result D Token- , _anyWord :: Result D Word- , _ioDesc :: Result D IODesc- , _anyOperator :: Result D String- , _assign :: Result D Assign- , _uncons :: Maybe (Char, D)- }--instance Monad m => Stream D m Char where- uncons = return . _uncons---- | Create a source from a string.-pack :: SourcePos -> String -> D-pack p s = fix $ \d ->- let result = womp d p- _token = result $ do- t <- I.word- guard $ not (null t)- next <- optional (lookAhead anyChar)- I.skipSpace- return $ case next of- Just c | c == '<' || c == '>'- , Right desc <- parse (descriptor <* eof) "" t- -> TIODesc desc- _ -> TWord t- _anyWord = result $ token >>= \case- TWord w -> return w- _ -> empty- _ioDesc = result $ token >>= \case- TIODesc desc -> return desc- _ -> empty- _anyOperator = result $ I.operator operators <* I.skipSpace- _assign = result $ I.assign <* I.skipSpace- _uncons = case s of- [] -> Nothing- (x:xs) -> Just (x, pack (updatePosChar p x) xs)- in D {..}---- | Parse a value satisfying the predicate.-satisfying- :: (Stream s m t, Show a)- => ParsecT s u m a- -> (a -> Bool)- -> ParsecT s u m a-satisfying a p = try $ do- t <- a- if p t then return t else unexpected (show t)---- | Shell reserved words.-reservedWords :: [Word]-reservedWords =- [ "!", "[[", "]]", "{", "}"- , "if", "then", "else", "elif", "fi"- , "case", "esac", "for", "select", "while", "until"- , "in", "do", "done", "time", "function"- ]---- | Shell assignment builtins. These builtins can take assignments as--- arguments.-assignBuiltins :: [Word]-assignBuiltins =- [ "alias", "declare", "export", "eval"- , "let", "local", "readonly", "typeset"- ]---- | All Bash operators.-operators :: [String]-operators =- [ "(", ")", ";;", ";&", ";;&"- , "|", "|&", "||", "&&", ";", "&", "\n"- , "<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"- , "<<", "<<-"- ]---- | Parse a descriptor.-descriptor :: Stream s m Char => ParsecT s u m IODesc-descriptor = IONumber . read <$> many1 digit- <|> IOVar <$ char '{' <*> I.name <* char '}'---- | Parse a single token.-token :: Monad m => ParsecT D u m Token-token = try (rat _token) <?> "token"---- | Parse any word.-anyWord :: Monad m => ParsecT D u m Word-anyWord = try (rat _anyWord) <?> "word"---- | Parse the given word.-word :: Monad m => Word -> ParsecT D u m Word-word w = anyWord `satisfying` (== w) <?> w---- | Parse a reversed word.-reservedWord :: Monad m => ParsecT D u m Word-reservedWord = anyWord `satisfying` (`elem` reservedWords) <?> "reserved word"---- | Parse a word that is not reserved.-unreservedWord :: Monad m => ParsecT D u m Word-unreservedWord = anyWord `satisfying` (`notElem` reservedWords)- <?> "unreserved word"---- | Parse an assignment builtin.-assignBuiltin :: Monad m => ParsecT D u m Word-assignBuiltin = anyWord `satisfying` (`elem` assignBuiltins)- <?> "assignment builtin"---- | Parse a redirection word or number.-ioDesc :: Monad m => ParsecT D u m IODesc-ioDesc = try (rat _ioDesc) <?> "IO descriptor"---- | Parse a variable name.-name :: Monad m => ParsecT D u m String-name = unreservedWord `satisfying` isName <?> "name"- where- isName s = case parse (I.name <* eof) "" s of- Left _ -> False- Right _ -> True---- | Parse any operator.-anyOperator :: Monad m => ParsecT D u m String-anyOperator = try (rat _anyOperator) <?> "operator"---- | Parse a given operator.-operator :: Monad m => String -> ParsecT D u m String-operator op = anyOperator `satisfying` (== op) <?> op---- | Parse an assignment.-assign :: Monad m => ParsecT D u m Assign-assign = try (rat _assign) <?> "assignment"---- | Parse an arithmetic expression.-arith :: Monad m => ParsecT D u m String-arith = try (string "((") *> I.arith <* string "))" <* I.skipSpace- <?> "arithmetic expression"
+ src/Language/Bash/Parse/Word.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE FlexibleContexts, RecordWildCards #-}+-- | Word-level parsers.+module Language.Bash.Parse.Word+ ( skipSpace+ , arith+ , word+ , heredocWord+ , name+ , subscript+ , assign+ , operator+ ) where++import Control.Applicative+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Text.Parsec hiding ((<|>), optional, many)++import Language.Bash.Parse.Builder ((<+>))+import qualified Language.Bash.Parse.Builder as B+import Language.Bash.Pretty+import Language.Bash.Syntax+import Language.Bash.Word++-- | @surroundBy p sep@ parses zero or more occurences of @p@, beginning,+-- ending, and separated by @sep@.+surroundBy+ :: Stream s m t+ => ParsecT s u m a+ -> ParsecT s u m sep+ -> ParsecT s u m [a]+surroundBy p sep = sep *> endBy p sep++-- | @upTo n p@ parses zero to @n@ occurences of @p@.+upTo :: Alternative f => Int -> f a -> f [a]+upTo m p = go m+ where+ go n | n < 0 = empty+ | n == 0 = pure []+ | otherwise = (:) <$> p <*> go (n - 1) <|> pure []++-- | @upTo1 n p@ parses one to @n@ occurences of @p@.+upTo1 :: Alternative f => Int -> f a -> f [a]+upTo1 n p = (:) <$> p <*> upTo (n - 1) p++-- | Parse a span until a delimeter.+spans+ :: Stream s m Char+ => [Char] -- ^ Delimiters+ -> Bool -- ^ Remove escaped newlines+ -> ParsecT s u m Span -- ^ Inner spans+ -> ParsecT s u m Word+spans delims removeEscapedNewline innerSpan = catMaybes <$> many inner+ where+ inner = Nothing <$ escapedNewline+ <|> Just <$> innerSpan+ <|> Just . Char <$> noneOf delims++ escapedNewline = if removeEscapedNewline+ then try (string "\\\n")+ else empty++-- | Parse a matched pair.+matchedPair+ :: Stream s m Char+ => Char -- ^ Start character+ -> Char -- ^ End character+ -> Bool -- ^ Remove escaped newlines+ -> ParsecT s u m Span -- ^ Inner spans+ -> ParsecT s u m Word+matchedPair begin end removeEscapedNewline innerSpan =+ char begin *> spans [end] removeEscapedNewline innerSpan <* char end++-- | Skip spaces, tabs, and comments.+skipSpace :: Stream s m Char => ParsecT s u m ()+skipSpace = skipMany spaceChar <* optional comment <?> "whitespace"+ where+ spaceChar = () <$ try (string "\\\n")+ <|> () <$ oneOf " \t"++ comment = char '#' *> many (satisfy (/= '\n'))++-- | Parse a single-quoted string.+singleQuote :: Stream s m Char => ParsecT s u m Span+singleQuote = Single <$> matchedPair '\'' '\'' False empty++-- | Parse a double-quoted string.+doubleQuote :: Stream s m Char => ParsecT s u m Span+doubleQuote = Double <$> matchedPair '"' '"' True inner+ where+ inner = try (Escape <$ char '\\' <*> oneOf "$\\`\"")+ <|> backquote+ <|> dollar++-- | Parse an ANSI C string.+ansiQuote :: Stream s m Char => ParsecT s u m Span+ansiQuote = ANSIC <$ char '$' <*> matchedPair '\'' '\'' True escape+ where+ escape = try (fromChar <$ char '\\' <*> escapeCode)++ fromChar c | c `elem` "\\\'" = Escape c+ | otherwise = Char c++ escapeCode = charCodes+ <|> char 'x' *> hex 2+ <|> char 'u' *> hex 4+ <|> char 'U' *> hex 8+ <|> oct 3+ <|> char 'c' *> ctrlCodes++ charCodes = codes "abeEfnrtv\\\'\"" "\a\b\ESC\ESC\f\n\r\t\v\\\'\""++ ctrlCodes = '\FS' <$ try (string "\\\\")+ <|> codes "@ABCDEFGHIJKLMOPQRSTUVWXYZ[]^_?"+ ("\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\BS\HT\LF\VT\FF" +++ "\CR\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM" +++ "\SUB\ESC\GS\RS\US\DEL")++ codes chars replacements = try $ do+ c <- anyChar+ case lookup c table of+ Nothing -> unexpected [c]+ Just c' -> return c'+ where+ table = zip chars replacements++ oct n = number n 8 octDigit+ hex n = number n 16 hexDigit++ number maxDigits base baseDigit = do+ digits <- map digitToInt <$> upTo1 maxDigits baseDigit+ let n = foldl' (\x d -> base*x + d) 0 digits+ return $ if n > ord maxBound then '\0' else chr n -- arbitrary++-- | Parse a locale string.+localeQuote :: Stream s m Char => ParsecT s u m Span+localeQuote = Locale <$ char '$' <*> matchedPair '"' '"' True inner+ where+ inner = try (Escape <$ char '\\' <*> oneOf "$\\`\"")+ <|> backquote+ <|> dollar++-- | Parse a backquoted string.+backquote :: Stream s m Char => ParsecT s u m Span+backquote = Backquote <$> matchedPair '`' '`' False escape+ where+ escape = try (Escape <$ char '\\' <*> oneOf "$\\`")++-- | Parse an arithmetic expression.+arith :: Stream s m Char => ParsecT s u m String+arith = B.toString <$> parens <?> "arithmetic expression"+ where+ parens = B.many inner+ inner = B.matchedPair '(' ')' parens++-- | Parse a parenthesized substitution.+subst :: Stream s m Char => ParsecT s u m String+subst = B.toString <$ char '(' <*> B.many parens <* char ')'+ where+ parens = B.char '(' <+> B.many parens <+> B.char ')'+ <|> B.char '#' <+> B.many (B.satisfy (/= '\n')) <+> B.char '\n'+ <|> B.char '\\' <+> B.anyChar+ <|> fromSpan <$> singleQuote+ <|> fromSpan <$> doubleQuote+ <|> fromSpan <$> backquote+ <|> fromSpan <$> dollar+ <|> B.satisfy (/= ')')++ fromSpan = B.fromString . prettyText++-- | Parse a dollar substitution.+dollar :: Stream s m Char => ParsecT s u m Span+dollar = char '$' *> rest+ where+ rest = arithSubst+ <|> commandSubst+ <|> braceSubst+ <|> bareSubst+ <|> pure (Char '$')++ arithSubst = ArithSubst <$ try (string "((") <*> arith <* string "))"+ commandSubst = CommandSubst <$> subst+ braceSubst = ParamSubst <$ char '{' <*> paramSubst <* char '}'++ bareSubst = ParamSubst . Bare <$> bareParam+ where+ bareParam = Parameter <$> bareParamName <*> pure Nothing++ bareParamName = name+ <|> specialName+ <|> (:[]) <$> digit++-- | Parse a parameter substitution.+paramSubst :: Stream s m Char => ParsecT s u m ParamSubst+paramSubst = try prefixSubst+ <|> try indicesSubst+ <|> try lengthSubst+ <|> normalSubst+ where+ param = Parameter <$> name <*> optional subscript+ <|> Parameter <$> many1 digit <*> pure Nothing+ <|> Parameter <$> specialName <*> pure Nothing++ switch c = isJust <$> optional (char c)++ doubled p = do+ a <- p+ d <- fmap isJust . optional . try $ do+ b <- p+ guard (a == b)+ return (a, d)++ direction = Front <$ char '#'+ <|> Back <$ char '%'++ substWord delims = spans delims True inner+ where+ inner = Escape <$ char '\\' <*> anyChar+ <|> singleQuote+ <|> doubleQuote+ <|> backquote+ <|> dollar++ prefixSubst = do+ _ <- char '!'+ prefix <- name+ modifier <- oneOf "*@"+ return Prefix{..}++ indicesSubst = do+ _ <- char '!'+ n <- name+ _ <- char '['+ sub <- oneOf "*@"+ _ <- char ']'+ let parameter = Parameter n (Just [Char sub])+ return Indices{..}++ lengthSubst = do+ _ <- char '#'+ parameter <- param+ return Length {..}++ normalSubst = do+ indirect <- switch '!'+ parameter <- param+ choice . map try $+ [ do testNull <- switch ':'+ altOp <- AltDefault <$ char '-'+ <|> AltAssign <$ char '='+ <|> AltError <$ char '?'+ <|> AltReplace <$ char '+'+ altWord <- substWord "}"+ return Alt{..}+ , do subOffset <- char ':' *> substWord ":}"+ subLength <- option [] (char ':' *> substWord "}")+ return Substring{..}+ , do (deleteDirection, longest) <- doubled direction+ pattern <- substWord "}"+ return Delete{..}+ , do _ <- char '/'+ replaceAll <- switch '/'+ replaceDirection <- optional direction+ pattern <- substWord "/}"+ replacement <- option [] (char '/' *> substWord "}")+ return Replace{..}+ , do (letterCaseOp, convertAll) <- doubled $+ ToLower <$ char ','+ <|> ToUpper <$ char '^'+ pattern <- substWord "}"+ return LetterCase{..}+ , return Brace {..}+ ]++-- | Parse a process substitution.+processSubst :: Stream s m Char => ParsecT s u m Span+processSubst = ProcessSubst <$> processSubstOp <*> subst+ where+ processSubstOp = ProcessIn <$ char '<'+ <|> ProcessOut <$ char '>'++-- | Parse any span that may occur in a word.+wordSpan :: Stream s m Char => ParsecT s u m Span+wordSpan = try (Escape <$ char '\\' <*> anyChar)+ <|> singleQuote+ <|> doubleQuote+ <|> try ansiQuote+ <|> try localeQuote+ <|> backquote+ <|> dollar+ <|> try processSubst++-- | Parse a word.+word :: Stream s m Char => ParsecT s u m Word+word = spans " \t\n$|;()<>" True wordSpan++-- | Parse a here document as a word. This parses substitutions, but not+-- most quoting.+heredocWord :: Stream s m Char => ParsecT s u m Word+heredocWord = spans [] True inner+ where+ inner = try (Escape <$ char '\\' <*> oneOf "$\\`")+ <|> backquote+ <|> dollar++-- | Parse a parameter name.+name :: Stream s m Char => ParsecT s u m String+name = (:) <$> nameStart <*> many nameLetter+ where+ nameStart = letter <|> char '_'+ nameLetter = alphaNum <|> char '_'++-- | Parse a special parameter name.+specialName :: Stream s m Char => ParsecT s u m String+specialName = (:[]) <$> oneOf "*@#?-$!_"++-- | Parse a subscript.+subscript :: Stream s m Char => ParsecT s u m Word+subscript = matchedPair '[' ']' True wordSpan++-- | Parse an assignment.+assign :: Stream s m Char => ParsecT s u m Assign+assign = Assign <$> lvalue <*> assignOp <*> rvalue <?> "assignment"+ where+ lvalue = Parameter <$> name <*> optional subscript++ assignOp = Equals <$ string "="+ <|> PlusEquals <$ string "+="++ rvalue = RArray <$ char '(' <*> arrayElems <* char ')'+ <|> RValue <$> word++ arrayElems = arrayElem `surroundBy` skipArraySpace++ arrayElem = do+ s <- optional (subscript <* char '=')+ w <- word+ case (s, w) of+ (Nothing, []) -> empty+ _ -> return (s, w)++ skipArraySpace = char '\n' `surroundBy` skipSpace++-- | Parse the longest available operator from a list.+operator :: Stream s m Char => [String] -> ParsecT s u m String+operator ops = go ops <?> "operator"+ where+ go xs+ | null xs = empty+ | "" `elem` xs = try (continue xs) <|> pure ""+ | otherwise = continue xs++ continue xs = do+ c <- anyChar+ (c :) <$> go (prefix c xs)++ prefix c = map tail . filter (\x -> not (null x) && head x == c)
src/Language/Bash/Syntax.hs view
@@ -1,18 +1,17 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} -- | Shell script types. module Language.Bash.Syntax- ( -- * Syntax- -- ** Words- Word- , Subscript- -- ** Commands- , Command(..)- , Redir(..)- , IODesc(..)- , RedirOp(..)+ (+ -- * Commands+ Command(..) , ShellCommand(..) , CaseClause(..) , CaseTerm(..)+ -- * Redirections+ , Redir(..)+ , IODesc(..)+ , RedirOp(..)+ , HeredocOp(..) -- * Lists , List(..) , Statement(..)@@ -21,7 +20,6 @@ , Pipeline(..) -- * Assignments , Assign(..)- , LValue(..) , AssignOp(..) , RValue(..) ) where@@ -31,6 +29,7 @@ import Language.Bash.Cond (CondExpr) import Language.Bash.Operator import Language.Bash.Pretty+import Language.Bash.Word -- | Indent by 4 columns. indent :: Pretty a => a -> Doc@@ -40,12 +39,6 @@ doDone :: Pretty a => a -> Doc doDone a = "do" $+$ indent a $+$ "done" --- | A Bash word.-type Word = String---- | A variable subscript @[...]@.-type Subscript = Word- -- | A Bash command with redirections. data Command = Command ShellCommand [Redir] deriving (Eq, Read, Show)@@ -53,121 +46,47 @@ instance Pretty Command where pretty (Command c rs) = pretty c <+> pretty rs --- | A redirection.-data Redir- -- | A redirection.- = Redir- { -- | An optional file descriptor.- redirDesc :: Maybe IODesc- -- | The redirection operator.- , redirOp :: RedirOp- -- | The redirection target.- , redirTarget :: Word- }- -- | A here document.- | Heredoc- { -- | 'True' if the here document was stripped of leading tabs using- -- the @\<\<-@ operator.- heredocStrip :: Bool- -- | The here document delimiter.- , heredocDelim :: String- -- | 'True' if the delimiter was quoted.- , heredocDelimQuoted :: Bool- -- | The document itself.- , hereDocument :: String- }- deriving (Eq, Read, Show)--instance Pretty Redir where- pretty Redir{..} =- pretty redirDesc <> pretty redirOp <> text redirTarget- pretty Heredoc{..} =- text (if heredocStrip then "<<-" else "<<") <>- text (if heredocDelimQuoted- then "'" ++ heredocDelim ++ "'"- else heredocDelim) <> "\n" <>- text hereDocument <> text heredocDelim <> "\n"-- prettyList = foldr f empty- where- f a@Redir{} b = pretty a <+> b- f a@Heredoc{} b = pretty a <> b---- | A redirection file descriptor.-data IODesc- -- | A file descriptor number.- = IONumber Int- -- | A variable @{/varname/}@ to allocate a file descriptor for.- | IOVar String- deriving (Eq, Read, Show)--instance Pretty IODesc where- pretty (IONumber n) = int n- pretty (IOVar n) = "{" <> text n <> "}"---- | A redirection operator.-data RedirOp- = In -- ^ @\<@- | Out -- ^ @\>@- | OutOr -- ^ @\>|@- | Append -- ^ @\>\>@- | AndOut -- ^ @&\>@- | AndAppend -- ^ @&\>\>@- | HereString -- ^ @\<\<\<@- | InAnd -- ^ @\<&@- | OutAnd -- ^ @\>&@- | InOut -- ^ @\<\>@- deriving (Eq, Ord, Read, Show, Enum, Bounded)--instance Operator RedirOp where- operatorTable = zip [minBound .. maxBound]- ["<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"]---- | A redirection operator.-instance Pretty RedirOp where- pretty = prettyOperator- -- | A Bash command. data ShellCommand- -- | A simple command consisting of assignments followed by words.+ -- | A simple command consisting of assignments followed by words. = SimpleCommand [Assign] [Word]- -- | The shell builtins @declare@, @eval@, @export@, @local@, @readonly@,- -- and @typeset@ can accept both assignments and words as arguments.+ -- | The shell builtins @declare@, @eval@, @export@, @local@, @readonly@,+ -- and @typeset@ can accept both assignments and words as arguments. | AssignBuiltin Word [Either Assign Word]- -- | A function name and definition.+ -- | A function name and definition. | FunctionDef String List- -- | A named coprocess.+ -- | A named coprocess. | Coproc String Command- -- | A @(...)@ list, denoting a subshell.+ -- | A @(...)@ list, denoting a subshell. | Subshell List- -- | A @{...}@ list.+ -- | A @{...}@ list. | Group List- -- | An arithmetic expression.+ -- | An arithmetic expression. | Arith String- -- | A Bash @[[...]]@ conditional expression.- | Cond CondExpr- -- | A @for /word/ in /words/@ command. If @in /words/@ is absent,- -- the word list defaults to @\"$\@\"@.+ -- | A Bash @[[...]]@ conditional expression.+ | Cond (CondExpr Word)+ -- | A @for /word/ in /words/@ command. If @in /words/@ is absent,+ -- the word list defaults to @\"$\@\"@. | For Word [Word] List- -- | An arithmetic @for ((...))@ command.+ -- | An arithmetic @for ((...))@ command. | ArithFor String List- -- | A @select /word/ in /words/@ command. If @in /words/@ is absent,- -- the word list defaults to @\"$\@\"@.+ -- | A @select /word/ in /words/@ command. If @in /words/@ is absent,+ -- the word list defaults to @\"$\@\"@. | Select Word [Word] List- -- | A @case@ command.+ -- | A @case@ command. | Case Word [CaseClause]- -- | An @if@ command, with a predicate, consequent, and alternative.- -- @elif@ clauses are parsed as nested @if@ statements.+ -- | An @if@ command, with a predicate, consequent, and alternative.+ -- @elif@ clauses are parsed as nested @if@ statements. | If List List (Maybe List)- -- | An @until@ command.+ -- | An @until@ command. | Until List List- -- | A @while@ command.+ -- | A @while@ command. | While List List deriving (Eq, Read, Show) instance Pretty ShellCommand where pretty (SimpleCommand as ws) = pretty as <+> pretty ws- pretty (AssignBuiltin w args) = text w <+> pretty args+ pretty (AssignBuiltin w args) = pretty w <+> pretty args pretty (FunctionDef name l) = text name <+> "()" $+$ pretty (Group l) pretty (Coproc name c) =@@ -181,13 +100,13 @@ pretty (Cond e) = "[[" <+> pretty e <+> "]]" pretty (For w ws l) =- "for" <+> text w <+> "in" <+> pretty ws <> ";" $+$ doDone l+ "for" <+> pretty w <+> "in" <+> pretty ws <> ";" $+$ doDone l pretty (ArithFor s l) = "for" <+> "((" <> text s <> "))" $+$ doDone l pretty (Select w ws l) =- "select" <+> text w <+> "in" <+> pretty ws <> ";" $+$ doDone l+ "select" <+> pretty w <+> "in" <+> pretty ws <> ";" $+$ doDone l pretty (Case w cs) =- "case" <+> text w <+> "in" $+$ indent cs $+$ "esac"+ "case" <+> pretty w <+> "in" $+$ indent cs $+$ "esac" pretty (If p t f) = "if" <+> pretty p <+> "then" $+$ indent t $+$ pretty (fmap (\l -> "else" $+$ indent l) f) $+$@@ -203,7 +122,7 @@ instance Pretty CaseClause where pretty (CaseClause ps l term) =- hcat (punctuate " | " (map text ps)) <> ")" $+$+ hcat (punctuate " | " (map pretty ps)) <> ")" $+$ indent l $+$ pretty term @@ -214,11 +133,98 @@ | Continue -- ^ @;;&@ deriving (Eq, Ord, Read, Show, Bounded, Enum) +instance Operator CaseTerm where+ operatorTable = zip [minBound .. maxBound] [";;", ";&", ";;&"]+ instance Pretty CaseTerm where- pretty Break = ";;"- pretty FallThrough = ";&"- pretty Continue = ";;&"+ pretty = prettyOperator +-- | A redirection.+data Redir+ -- | A redirection.+ = Redir+ { -- | An optional file descriptor.+ redirDesc :: Maybe IODesc+ -- | The redirection operator.+ , redirOp :: RedirOp+ -- | The redirection target.+ , redirTarget :: Word+ }+ -- | A here document.+ | Heredoc+ { -- | The here document operator.+ heredocOp :: HeredocOp+ -- | The here document delimiter.+ , heredocDelim :: String+ -- | 'True' if the delimiter was quoted.+ , heredocDelimQuoted :: Bool+ -- | The document itself, if the delimiter was quoted, no expansions+ -- are parsed. If the delimiter was not quoted, parameter, arithmetic+ -- and command substitutions take place.+ , hereDocument :: Word+ }+ deriving (Eq, Read, Show)++instance Pretty Redir where+ pretty Redir{..} =+ pretty redirDesc <> pretty redirOp <> pretty redirTarget+ pretty Heredoc{..} =+ pretty heredocOp <>+ text (if heredocDelimQuoted+ then "'" ++ heredocDelim ++ "'"+ else heredocDelim) <> "\n" <>+ pretty hereDocument <> text heredocDelim <> "\n"++ prettyList = foldr f empty+ where+ f a@Redir{} b = pretty a <+> b+ f a@Heredoc{} b = pretty a <> b++-- | A redirection file descriptor.+data IODesc+ -- | A file descriptor number.+ = IONumber Int+ -- | A variable @{/varname/}@ to allocate a file descriptor for.+ | IOVar String+ deriving (Eq, Read, Show)++instance Pretty IODesc where+ pretty (IONumber n) = int n+ pretty (IOVar n) = "{" <> text n <> "}"++-- | A redirection operator.+data RedirOp+ = In -- ^ @\<@+ | Out -- ^ @\>@+ | OutOr -- ^ @\>|@+ | Append -- ^ @\>\>@+ | AndOut -- ^ @&\>@+ | AndAppend -- ^ @&\>\>@+ | HereString -- ^ @\<\<\<@+ | InAnd -- ^ @\<&@+ | OutAnd -- ^ @\>&@+ | InOut -- ^ @\<\>@+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Operator RedirOp where+ operatorTable = zip [minBound .. maxBound]+ ["<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"]++instance Pretty RedirOp where+ pretty = prettyOperator++-- | A here document operator.+data HeredocOp+ = Here -- ^ @\<\<@+ | HereStrip -- ^ @\<\<-@+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Operator HeredocOp where+ operatorTable = zip [Here, HereStrip] ["<<", "<<-"]++instance Pretty HeredocOp where+ pretty = prettyOperator+ -- | A compound list of statements. newtype List = List [Statement] deriving (Eq, Read, Show)@@ -241,23 +247,27 @@ -- | A statement terminator. data ListTerm- -- | The @;@ operator.- = Sequential- -- | The @&@ operator.- | Asynchronous+ = Sequential -- ^ @;@+ | Asynchronous -- ^ @&@ deriving (Eq, Ord, Read, Show, Bounded, Enum) +instance Operator ListTerm where+ operatorTable =+ [ (Sequential , ";" )+ , (Sequential , "\n")+ , (Asynchronous, "&" )+ ]+ instance Pretty ListTerm where- pretty Sequential = ";"- pretty Asynchronous = "&"+ pretty = prettyOperator -- | A right-associative list of pipelines. data AndOr- -- | The last pipeline of a list.+ -- | The last pipeline of a list. = Last Pipeline- -- | An @&&@ construct.+ -- | A @&&@ construct. | And Pipeline AndOr- -- | An @||@ construct.+ -- | A @||@ construct. | Or Pipeline AndOr deriving (Eq, Read, Show) @@ -285,43 +295,38 @@ (if timed then "time" else empty) <+> (if timedPosix then "-p" else empty) <+> (if inverted then "!" else empty) <+>- pretty commands+ hcat (punctuate " | " (map pretty commands)) -- | An assignment.-data Assign = Assign LValue AssignOp RValue+data Assign = Assign Parameter AssignOp RValue deriving (Eq, Read, Show) instance Pretty Assign where pretty (Assign lhs op rhs) = pretty lhs <> pretty op <> pretty rhs --- | The left side of an assignment.-data LValue = LValue String (Maybe Subscript)- deriving (Eq, Read, Show)--instance Pretty LValue where- pretty (LValue name sub) =- text name <> pretty (fmap (\s -> "[" ++ s ++ "]") sub)- -- | An assignment operator. data AssignOp = Equals -- ^ @=@ | PlusEquals -- ^ @+=@ deriving (Eq, Ord, Read, Show, Bounded, Enum) +instance Operator AssignOp where+ operatorTable = zip [Equals, PlusEquals] ["=", "+="]+ instance Pretty AssignOp where- pretty Equals = "="- pretty PlusEquals = "+="+ pretty = prettyOperator -- | The right side of an assignment. data RValue- -- | A simple word.+ -- | A simple word. = RValue Word- -- | An array assignment.- | RArray [(Maybe Subscript, Word)]+ -- | An array assignment, as @(subscript, word)@ pairs.+ | RArray [(Maybe Word, Word)] deriving (Eq, Read, Show) instance Pretty RValue where- pretty (RValue w) = text w+ pretty (RValue w) = pretty w pretty (RArray rs) = "(" <> hsep (map f rs) <> ")" where- f (sub, w) = pretty (fmap (\s -> "[" ++ s ++ "]=") sub) <> text w+ f (Nothing , w) = pretty w+ f (Just sub, w) = "[" <> pretty sub <> "]=" <> pretty w
+ src/Language/Bash/Word.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE+ FlexibleInstances+ , OverloadedStrings+ , RecordWildCards+ , TypeSynonymInstances+ #-}+-- | Bash words and substitutions.+module Language.Bash.Word+ ( + -- * Words+ Word+ , Span(..)+ -- * Parameters+ , Parameter(..)+ , ParamSubst(..)+ , AltOp(..)+ , LetterCaseOp(..)+ , Direction(..)+ -- * Process+ , ProcessSubstOp(..)+ -- * Manipulation+ , fromString+ , unquote+ ) where++import qualified Data.String+import Text.PrettyPrint++import Language.Bash.Operator+import Language.Bash.Pretty++-- | A Bash word, broken up into logical spans.+type Word = [Span]++instance Data.String.IsString Word where+ fromString = fromString++-- | An individual unit of a word.+data Span+ -- | A normal character.+ = Char Char+ -- | An escaped character.+ | Escape Char+ -- | A single-quoted string.+ | Single Word+ -- | A double-quoted string.+ | Double Word+ -- | A ANSI C string.+ | ANSIC Word+ -- | A locale-translated string.+ | Locale Word+ -- | A backquote-style command substitution.+ -- To extract the command string, 'unquote' the word inside.+ | Backquote Word+ -- | A parameter substitution.+ | ParamSubst ParamSubst+ -- | An arithmetic substitution.+ | ArithSubst String+ -- | A command substitution.+ | CommandSubst String+ -- | A process substitution.+ | ProcessSubst ProcessSubstOp String+ deriving (Eq, Read, Show)++instance Pretty Span where+ pretty (Char c) = char c+ pretty (Escape c) = "\\" <> char c+ pretty (Single w) = "\'" <> pretty w <> "\'"+ pretty (Double w) = "\"" <> pretty w <> "\""+ pretty (ANSIC w) = "$\'" <> pretty w <> "\'"+ pretty (Locale w) = "$\"" <> pretty w <> "\""+ pretty (Backquote w) = "`" <> pretty w <> "`"+ pretty (ParamSubst s) = pretty s+ pretty (ArithSubst s) = "$((" <> text s <> "))"+ pretty (CommandSubst s) = "$(" <> text s <> ")"+ pretty (ProcessSubst c s) = pretty c <> "(" <> text s <> ")"++ prettyList = hcat . map pretty++-- | A parameter name an optional subscript.+data Parameter = Parameter String (Maybe Word)+ deriving (Eq, Read, Show)++instance Pretty Parameter where+ pretty (Parameter s sub) = text s <> subscript sub+ where+ subscript Nothing = empty+ subscript (Just w) = "[" <> pretty w <> "]"++-- | A parameter substitution.+data ParamSubst+ = Bare+ { -- | The parameter to substitute.+ parameter :: Parameter+ }+ | Brace+ { -- | Use indirect expansion.+ indirect :: Bool+ , parameter :: Parameter+ }+ | Alt+ { indirect :: Bool+ , parameter :: Parameter+ -- | Test for both existence and null values.+ , testNull :: Bool+ -- | The operator.+ , altOp :: AltOp+ -- | The alternate word.+ , altWord :: Word+ }+ | Substring+ { indirect :: Bool+ , parameter :: Parameter+ -- | The substring offset.+ , subOffset :: Word+ -- | The substring length, if any.+ , subLength :: Word+ }+ | Prefix+ { -- | The variable prefix.+ prefix :: String+ -- | Either @\@@ of @*@.+ , modifier :: Char+ }+ | Indices+ { parameter :: Parameter+ }+ | Length+ { parameter :: Parameter+ }+ | Delete+ { indirect :: Bool+ , parameter :: Parameter+ -- | Replace the longest match instead of the shortest match.+ , longest :: Bool+ -- | Where to delete from.+ , deleteDirection :: Direction+ -- | The replacement pattern.+ , pattern :: Word+ }+ | Replace+ { indirect :: Bool+ , parameter :: Parameter+ -- | Replace all occurences.+ , replaceAll :: Bool+ -- | Where to replace.+ , replaceDirection :: Maybe Direction+ , pattern :: Word+ -- | The replacement string.+ , replacement :: Word+ }+ | LetterCase+ { indirect :: Bool+ , parameter :: Parameter+ -- | Convert to lowercase, not uppercase.+ , letterCaseOp :: LetterCaseOp+ -- | Convert all characters, not only the starts of words.+ , convertAll :: Bool+ , pattern :: Word+ }+ deriving (Eq, Read, Show)++prettyParameter :: Bool -> Parameter -> Doc -> Doc+prettyParameter bang param suffix =+ "${" <> (if bang then "!" else empty) <> pretty param <> suffix <> "}"++twiceWhen :: Bool -> Doc -> Doc+twiceWhen False d = d+twiceWhen True d = d <> d++instance Pretty ParamSubst where+ pretty Bare{..} = "$" <> pretty parameter+ pretty Brace{..} = prettyParameter indirect parameter empty+ pretty Alt{..} = prettyParameter indirect parameter $+ (if testNull then ":" else empty) <>+ pretty altOp <>+ pretty altWord+ pretty Substring{..} = prettyParameter indirect parameter $+ ":" <> pretty subOffset <>+ (if null subLength then empty else ":") <> pretty subLength+ pretty Prefix{..} = "${!" <> text prefix <> char modifier <> "}"+ pretty Indices{..} = prettyParameter True parameter empty+ pretty Length{..} = "${#" <> pretty parameter <> "}"+ pretty Delete{..} = prettyParameter indirect parameter $+ twiceWhen longest (pretty deleteDirection) <>+ pretty pattern+ pretty Replace{..} = prettyParameter indirect parameter $+ "/" <>+ (if replaceAll then "/" else empty) <>+ pretty replaceDirection <>+ pretty pattern <>+ "/" <>+ pretty replacement+ pretty LetterCase{..} = prettyParameter indirect parameter $+ twiceWhen convertAll (pretty letterCaseOp) <>+ pretty pattern++-- | An alternation operator.+data AltOp+ = AltDefault -- ^ '-', ':-'+ | AltAssign -- ^ '=', ':='+ | AltError -- ^ '?', ':?'+ | AltReplace -- ^ '+', ':+'+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Operator AltOp where+ operatorTable = zip [minBound .. maxBound] ["-", "=", "?", "+"]++instance Pretty AltOp where+ pretty = prettyOperator++-- | A letter case operator.+data LetterCaseOp+ = ToLower+ | ToUpper+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Operator LetterCaseOp where+ operatorTable = zip [ToLower, ToUpper] [",", "^"]++instance Pretty LetterCaseOp where+ pretty = prettyOperator++-- | A string direction.+data Direction+ = Front+ | Back+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Pretty Direction where+ pretty Front = "#"+ pretty Back = "%"++-- | A process substitution.+data ProcessSubstOp+ = ProcessIn -- ^ @\<@+ | ProcessOut -- ^ @\>@+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance Operator ProcessSubstOp where+ operatorTable = zip [ProcessIn, ProcessOut] ["<", ">"]++instance Pretty ProcessSubstOp where+ pretty = prettyOperator++-- | Convert a string to an unquoted word.+fromString :: String -> Word+fromString = map Char++-- | Remove all quoting characters from a word.+unquote :: Word -> String+unquote = render . unquoteWord+ where+ unquoteWord = hcat . map unquoteSpan++ unquoteSpan (Char c) = char c+ unquoteSpan (Escape c) = char c+ unquoteSpan (Single w) = unquoteWord w+ unquoteSpan (Double w) = unquoteWord w+ unquoteSpan (ANSIC w) = unquoteWord w+ unquoteSpan (Locale w) = unquoteWord w+ unquoteSpan s = pretty s