Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

80 lines (64 sloc) 2.662 kB
{-# LANGUAGE RecordWildCards, ViewPatterns, FlexibleInstances, MultiParamTypeClasses #-}
import Text.Parsec
import qualified Text.Parsec.Token as T
import Text.Parsec.Token (GenLanguageDef(..), GenTokenParser(TokenParser))
import Text.Parsec.Pos (initialPos, updatePosChar)
import Data.Functor.Identity (Identity(..))
import Control.Applicative hiding ((<|>))
import Control.Monad.Fix (fix)
(</>) :: Monad m => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
p </> q = try p <|> q
infixl 3 </>
type Result d a = Consumed (Reply d () a)
womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a
womp d pos p = fmap runIdentity . runIdentity $ runParsecT p (State d pos ())
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
myLanguageDef :: Monad m => T.GenLanguageDef D u m
myLanguageDef = T.LanguageDef
{ commentStart = "{-"
, commentEnd = "-}"
, commentLine = "--"
, nestedComments = True
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> oneOf "_'"
, opStart = opLetter myLanguageDef
, opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
, reservedOpNames = []
, reservedNames = []
, caseSensitive = True
}
TokenParser {..} = T.makeTokenParser myLanguageDef
-- * Building a packrat parser with parsec
-- I used to bullseye womp rats in my T-16 back home.
data D = D
{ _add :: Result D Integer
, _mult :: Result D Integer
, _primary :: Result D Integer
, _dec :: Result D Integer
, _uncons :: Maybe (Char, D)
}
instance Monad m => Stream D m Char where
uncons = return . _uncons
add, mult, primary, dec :: Parsec D u Integer
add = rat _add
mult = rat _mult
primary = rat _primary
dec = rat _dec
prep :: SourceName -> String -> D
prep n = go (initialPos n) where
go p s = fix $ \d -> let
(womp d p -> _add) = (+) <$> mult <* reservedOp "+" <*> add </> mult <?> "summand"
(womp d p -> _mult) = (*) <$> primary <* reservedOp "*" <*> mult </> primary <?> "factor"
(womp d p -> _primary) = parens add </> dec <?> "number"
(womp d p -> _dec) = natural
_uncons = case s of
(x:xs) -> Just (x, go (updatePosChar p x) xs)
[] -> Nothing
in D { .. }
runD :: Parsec D u a -> u -> SourceName -> String -> Either ParseError a
runD p u fn s = runParser p u fn (prep fn s)
eval :: String -> Integer
eval s = either (error . show) id $ runD (whiteSpace *> add <* eof) () "-" s
Jump to Line
Something went wrong with that request. Please try again.