-------------------------------------------------------------------------
-- 
--  Haskell: The Craft of Functional Programming, 3e
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
-- 
--  ParseLib.hs
-- 
--  Library functions for parsing   
--      Note that this is not a monadic approach to parsing.    
-- 
---------------------------------------------------------------------------                                                                                                  

module ParseLib where

import Control.Monad (liftM, ap)
import Data.Char

infixr 5 >*>
--   
-- The type of parsers.                     
--  
type Parse a b = [a] -> [(b,[a])]
--  
-- Some basic parsers                       
--  
--  
-- Fail on any input.                       
--  
none :: Parse a b
none :: forall a b. Parse a b
none [a]
inp = []
--  
-- Succeed, returning the value supplied.               
--  
succeed :: b -> Parse a b 
succeed :: forall b a. b -> Parse a b
succeed b
val [a]
inp = [(b
val,[a]
inp)]
--  
-- token t recognises t as the first value in the input.        
--  
token :: Eq a => a -> Parse a a
token :: forall a. Eq a => a -> Parse a a
token a
t (a
x:[a]
xs) 
  | a
ta -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x    = [(a
t,[a]
xs)]
  | Bool
otherwise   = []
token a
t []    = []
--  
-- spot whether an element with a particular property is the    
-- first element of input.                      
--  
spot :: (a -> Bool) -> Parse a a
spot :: forall a. (a -> Bool) -> Parse a a
spot a -> Bool
p (a
x:[a]
xs) 
  | a -> Bool
p a
x     = [(a
x,[a]
xs)]
  | Bool
otherwise   = []
spot a -> Bool
p []    = []
--  
-- Examples.                            
--  
bracket :: Parse Char Char
bracket = Char -> Parse Char Char
forall a. Eq a => a -> Parse a a
token Char
'('
dig :: Parse Char Char
dig     =  (Char -> Bool) -> Parse Char Char
forall a. (a -> Bool) -> Parse a a
spot Char -> Bool
isDigit

-- Succeeds with value given when the input is empty.

endOfInput :: b -> Parse a b
endOfInput :: forall b a. b -> Parse a b
endOfInput b
x [] = [(b
x,[])]
endOfInput b
x [a]
_  = []
--  
-- Combining parsers                        
--  
--  
-- alt p1 p2 recognises anything recogniseed by p1 or by p2.    
--  
alt :: Parse a b -> Parse a b -> Parse a b
alt :: forall a b. Parse a b -> Parse a b -> Parse a b
alt Parse a b
p1 Parse a b
p2 [a]
inp = Parse a b
p1 [a]
inp [(b, [a])] -> [(b, [a])] -> [(b, [a])]
forall a. [a] -> [a] -> [a]
++ Parse a b
p2 [a]
inp
exam1 :: [(Char, [Char])]
exam1 = (Parse Char Char
bracket Parse Char Char -> Parse Char Char -> Parse Char Char
forall a b. Parse a b -> Parse a b -> Parse a b
`alt` Parse Char Char
dig) [Char]
"234" 
--  
-- Apply one parser then the second to the result(s) of the first.  
--  

(>*>) :: Parse a b -> Parse a c -> Parse a (b,c)
--  
>*> :: forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
(>*>) Parse a b
p1 Parse a c
p2 [a]
inp 
  = [((b
y,c
z),[a]
rem2) | (b
y,[a]
rem1) <- Parse a b
p1 [a]
inp , (c
z,[a]
rem2)  <- Parse a c
p2 [a]
rem1 ]
--  
-- Transform the results of the parses according to the function.   
--  
build :: Parse a b -> (b -> c) -> Parse a c
build :: forall a b c. Parse a b -> (b -> c) -> Parse a c
build Parse a b
p b -> c
f [a]
inp = [ (b -> c
f b
x,[a]
rem) | (b
x,[a]
rem) <- Parse a b
p [a]
inp ]
--  
-- Recognise a list of objects.                 
--  
--  
list :: Parse a b -> Parse a [b]
list :: forall a b. Parse a b -> Parse a [b]
list Parse a b
p = ([b] -> Parse a [b]
forall b a. b -> Parse a b
succeed []) 
         Parse a [b] -> Parse a [b] -> Parse a [b]
forall a b. Parse a b -> Parse a b -> Parse a b
`alt`
         ((Parse a b
p Parse a b -> Parse a [b] -> Parse a (b, [b])
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*> Parse a b -> Parse a [b]
forall a b. Parse a b -> Parse a [b]
list Parse a b
p) Parse a (b, [b]) -> ((b, [b]) -> [b]) -> Parse a [b]
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` (b, [b]) -> [b]
forall {a}. (a, [a]) -> [a]
convert)
         where
         convert :: (a, [a]) -> [a]
convert = (a -> [a] -> [a]) -> (a, [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)
--  
-- Some variants...

-- A non-empty list of objects.                     
--  
neList   :: Parse a b -> Parse a [b]
neList :: forall a b. Parse a b -> Parse a [b]
neList Parse a b
p = (Parse a b
p  Parse a b -> (b -> [b]) -> Parse a [b]
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` (b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[]))
           Parse a [b] -> Parse a [b] -> Parse a [b]
forall a b. Parse a b -> Parse a b -> Parse a b
`alt`
           ((Parse a b
p Parse a b -> Parse a [b] -> Parse a (b, [b])
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*> Parse a b -> Parse a [b]
forall a b. Parse a b -> Parse a [b]
list Parse a b
p) Parse a (b, [b]) -> ((b, [b]) -> [b]) -> Parse a [b]
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` ((b -> [b] -> [b]) -> (b, [b]) -> [b]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)))

-- Zero or one object.

optional :: Parse a b -> Parse a [b]
optional :: forall a b. Parse a b -> Parse a [b]
optional Parse a b
p = ([b] -> Parse a [b]
forall b a. b -> Parse a b
succeed []) 
             Parse a [b] -> Parse a [b] -> Parse a [b]
forall a b. Parse a b -> Parse a b -> Parse a b
`alt`  
             (Parse a b
p  Parse a b -> (b -> [b]) -> Parse a [b]
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` (b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[]))

-- A given number of objects.

nTimes :: Int -> Parse a b -> Parse a [b]
nTimes :: forall a b. Int -> Parse a b -> Parse a [b]
nTimes Int
0 Parse a b
p     = [b] -> Parse a [b]
forall b a. b -> Parse a b
succeed []
nTimes Int
n Parse a b
p     = (Parse a b
p Parse a b -> Parse a [b] -> Parse a (b, [b])
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*> Int -> Parse a b -> Parse a [b]
forall a b. Int -> Parse a b -> Parse a [b]
nTimes (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Parse a b
p) Parse a (b, [b]) -> ((b, [b]) -> [b]) -> Parse a [b]
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` ((b -> [b] -> [b]) -> (b, [b]) -> [b]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:))
--  
-- Monadic parsing

data SParse a b = SParse (Parse a b)

instance Monad (SParse a) where
  return :: forall a. a -> SParse a a
return a
x = Parse a a -> SParse a a
forall a b. Parse a b -> SParse a b
SParse (a -> Parse a a
forall b a. b -> Parse a b
succeed a
x)
  (SParse Parse a a
pr) >>= :: forall a b. SParse a a -> (a -> SParse a b) -> SParse a b
>>= a -> SParse a b
f 
    = Parse a b -> SParse a b
forall a b. Parse a b -> SParse a b
SParse (\[a]
st -> [[(b, [a])]] -> [(b, [a])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ SParse a b -> Parse a b
forall a b. SParse a b -> Parse a b
sparse (a -> SParse a b
f a
a) [a]
rest | (a
a,[a]
rest) <- Parse a a
pr [a]
st ])

instance Applicative (SParse a) where
  pure :: forall a. a -> SParse a a
pure = a -> SParse a a
forall a. a -> SParse a a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. SParse a (a -> b) -> SParse a a -> SParse a b
(<*>) = SParse a (a -> b) -> SParse a a -> SParse a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (SParse a) where
  fmap :: forall a b. (a -> b) -> SParse a a -> SParse a b
fmap = (a -> b) -> SParse a a -> SParse a b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

sparse :: SParse a b -> Parse a b

sparse :: forall a b. SParse a b -> Parse a b
sparse (SParse Parse a b
pr) = Parse a b
pr