1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}
5-----------------------------------------------------------------------------
6-- |
7-- Module      :  Distribution.Compat.CharParsing
8-- Copyright   :  (c) Edward Kmett 2011
9-- License     :  BSD3
10--
11-- Maintainer  :  ekmett@gmail.com
12-- Stability   :  experimental
13-- Portability :  non-portable
14--
15-- Parsers for character streams
16--
17-- Originally in @parsers@ package.
18--
19-----------------------------------------------------------------------------
20module Distribution.Compat.CharParsing
21  (
22  -- * Combinators
23    oneOf        -- :: CharParsing m => [Char] -> m Char
24  , noneOf       -- :: CharParsing m => [Char] -> m Char
25  , spaces       -- :: CharParsing m => m ()
26  , space        -- :: CharParsing m => m Char
27  , newline      -- :: CharParsing m => m Char
28  , tab          -- :: CharParsing m => m Char
29  , upper        -- :: CharParsing m => m Char
30  , lower        -- :: CharParsing m => m Char
31  , alphaNum     -- :: CharParsing m => m Char
32  , letter       -- :: CharParsing m => m Char
33  , digit        -- :: CharParsing m => m Char
34  , hexDigit     -- :: CharParsing m => m Char
35  , octDigit     -- :: CharParsing m => m Char
36  , satisfyRange -- :: CharParsing m => Char -> Char -> m Char
37  -- * Class
38  , CharParsing(..)
39  -- * Cabal additions
40  , integral
41  , signedIntegral
42  , munch1
43  , munch
44  , skipSpaces1
45  , module Distribution.Compat.Parsing
46  ) where
47
48import Prelude ()
49import Distribution.Compat.Prelude
50
51import Control.Monad.Trans.Class (lift)
52import Control.Monad.Trans.State.Lazy as Lazy
53import Control.Monad.Trans.State.Strict as Strict
54import Control.Monad.Trans.Writer.Lazy as Lazy
55import Control.Monad.Trans.Writer.Strict as Strict
56import Control.Monad.Trans.RWS.Lazy as Lazy
57import Control.Monad.Trans.RWS.Strict as Strict
58import Control.Monad.Trans.Reader (ReaderT (..))
59import Control.Monad.Trans.Identity (IdentityT (..))
60import Data.Char
61import Data.Text (Text, unpack)
62
63import qualified Text.Parsec as Parsec
64
65import Distribution.Compat.Parsing
66
67-- | @oneOf cs@ succeeds if the current character is in the supplied
68-- list of characters @cs@. Returns the parsed character. See also
69-- 'satisfy'.
70--
71-- >   vowel  = oneOf "aeiou"
72oneOf :: CharParsing m => [Char] -> m Char
73oneOf xs = satisfy (\c -> c `elem` xs)
74{-# INLINE oneOf #-}
75
76-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current
77-- character is /not/ in the supplied list of characters @cs@. Returns the
78-- parsed character.
79--
80-- >  consonant = noneOf "aeiou"
81noneOf :: CharParsing m => [Char] -> m Char
82noneOf xs = satisfy (\c -> c `notElem` xs)
83{-# INLINE noneOf #-}
84
85-- | Skips /zero/ or more white space characters. See also 'skipMany'.
86spaces :: CharParsing m => m ()
87spaces = skipMany space <?> "white space"
88{-# INLINE spaces #-}
89
90-- | Parses a white space character (any character which satisfies 'isSpace')
91-- Returns the parsed character.
92space :: CharParsing m => m Char
93space = satisfy isSpace <?> "space"
94{-# INLINE space #-}
95
96-- | Parses a newline character (\'\\n\'). Returns a newline character.
97newline :: CharParsing m => m Char
98newline = char '\n' <?> "new-line"
99{-# INLINE newline #-}
100
101-- | Parses a tab character (\'\\t\'). Returns a tab character.
102tab :: CharParsing m => m Char
103tab = char '\t' <?> "tab"
104{-# INLINE tab #-}
105
106-- | Parses an upper case letter. Returns the parsed character.
107upper :: CharParsing m => m Char
108upper = satisfy isUpper <?> "uppercase letter"
109{-# INLINE upper #-}
110
111-- | Parses a lower case character. Returns the parsed character.
112lower :: CharParsing m => m Char
113lower = satisfy isLower <?> "lowercase letter"
114{-# INLINE lower #-}
115
116-- | Parses a letter or digit. Returns the parsed character.
117alphaNum :: CharParsing m => m Char
118alphaNum = satisfy isAlphaNum <?> "letter or digit"
119{-# INLINE alphaNum #-}
120
121-- | Parses a letter (an upper case or lower case character). Returns the
122-- parsed character.
123letter :: CharParsing m => m Char
124letter = satisfy isAlpha <?> "letter"
125{-# INLINE letter #-}
126
127-- | Parses a digit. Returns the parsed character.
128digit :: CharParsing m => m Char
129digit = satisfy isDigit <?> "digit"
130{-# INLINE digit #-}
131
132-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and
133-- \'f\' or \'A\' and \'F\'). Returns the parsed character.
134hexDigit :: CharParsing m => m Char
135hexDigit = satisfy isHexDigit <?> "hexadecimal digit"
136{-# INLINE hexDigit #-}
137
138-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns
139-- the parsed character.
140octDigit :: CharParsing m => m Char
141octDigit = satisfy isOctDigit <?> "octal digit"
142{-# INLINE octDigit #-}
143
144satisfyRange :: CharParsing m => Char -> Char -> m Char
145satisfyRange a z = satisfy (\c -> c >= a && c <= z)
146{-# INLINE satisfyRange #-}
147
148-- | Additional functionality needed to parse character streams.
149class Parsing m => CharParsing m where
150  -- | Parse a single character of the input, with UTF-8 decoding
151  satisfy :: (Char -> Bool) -> m Char
152
153  -- | @char c@ parses a single character @c@. Returns the parsed
154  -- character (i.e. @c@).
155  --
156  -- /e.g./
157  --
158  -- @semiColon = 'char' ';'@
159  char :: Char -> m Char
160  char c = satisfy (c ==) <?> show [c]
161  {-# INLINE char #-}
162
163  -- | @notChar c@ parses any single character other than @c@. Returns the parsed
164  -- character.
165  notChar :: Char -> m Char
166  notChar c = satisfy (c /=)
167  {-# INLINE notChar #-}
168
169  -- | This parser succeeds for any character. Returns the parsed character.
170  anyChar :: m Char
171  anyChar = satisfy (const True)
172  {-# INLINE anyChar #-}
173
174  -- | @string s@ parses a sequence of characters given by @s@. Returns
175  -- the parsed string (i.e. @s@).
176  --
177  -- >  divOrMod    =   string "div"
178  -- >              <|> string "mod"
179  string :: String -> m String
180  string s = s <$ try (traverse_ char s) <?> show s
181  {-# INLINE string #-}
182
183  -- | @text t@ parses a sequence of characters determined by the text @t@ Returns
184  -- the parsed text fragment (i.e. @t@).
185  --
186  -- Using @OverloadedStrings@:
187  --
188  -- >  divOrMod    =   text "div"
189  -- >              <|> text "mod"
190  text :: Text -> m Text
191  text t = t <$ string (unpack t)
192  {-# INLINE text #-}
193
194instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where
195  satisfy = lift . satisfy
196  {-# INLINE satisfy #-}
197  char    = lift . char
198  {-# INLINE char #-}
199  notChar = lift . notChar
200  {-# INLINE notChar #-}
201  anyChar = lift anyChar
202  {-# INLINE anyChar #-}
203  string  = lift . string
204  {-# INLINE string #-}
205  text = lift . text
206  {-# INLINE text #-}
207
208instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where
209  satisfy = lift . satisfy
210  {-# INLINE satisfy #-}
211  char    = lift . char
212  {-# INLINE char #-}
213  notChar = lift . notChar
214  {-# INLINE notChar #-}
215  anyChar = lift anyChar
216  {-# INLINE anyChar #-}
217  string  = lift . string
218  {-# INLINE string #-}
219  text = lift . text
220  {-# INLINE text #-}
221
222instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where
223  satisfy = lift . satisfy
224  {-# INLINE satisfy #-}
225  char    = lift . char
226  {-# INLINE char #-}
227  notChar = lift . notChar
228  {-# INLINE notChar #-}
229  anyChar = lift anyChar
230  {-# INLINE anyChar #-}
231  string  = lift . string
232  {-# INLINE string #-}
233  text = lift . text
234  {-# INLINE text #-}
235
236instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where
237  satisfy = lift . satisfy
238  {-# INLINE satisfy #-}
239  char    = lift . char
240  {-# INLINE char #-}
241  notChar = lift . notChar
242  {-# INLINE notChar #-}
243  anyChar = lift anyChar
244  {-# INLINE anyChar #-}
245  string  = lift . string
246  {-# INLINE string #-}
247  text = lift . text
248  {-# INLINE text #-}
249
250instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where
251  satisfy = lift . satisfy
252  {-# INLINE satisfy #-}
253  char    = lift . char
254  {-# INLINE char #-}
255  notChar = lift . notChar
256  {-# INLINE notChar #-}
257  anyChar = lift anyChar
258  {-# INLINE anyChar #-}
259  string  = lift . string
260  {-# INLINE string #-}
261  text = lift . text
262  {-# INLINE text #-}
263
264instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where
265  satisfy = lift . satisfy
266  {-# INLINE satisfy #-}
267  char    = lift . char
268  {-# INLINE char #-}
269  notChar = lift . notChar
270  {-# INLINE notChar #-}
271  anyChar = lift anyChar
272  {-# INLINE anyChar #-}
273  string  = lift . string
274  {-# INLINE string #-}
275  text = lift . text
276  {-# INLINE text #-}
277
278instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where
279  satisfy = lift . satisfy
280  {-# INLINE satisfy #-}
281  char    = lift . char
282  {-# INLINE char #-}
283  notChar = lift . notChar
284  {-# INLINE notChar #-}
285  anyChar = lift anyChar
286  {-# INLINE anyChar #-}
287  string  = lift . string
288  {-# INLINE string #-}
289  text = lift . text
290  {-# INLINE text #-}
291
292instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where
293  satisfy = lift . satisfy
294  {-# INLINE satisfy #-}
295  char    = lift . char
296  {-# INLINE char #-}
297  notChar = lift . notChar
298  {-# INLINE notChar #-}
299  anyChar = lift anyChar
300  {-# INLINE anyChar #-}
301  string  = lift . string
302  {-# INLINE string #-}
303  text = lift . text
304  {-# INLINE text #-}
305
306instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where
307  satisfy   = Parsec.satisfy
308  char      = Parsec.char
309  notChar c = Parsec.satisfy (/= c)
310  anyChar   = Parsec.anyChar
311  string    = Parsec.string
312
313-------------------------------------------------------------------------------
314-- Our additions
315-------------------------------------------------------------------------------
316
317integral :: (CharParsing m, Integral a) => m a
318integral = toNumber <$> some d <?> "integral"
319  where
320    toNumber = foldl' (\a b -> a * 10 + b) 0
321    d = f <$> satisfyRange '0' '9'
322    f '0' = 0
323    f '1' = 1
324    f '2' = 2
325    f '3' = 3
326    f '4' = 4
327    f '5' = 5
328    f '6' = 6
329    f '7' = 7
330    f '8' = 8
331    f '9' = 9
332    f _   = error "panic! integral"
333{-# INLINE integral #-}
334
335-- | Accepts negative (starting with @-@) and positive (without sign) integral
336-- numbers.
337--
338-- @since 3.4.0.0
339signedIntegral :: (CharParsing m, Integral a) => m a
340signedIntegral = negate <$ char '-' <*> integral <|> integral
341{-# INLINE signedIntegral #-}
342
343-- | Greedily munch characters while predicate holds.
344-- Require at least one character.
345munch1 :: CharParsing m => (Char -> Bool) -> m String
346munch1 = some . satisfy
347{-# INLINE munch1 #-}
348
349-- | Greedely munch characters while predicate holds.
350-- Always succeeds.
351munch :: CharParsing m => (Char -> Bool) -> m String
352munch = many . satisfy
353{-# INLINE munch #-}
354
355skipSpaces1 :: CharParsing m => m ()
356skipSpaces1 = skipSome space
357{-# INLINE skipSpaces1 #-}
358