uu-parsinglib-2.7.0: src/Text/ParserCombinators/UU/Demo/Examples.hs
{-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE FlexibleInstances,
TypeSynonymInstances,
MultiParamTypeClasses,
Rank2Types, FlexibleContexts, NoMonomorphismRestriction,
CPP #-}
-- | This module contains a lot of examples of the typical use of our parser combinator library.
-- We strongly encourage you to take a look at the source code
-- At the end you find a @`main`@ function which demonstrates the main characteristics.
-- Only the @`run`@ function is exported since it may come in handy elsewhere.
module Text.ParserCombinators.UU.Demo.Examples where
import Data.Char
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.BasicInstances
import System.IO
import GHC.IO.Handle.Types
-- import Control.Monad
#define DEMO(p,i) demo "p" i p
justamessage = "justamessage"
-- | Running the function `show_demos` should give the following output:
--
-- >>> run pa "a"
-- Result: "a"
--
-- >>> run pa ""
-- Result: "a"
-- Correcting steps:
-- Inserted 'a' at position LineColPos 0 0 0 expecting 'a'
--
-- >>> run pa "b"
-- Result: "a"
-- Correcting steps:
-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'
-- Inserted 'a' at position LineColPos 0 1 1 expecting 'a'
--
-- >>> run ((++) <$> pa <*> pa) "bbab"
-- Result: "aa"
-- Correcting steps:
-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'
-- Deleted 'b' at position LineColPos 0 1 1 expecting 'a'
-- Deleted 'b' at position LineColPos 0 3 3 expecting 'a'
-- Inserted 'a' at position LineColPos 0 4 4 expecting 'a'
--
-- >>> run pa "ba"
-- Result: "a"
-- Correcting steps:
-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'
--
-- >>> run pa "aa"
-- Result: "a"
-- Correcting steps:
-- The token 'a' was not consumed by the parsing process.
--
-- >>> run (pCount pa :: Parser Int) "aaa"
-- Result: 3
--
-- >>> run (do {l <- pCount pa; pExact l pb}) "aaacabbbbb"
-- Result: ["b","b","b","b"]
-- Correcting steps:
-- Deleted 'c' at position LineColPos 0 3 3 expecting one of ['b', 'a']
-- The token 'b' was not consumed by the parsing process.
--
-- >>> run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaaaa"
-- Result: ["aaaaa","aaaaa"]
--
-- >>> run (pList pLower) "doaitse"
-- Result: "doaitse"
--
-- >>> run paz "abc2ez"
-- Result: "abcez"
-- Correcting steps:
-- Deleted '2' at position LineColPos 0 3 3 expecting 'a'..'z'
--
-- >>> run (max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0) "((()))()(())"
-- Result: 3
--
-- >>> run (pa <|> pb <?> justamessage) "c"
-- Result: "b"
-- Correcting steps:
-- Deleted 'c' at position LineColPos 0 0 0 expecting justamessage
-- Inserted 'b' at position LineColPos 0 1 1 expecting 'b'
--
-- >>> run (amb (pEither parseIntString pIntList)) "(123;456;789)"
-- Result: [Left ["123","456","789"],Right [123,456,789]]
--
show_demos :: IO ()
show_demos =
do DEMO (pa, "a")
DEMO (pa, "" )
DEMO (pa, "b")
DEMO (((++) <$> pa <*> pa), "bbab")
DEMO (pa, "ba")
DEMO (pa, "aa")
DEMO ((pCount pa :: Parser Int), "aaa")
DEMO ((do {l <- pCount pa; pExact l pb}), "aaacabbbbb")
DEMO ((amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)), "aaaaa")
DEMO ((pList pLower), "doaitse")
DEMO (paz, "abc2ez")
DEMO ((max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0), "((()))()(())")
DEMO ((pa <|> pb <?> justamessage), "c")
DEMO ((amb (pEither parseIntString pIntList)), "(123;456;789)")
-- DEMO ((pa *> pMunch ( `elem` "^=*") <* pb), "a^=^**^^b")
-- | 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 => Parser t -> String -> IO ()
run p inp = do let r@(a, errors) = parse ( (,) <$> p <*> pEnd) (createStr (LineColPos 0 0 0) inp)
putStrLn ("-- Result: " ++ show a)
if null errors then return ()
else do putStr ("-- Correcting steps: \n")
show_errors errors
putStrLn "-- "
where show_errors :: (Show a) => [a] -> IO ()
show_errors = sequence_ . (map (putStrLn . show))
-- | 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 recognsised character into `String` so they can be easily combined.
pa ::Parser String
pa = lift <$> pSym 'a'
pb :: Parser String
pb = lift <$> pSym 'b'
pc :: Parser String
pc = lift <$> pSym 'c'
lift a = [a]
(<++>) :: Parser String -> Parser String -> Parser String
p <++> q = (++) <$> p <*> q
pa2 = pa <++> pa
pa3 = pa <++> pa2
paz :: Parser String
paz = pList (pSatisfy (\t -> 'a' <= t && t <= 'z') (Insertion "'a'..'z'" 'k' 5))
-- | The applicative style makes it very easy to merge recogition and computing a result.
-- As an example we parse a sequence of nested well formed parentheses pairs and
-- compute the maximum nesting depth with @`wfp`@:
wfp :: Parser Int
wfp = max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0
-- | It is very easy to recognise infix expressions with any number of priorities and operators:
--
-- > operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]
-- > same_prio ops = msum [ op <$ pSym c | (c, op) <- ops]
-- > expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators) --
--
-- which we can call:
--
-- > run expr "15-3*5+2^5"
--
-- > Result: 32
--
-- 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', '^', '*', '-', '+']
-- > Deleted ' ' at position 3 expecting one of ['(', '0'..'9']
-- > Inserted '0' at position 4 expecting '0'..'9'
-- > Deleted ' ' at position 5 expecting one of ['(', '0'..'9']
-- > Deleted ' ' at position 7 expecting one of ['0'..'9', '^', '*', '-', '+']
--
test11 = run expr "15-3*5"
expr :: Parser Int
operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]
same_prio ops = foldr (<|>) empty [ op <$ pSym c | (c, op) <- ops]
expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators)
-- | 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 for @test13@ and @test14@:
--
-- > Result: ["IfThenElse","a","if","c"]
-- > Result: ["ifx","a","then","if", "else","c"]
--
-- | A mistake which is made quite often is to construct a parser which can recognise a sequence of elements using one of the
-- derived combinators (say @`pList`@), but where the argument parser can recognise the empty string.
-- The derived combinators check whether this is the case and terminate the parsing process with an error message:
--
-- > run (pList spaces) ""
-- > Result: *** Exception: The combinator pList
-- > requires that it's argument cannot recognise the empty string
--
-- > run (pMaybe spaces) " "
-- > Result: *** Exception: The combinator pMaybe
-- > requires that it's argument cannot recognise the empty string
test16 :: IO ()
test16 = run (pList spaces) " "
ident = ((:) <$> pRange ('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 (`elem` " \n")
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"
pManyTill :: P st a -> P st b -> P st [a]
pManyTill p end = [] <$ end
<<|>
(:) <$> p <*> pManyTill p end
simpleComment = string "<!--" *> pManyTill pAscii (string "-->")
string :: String -> Parser String
string = pToken
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
pIntList :: Parser [Int]
pIntList = pParens ((pSym ';') `pListSep` (read <$> pList1 (pRange ('0', '9'))))
parseIntString :: Parser [String]
parseIntString = pParens ((pSym ';') `pListSep` ( pList1 (pRange('0', '9'))))
demo :: Show r => String -> String -> Parser r -> IO ()
demo str input p= do putStr ("-- >>> run " ++ str ++ " " ++ show input ++ "\n")
run p input