uu-parsinglib-2.4.0: src/Text/ParserCombinators/UU/Examples.hs
{-# LANGUAGE RankNTypes #-}
-- GADTs,
-- MultiParamTypeClasses,
-- FunctionalDependencies,
-- FlexibleInstances,
-- FlexibleContexts,
-- UndecidableInstances,
-- NoMonomorphismRestriction
module Text.ParserCombinators.UU.Examples where
import Char
import Text.ParserCombinators.UU
-- |We start out by defining the type of parser we want; by specifying the type of the state we resolve a lot of overloading
type Parser a = P (Str Char) a
-- | The fuction @`run`@ runs the parser and shows both the result, and the correcting steps which were taken during the parsing process.
run :: Show t => P (Str Char) t -> String -> IO ()
run p inp = do let r@(a, errors) = parse ( (,) <$> p <*> pEnd) (listToStr inp)
putStrLn "--"
putStrLn "-- @"
putStrLn ("-- Result: " ++ show a)
if null errors then return ()
else do putStr ("-- Correcting steps: \n")
show_errors errors
putStrLn "-- @"
-- | Our first two parsers are simple; one recognises a single 'a' character and the other one a single 'b'. Since we will use them later we
-- convert the recognsied character into String so they can be easily combined.
pa ::Parser String
pa = lift <$> pSym 'a'
pb :: Parser String
pb = lift <$> pSym 'b'
lift a = [a]
-- | We can now run the parser @`pa`@ on input \"a\", which succeeds:
--
-- @
-- Result: \"a\"
-- @
test1 = run pa "a"
-- | If we run the parser @`pa`@ on the empty input \"\", the expected symbol in inserted, that the position where it was inserted is reported, and
-- we get information about what was expected at that position: @run pa \"\"@
--
-- @
-- Result: \"a\"
-- Correcting steps:
-- Inserted 'a' at position 0 expecting 'a'
-- @
test2 = run pa ""
-- | Now let's see what happens if we encounter an unexpected symbol, as in @run pa \"b\"@:
--
-- @
-- Result: \"a\"
-- Correcting steps:
-- Deleted 'b' at position 0 expecting 'a'
-- Inserted 'a' at position 1 expecting 'a'
-- @
test3 = run pa "b"
-- | The combinator @\<++>@ applies two parsers sequentially to the input and concatenates their results: @run (pa <++> pa) \"aa\"@:
--
-- @
-- Result: \"aa\"
-- @
(<++>) :: Parser String -> Parser String -> Parser String
p <++> q = (++) <$> p <*> q
pa2 = pa <++> pa
pa3 = pa <++> pa2
test4 = run pa2 "aa"
-- | The function @`pSym`@ is overloaded. The type of its argument determines how to interpret the argument. Thus far we have seen single characters,
-- but we may pass ranges as well as argument: @\run (pList (pSym ('a','z'))) \"doaitse\"@
--
-- @
-- Result: "doaitse"
-- @
test5 = run (pList (pSym ('a','z'))) "doaitse"
paz = pList (pSym ('a', 'z'))
-- | An even more general instance of @`pSym`@ takes a triple as argument: a predicate, a string indicating what is expected,
-- and the value to insert if nothing can be recognised: @run (pSym (\t -> 'a' <= t && t <= 'z', \"'a'..'z'\", 'k')) \"v\"@
--
-- @
-- Result: 'k'
-- Correcting steps:
-- Deleted '1' at position 0 expecting 'a'..'z'
-- Inserted 'k' at position 1 expecting 'a'..'z'
-- @
test6 = run paz' "1"
paz' = pSym (\t -> 'a' <= t && t <= 'z', "'a'..'z'", 'k')
-- | The parser `pCount` recognises a sequence of elements, throws away the results of the recognition process (@ \<$ @), and just returns the number of returned elements.
-- The choice combinator @\<\<|>@ indicates that prefernce is to be given to the left alternative if it can make progress. This enables us to specify greedy strategies:
-- @ run (pCount pa) \"aaaaa\"@
--
-- @
-- Result: 5
-- @
pCount p = (+1) <$ p <*> pCount p <<|> pReturn 0
test7 = run (pCount pa) "aaaaa"
-- | The parsers are instance of the class Monad and hence we can use the result of a previous parser to construct a following one: @run (do {l <- pCount pa; pExact l pb}) \"aaacabbb\"@
--
-- @
-- Result: [\"b\",\"b\",\"b\",\"b\"]
-- Correcting steps:
-- Deleted 'c' at position 3 expecting one of ['a', 'b']
-- Inserted 'b' at position 8 expecting 'b'
-- @
test8 = run (do {l <- pCount pa; pExact l pb}) "aaacabbb"
pExact 0 p = pReturn []
pExact n p = (:) <$> p <*> pExact (n-1) p
-- | The function @`amb`@ converts an ambigous parser into one which returns all possible parses: @run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) \"aaaaa\"@
--
-- @
-- Result: [\"aaaaa\",\"aaaaa\"]
-- @
test9 = run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaaaa"
-- | The applicative style makes it very easy to merge recognsition and computing a result. As an example we parse a sequence of nested well formed parentheses pairs a,d
-- compute the maximum nesting depth: @run ( max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0) \"((()))()(())\" @
--
-- @
-- Result: 3
-- @
test10 = run wfp "((()))()(())"
wfp = max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0
-- | It is very easy to recognise infix expressions with any number of priorities and operators:
--
-- @
-- pOp (c, op) = op <$ pSym c
-- sepBy p op = pChainl op p
-- expr = foldr sepBy factor [(pOp ('+', (+)) <|> pOp ('-', (-))), pOp ('*' , (*))]
-- factor = pNatural <|> pParens expr
-- @
--
-- | which we can call: @run expr \"15-3*5\"@
--
-- @
-- Result: 0
-- @
--
-- | Note that also here correction takes place: @run expr \"2 + + 3 5\"@
--
-- @
-- Result: 37
-- Correcting steps:
-- Deleted ' ' at position 1 expecting one of ['0'..'9', '*', '-', '+']
-- Inserted '0' at position 3 expecting one of ['(', '0'..'9']
-- Deleted ' ' at position 4 expecting one of ['(', '0'..'9']
-- Deleted ' ' at position 6 expecting one of ['0'..'9', '*', '-', '+']
-- @
test11 = run expr "15-3*5"
-- parsing expressions
pOp (c, op) = op <$ pSym c
expr = foldr pChainl factor [(pOp ('+', (+)) <|> pOp ('-', (-))), pOp ('*' , (*))]
factor = pNatural <|> pParens expr
-- parsing numbers
pDigit :: Parser Char
pDigit = pSym ('0', '9')
pDigitAsInt = digit2Int <$> pDigit
pNatural = foldl (\a b -> a * 10 + b ) 0 <$> pList1 pDigitAsInt
digit2Int a = ord a - ord '0'
-- | A common case where ambiguity arises is when we e.g. want to recognise identifiers, but only those which are not keywords.
-- The combinator `micro` inserts steps with a specfied cost in the result of the parser which can be used to disambiguate:
--
-- @
-- ident :: Parser String
-- ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces
-- idents = pList1 ident
-- pKey keyw = pToken keyw `micro` 1 <* spaces
-- spaces :: Parser String
-- spaces = pMunch (==' ')
-- takes_second_alt = pList ident
-- \<|> (\ c t e -> [\"IfThenElse\"] ++ c ++ t ++ e)
-- \<$ pKey \"if\" \<*> pList_ng ident
-- \<* pKey \"then\" \<*> pList_ng ident
-- \<* pKey \"else\" \<*> pList_ng ident
-- @
--
-- | A keyword is followed by a small cost @1@, which makes sure that identifiers which have a keyword as a prefix win over the keyword. Identifiers are however
-- followed by a cost @2@, with as result that in this case the keyword wins.
-- Note that a limitation of this approach is that keywords are only recognised as such when expected!
--
-- @
-- test13 = run takes_second_alt \"if a then if else c\"
-- test14 = run takes_second_alt \"ifx a then if else c\"
-- @
--
-- with results:
--
-- @
-- Text.ParserCombinators.UU.Examples> test14
-- Result: [\"IfThenElse\",\"a\",\"if\",\"c\"]
-- Text.ParserCombinators.UU.Examples> test14
-- Result: [\"ifx\",\"a\",\"then\",\"if\",\"else\",\"c\"]
-- @
ident :: Parser String
ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces
idents = pList1 ident
pKey keyw = pToken keyw `micro` 1 <* spaces
spaces :: Parser String
spaces = pMunch (==' ')
takes_second_alt = pList ident
<|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e)
<$ pKey "if" <*> pList_ng ident
<* pKey "then" <*> pList_ng ident
<* pKey "else" <*> pList_ng ident
test13 = run takes_second_alt "if a then if else c"
test14 = run takes_second_alt "ifx a then if else c"
munch = (,,) <$> pa <*> pMunch ( `elem` "^=*") <*> pb
-- bracketing expressions
pParens :: Parser a -> Parser a
pParens p = pSym '(' *> p <* pSym ')'
pBracks p = pSym '[' *> p <* pSym ']'
pCurlys p = pSym '{' *> p <* pSym '}'
-- parsing letters and identifiers
pLower = pSym ('a','z')
pUpper = pSym ('A','Z')
pLetter = pUpper <|> pLower
pVarId = (:) <$> pLower <*> pList pIdChar
pConId = (:) <$> pUpper <*> pList pIdChar
pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"
pAnyToken :: [String] -> Parser String
pAnyToken = pAny pToken
-- parsing two alternatives and returning both rsults
pAscii = pSym ('\000', '\254')
pIntList ::Parser [Int]
pIntList = pParens ((pSym ';') `pListSep` (read <$> pList (pSym ('0', '9'))))
parseIntString :: Parser String
parseIntString = pList (pAscii)
parseBoth = pPair pIntList parseIntString
pPair p q = amb (Left <$> p <|> Right <$> q)
main :: IO ()
main = do test1
run pa "b"
run pa2 "bbab"
run pa "ba"
run pa "aa"
run (do {l <- pCount pa; pExact l pb}) "aaacabbbb"
run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaabaa"
run paz "ab1z7"
run paz' "m"
run paz' ""
run (pa <|> pb <?> "just a message") "c"
run parseBoth "(123;456;789)"
run munch "a^=^**^^b"