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 Prelude
  30 import Data.List (nub,sortBy)
  31 import Text.ParserCombinators.Parsec.Pos
  32
  33 -----------------------------------------------------------
  34 -- Messages
  35 -----------------------------------------------------------
  36 data Message        = SysUnExpect !String   --library generated unexpect
  37                     | UnExpect    !String   --unexpected something
  38                     | Expect      !String   --expecting something
  39                     | Message     !String   --raw message
  40
  41 messageToEnum msg
  42     = case msg of SysUnExpect _ -> 0
  43                   UnExpect _    -> 1
  44                   Expect _      -> 2
  45                   Message _     -> 3
  46
  47 messageCompare :: Message -> Message -> Ordering
  48 messageCompare msg1 msg2
  49     = compare (messageToEnum msg1) (messageToEnum msg2)
  50
  51 messageString :: Message -> String
  52 messageString msg
  53     = case msg of SysUnExpect s -> s
  54                   UnExpect s    -> s
  55                   Expect s      -> s
  56                   Message s     -> s
  57
  58 messageEq :: Message -> Message -> Bool
  59 messageEq msg1 msg2
  60     = (messageCompare msg1 msg2 == EQ)
  61
  62
  63 -----------------------------------------------------------
  64 -- Parse Errors
  65 -----------------------------------------------------------
  66 data ParseError     = ParseError !SourcePos [Message]
  67
  68 errorPos :: ParseError -> SourcePos
  69 errorPos (ParseError pos msgs)
  70     = pos
  71
  72 errorMessages :: ParseError -> [Message]
  73 errorMessages (ParseError pos msgs)
  74     = sortBy messageCompare msgs
  75
  76 errorIsUnknown :: ParseError -> Bool
  77 errorIsUnknown (ParseError pos msgs)
  78     = null msgs
  79
  80
  81 -----------------------------------------------------------
  82 -- Create parse errors
  83 -----------------------------------------------------------
  84 newErrorUnknown :: SourcePos -> ParseError
  85 newErrorUnknown pos
  86     = ParseError pos []
  87
  88 newErrorMessage :: Message -> SourcePos -> ParseError
  89 newErrorMessage msg pos
  90     = ParseError pos [msg]
  91
  92 addErrorMessage :: Message -> ParseError -> ParseError
  93 addErrorMessage msg (ParseError pos msgs)
  94     = ParseError pos (msg:msgs)
  95
  96 setErrorPos :: SourcePos -> ParseError -> ParseError
  97 setErrorPos pos (ParseError _ msgs)
  98     = ParseError pos msgs
  99
 100 setErrorMessage :: Message -> ParseError -> ParseError
 101 setErrorMessage msg (ParseError pos msgs)
 102     = ParseError pos (msg:filter (not . messageEq msg) msgs)
 103
 104
 105 mergeError :: ParseError -> ParseError -> ParseError
 106 mergeError (ParseError pos msgs1) (ParseError _ msgs2)
 107     = ParseError pos (msgs1 ++ msgs2)
 108
 109
 110
 111 -----------------------------------------------------------
 112 -- Show Parse Errors
 113 -----------------------------------------------------------
 114 instance Show ParseError where
 115   show err
 116     = show (errorPos err) ++ ":" ++
 117       showErrorMessages "or" "unknown parse error"
 118                         "expecting" "unexpected" "end of input"
 119                        (errorMessages err)
 120
 121
 122 -- Language independent show function
 123 showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
 124     | null msgs = msgUnknown
 125     | otherwise = concat $ map ("\n"++) $ clean $
 126                  [showSysUnExpect,showUnExpect,showExpect,showMessages]
 127     where
 128       (sysUnExpect,msgs1)   = span (messageEq (SysUnExpect "")) msgs
 129       (unExpect,msgs2)      = span (messageEq (UnExpect "")) msgs1
 130       (expect,messages)     = span (messageEq (Expect "")) msgs2
 131
 132       showExpect        = showMany msgExpecting expect
 133       showUnExpect      = showMany msgUnExpected unExpect
 134       showSysUnExpect   | not (null unExpect) ||
 135                           null sysUnExpect       = ""
 136                         | null firstMsg          = msgUnExpected ++ " " ++ msgEndOfInput
 137                         | otherwise              = msgUnExpected ++ " " ++ firstMsg
 138                         where
 139                           firstMsg  = messageString (head sysUnExpect)
 140
 141       showMessages      = showMany "" messages
 142
 143
 144       --helpers
 145       showMany pre msgs = case (clean (map messageString msgs)) of
 146                             [] -> ""
 147                             ms | null pre  -> commasOr ms
 148                                | otherwise -> pre ++ " " ++ commasOr ms
 149
 150       commasOr []       = ""
 151       commasOr [m]      = m
 152       commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
 153
 154       commaSep          = seperate ", " . clean
 155       semiSep           = seperate "; " . clean
 156
 157       seperate sep []   = ""
 158       seperate sep [m]  = m
 159       seperate sep (m:ms) = m ++ sep ++ seperate sep ms
 160
 161       clean             = nub . filter (not.null)
 162