-------------------------------------------------------------------------------
-- |
-- Module : CCO.Parsing.UU
-- Copyright : (c) 2008 Utrecht University
-- License : All rights reserved
--
-- Maintainer : stefan@cs.uu.nl
-- Stability : provisional
-- Portability : portable
--
-- Utility for executing 'Parser's from the Haskell Utrecht Tools Library
-- within the 'Feedback' monad.
--
-- This module can be regarded a satellite to the utility library accompanying
-- the course on Compiler Construction (INFOMCCO) at Utrecht University.
--
-------------------------------------------------------------------------------
module CCO.Parsing.UU (
-- * Executing parsers within the Feedback monad
parseFeedback -- :: (Eq s, Show s, Symbol s) =>
-- Parser s a -> [s] -> Feedback a
) where
import CCO.Feedback (Feedback, errorMessage)
import CCO.Printing (Doc, text, wrapped, (>|<), above)
import UU.Parsing
-------------------------------------------------------------------------------
-- Executing parsers within the Feedback monad
-------------------------------------------------------------------------------
-- | Executes a 'Parser' within the 'Feedback' monad.
parseFeedback :: (Eq s, Show s, Symbol s) => Parser s a -> [s] -> Feedback a
parseFeedback parser input = do Pair x final <- evalSteps (parse parser input)
final `seq` return x
where
evalSteps :: (Eq s, Show s) => Steps a s (Maybe s) -> Feedback a
evalSteps (OkVal f rest) = do x <- evalSteps rest
return (f x)
evalSteps (Ok rest) = evalSteps rest
evalSteps (Cost _ rest) = evalSteps rest
evalSteps (StRepair _ msg rest) = do errorMessage (ppMessage msg)
evalSteps rest
evalSteps (Best _ rest _) = evalSteps rest
evalSteps (NoMoreSteps x) = return x
-- | Pretty prints a 'Message' produced by a 'Parser'.
ppMessage :: (Eq s, Show s) => Message s (Maybe s) -> Doc
ppMessage (Msg exp pos action)
= above [ppHeader, ppUnexpected, ppExpected]
where
ppHeader = wrapped "Parse error."
ppUnexpected = text "*** Unexpected : " >|< wrapped (describePosition pos)
ppExpected = text "*** Expected : " >|< wrapped (describeExpecting exp)
-- | Describes a symbol or the end of input.
describePosition :: Show s => Maybe s -> String
describePosition Nothing = "end of input"
describePosition (Just s) = show s
-- | Describes an expected symbol.
describeExpecting :: (Eq s, Show s) => Expecting s -> String
describeExpecting (ESym EmptyR) = "end of input"
describeExpecting (ESym (Range l r)) | l == r = show l
| otherwise = show l ++ " .. " ++ show r
describeExpecting (EStr s) = s
describeExpecting (EOr []) = "end of input"
describeExpecting (EOr [e]) = describeExpecting e
describeExpecting (EOr [e, e']) = describeExpecting e ++ " or " ++
describeExpecting e'
describeExpecting (EOr [e, e', e'']) = describeExpecting e ++ ", " ++
describeExpecting e' ++ ", or " ++
describeExpecting e''
describeExpecting (EOr (e : es)) = describeExpecting e ++ ", " ++
describeExpecting (EOr es)
describeExpecting (ESeq []) = "end of input"
describeExpecting (ESeq (e : _)) = describeExpecting e