1module Text.ParserCombinators.Poly.Base
2  ( -- * The PolyParse classes
3    Commitment(..)	-- class of all two-level-error values
4  , PolyParse		-- class of all monadic two-level-error parsers
5
6    -- * Combinators general to all parser types.
7    -- ** Simple combinators
8  , apply	-- :: PolyParse p => p (a->b) -> p a -> p b
9  , discard	-- :: PolyParse p => p a      -> p b -> p a
10    -- ** Error-handling
11  , failBad	-- :: PolyParse p => String -> p a
12  , adjustErrBad-- :: PolyParse p => p a -> (String->String) -> p a
13  , indent	-- :: Int -> String -> String
14    -- ** Choices
15  , oneOf	-- :: PolyParse p => [p a] -> p a
16    -- ** Sequences
17  , exactly	-- :: PolyParse p => Int -> p a -> p [a]
18  , upto	-- :: PolyParse p => Int -> p a -> p [a]
19  , many1	-- :: PolyParse p => p a -> p [a]
20  , sepBy	-- :: PolyParse p => p a -> p sep -> p [a]
21  , sepBy1	-- :: PolyParse p => p a -> p sep -> p [a]
22  , bracketSep	-- :: PolyParse p => p bra -> p sep -> p ket -> p a -> p [a]
23  , bracket	-- :: PolyParse p => p bra -> p ket -> p a -> p a
24  , manyFinally -- :: PolyParse p => p a -> p z -> p [a]
25  , manyFinally'-- :: PolyParse p => p a -> p z -> p [a]
26  ) where
27
28import Control.Applicative
29import qualified Control.Monad.Fail as Fail
30
31#ifdef __NHC__
32default (Integer,Double,[])	-- hack to avoid bizarre type defaulting error
33instance Commitment []
34instance PolyParse []
35#endif
36
37-- | The @Commitment@ class is an abstraction over all the current
38--   concrete representations of monadic/applicative parser combinators in this
39--   package.  The common feature is two-level error-handling.
40--   Some primitives must be implemented specific to each parser type
41--   (e.g. depending on whether the parser has a running state, or
42--   whether it is lazy).  But given those primitives, large numbers of
43--   combinators do not depend any further on the internal structure of
44--   the particular parser.
45class Commitment p where
46    -- | Commit is a way of raising the severity of any errors found within
47    --   its argument.  Used in the middle of a parser definition, it means that
48    --   any operations prior to commitment fail softly, but after commitment,
49    --   they fail hard.
50    commit    :: p a -> p a
51    -- | @p `adjustErr` f@ applies the transformation @f@ to any error message
52    --   generated in @p@, having no effect if @p@ succeeds.
53    adjustErr :: p a -> (String -> String) -> p a
54    -- | Parse the first alternative that succeeds, but if none succeed,
55    --   report only the severe errors, and if none of those, then report
56    --   all the soft errors.
57    oneOf'    :: [(String, p a)] -> p a
58
59-- | The @PolyParse@ class is an abstraction gathering all of the common
60--   features that a two-level error-handling parser requires:
61--   the applicative parsing interface, the monadic interface, and commitment.
62--
63--   There are two additional basic combinators that we expect to be implemented
64--   afresh for every concrete type, but which (for technical reasons)
65--   cannot be class methods.  They are @next@ and @satisfy@.
66class (Functor p, Monad p, Fail.MonadFail p, Applicative p, Alternative p, Commitment p) =>
67      PolyParse p
68
69infixl 3 `apply`
70infixl 3 `discard`
71
72-- | Apply a parsed function to a parsed value.
73--   Rather like ordinary function application lifted into parsers.
74apply  :: PolyParse p => p (a->b) -> p a -> p b
75apply = (<*>)
76
77-- | @x `discard` y@ parses both x and y, but discards the result of y.
78--   Rather like @const@ lifted into parsers.
79discard :: PolyParse p => p a -> p b -> p a
80px `discard` py = do { x <- px; y <- py; y `seq` return x; }
81
82{-
83-- Combinators we expect most concrete parser types to implement.
84--   For technical reasons, they cannot be class members.
85
86-- | Yield the next token
87next      :: PolyParse p => p t
88  --  where t is constrained to be the input token type
89
90-- | One token satisfying a predicate.
91satisfy :: PolyParse p => (t->Bool) -> p t t
92satisfy p = do{ x <- next
93              ; if p x then return x else fail "Parse.satisfy: failed"
94              }
95  -- note: must be re-defined for each implementation because
96  --       its type cannot be expressed otherwise.
97-}
98
99-- | When a simple fail is not strong enough, use failBad for emphasis.
100--   An emphasised (severe) error cannot be overridden by choice
101--   operators.
102failBad :: PolyParse p => String -> p a
103failBad e = commit (Fail.fail e)
104
105-- | @adjustErrBad@ is just like @adjustErr@ except it also raises the
106--   severity of the error.
107adjustErrBad :: PolyParse p => p a -> (String->String) -> p a
108p `adjustErrBad` f = commit (p `adjustErr` f)
109
110-- | Parse the first alternative in the list that succeeds.
111oneOf :: PolyParse p => [p a] -> p a
112oneOf []     = Fail.fail ("failed to parse any of the possible choices")
113oneOf (p:ps) = p <|> oneOf ps
114--oneOf :: Show t => [Parser t a] -> Parser t a
115--oneOf []     = do { n <- next
116--                  ; fail ("failed to parse any of the possible choices"
117--                         ++"\n  next token is "++show n)
118--                  }
119--oneOf (p:ps) = p `onFail` oneOf ps
120
121-- | Helper for formatting error messages: indents all lines by a fixed amount.
122indent :: Int -> String -> String
123indent n = unlines . map (replicate n ' ' ++) . lines
124
125-- | 'exactly n p' parses precisely n items, using the parser p, in sequence.
126exactly :: PolyParse p => Int -> p a -> p [a]
127exactly 0 p = return []
128exactly n p = return (:) `apply`  (p `adjustErr` (("When expecting exactly "
129                                                    ++show n++" more items")++))
130                         `apply`  exactly (n-1) p
131
132-- | 'upto n p' parses n or fewer items, using the parser p, in sequence.
133upto :: PolyParse p => Int -> p a -> p [a]
134upto 0 p = return []
135upto n p = do x <- p; return (x:) `apply` upto (n-1) p
136           <|> return []
137
138
139{- is in Control.Applicative
140-- | 'optional' indicates whether the parser succeeded through the Maybe type.
141optional :: PolyParse p => p a -> p (Maybe a)
142optional p = fmap Just p `onFail` return Nothing
143-}
144{- is in Control.Applicative
145-- | 'many p' parses a list of elements with individual parser p.
146--   Cannot fail, since an empty list is a valid return value.
147many :: PolyParse p => p a -> p [a]
148many p = many1 p `onFail` return []
149-}
150
151-- | Parse a non-empty list of items.
152many1 :: PolyParse p => p a -> p [a]
153many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2)
154             ; return (x:) `apply` many p
155             }
156--       `adjustErr` ("When looking for a non-empty sequence:\n\t"++)
157
158-- | Parse a list of items separated by discarded junk.
159sepBy :: PolyParse p => p a -> p sep -> p [a]
160sepBy p sep = do sepBy1 p sep <|> return []
161
162-- | Parse a non-empty list of items separated by discarded junk.
163sepBy1 :: PolyParse p => p a -> p sep -> p [a]
164sepBy1 p sep = do { x <- p
165                  ; return (x:) `apply` many (do {sep; p})
166                  }
167         `adjustErr` ("When looking for a non-empty sequence with separators:\n\t"++)
168
169-- | Parse a list of items, discarding the start, end, and separator
170--   items.
171bracketSep :: PolyParse p => p bra -> p sep -> p ket -> p a -> p [a]
172bracketSep open sep close p =
173    do { open; close; return [] }
174       <|>
175    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
176       ; x <- p  `adjustErr` ("After first bracket in a group:\n\t"++)
177       ; return (x:)
178           `apply` manyFinally (do {sep; p})
179              (close `adjustErrBad` ("When looking for closing bracket:\n\t"++))
180       }
181
182-- | Parse a bracketed item, discarding the brackets.
183--   If everything matches /except/ the closing bracket, the whole
184--   parse fails soft, which can give less-than-satisfying error messages.
185--   If you want better error messages, try calling with e.g.
186--     @bracket open (commit close) item@
187bracket :: PolyParse p => p bra -> p ket -> p a -> p a
188bracket open close p = do
189    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
190       ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))
191       }
192
193-- | @manyFinally e t@ parses a possibly-empty sequence of @e@'s,
194--   terminated by a @t@.  The final @t@ is discarded.  Any parse failures
195--   could be due either to a badly-formed terminator or a badly-formed
196--   element, so it raises both possible errors.
197manyFinally :: PolyParse p => p a -> p z -> p [a]
198{-
199-- This implementation is incorrect.  If at least one item has been
200-- parsed, but the terminator is missing, then this erroneously succeeds
201-- returning the empty list.
202manyFinally p t =
203    (many p `discard` t)
204      <|>
205    oneOf' [ ("sequence terminator", do { t; return [] } )
206           , ("item in a sequence",  do { p; return [] } )
207           ]
208-}
209
210manyFinally p t =
211    do { xs <- many p
212       ; oneOf' [ ("sequence terminator", do { t; return () } )
213                , ("item in a sequence",  do { p; return () } )
214                ]
215       ; return xs
216       }
217
218-- | @manyFinally'@ is like @manyFinally@, except when the terminator
219--   parser overlaps with the element parser.  In @manyFinally e t@,
220--   the parser @t@ is tried only when parser @e@ fails, whereas in
221--   @manyFinally' e t@, the parser @t@ is always tried first, then
222--   parser @e@ only if the terminator is not found.  For instance,
223--   @manyFinally (accept "01") (accept "0")@ on input @"0101010"@ returns
224--   @["01","01","01"]@, whereas @manyFinally'@ with the same arguments
225--   and input returns @[]@.
226manyFinally' :: (PolyParse p, Show a) => p a -> p z -> p [a]
227manyFinally' p t = fmap reverse $ go []
228  where
229    go acc = ( do t; return acc )
230             <|>
231             ( do { x <- p
232                         <|>
233                         oneOf' [ ( "terminator in a manyFinally' sequence"
234                                  , do { t; return undefined }
235                                  )
236                                , ( "item in a manyFinally' sequence", p)
237                                ]
238                         `adjustErr` (("After successful partial sequence "
239                                      ++show (reverse acc)++",\n")++)
240                  ; go (x: acc)
241                  }
242             )
243
244
245------------------------------------------------------------------------
246