-------------------------------------------------------------------------
-- 
--  Haskell: The Craft of Functional Programming, 3e
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
-- 
--      Case study: Parsing expressions 
-- 
--      Note that this is not a monadic approach to parsing.    
-- 
---------------------------------------------------------------------------                                                     

module ParsingBasics where

import Data.Char

infixr 5 >*>
--  
-- Syntactic types                          
--  
type Var = Char
data Expr = Lit Int | Var Var | Op Op Expr Expr
data Op   = Add | Sub | Mul | Div | Mod
--  
-- 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
--  
-- 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 (:)
--  
-- From the exercises...                        
--  
neList   :: Parse a b -> Parse a [b]
neList :: forall a b. Parse a b -> Parse a [b]
neList = Parse a b -> Parse a [b]
forall a b. Parse a b -> Parse a [b]
neList          -- dummy definition
optional :: Parse a b -> Parse a [b]
optional :: forall a b. Parse a b -> Parse a [b]
optional = Parse a b -> Parse a [b]
forall a b. Parse a b -> Parse a [b]
optional      -- dummy definition
nTimes :: Int -> Parse a b -> Parse a [b]
nTimes :: forall a b. Int -> Parse a b -> Parse a [b]
nTimes = Int -> Parse a b -> Parse a [b]
forall a b. Int -> Parse a b -> Parse a [b]
nTimes          -- dummy definition
--  
-- A parser for expressions                 
--  
--  
-- The parser has three components, corresponding to the three  
-- clauses in the definition of the syntactic type.     
--  
parser :: Parse Char Expr
parser :: Parse Char Expr
parser = (Parse Char Expr
litParse Parse Char Expr -> Parse Char Expr -> Parse Char Expr
forall a b. Parse a b -> Parse a b -> Parse a b
`alt` Parse Char Expr
varParse) Parse Char Expr -> Parse Char Expr -> Parse Char Expr
forall a b. Parse a b -> Parse a b -> Parse a b
`alt` Parse Char Expr
opExpParse
--  
-- Spotting variables.                      
--  
varParse :: Parse Char Expr
varParse :: Parse Char Expr
varParse = (Char -> Bool) -> Parse Char Char
forall a. (a -> Bool) -> Parse a a
spot Char -> Bool
isVar Parse Char Char -> (Char -> Expr) -> Parse Char Expr
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` Char -> Expr
Var

isVar :: Char -> Bool
isVar :: Char -> Bool
isVar Char
x = (Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
x Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
--  
-- Parsing (fully bracketed) operator applications.     
--  
opExpParse :: Parse Char Expr
opExpParse 
  = (Char -> Parse Char Char
forall a. Eq a => a -> Parse a a
token Char
'(' Parse Char Char
-> Parse Char (Expr, (Char, (Expr, Char)))
-> Parse Char (Char, (Expr, (Char, (Expr, Char))))
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*>
     Parse Char Expr
parser    Parse Char Expr
-> Parse Char (Char, (Expr, Char))
-> Parse Char (Expr, (Char, (Expr, Char)))
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*>
     (Char -> Bool) -> Parse Char Char
forall a. (a -> Bool) -> Parse a a
spot Char -> Bool
isOp Parse Char Char
-> Parse Char (Expr, Char) -> Parse Char (Char, (Expr, Char))
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*>
     Parse Char Expr
parser    Parse Char Expr -> Parse Char Char -> Parse Char (Expr, Char)
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*>
     Char -> Parse Char Char
forall a. Eq a => a -> Parse a a
token Char
')') 
     Parse Char (Char, (Expr, (Char, (Expr, Char))))
-> ((Char, (Expr, (Char, (Expr, Char)))) -> Expr)
-> Parse Char Expr
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` (Char, (Expr, (Char, (Expr, Char)))) -> Expr
forall {a} {b}. (a, (Expr, (Char, (Expr, b)))) -> Expr
makeExpr

makeExpr :: (a, (Expr, (Char, (Expr, b)))) -> Expr
makeExpr (a
_,(Expr
e1,(Char
bop,(Expr
e2,b
_)))) = Op -> Expr -> Expr -> Expr
Op (Char -> Op
charToOp Char
bop) Expr
e1 Expr
e2

isOp :: Char -> Bool
isOp :: Char -> Bool
isOp = Char -> Bool
isOp          -- dummy definition

charToOp :: Char -> Op
charToOp :: Char -> Op
charToOp = Char -> Op
charToOp      -- dummy definition

--  
-- A number is a list of digits with an optional ~ at the front. 
--  
litParse :: Parse Char Expr
litParse 
  = ((Parse Char Char -> Parse Char [Char]
forall a b. Parse a b -> Parse a [b]
optional (Char -> Parse Char Char
forall a. Eq a => a -> Parse a a
token Char
'~')) Parse Char [Char]
-> Parse Char [Char] -> Parse Char ([Char], [Char])
forall a b c. Parse a b -> Parse a c -> Parse a (b, c)
>*>
     (Parse Char Char -> Parse Char [Char]
forall a b. Parse a b -> Parse a [b]
neList ((Char -> Bool) -> Parse Char Char
forall a. (a -> Bool) -> Parse a a
spot Char -> Bool
isDigit)))
     Parse Char ([Char], [Char])
-> (([Char], [Char]) -> Expr) -> Parse Char Expr
forall a b c. Parse a b -> (b -> c) -> Parse a c
`build` ([Char] -> Expr
charlistToExpr([Char] -> Expr)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Char], [Char]) -> [Char]
forall {a}. ([a], [a]) -> [a]
join) 
     where
     join :: ([a], [a]) -> [a]
join = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
--  
-- From the exercises...                        
--  
charlistToExpr :: [Char] -> Expr
charlistToExpr :: [Char] -> Expr
charlistToExpr = [Char] -> Expr
charlistToExpr      -- dummy definition
--  
-- A grammar for unbracketed expressions.               
--                              
-- eXpr  ::= Int | Var | (eXpr Op eXpr) |               
--           lexpr mop mexpr | mexpr aop eXpr           
-- lexpr ::= Int | Var | (eXpr Op eXpr)             
-- mexpr ::= Int | Var | (eXpr Op eXpr) |   lexpr mop mexpr     
-- mop   ::= 'a' | '/' | '\%'                   
-- aop   ::= '+' | '-'                      
--  
--  
-- The top-level parser                     
--  
topLevel :: Parse a b -> [a] -> b
topLevel :: forall a b. Parse a b -> [a] -> b
topLevel Parse a b
p [a]
inp
  = case [b]
results of
      [] -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"parse unsuccessful"
      [b]
_  -> [b] -> b
forall a. HasCallStack => [a] -> a
head [b]
results
    where
    results :: [b]
results = [ b
found | (b
found,[]) <- Parse a b
p [a]
inp ]
--  
-- The type of commands.                        
--  
data Command = Eval Expr | Assign Var Expr | Null
commandParse :: Parse Char Command
commandParse :: Parse Char Command
commandParse = Parse Char Command
commandParse      -- dummy definition
--  
-- From the exercises.                      
--  
-- tokenList :: [a] -> Parse a [a]
-- spotWhile :: (a -> Bool) -> Parse a [a]