Parsing.hs

{-# LANGUAGE FlexibleInstances #-}
-- | Home-grown parser, just because.
module Haste.Parsing (
    Parse, runParser, char, charP, string, oneOf, possibly, atLeast,
    whitespace, word, Haste.Parsing.words, int, double, positiveDouble,
    suchThat, quotedString, skip, rest, lookahead, anyChar
  ) where
import Control.Applicative
import Control.Monad
import Data.Char

newtype Parse a = Parse {unP :: (String -> Maybe (String, a))}

runParser :: Parse a -> String -> Maybe a
runParser (Parse p) s =
  case p s of
    Just ("", x) -> Just x
    _            -> Nothing

instance Monad Parse where
  return x = Parse $ \s -> Just (s, x)
  Parse m >>= f = Parse $ \s -> do
    (s', x) <- m s
    unP (f x) s'

instance Alternative Parse where
  empty = mzero
  (<|>) = mplus

instance MonadPlus Parse where
  mplus (Parse p1) (Parse p2) = Parse $ \s ->
    case p1 s of
      x@(Just _) -> x
      _          -> p2 s
  mzero = Parse $ const Nothing

instance Functor Parse where
  fmap f (Parse g) = Parse $ fmap (fmap f) . g

instance Applicative Parse where
  pure  = return
  (<*>) = ap

-- | Read one character. Fails if end of stream.
anyChar :: Parse Char
anyChar = Parse $ \s ->
  case s of
    (c:cs) -> Just (cs, c)
    _      -> Nothing

-- | Require a specific character.
char :: Char -> Parse Char
char c = charP (== c)

-- | Parse a character that matches a given predicate.
charP :: (Char -> Bool) -> Parse Char
charP p = Parse $ \s ->
  case s of
    (c:next) | p c -> Just (next, c)
    _              -> Nothing  

-- | Require a specific string.
string :: String -> Parse String
string str = Parse $ \s ->
  let len        = length str
      (s', next) = splitAt len s
  in if s' == str
       then Just (next, str)
       else Nothing

-- | Apply the first matching parser.
oneOf :: [Parse a] -> Parse a
oneOf = msum

-- | Invoke a parser with the possibility of failure.
possibly :: Parse a -> Parse (Maybe a)
possibly p = oneOf [Just <$> p, return Nothing]

-- | Invoke a parser at least n times.
atLeast :: Int -> Parse a -> Parse [a]
atLeast 0 p = do
  x <- possibly p
  case x of
    Just x' -> do
      xs <- atLeast 0 p
      return (x':xs)
    _ ->
      return []
atLeast n p = do
  x <- p
  xs <- atLeast (n-1) p
  return (x:xs)

-- | Parse zero or more characters of whitespace.
whitespace :: Parse String
whitespace = atLeast 0 $ charP isSpace

-- | Parse a non-empty word. A word is a string of at least one non-whitespace
--   character.
word :: Parse String
word = atLeast 1 $ charP (not . isSpace)

-- | Parse several words, separated by whitespace.
words :: Parse [String]
words = atLeast 0 $ word <* whitespace

-- | Parse an Int.
int :: Parse Int
int = oneOf [read <$> atLeast 1 (charP isDigit),
             char '-' >> (0-) . read <$> atLeast 1 (charP isDigit)]

-- | Parse a floating point number.
double :: Parse Double
double = oneOf [positiveDouble,
                char '-' >> (0-) <$> positiveDouble]

-- | Parse a non-negative floating point number.
positiveDouble :: Parse Double
positiveDouble = do
  first <- atLeast 1 $ charP isDigit
  msecond <- possibly $ char '.' *> atLeast 1 (charP isDigit)
  case msecond of
    Just second -> return $ read $ first ++ "." ++ second
    _           -> return $ read first

-- | Fail on unwanted input.
suchThat :: Parse a -> (a -> Bool) -> Parse a
suchThat p f = do {x <- p ; if f x then return x else mzero}

-- | A string quoted with the given quotation mark. Strings can contain escaped
--   quotation marks; escape characters are stripped from the returned string.
quotedString :: Char -> Parse String
quotedString q = char q *> strContents q <* char q

strContents :: Char -> Parse String
strContents c = do
  s <- atLeast 0 $ charP (\x -> x /= c && x /= '\\')
  c' <- lookahead anyChar
  if c == c'
    then do
      return s
    else do
      skip 1
      c'' <- anyChar
      s' <- strContents c
      return $ s ++ [c''] ++ s'

-- | Read the rest of the input.
rest :: Parse String
rest = Parse $ \s -> Just ("", s)

-- | Run a parser with the current parsing state, but don't consume any input.
lookahead :: Parse a -> Parse a
lookahead p = do
  s' <- Parse $ \s -> Just (s, s)
  x <- p
  Parse $ \_ -> Just (s', x)

-- | Skip n characters from the input.
skip :: Int -> Parse ()
skip n = Parse $ \s -> Just (drop n s, ())