Last active
August 29, 2015 14:03
-
-
Save tonosaman/6e5c68f636e889a4cf31 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.Maybe | |
import Control.Applicative | |
import Control.Monad | |
import Data.Char (isSpace, digitToInt) | |
import Debug.Trace | |
main :: IO () | |
main = print . runParser $ "(1+2-3*4)*2" | |
runParser :: String -> Maybe Int | |
runParser s = fmap fst $ msum $ [dvMultitive, dvPrimary, dvDecimal, dvAdditive] <*> [parse s 0] | |
newtype Parser v = Parser (Derivs -> Result v) | |
type Result v = Maybe (v, Derivs) | |
data Derivs = Derivs | |
{ dvAdditive :: Result Int | |
, dvAdditiveSuffix :: Result (Int -> Int) | |
, dvMultitive :: Result Int | |
, dvPrimary :: Result Int | |
, dvDecimal :: Result Int | |
, dvSymbol :: Result Char | |
, dvSpacing :: Result () | |
, dvChar :: Result Char | |
, depth :: Int | |
} | |
instance Monad Parser where | |
(Parser p) >>= f = Parser $ \d -> case p d of | |
Just (v, d') -> let Parser p' = f v in p' d' | |
Nothing -> Nothing | |
return v = Parser $ \d -> Just (v, d) | |
fail msg = Parser $ \d -> Nothing | |
instance MonadPlus Parser where | |
mzero = fail "" | |
Parser p1 `mplus` Parser p2 = Parser $ \d -> case p1 d of | |
r@(Just _) -> r | |
Nothing -> case p2 d of | |
r@(Just _) -> r | |
Nothing -> Nothing | |
(</>) = mplus | |
parse :: String -> Int -> Derivs | |
parse s depth = d where | |
d = Derivs add asuf mult prim dec sym spc chr depth | |
add = trace ("*** Derivs[" ++ (show depth) ++ "] add ***") $ pAdditive d | |
asuf = trace ("*** Derivs[" ++ (show depth) ++ "] asuf ***") $ pAdditiveSuffix d | |
mult = trace ("*** Derivs[" ++ (show depth) ++ "] mult ***") $ pMultitive d | |
prim = trace ("*** Derivs[" ++ (show depth) ++ "] prim ***") $ pPrimary d | |
dec = trace ("*** Derivs[" ++ (show depth) ++ "] dec ***") $ pDecimal d | |
sym = trace ("*** Derivs[" ++ (show depth) ++ "] sym ***") $ pSymbol d | |
spc = trace ("*** Derivs[" ++ (show depth) ++ "] spc ***") $ pSpacing d | |
chr = trace ("*** Derivs[" ++ (show depth) ++ "] chr ***") $ case s of | |
(c:s') -> trace (show c) $ Just (c, parse s' $ depth + 1) | |
[] -> Nothing | |
char :: Char -> Parser Char | |
char c = Parser $ \d -> case dvSymbol d of | |
r@(Just (v, _)) -> if c == v then r else Nothing | |
Nothing -> Nothing | |
pAdditive :: Derivs -> Result Int | |
Parser pAdditive = do | |
l <- Parser dvMultitive | |
f <- Parser dvAdditiveSuffix | |
return $ f l | |
pAdditiveSuffix :: Derivs -> Result (Int -> Int) | |
Parser pAdditiveSuffix = alt1 </> alt2 </> return id | |
where | |
alt1 = do | |
char '+' | |
r <- Parser dvMultitive | |
f <- Parser dvAdditiveSuffix | |
return $ f . \x -> x + r | |
alt2 = do | |
char '-' | |
r <- Parser dvMultitive | |
f <- Parser dvAdditiveSuffix | |
return $ f . \x -> x - r | |
pMultitive :: Derivs -> Result Int | |
Parser pMultitive = alt1 </> do Parser dvPrimary | |
where | |
alt1 = do | |
l <- Parser dvPrimary | |
char '*' | |
r <- Parser dvMultitive | |
return $ l * r | |
pPrimary :: Derivs -> Result Int | |
Parser pPrimary = alt1 </> do Parser dvDecimal | |
where | |
alt1 = do | |
char '(' | |
v <- Parser dvAdditive | |
char ')' | |
return v | |
pDecimal :: Derivs -> Result Int | |
Parser pDecimal = do | |
c <- Parser dvChar | |
guard $ c `elem` ['0'..'9'] | |
return $ digitToInt c | |
pSpacing :: Derivs -> Result () | |
Parser pSpacing = do | |
c <- Parser dvChar | |
if isSpace c | |
then Parser dvSpacing | |
else return () | |
pSymbol :: Derivs -> Result Char | |
Parser pSymbol = do | |
c <- Parser dvChar | |
guard $ c `elem` "+-*/%()" | |
return c |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
From "Packrat Parsing: a Practical Linear-Time Algorithm with Backtracking" by Bryan Ford