80 lines
1.9 KiB
Haskell
80 lines
1.9 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Monpar where
|
|
|
|
import qualified Control.Applicative as Ap
|
|
import Control.Applicative ((<|>), Alternative, many, some)
|
|
import Control.Monad ( MonadPlus(mzero))
|
|
newtype Parser a = Parser {runParser :: String -> [(a, String)]}
|
|
|
|
instance Functor Parser where
|
|
fmap f p = Parser $ \inp -> [ (f x,xs) | (x,xs) <- runParser p inp ]
|
|
|
|
instance Applicative Parser where
|
|
pure v = Parser $ \inp -> [(v,inp)]
|
|
d <*> e = d >>= (<$> e)
|
|
|
|
instance Monad Parser where
|
|
return = pure
|
|
p >>= f = Parser $ \inp -> concat [runParser (f v) out | (v,out) <- runParser p inp]
|
|
|
|
instance Alternative Parser where
|
|
empty = Parser $ const []
|
|
p <|> q = Parser $ \inp -> runParser p inp ++ runParser q inp
|
|
many p = do { x <- p; xs <- many p; return $ x:xs } <|> return []
|
|
some p = do
|
|
x <- p
|
|
xs <- many p
|
|
return $ x:xs
|
|
|
|
instance MonadPlus Parser
|
|
|
|
instance MonadFail Parser where
|
|
fail _ = mzero
|
|
|
|
(<++) :: Parser a -> Parser a -> Parser a
|
|
p <++ q = Parser $ \inp -> let r1 = runParser p inp in
|
|
if null r1 then runParser q inp else r1
|
|
|
|
get :: Parser Char
|
|
get = Parser $ \case
|
|
[] -> []
|
|
x:xs -> [(x,xs)]
|
|
|
|
|
|
look :: Parser Char
|
|
look = Parser $ \case
|
|
[] -> []
|
|
x:xs -> [(x,x:xs)]
|
|
|
|
sat :: (Char -> Bool) -> Parser Char
|
|
sat p = do
|
|
c <- get
|
|
if p c then return c else mzero
|
|
|
|
char :: Char -> Parser Char
|
|
char c = sat (== c)
|
|
|
|
string :: String -> Parser String
|
|
string "" = return ""
|
|
string (x:xs) = do
|
|
_ <- char x
|
|
_ <- string xs
|
|
return (x:xs)
|
|
|
|
eof :: Parser ()
|
|
eof = Parser $ \inp -> [((), inp) | null inp]
|
|
|
|
option :: a -> Parser a -> Parser a
|
|
option x p = p <|> return x
|
|
|
|
word :: Parser String
|
|
word = neWord <|> return ""
|
|
where
|
|
neWord = do
|
|
x <- sat (\x -> x /= '\n' && x /= ' ')
|
|
xs <- word
|
|
return $ x:xs
|
|
|
|
manyTill :: Parser a -> Parser b -> Parser [a]
|
|
manyTill p q = (q >> return []) <++ do { x <- p; xs <- manyTill p q; return $ x:xs }
|