module CCO.Parsing.UU (
parseFeedback
) where
import CCO.Feedback (Feedback, errorMessage)
import CCO.Printing (Doc, text, wrapped, (>|<), above)
import UU.Parsing
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
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)
describePosition :: Show s => Maybe s -> String
describePosition Nothing = "end of input"
describePosition (Just s) = show s
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