/src/Parsers.hs

http://github.com/Eelis/geordi · Haskell · 275 lines · 192 code · 55 blank · 28 comment · 24 complexity · c41cd18fea33052d1d9fb1f2db233692 MD5 · raw file

  1. {-# LANGUAGE UnicodeSyntax, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, RecordWildCards, NamedFieldPuns, ViewPatterns, TypeSynonymInstances #-}
  2. module Parsers where
  3. import qualified Data.List as List
  4. import qualified Text.ParserCombinators.Parsec as PS
  5. import qualified Editing.Commands
  6. import qualified Editing.Show ()
  7. import qualified Data.Char as Ch
  8. import Data.List.NonEmpty (NonEmpty((:|)))
  9. import Data.Foldable (toList)
  10. import Control.Monad (liftM, liftM2)
  11. import Control.Arrow (first)
  12. import Data.List ((\\))
  13. import Data.Maybe (fromMaybe)
  14. import Editing.Basics (positionIn)
  15. import Util ((.), Finite(..), commas_or, Option(..), (..), isIdChar, (<<), NeList, MyMonadError(..))
  16. import Prelude hiding ((.))
  17. import Prelude.Unicode
  18. -- To let us write parsers that work with both Parsec and our own Parser monad, we introduce the ParserLike class:
  19. class (Functor m, Monad m) ParserLike m t | m t where
  20. anySymbol :: m t
  21. anySymbol = satisfy $ const True
  22. symbols :: (Eq t, Show t) [t] m [t]
  23. symbols = foldr (\ h liftM2 (:) (satisfy (== h))) (return [])
  24. satisfy :: (t Bool) m t
  25. (<|>) :: m a m a m a
  26. (<?>) :: m a String m a
  27. lookAhead :: m a m a
  28. pzero :: m a
  29. eof :: m ()
  30. try :: m a m a
  31. getInput :: m [t]
  32. getInput = many anySymbol << eof
  33. infix 0 <?>
  34. infixr 1 <|>
  35. -- Parsec is clearly ParserLike:
  36. instance ParserLike (PS.GenParser Char st) Char where
  37. (<?>) = (PS.<?>)
  38. lookAhead = PS.lookAhead
  39. (<|>) = (PS.<|>)
  40. symbols = PS.string
  41. anySymbol = PS.anyChar
  42. satisfy = PS.satisfy
  43. pzero = PS.pzero
  44. eof = PS.eof
  45. try = PS.try
  46. -- Utility parser combinators:
  47. manyTill :: ParserLike m t m a m b m ([a], b)
  48. manyTill p e = ((,) [] . e) <|> liftM2 (\x (y, z) (x:y, z)) p (manyTill p e)
  49. many1Till :: ParserLike m t m a m b m (NeList a, b)
  50. many1Till p e = p >>= \v first (v :|) . manyTill p e
  51. optionMaybe :: ParserLike m t m a m (Maybe a)
  52. optionMaybe p = Just . p <|> return Nothing
  53. optional :: ParserLike m t m a m (Maybe a)
  54. optional p = Just . p <|> return Nothing
  55. option :: ParserLike m t a m a m a
  56. option x p = fromMaybe x . optional p
  57. symbol :: (Show t, Eq t, ParserLike m t) t m t
  58. symbol x = satisfy (== x) <?> show x
  59. choice :: ParserLike m t [m a] m a
  60. choice = foldl (<|>) pzero
  61. many :: ParserLike m t m a m [a]
  62. many p = liftM2 (:) p (many p) <|> return []
  63. many1 :: ParserLike m t m a m (NeList a)
  64. many1 p = liftM2 (:|) p (many p)
  65. spaces :: ParserLike m Char m String
  66. spaces = many $ symbol ' '
  67. noneOf :: (Eq t, ParserLike m t) [t] m t
  68. noneOf l = satisfy ( l)
  69. oneOf :: (Eq t, ParserLike m t) [t] m t
  70. oneOf l = satisfy ( l)
  71. sep :: ParserLike m t m a m b m (a, [(b, a)])
  72. sep p p' = liftM2 (,) p (many (liftM2 (,) p' p))
  73. sepBy1' :: ParserLike m t ⇒ m a → m b → m (NeList a)
  74. sepBy1' x y = (\(h, t) → h :| map snd t) . sep x y
  75. sepBy1 :: ParserLike m t m a m b m [a]
  76. sepBy1 p e = liftM2 (:) p ((e >> sepBy1 p e) <|> return [])
  77. kwd :: String Parser Char String
  78. kwd s = try $ symbols s << notFollowedBy (satisfy isIdChar) << spaces
  79. kwds :: [String] Parser Char String
  80. kwds = choice . (kwd .)
  81. char_unit :: (Eq a, Show a) a Parser a ()
  82. char_unit = (>> return ()) . char
  83. {-
  84. Parsec's parse error descriptions aren't very good for parsers that backtrack. Consider
  85. parse (try (char 'x' >> char 'y') <|> char 'a') "" "x3"
  86. This 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:
  87. Left (line 1, column 1):
  88. unexpected "3"
  89. expecting "y" or "a"
  90. Here, 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.
  91. The 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.
  92. Parsec 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.
  93. -}
  94. data Expectation = Expected { expectedAt :: Int, expectedWhat :: [String] }
  95. uninformativeExpectation :: Expectation
  96. uninformativeExpectation = Expected 0 []
  97. data ParseResult t a
  98. = ParseSuccess a [t] Int (Maybe Expectation)
  99. -- 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.
  100. | ParseFailure Expectation Bool
  101. -- The Bool indicates whether the failure is terminal.
  102. instance Functor (ParseResult t) where
  103. fmap f (ParseSuccess x t i m) = ParseSuccess (f x) t i m; fmap _ (ParseFailure e b) = ParseFailure e b
  104. newtype Parser t a = Parser { run_parser :: [t] ParseResult t a }
  105. peek :: Parser t [t]
  106. peek = Parser $ \s ParseSuccess s s 0 Nothing
  107. drain :: Parser t [t]
  108. drain = Parser $ \s ParseSuccess s [] (length s) Nothing
  109. parseSuccess :: a Parser t a
  110. parseSuccess = return
  111. -- Parser is a Functor, a Monad, and ParserLike:
  112. instance Functor (Parser t) where fmap = liftM
  113. instance Monad (Parser t) where
  114. return x = Parser $ \s ParseSuccess x s 0 Nothing
  115. Parser p >>= f = Parser $ \s case p s of
  116. ParseSuccess r s' n m → case run_parser (f r) s' of
  117. ParseSuccess r' s'' n' m' → ParseSuccess r' s'' (n + n') (furthest m (offset n . m'))
  118. ParseFailure (offset n m') b → ParseFailure (maybe m' (furthest' m') m) b
  119. ParseFailure e b ParseFailure e b
  120. fail = const pzero
  121. instance ParserLike (Parser a) a where
  122. anySymbol = satisfy (const True) <?> "any symbol"
  123. satisfy p = Parser $ \s case s of
  124. h:t | p h ParseSuccess h t 1 Nothing
  125. _ ParseFailure uninformativeExpectation False
  126. symbols t = Parser $ \s case List.stripPrefix t s of
  127. Nothing ParseFailure (Expected 0 [show t]) False
  128. Just s' → ParseSuccess t s' (length t) Nothing
  129. Parser p <|> Parser q = Parser $ \s case p s of
  130. ParseFailure m False case q s of
  131. ParseSuccess r u n' m' ParseSuccess r u n' $ Just $ maybe m (furthest' m) m'
  132. ParseFailure m' b → ParseFailure (furthest' m m') b
  133. ps ps
  134. Parser p <?> m = Parser $ \s case p s of
  135. ParseFailure (Expected 0 _) b ParseFailure (Expected 0 [m]) b
  136. b b
  137. lookAhead (Parser p) = Parser $ \s case p s of
  138. ParseSuccess r _ _ m ParseSuccess r s 0 m
  139. e e
  140. pzero = Parser $ const $ ParseFailure uninformativeExpectation False
  141. eof = Parser $ \s if null s then ParseSuccess () [] 0 Nothing else ParseFailure (Expected 0 ["EOF"]) False
  142. try = id
  143. getInput = Parser $ \s ParseSuccess s s 0 Nothing
  144. notFollowedBy :: Parser t a Parser t ()
  145. notFollowedBy (Parser p) = Parser $ \s case p s of
  146. ParseFailure{} ParseSuccess () s 0 Nothing
  147. ParseSuccess{} ParseFailure uninformativeExpectation False
  148. -- Some Parser-specific parsers:
  149. guarded :: (a Bool) Parser t a Parser t a
  150. guarded f (Parser p) = Parser $ \s case p s of
  151. ParseSuccess x _ _ _ | not (f x) ParseFailure uninformativeExpectation False
  152. k k
  153. char :: (Show t, Eq t) t Parser t t
  154. char t = satisfy (== t) <?> show t
  155. commit :: Parser t a Parser t a
  156. commit (Parser p) = Parser $ \s case p s of
  157. ParseFailure x _ ParseFailure x True
  158. ps ps
  159. silent :: Parser t a Parser t a
  160. silent (Parser p) = Parser $ \s case p s of
  161. ParseFailure _ b ParseFailure uninformativeExpectation b
  162. ParseSuccess r t n _ ParseSuccess r t n Nothing
  163. optParser :: (MyMonadError String m, Functor m, Finite o, Option o) Parser Char (m [o])
  164. optParser = (<?> "option") $ (char '-' >>) $ do
  165. char '-'
  166. n (<?> "option name") $ toList . many1 (satisfy $ isIdChar .. (== '-'))
  167. spaces
  168. case List.find ((== n) . long) all_values of
  169. Nothing return $ throwError $ "No such option: --" ++ n
  170. Just o ((o:) .) . option (return []) optParser
  171. <|> do
  172. x many1 $ do
  173. d satisfy Ch.isAlpha <?> "option letter"
  174. return $ case List.find ((== Just d) . short) all_values of
  175. Nothing throwError $ "No such option: -" ++ [d]
  176. Just o return o
  177. spaces
  178. y option (return []) optParser
  179. return (liftM2 (++) (sequence $ toList x) y)
  180. -- Misc:
  181. showParseError :: String String Int [String] String
  182. showParseError subject_desc input column expectation =
  183. "Unexpected " ++ unexpectation ++ "." ++
  184. if null expectation' then "" else " Expected " ++ commas_or expectation' ++ "."
  185. where
  186. unexpectation
  187. | h:t drop column input =
  188. '`' : (if Ch.isAlphaNum h then h : takeWhile Ch.isAlphaNum t else [h]) ++ "` " ++
  189. show (Editing.Commands.describe_position_after (positionIn input column) input)
  190. | otherwise = "end of " ++ subject_desc
  191. expectation' = (List.nub expectation \\ ["EOF", "' '"]) ++
  192. ["end of " ++ subject_desc | "EOF" expectation]
  193. furthest' :: Expectation → Expectation → Expectation
  194. furthest' (Expected n s) (Expected n' s')
  195. | n < n' = Expected n' s'
  196. | n' < n = Expected n s
  197. | otherwise = Expected n (s ++ s')
  198. furthest :: Maybe Expectation Maybe Expectation Maybe Expectation
  199. furthest Nothing x = x
  200. furthest x Nothing = x
  201. furthest (Just x) (Just y) = Just $ furthest' x y
  202. offset :: Int Expectation Expectation
  203. offset n Expected{..} = Expected{expectedAt = expectedAt + n, ..}
  204. parseOrFailE :: Parser Char (Either String a) String String Either String a
  205. parseOrFailE p input desc = case run_parser p input of
  206. ParseSuccess (Left e) _ _ _ throwError e
  207. ParseSuccess (Right x) _ _ _ return x
  208. ParseFailure (Expected x y) _ throwError $ showParseError desc input x y
  209. parseOrFail :: Parser Char a String String Either String a
  210. parseOrFail p input desc = case run_parser p input of
  211. ParseSuccess x _ _ _ return x
  212. ParseFailure (Expected x y) _ throwError $ showParseError desc input x y