module Wumpus.Basic.Utils.TokenParsers
(
LexemeParser
, spaceLexemeParser
, spaceCharLexemeParser
, commentLexemeParser
, commentLineLexemeParser
, commentMultiLexemeParser
, lexeme
, whiteSpace
, octBase
, octHask
, hexBase
, natural
, integer
, double
) where
import Wumpus.Basic.Utils.ParserCombinators
import Control.Applicative
newtype LexemeParser = LexemeParser { getLexemeParser :: CharParser () }
spaceLexemeParser :: LexemeParser
spaceLexemeParser = LexemeParser go
where
go = () <$ many space
spaceCharLexemeParser :: [Char] -> LexemeParser
spaceCharLexemeParser cs = LexemeParser go
where
go = skipMany (oneOf cs)
commentLexemeParser :: String -> (String,String) -> [Char] -> LexemeParser
commentLexemeParser line (start,end) cs = LexemeParser go
where
go = skipMany (whiteChar <|> lineComment line
<|> spanComment start end)
whiteChar = skipOne (oneOf cs)
commentLineLexemeParser :: String -> [Char] -> LexemeParser
commentLineLexemeParser start cs = LexemeParser go
where
go = skipMany (whiteChar <|> lineComment start)
whiteChar = skipOne (oneOf cs)
commentMultiLexemeParser :: String -> String -> [Char] -> LexemeParser
commentMultiLexemeParser start end cs = LexemeParser go
where
go = skipMany (whiteChar <|> spanComment start end)
whiteChar = skipOne (oneOf cs)
lineComment :: String -> CharParser ()
lineComment start =
skipOne (string start *> manyTill anyChar endLine)
spanComment :: String -> String -> CharParser ()
spanComment start end =
string start *> manyTill anyChar (string end) *> return ()
endLine :: CharParser ()
endLine = skipOne (char '\n') <|> eof
lexeme :: LexemeParser -> CharParser a -> CharParser a
lexeme trail p = p <* getLexemeParser trail
whiteSpace :: LexemeParser -> CharParser ()
whiteSpace = getLexemeParser
octBase :: CharParser Int
octBase = (\cs -> read $ '0':'o':cs) <$> many1 octDigit
octHask :: CharParser Int
octHask = (string "0o" <|> string "0O") *> octBase
hexBase :: CharParser Int
hexBase = (\xs -> read $ '0':'x':xs) <$> many1 hexDigit
natural :: CharParser Integer
natural = liftA read (many1 digit)
integer :: CharParser Integer
integer = ($) <$> psign <*> natural
where
psign = option id (negate <$ char '-')
double :: CharParser Double
double = (\signf intpart fracpart -> signf $ intpart + fracpart)
<$> psign <*> onatural <*> ofrac
where
psign = option id (negate <$ char '-')
onatural = option 0 (fromIntegral <$> natural)
ofrac = option 0 ((\xs -> read $ '.':xs) <$> (char '.' *> (many1 digit)))