-----------------------------------------------------------------------------
-- |
-- Module      :  Text.ParserCombinators.HuttonMeijer
-- Copyright   :  Graham Hutton (University of Nottingham), Erik Meijer (University of Utrecht)
-- Licence     :  BSD
-- 
-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
-- Stability   :  Stable
-- Portability :  All
--
--                  A LIBRARY OF MONADIC PARSER COMBINATORS
-- 
--                               29th July 1996
-- 
--                  Graham Hutton               Erik Meijer
--             University of Nottingham    University of Utrecht
-- 
-- This Haskell script defines a library of parser combinators, and is
-- taken from sections 1-6 of our article "Monadic Parser Combinators".
-- Some changes to the library have been made in the move from Gofer
-- to Haskell:
-- 
--    * Do notation is used in place of monad comprehension notation;
-- 
--    * The parser datatype is defined using "newtype", to avoid the overhead
--      of tagging and untagging parsers with the P constructor.
-----------------------------------------------------------------------------


module Text.ParserCombinators.HuttonMeijer
   (Parser(..), item, first, papply, (+++), sat, {-tok,-} many, many1,
    sepby, sepby1, chainl,
    chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,
    letter, alphanum, string, ident, nat, int, spaces, comment, junk,
    skip, token, natural, integer, symbol, identifier) where

import Data.Char
import Control.Applicative ( Applicative(pure,(<*>)), Alternative(empty,(<|>)) )
import Control.Monad
import qualified Control.Monad.Fail as Fail

infixr 5 +++

type Token = Char

---------------------------------------------------------
-- | The parser monad

newtype Parser a   = P ([Token] -> [(a,[Token])])

instance Functor Parser where
   -- map         :: (a -> b) -> (Parser a -> Parser b)
   fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f (P String -> [(a, String)]
p)    = (String -> [(b, String)]) -> Parser b
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> [(a -> b
f a
v, String
out) | (a
v,String
out) <- String -> [(a, String)]
p String
inp])

instance Applicative Parser where
   pure :: forall a. a -> Parser a
pure a
v        = (String -> [(a, String)]) -> Parser a
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> [(a
v,String
inp)])
   <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
(<*>) = Parser (a -> b) -> Parser a -> Parser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Parser where
   -- return      :: a -> Parser a
   return :: forall a. a -> Parser a
return          = a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

   -- >>=         :: Parser a -> (a -> Parser b) -> Parser b
   (P String -> [(a, String)]
p) >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
f     = (String -> [(b, String)]) -> Parser b
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> [[(b, String)]] -> [(b, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Parser b -> String -> [(b, String)]
forall a. Parser a -> String -> [(a, String)]
papply (a -> Parser b
f a
v) String
out | (a
v,String
out) <- String -> [(a, String)]
p String
inp])

#if !MIN_VERSION_base(4,13,0)
   fail            = Fail.fail
#endif

instance Fail.MonadFail Parser where
   -- fail        :: String -> Parser a
   fail :: forall a. String -> Parser a
fail String
_          = (String -> [(a, String)]) -> Parser a
forall a. (String -> [(a, String)]) -> Parser a
P (\String
_ -> [])

instance Alternative Parser where
   empty :: forall a. Parser a
empty = Parser a
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
   <|> :: forall a. Parser a -> Parser a -> Parser a
(<|>) = Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus Parser where
   -- mzero       :: Parser a
   mzero :: forall a. Parser a
mzero           = (String -> [(a, String)]) -> Parser a
forall a. (String -> [(a, String)]) -> Parser a
P (\String
_ -> [])

   -- mplus       :: Parser a -> Parser a -> Parser a
   (P String -> [(a, String)]
p) mplus :: forall a. Parser a -> Parser a -> Parser a
`mplus` (P String -> [(a, String)]
q)  = (String -> [(a, String)]) -> Parser a
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> (String -> [(a, String)]
p String
inp [(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
++ String -> [(a, String)]
q String
inp))

-- ------------------------------------------------------------
-- * Other primitive parser combinators
-- ------------------------------------------------------------

item               :: Parser Token
item :: Parser Char
item                = (String -> [(Char, String)]) -> Parser Char
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> case String
inp of
                                   []     -> []
                                   (Char
x:String
xs) -> [(Char
x,String
xs)])

first             :: Parser a -> Parser a
first :: forall a. Parser a -> Parser a
first (P String -> [(a, String)]
p)        = (String -> [(a, String)]) -> Parser a
forall a. (String -> [(a, String)]) -> Parser a
P (\String
inp -> case String -> [(a, String)]
p String
inp of
                                   []    -> []
                                   ((a, String)
x:[(a, String)]
_) -> [(a, String)
x])

papply            :: Parser a -> [Token] -> [(a,[Token])]
papply :: forall a. Parser a -> String -> [(a, String)]
papply (P String -> [(a, String)]
p) String
inp   = String -> [(a, String)]
p String
inp

-- ------------------------------------------------------------
-- * Derived combinators
-- ------------------------------------------------------------

(+++)             :: Parser a -> Parser a -> Parser a
Parser a
p +++ :: forall a. Parser a -> Parser a -> Parser a
+++ Parser a
q            = Parser a -> Parser a
forall a. Parser a -> Parser a
first (Parser a
p Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Parser a
q)

sat               :: (Token -> Bool) -> Parser Token
sat :: (Char -> Bool) -> Parser Char
sat Char -> Bool
p              = do {Char
x <- Parser Char
item; if Char -> Bool
p Char
x then Char -> Parser Char
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
x else Parser Char
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero}

--tok               :: Token -> Parser Token
--tok t              = do {x <- item; if t==snd x then return t else mzero}

many              :: Parser a -> Parser [a]
many :: forall a. Parser a -> Parser [a]
many Parser a
p             = Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
many1 Parser a
p Parser [a] -> Parser [a] -> Parser [a]
forall a. Parser a -> Parser a -> Parser a
+++ [a] -> Parser [a]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return []
--many p           = force (many1 p +++ return [])

many1             :: Parser a -> Parser [a]
many1 :: forall a. Parser a -> Parser [a]
many1 Parser a
p            = do {a
x <- Parser a
p; [a]
xs <- Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
many Parser a
p; [a] -> Parser [a]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)}

sepby             :: Parser a -> Parser b -> Parser [a]
Parser a
p sepby :: forall a b. Parser a -> Parser b -> Parser [a]
`sepby` Parser b
sep      = (Parser a
p Parser a -> Parser b -> Parser [a]
forall a b. Parser a -> Parser b -> Parser [a]
`sepby1` Parser b
sep) Parser [a] -> Parser [a] -> Parser [a]
forall a. Parser a -> Parser a -> Parser a
+++ [a] -> Parser [a]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return []

sepby1            :: Parser a -> Parser b -> Parser [a]
Parser a
p sepby1 :: forall a b. Parser a -> Parser b -> Parser [a]
`sepby1` Parser b
sep     = do {a
x <- Parser a
p; [a]
xs <- Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
many (do {Parser b
sep; Parser a
p}); [a] -> Parser [a]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)}

chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl :: forall a. Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl Parser a
p Parser (a -> a -> a)
op a
v      = (Parser a
p Parser a -> Parser (a -> a -> a) -> Parser a
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainl1` Parser (a -> a -> a)
op) Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
+++ a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a
Parser a
p chainl1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainl1` Parser (a -> a -> a)
op     = do {a
x <- Parser a
p; a -> Parser a
rest a
x}
                     where
                        rest :: a -> Parser a
rest a
x = do {a -> a -> a
f <- Parser (a -> a -> a)
op; a
y <- Parser a
p; a -> Parser a
rest (a -> a -> a
f a
x a
y)}
                                 Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
+++ a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainr :: forall a. Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainr Parser a
p Parser (a -> a -> a)
op a
v      = (Parser a
p Parser a -> Parser (a -> a -> a) -> Parser a
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainr1` Parser (a -> a -> a)
op) Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
+++ a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a
Parser a
p chainr1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainr1` Parser (a -> a -> a)
op     = do {a
x <- Parser a
p; a -> Parser a
rest a
x}
                     where
                        rest :: a -> Parser a
rest a
x = do {a -> a -> a
f <- Parser (a -> a -> a)
op; a
y <- Parser a
p Parser a -> Parser (a -> a -> a) -> Parser a
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainr1` Parser (a -> a -> a)
op; a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
f a
x a
y)}
                                 Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
+++ a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

ops               :: [(Parser a, b)] -> Parser b
ops :: forall a b. [(Parser a, b)] -> Parser b
ops [(Parser a, b)]
xs             = (Parser b -> Parser b -> Parser b) -> [Parser b] -> Parser b
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser b -> Parser b -> Parser b
forall a. Parser a -> Parser a -> Parser a
(+++) [do {Parser a
p; b -> Parser b
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return b
op} | (Parser a
p,b
op) <- [(Parser a, b)]
xs]

bracket           :: Parser a -> Parser b -> Parser c -> Parser b
bracket :: forall a b c. Parser a -> Parser b -> Parser c -> Parser b
bracket Parser a
open Parser b
p Parser c
close = do {Parser a
open; b
x <- Parser b
p; Parser c
close; b -> Parser b
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x}

-- ------------------------------------------------------------
-- * Useful parsers
-- ------------------------------------------------------------

char              :: Char -> Parser Char
char :: Char -> Parser Char
char Char
x             = (Char -> Bool) -> Parser Char
sat (\Char
y -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y)

digit             :: Parser Char
digit :: Parser Char
digit              = (Char -> Bool) -> Parser Char
sat Char -> Bool
isDigit

lower             :: Parser Char
lower :: Parser Char
lower              = (Char -> Bool) -> Parser Char
sat Char -> Bool
isLower

upper             :: Parser Char
upper :: Parser Char
upper              = (Char -> Bool) -> Parser Char
sat Char -> Bool
isUpper

letter            :: Parser Char
letter :: Parser Char
letter             = (Char -> Bool) -> Parser Char
sat Char -> Bool
isAlpha

alphanum          :: Parser Char
alphanum :: Parser Char
alphanum           = (Char -> Bool) -> Parser Char
sat Char -> Bool
isAlphaNum Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
+++ Char -> Parser Char
char Char
'_'

string            :: String -> Parser String
string :: String -> Parser String
string String
""          = String -> Parser String
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
string (Char
x:String
xs)      = do {Char -> Parser Char
char Char
x; String -> Parser String
string String
xs; String -> Parser String
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)}

ident             :: Parser String
ident :: Parser String
ident              = do {Char
x <- Parser Char
lower; String
xs <- Parser Char -> Parser String
forall a. Parser a -> Parser [a]
many Parser Char
alphanum; String -> Parser String
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)}

nat               :: Parser Int
nat :: Parser Int
nat                = do {Char
x <- Parser Char
digit; Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0')} Parser Int -> Parser (Int -> Int -> Int) -> Parser Int
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
`chainl1` (Int -> Int -> Int) -> Parser (Int -> Int -> Int)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Int -> Int -> Int
forall a. Num a => a -> a -> a
op
                     where
                        a
m op :: a -> a -> a
`op` a
n = a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
m a -> a -> a
forall a. Num a => a -> a -> a
+ a
n

int               :: Parser Int
int :: Parser Int
int                = do {Char -> Parser Char
char Char
'-'; Int
n <- Parser Int
nat; Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
n)} Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
+++ Parser Int
nat

-- ------------------------------------------------------------
-- * Lexical combinators
-- ------------------------------------------------------------

spaces            :: Parser ()
spaces :: Parser ()
spaces             = do {Parser Char -> Parser String
forall a. Parser a -> Parser [a]
many1 ((Char -> Bool) -> Parser Char
sat Char -> Bool
isSpace); () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()}

comment           :: Parser ()
--comment            = do {string "--"; many (sat (\x -> x /= '\n')); return ()}
--comment            = do 
--                       _ <- string "--"
--                       _ <- many (sat (\x -> x /= '\n'))
--                       return ()
comment :: Parser ()
comment            = do
                       Parser String -> Parser String -> Parser String -> Parser String
forall a b c. Parser a -> Parser b -> Parser c -> Parser b
bracket (String -> Parser String
string String
"/*") (Parser Char -> Parser String
forall a. Parser a -> Parser [a]
many Parser Char
item) (String -> Parser String
string String
"*/")
                       () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

junk              :: Parser ()
junk :: Parser ()
junk               = do {Parser () -> Parser [()]
forall a. Parser a -> Parser [a]
many (Parser ()
spaces Parser () -> Parser () -> Parser ()
forall a. Parser a -> Parser a -> Parser a
+++ Parser ()
comment); () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()}

skip              :: Parser a -> Parser a
skip :: forall a. Parser a -> Parser a
skip Parser a
p             = do {Parser ()
junk; Parser a
p}

token             :: Parser a -> Parser a
token :: forall a. Parser a -> Parser a
token Parser a
p            = do {a
v <- Parser a
p; Parser ()
junk; a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v}

-- ------------------------------------------------------------
-- * Token parsers
-- ------------------------------------------------------------

natural           :: Parser Int
natural :: Parser Int
natural            = Parser Int -> Parser Int
forall a. Parser a -> Parser a
token Parser Int
nat

integer           :: Parser Int
integer :: Parser Int
integer            = Parser Int -> Parser Int
forall a. Parser a -> Parser a
token Parser Int
int

symbol            :: String -> Parser String
symbol :: String -> Parser String
symbol String
xs          = Parser String -> Parser String
forall a. Parser a -> Parser a
token (String -> Parser String
string String
xs)

identifier        :: [String] -> Parser String
identifier :: [String] -> Parser String
identifier [String]
ks      = Parser String -> Parser String
forall a. Parser a -> Parser a
token (do {String
x <- Parser String
ident;
                                if Bool -> Bool
not (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x [String]
ks) then String -> Parser String
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
                                else String -> Parser String
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return String
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero})

------------------------------------------------------------------------------