Text/ParserCombinators/Parsec/Error.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.ParserCombinators.Parsec.Error
   4 -- Copyright   :  (c) Daan Leijen 1999-2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  daan@cs.uu.nl
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- Parse errors
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Text.ParserCombinators.Parsec.Error
  16                   ( Message(SysUnExpect,UnExpect,Expect,Message)
  17                   , messageString, messageCompare, messageEq
  18
  19                   , ParseError, errorPos, errorMessages, errorIsUnknown
  20                   , showErrorMessages
  21
  22                   , newErrorMessage, newErrorUnknown
  23                   , addErrorMessage, setErrorPos, setErrorMessage
  24                   , mergeError
  25                   )
  26                   where
  27
  28
  29 import Data.List (nub,sortBy)
  30 import Text.ParserCombinators.Parsec.Pos
  31
  32 -----------------------------------------------------------
  33 -- Messages
  34 -----------------------------------------------------------
  35 data Message        = SysUnExpect !String   --library generated unexpect
  36                     | UnExpect    !String   --unexpected something
  37                     | Expect      !String   --expecting something
  38                     | Message     !String   --raw message
  39
  40 messageToEnum msg
  41     = case msg of SysUnExpect _ -> 0
  42                   UnExpect _    -> 1
  43                   Expect _      -> 2
  44                   Message _     -> 3
  45
  46 messageCompare msg1 msg2
  47     = compare (messageToEnum msg1) (messageToEnum msg2)
  48
  49 messageString msg
  50     = case msg of SysUnExpect s -> s
  51                   UnExpect s    -> s
  52                   Expect s      -> s
  53                   Message s     -> s
  54
  55 messageEq msg1 msg2
  56     = (messageCompare msg1 msg2 == EQ)
  57
  58
  59 -----------------------------------------------------------
  60 -- Parse Errors
  61 -----------------------------------------------------------
  62 data ParseError     = ParseError !SourcePos [Message]
  63
  64 errorPos :: ParseError -> SourcePos
  65 errorPos (ParseError pos msgs)
  66     = pos
  67
  68 errorMessages :: ParseError -> [Message]
  69 errorMessages (ParseError pos msgs)
  70     = sortBy messageCompare msgs
  71
  72 errorIsUnknown :: ParseError -> Bool
  73 errorIsUnknown (ParseError pos msgs)
  74     = null msgs
  75
  76
  77 -----------------------------------------------------------
  78 -- Create parse errors
  79 -----------------------------------------------------------
  80 newErrorUnknown pos
  81     = ParseError pos []
  82
  83 newErrorMessage msg pos
  84     = ParseError pos [msg]
  85
  86 addErrorMessage msg (ParseError pos msgs)
  87     = ParseError pos (msg:msgs)
  88
  89 setErrorPos pos (ParseError _ msgs)
  90     = ParseError pos msgs
  91
  92 setErrorMessage msg (ParseError pos msgs)
  93     = ParseError pos (msg:filter (not . messageEq msg) msgs)
  94
  95
  96 mergeError :: ParseError -> ParseError -> ParseError
  97 mergeError (ParseError pos msgs1) (ParseError _ msgs2)
  98     = ParseError pos (msgs1 ++ msgs2)
  99
 100
 101
 102 -----------------------------------------------------------
 103 -- Show Parse Errors
 104 -----------------------------------------------------------
 105 instance Show ParseError where
 106   show err
 107     = show (errorPos err) ++ ":" ++
 108       showErrorMessages "or" "unknown parse error"
 109                         "expecting" "unexpected" "end of input"
 110                        (errorMessages err)
 111
 112
 113 -- Language independent show function
 114 showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
 115     | null msgs = msgUnknown
 116     | otherwise = concat $ map ("\n"++) $ clean $
 117                  [showSysUnExpect,showUnExpect,showExpect,showMessages]
 118     where
 119       (sysUnExpect,msgs1)   = span (messageEq (SysUnExpect "")) msgs
 120       (unExpect,msgs2)      = span (messageEq (UnExpect "")) msgs1
 121       (expect,messages)     = span (messageEq (Expect "")) msgs2
 122
 123       showExpect        = showMany msgExpecting expect
 124       showUnExpect      = showMany msgUnExpected unExpect
 125       showSysUnExpect   | not (null unExpect) ||
 126                           null sysUnExpect       = ""
 127                         | null firstMsg          = msgUnExpected ++ " " ++ msgEndOfInput
 128                         | otherwise              = msgUnExpected ++ " " ++ firstMsg
 129                         where
 130                           firstMsg  = messageString (head sysUnExpect)
 131
 132       showMessages      = showMany "" messages
 133
 134
 135       --helpers
 136       showMany pre msgs = case (clean (map messageString msgs)) of
 137                             [] -> ""
 138                             ms | null pre  -> commasOr ms
 139                                | otherwise -> pre ++ " " ++ commasOr ms
 140
 141       commasOr []       = ""
 142       commasOr [m]      = m
 143       commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
 144
 145       commaSep          = seperate ", " . clean
 146       semiSep           = seperate "; " . clean
 147
 148       seperate sep []   = ""
 149       seperate sep [m]  = m
 150       seperate sep (m:ms) = m ++ sep ++ seperate sep ms
 151
 152       clean             = nub . filter (not.null)
 153