Parsec analogue (too dumb to learn parsec, I'd better write my own, mwahaha)

Parser.hs

{-# LANGUAGE FunctionalDependencies,
             FlexibleInstances       #-}

module Parser where

import Control.Monad

newtype Parser e s a = Parser { runParser :: s -> Either (Error e s) (a, s) }

data Error a b = Error a String b deriving Show

parser = Parser

ok (a, s) = Right (a, s)

err msg = Left msg

nothing = ()

instance Functor (Parser e s) where
  fmap f p = do r <- p
                return (f r)

result_of :: (a -> b) -> Parser e s a -> Parser e s b
result_of = fmap

instance Monad (Parser e s) where
  return value = parser $ \text -> ok (value, text)

  p >>= fp = parser $ \text ->
    case runParser p text of
         Left  errmsg         -> err errmsg
         Right (value, text)  -> runParser (fp value) text

eos = parser $ \text ->
  protect
    (do hd <- safeHead text
        return $ err $ "EOS" `expected_but_found` text)

    (ok ([], []))

char c = parser $ \text ->
  protect
    (do hd <- safeHead text
        guard (hd == c)
        return $ ok (c, tail text))

    (err $ [c] `expected_but_found` text)
    

string []     = return [] :: Parser e a String

string (c:cs) = do _ <- char c
                   _ <- string cs
                   return (c:cs)

many1 p = do r  <- p
             rs <- many p ||| return []

             return (r:rs)

many p = many1 p ||| return []

p ||| r = parser $ \text -> 
  case runParser p text of
       Left  err    -> runParser r text
       Right result -> Right result

class Range c cs where
  inside :: c -> cs -> Bool

data Between a = a :.. a deriving Show

data NotFrom a = NotFrom a deriving Show

data Join a b = Join a b deriving Show

a `or_in` b = Join a b

data And a b = And a b deriving Show

a `and_in` b = And a b

instance Ord a => Range a (Between a) where
  inside c (l :.. h) = c >= l && c < h

instance Ord a => Range a [a] where
  inside = elem

instance (Ord a, Range a b, Range a c) => Range a (Join b c) where
  inside a (Join b c) = a `inside` b || a `inside` c

instance (Ord a, Range a b, Range a c) => Range a (And b c) where
  inside a (And b c) = a `inside` b && a `inside` c

instance (Ord a, Range a b) => Range a (NotFrom b) where
  inside a (NotFrom b) = not $ a `inside` b

instance (Ord a) => Range a (a -> Bool) where
  inside a f = f a

from_set :: Range c cs => cs -> Parser cs [c] c
from_set set = parser $ \text ->
  protect
    (do hd <- safeHead text
        guard (hd `inside` set)
        return $ ok (hd, tail text))

    (err $ set `expected_but_found` text)

a `expected_but_found` b = Error a "expected but found" b

p <* sp = do r <- p
             sp
             return r

sp *> p = do sp
             p

tokenized p = many (char ' ') *> p <* many (char ' ')

token = tokenized . string

what `between` set = 
  do delim <- from_set set
     r <- many (from_set $ (NotFrom [delim]) `and_in` what)
     char delim

     return r

-- just const :: a -> b is wider than const :: Char -> Bool, so be it
anything :: Char -> Bool
anything = const True

the p = p

unless set = many (from_set $ NotFrom set)

sep_by p sp = do r <- p
                 rs <- many (sp *> p)

                 return (r:rs)

sep_by_tokens p sp = do r <- p
                        rs <- sp 

                        rest <- sep_by_tokens p sp ||| return []

                        return (r:rs:rest)

b2m True value = Just value
b2m False _    = Nothing

safeHead [] = Nothing
safeHead x  = Just $ head x

protect ma b = case ma of
                    Just x  -> x
                    Nothing -> b