{-# LANGUAGE
FlexibleContexts
, FlexibleInstances
, LambdaCase
, CPP
, MultiParamTypeClasses
, PatternGuards
, RecordWildCards
#-}
module Language.Bash.Parse.Internal
(
D
, pack
, satisfying
, I.skipSpace
, anyWord
, word
, reservedWord
, unreservedWord
, assignBuiltin
, ioDesc
, name
, anyOperator
, operator
, assign
, arith
, heredocWord
) where
#if __GLASGOW_HASKELL__ >= 710
import Prelude hiding (Word)
#endif
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.Error
import Text.Parsec.Prim hiding ((<|>), token)
import Text.Parsec.Pos
import qualified Language.Bash.Parse.Word as I
import Language.Bash.Pretty
import Language.Bash.Syntax
import Language.Bash.Word
type Result d a = Consumed (Reply d () a)
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
womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a
womp d pos p = fmap runIdentity . runIdentity $
runParsecT p (State d pos ())
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
patch (State _ pos _) (Left e) = Empty (Error (setErrorPos pos e))
patch s (Right r) = Empty (Ok r s (unknownError s))
data Token
= TWord Word
| TIODesc IODesc
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
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 {..}
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)
reservedWords :: [Word]
reservedWords = map stringToWord
[ "!", "[[", "]]", "{", "}"
, "if", "then", "else", "elif", "fi"
, "case", "esac", "for", "select", "while", "until"
, "in", "do", "done", "time", "function"
]
assignBuiltins :: [Word]
assignBuiltins = map stringToWord
[ "alias", "declare", "export", "eval"
, "let", "local", "readonly", "typeset"
]
operators :: [String]
operators =
[ "(", ")", ";;", ";&", ";;&"
, "|", "|&", "||", "&&", ";", "&", "\n"
, "<", ">", ">|", ">>", "&>", "&>>", "<<<", "<&", ">&", "<>"
, "<<", "<<-"
]
descriptor :: Stream s m Char => ParsecT s u m IODesc
descriptor = IONumber . read <$> many1 digit
<|> IOVar <$ char '{' <*> I.name <* char '}'
token :: Monad m => ParsecT D u m Token
token = try (rat _token) <?> "token"
anyWord :: Monad m => ParsecT D u m Word
anyWord = try (rat _anyWord) <?> "word"
word :: Monad m => String -> ParsecT D u m Word
word w = anyWord `satisfying` (== stringToWord w) <?> prettyText w
reservedWord :: Monad m => ParsecT D u m Word
reservedWord = anyWord `satisfying` (`elem` reservedWords) <?> "reserved word"
unreservedWord :: Monad m => ParsecT D u m Word
unreservedWord = anyWord `satisfying` (`notElem` reservedWords)
<?> "unreserved word"
assignBuiltin :: Monad m => ParsecT D u m Word
assignBuiltin = anyWord `satisfying` (`elem` assignBuiltins)
<?> "assignment builtin"
ioDesc :: Monad m => ParsecT D u m IODesc
ioDesc = try (rat _ioDesc) <?> "IO descriptor"
name :: Monad m => ParsecT D u m String
name = (prettyText <$> unreservedWord) `satisfying` isName <?> "name"
where
isName s = case parse (I.name <* eof) "" (prettyText s) of
Left _ -> False
Right _ -> True
anyOperator :: Monad m => ParsecT D u m String
anyOperator = try (rat _anyOperator) <?> "operator"
operator :: Monad m => String -> ParsecT D u m String
operator op = anyOperator `satisfying` (== op) <?> op
assign :: Monad m => ParsecT D u m Assign
assign = try (rat _assign) <?> "assignment"
arith :: Monad m => ParsecT D u m String
arith = try (string "((") *> I.arith <* string "))" <* I.skipSpace
<?> "arithmetic expression"
heredocWord :: Monad m => String -> ParsecT s u m Word
heredocWord = reparse I.heredocWord