/src/Parsers.hs

  1{-# LANGUAGE UnicodeSyntax, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, RecordWildCards, NamedFieldPuns, ViewPatterns, TypeSynonymInstances #-}
  2
  3module Parsers where
  4
  5import qualified Data.List as List
  6import qualified Text.ParserCombinators.Parsec as PS
  7import qualified Editing.Commands
  8import qualified Editing.Show ()
  9import qualified Data.Char as Ch
 10
 11import Data.List.NonEmpty (NonEmpty((:|)))
 12import Data.Foldable (toList)
 13import Control.Monad (liftM, liftM2)
 14import Control.Arrow (first)
 15import Data.List ((\\))
 16import Data.Maybe (fromMaybe)
 17import Editing.Basics (positionIn)
 18import Util ((.), Finite(..), commas_or, Option(..), (.∨.), isIdChar, (<<), NeList, MyMonadError(..))
 19
 20import Prelude hiding ((.))
 21import Prelude.Unicode
 22
 23-- To let us write parsers that work with both Parsec and our own Parser monad, we introduce the ParserLike class:
 24
 25class (Functor m, Monad m) ⇒ ParserLike m t | m → t where
 26  anySymbol :: m t
 27  anySymbol = satisfy $ const True
 28  symbols :: (Eq t, Show t) ⇒ [t] → m [t]
 29  symbols = foldr (\ h → liftM2 (:) (satisfy (== h))) (return [])
 30  satisfy :: (t → Bool) → m t
 31  (<|>) :: m a → m a → m a
 32  (<?>) :: m a → String → m a
 33  lookAhead :: m a → m a
 34  pzero :: m a
 35  eof :: m ()
 36  try :: m a → m a
 37  getInput :: m [t]
 38  getInput = many anySymbol << eof
 39
 40infix 0 <?>
 41infixr 1 <|>
 42
 43-- Parsec is clearly ParserLike:
 44
 45instance ParserLike (PS.GenParser Char st) Char where
 46  (<?>) = (PS.<?>)
 47  lookAhead = PS.lookAhead
 48  (<|>) = (PS.<|>)
 49  symbols = PS.string
 50  anySymbol = PS.anyChar
 51  satisfy = PS.satisfy
 52  pzero = PS.pzero
 53  eof = PS.eof
 54  try = PS.try
 55
 56-- Utility parser combinators:
 57
 58manyTill :: ParserLike m t ⇒ m a → m b → m ([a], b)
 59manyTill p e = ((,) [] . e) <|> liftM2 (\x (y, z) → (x:y, z)) p (manyTill p e)
 60
 61many1Till :: ParserLike m t ⇒ m a → m b → m (NeList a, b)
 62many1Till p e = p >>= \v → first (v :|) . manyTill p e
 63
 64optionMaybe :: ParserLike m t ⇒ m a → m (Maybe a)
 65optionMaybe p = Just . p <|> return Nothing
 66
 67optional :: ParserLike m t ⇒ m a → m (Maybe a)
 68optional p = Just . p <|> return Nothing
 69
 70option :: ParserLike m t ⇒ a → m a → m a
 71option x p = fromMaybe x . optional p
 72
 73symbol :: (Show t, Eq t, ParserLike m t) ⇒ t → m t
 74symbol x = satisfy (== x) <?> show x
 75
 76choice :: ParserLike m t ⇒ [m a] → m a
 77choice = foldl (<|>) pzero
 78
 79many :: ParserLike m t ⇒ m a → m [a]
 80many p = liftM2 (:) p (many p) <|> return []
 81
 82many1 :: ParserLike m t ⇒ m a → m (NeList a)
 83many1 p = liftM2 (:|) p (many p)
 84
 85spaces :: ParserLike m Char ⇒ m String
 86spaces = many $ symbol ' '
 87
 88noneOf :: (Eq t, ParserLike m t) ⇒ [t] → m t
 89noneOf l = satisfy (∉ l)
 90
 91oneOf :: (Eq t, ParserLike m t) ⇒ [t] → m t
 92oneOf l = satisfy (∈ l)
 93
 94sep :: ParserLike m t ⇒ m a → m b → m (a, [(b, a)])
 95sep p p' = liftM2 (,) p (many (liftM2 (,) p' p))
 96
 97sepBy1' :: ParserLike m t ⇒ m a → m b → m (NeList a)
 98sepBy1' x y = (\(h, t) → h :| map snd t) . sep x y
 99
100sepBy1 :: ParserLike m t ⇒ m a → m b → m [a]
101sepBy1 p e = liftM2 (:) p ((e >> sepBy1 p e) <|> return [])
102
103kwd :: String → Parser Char String
104kwd s = try $ symbols s << notFollowedBy (satisfy isIdChar) << spaces
105
106kwds :: [String] → Parser Char String
107kwds = choice . (kwd .)
108
109char_unit :: (Eq a, Show a) ⇒ a → Parser a ()
110char_unit = (>> return ()) . char
111
112{-
113
114Parsec's parse error descriptions aren't very good for parsers that backtrack. Consider
115
116  parse (try (char 'x' >> char 'y') <|> char 'a') "" "x3"
117
118This parse fails because (1) there is no 'y' at the second column, and (2) there is no 'a' at the first column. Intuitively, we feel that the first cause is the "real" cause, as it follows a longer partial match. Unfortunately, Parsec's errors do not reflect this:
119
120  Left (line 1, column 1):
121  unexpected "3"
122  expecting "y" or "a"
123
124Here, column numbers start at 1. Thus, while it /does/ mention the 'y' expectation and the unexpected '3', it fails to give the column number where 'y' was expected, and also does not show that the 'y' expectation followed a longer partial match than the 'a' expectation.
125
126The parsing combinators in this module properly keep track of lengths of partial matches, to get intuitive error descriptions. For the parse above, they report only the 'y' expectation, at the second column.
127
128Parsec mixes ordinary parse errors with custom parse errors. One can "fail" at any point. The parsers below can only fail due to unexpected symbols. Additional errors can be added by using parsers returning (Either String a)'s.
129
130-}
131
132data Expectation = Expected { expectedAt :: Int, expectedWhat :: [String] }
133
134uninformativeExpectation :: Expectation
135uninformativeExpectation = Expected 0 []
136
137data ParseResult t a
138  = ParseSuccess a [t] Int (Maybe Expectation)
139  -- The Int is the length of the match. Hence, the [t] is strictly redundant, but there for efficiency. The Maybe is the furthest we've been able to parse successfully, with an indication of why we couldn't go even further.
140  | ParseFailure Expectation Bool
141  -- The Bool indicates whether the failure is terminal.
142
143instance Functor (ParseResult t) where
144  fmap f (ParseSuccess x t i m) = ParseSuccess (f x) t i m; fmap _ (ParseFailure e b) = ParseFailure e b
145
146newtype Parser t a = Parser { run_parser :: [t] → ParseResult t a }
147
148peek :: Parser t [t]
149peek = Parser $ \s → ParseSuccess s s 0 Nothing
150
151drain :: Parser t [t]
152drain = Parser $ \s → ParseSuccess s [] (length s) Nothing
153
154parseSuccess :: a → Parser t a
155parseSuccess = return
156
157-- Parser is a Functor, a Monad, and ParserLike:
158
159instance Functor (Parser t) where fmap = liftM
160
161instance Monad (Parser t) where
162  return x = Parser $ \s → ParseSuccess x s 0 Nothing
163  Parser p >>= f = Parser $ \s → case p s of
164    ParseSuccess r s' n m → case run_parser (f r) s' of
165      ParseSuccess r' s'' n' m' → ParseSuccess r' s'' (n + n') (furthest m (offset n . m'))
166      ParseFailure (offset n → m') b → ParseFailure (maybe m' (furthest' m') m) b
167    ParseFailure e b → ParseFailure e b
168  fail = const pzero
169
170instance ParserLike (Parser a) a where
171  anySymbol = satisfy (const True) <?> "any symbol"
172  satisfy p = Parser $ \s → case s of
173    h:t | p h → ParseSuccess h t 1 Nothing
174    _ → ParseFailure uninformativeExpectation False
175  symbols t = Parser $ \s → case List.stripPrefix t s of
176    Nothing → ParseFailure (Expected 0 [show t]) False
177    Just s' → ParseSuccess t s' (length t) Nothing
178  Parser p <|> Parser q = Parser $ \s → case p s of
179    ParseFailure m False → case q s of
180      ParseSuccess r u n' m' → ParseSuccess r u n' $ Just $ maybe m (furthest' m) m'
181      ParseFailure m' b → ParseFailure (furthest' m m') b
182    ps → ps
183  Parser p <?> m = Parser $ \s → case p s of
184    ParseFailure (Expected 0 _) b → ParseFailure (Expected 0 [m]) b
185    b → b
186  lookAhead (Parser p) = Parser $ \s → case p s of
187    ParseSuccess r _ _ m → ParseSuccess r s 0 m
188    e → e
189  pzero = Parser $ const $ ParseFailure uninformativeExpectation False
190  eof = Parser $ \s → if null s then ParseSuccess () [] 0 Nothing else ParseFailure (Expected 0 ["EOF"]) False
191  try = id
192  getInput = Parser $ \s → ParseSuccess s s 0 Nothing
193
194notFollowedBy :: Parser t a → Parser t ()
195notFollowedBy (Parser p) = Parser $ \s → case p s of
196  ParseFailure{} → ParseSuccess () s 0 Nothing
197  ParseSuccess{} → ParseFailure uninformativeExpectation False
198
199-- Some Parser-specific parsers:
200
201guarded :: (a → Bool) → Parser t a → Parser t a
202guarded f (Parser p) = Parser $ \s → case p s of
203  ParseSuccess x _ _ _ | not (f x) → ParseFailure uninformativeExpectation False
204  k → k
205
206char :: (Show t, Eq t) ⇒ t → Parser t t
207char t = satisfy (== t) <?> show t
208
209commit :: Parser t a → Parser t a
210commit (Parser p) = Parser $ \s → case p s of
211  ParseFailure x _ → ParseFailure x True
212  ps → ps
213
214silent :: Parser t a → Parser t a
215silent (Parser p) = Parser $ \s → case p s of
216  ParseFailure _ b → ParseFailure uninformativeExpectation b
217  ParseSuccess r t n _ → ParseSuccess r t n Nothing
218
219optParser :: (MyMonadError String m, Functor m, Finite o, Option o) ⇒ Parser Char (m [o])
220optParser = (<?> "option") $ (char '-' >>) $ do
221    char '-'
222    n ← (<?> "option name") $ toList . many1 (satisfy $ isIdChar .∨. (== '-'))
223    spaces
224    case List.find ((== n) . long) all_values of
225      Nothing → return $ throwError $ "No such option: --" ++ n
226      Just o → ((o:) .) . option (return []) optParser
227  <|> do
228    x ← many1 $ do
229      d ← satisfy Ch.isAlpha <?> "option letter"
230      return $ case List.find ((== Just d) . short) all_values of
231        Nothing → throwError $ "No such option: -" ++ [d]
232        Just o → return o
233    spaces
234    y ← option (return []) optParser
235    return (liftM2 (++) (sequence $ toList x) y)
236
237-- Misc:
238
239showParseError :: String → String → Int → [String] → String
240showParseError subject_desc input column expectation =
241  "Unexpected " ++ unexpectation ++ "." ++
242  if null expectation' then "" else " Expected " ++ commas_or expectation' ++ "."
243  where
244    unexpectation
245      | h:t ← drop column input =
246        '`' : (if Ch.isAlphaNum h then h : takeWhile Ch.isAlphaNum t else [h]) ++ "` " ++
247        show (Editing.Commands.describe_position_after (positionIn input column) input)
248      | otherwise = "end of " ++ subject_desc
249    expectation' = (List.nub expectation \\ ["EOF", "' '"]) ++
250      ["end of " ++ subject_desc | "EOF" ∈ expectation]
251
252furthest' :: Expectation → Expectation → Expectation
253furthest' (Expected n s) (Expected n' s')
254  | n < n' = Expected n' s'
255  | n' < n = Expected n s
256  | otherwise = Expected n (s ++ s')
257
258furthest :: Maybe Expectation → Maybe Expectation → Maybe Expectation
259furthest Nothing x = x
260furthest x Nothing = x
261furthest (Just x) (Just y) = Just $ furthest' x y
262
263offset :: Int → Expectation → Expectation
264offset n Expected{..} = Expected{expectedAt = expectedAt + n, ..}
265
266parseOrFailE :: Parser Char (Either String a) → String → String → Either String a
267parseOrFailE p input desc = case run_parser p input of
268  ParseSuccess (Left e) _ _ _ → throwError e
269  ParseSuccess (Right x) _ _ _ → return x
270  ParseFailure (Expected x y) _ → throwError $ showParseError desc input x y
271
272parseOrFail :: Parser Char a → String → String → Either String a
273parseOrFail p input desc = case run_parser p input of
274  ParseSuccess x _ _ _ → return x
275  ParseFailure (Expected x y) _ → throwError $ showParseError desc input x y