public
Created

Toy parser

  • Download Gist
Examples.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
module Examples where
 
import FooParser
 
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Char
 
-- | Parse a word with zero or more pairs of parentheses surrounding it. The
-- result contains the number of paren pairs and the word itself.
--
-- > runParser (example0 <* end) "(((foo)))" == [((3,"foo"),"")]
example0 :: Parser Char (Integer, String)
example0 = token '(' *> (first (+1) <$> example0) <* token ')'
<|> (,) 0 <$> word
 
-- | Parse a number, some whitespace and then as many characters as the number
-- indicated. The result contains the characters.
--
-- > runParser example1 "6 foobarbaz" == [("foobar","baz")]
example1 :: Parser Char String
example1 = do
n <- fromInteger <$> number
_ <- spaces
replicateM n anyToken
 
-- An s-expr subset parser.
 
-- http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-7.html
 
data SExpr = Identifier String
| Number Integer
| List (SList SExpr)
deriving (Eq, Show, Read)
 
data SList a = SList [a]
| SDotted [a] a
deriving (Eq, Show, Read, Functor)
 
sexpr :: Parser Char SExpr
sexpr = identifier <|> sNumber <|> list
 
identifier :: Parser Char SExpr
identifier = Identifier <$> liftA2 (:) initial (many subsequent) <* spaces
where
initial = letter <|> symbol
subsequent = letter <|> digit <|> symbol
-- 4.2.4 Identifiers
letter = satisfy isAlpha
digit = satisfy isDigit
symbol = satisfy (`elem` "!$%&*+-./:<=>?@^_~")
 
sNumber :: Parser Char SExpr
sNumber = Number <$> number <* spaces
 
list :: Parser Char SExpr
list = bra *> (List <$> entry)
where
bra = token '(' <* spaces
ket = token ')' <* spaces
dot = token '.' <* spaces
 
-- Right after ( or after a previous item in the list.
entry = nil <|> notNil
 
nil = SList [] <$ ket
 
notNil = liftA2 cons sexpr (dotted <|> entry)
where
cons x (SList xs) = SList (x:xs)
cons x (SDotted xs y) = SDotted (x:xs) y
 
dotted = dot *> (dottedList <|> dottedSExpr) <* ket
 
-- An inner list follows the dot: just a cons.
dottedList = bra *> entry
-- Some other sexpr follows the dot.
dottedSExpr = SDotted [] <$> sexpr
 
word :: Parser Char String
word = some (satisfy isAlpha)
 
number :: Parser Char Integer
number = read <$> some (satisfy isDigit)
 
spaces :: Parser Char String
spaces = many (satisfy isSpace)
FooParser.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
module FooParser
( Parser (..)
, failure
, satisfy
, end
, anyToken
, token
) where
 
import Control.Applicative
import Control.Arrow
import Control.Monad
 
-- [i]: input tokens.
-- (o, [i]): parsed output and remaining input.
newtype Parser i o = Parser { runParser :: [i] -> [(o, [i])] }
 
-- | A parse failure.
failure :: Parser i o
failure = Parser (const [])
 
-- Result in the input value without consuming any input.
retP :: o -> Parser i o
retP o = Parser (\i -> [(o, i)])
 
-- Map a function to the result values of a parser.
mapP :: (a -> b) -> Parser i a -> Parser i b
mapP f p = Parser (map (first f) . runParser p)
 
-- For the Monad instance.
joinP :: Parser i (Parser i o) -> Parser i o
joinP pOuter = Parser $ \i0 -> do
(pInner, i1) <- runParser pOuter i0
runParser pInner i1
 
-- If the first parser fails try the second one.
orP :: Parser i o -> Parser i o -> Parser i o
orP xp yp = Parser $ \i ->
case runParser xp i of
[] -> runParser yp i
res -> res
 
-- | Match a token if the predicate returns True.
satisfy :: (i -> Bool) -> Parser i i
satisfy f = Parser $ \i ->
case i of
(x:xs) | f x -> [(x, xs)]
_ -> []
 
-- | Match the end of input.
end :: Parser i ()
end = Parser $ \i ->
case i of
[] -> [((), i)]
_ -> []
 
-- | Match any token.
anyToken :: Parser i i
anyToken = satisfy (const True)
 
-- | Match a token that is equal to the parameter.
token :: Eq i => i -> Parser i i
token t = satisfy (==t)
 
instance Functor (Parser i) where
fmap = mapP
 
instance Applicative (Parser i) where
pure = retP
(<*>) = ap
 
instance Alternative (Parser i) where
empty = failure
(<|>) = orP
 
instance Monad (Parser i) where
return = retP
p >>= f = joinP (mapP f p)
fail _ = failure
 
instance MonadPlus (Parser i) where
mzero = failure
mplus = orP

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.