1{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
2module Text.ParserCombinators.Poly.StateLazy
3  ( -- * The Parser datatype
4    Parser(P)	-- datatype, instance of: Functor, Monad, PolyParse
5  , Result(..)	-- internal to the parser monad
6  , runParser	-- :: Parser s t a -> s -> [t] -> (Either String a, s, [t])
7    -- ** Basic parsers
8  , next	-- :: Parser s t t
9  , eof		-- :: Parser s t ()
10  , satisfy	-- :: (t->Bool) -> Parser s t t
11  , onFail      -- :: Parser s t a -> Parser s t a -> Parser s t a
12  , manyFinally	-- :: Parser s t a -> Parser s t z -> Parser s t [a]
13    -- ** State-handling
14  , stUpdate    -- :: (s->s) -> Parser s t ()
15  , stQuery     -- :: (s->a) -> Parser s t a
16  , stGet       -- :: Parser s t s
17    -- ** Re-parsing
18  , reparse	-- :: [t] -> Parser s t ()
19    -- * Re-export all more general combinators
20  , module Text.ParserCombinators.Poly.Base
21  , module Control.Applicative
22  ) where
23
24
25import Text.ParserCombinators.Poly.Base hiding (manyFinally)
26import Text.ParserCombinators.Poly.Result
27import qualified Text.ParserCombinators.Poly.StateParser as P
28import Control.Applicative
29import qualified Control.Monad.Fail as Fail
30
31#if __GLASGOW_HASKELL__
32import Control.Exception hiding (bracket)
33throwE :: String -> a
34throwE msg = throw (ErrorCall msg)
35#else
36throwE :: String -> a
37throwE msg = error msg
38#endif
39
40-- | The only differences between a State and a StateLazy parser are the
41--   instance of Applicative, and the type (and implementation) of runParser.
42--   We therefore need to /newtype/ the original Parser type, to allow it
43--   to have a different instance.
44newtype Parser s t a = P (P.Parser s t a)
45#ifdef __GLASGOW_HASKELL__
46        deriving (Functor,Monad,Fail.MonadFail,Commitment)
47#else
48instance Functor (Parser s t) where
49    fmap f (P p) = P (fmap f p)
50instance Monad (Parser s t) where
51    return x  = P (return x)
52    fail      = Fail.fail
53    (P f) >>= g = P (f >>= (\(P g')->g') . g)
54instance Fail.MonadFail (Parser s t) where
55    fail e    = P (fail e)
56instance Commitment (Parser s t) where
57    commit (P p)   = P (commit p)
58    (P p) `adjustErr` f  = P (p `adjustErr` f)
59#endif
60
61-- | Apply a parser to an input token sequence.
62runParser :: Parser s t a -> s -> [t] -> (a, s, [t])
63runParser (P (P.P p)) = \s -> fromResult . p s
64  where
65    fromResult :: Result (z,s) a -> (a, s, z)
66    fromResult (Success (z,s) a)  =  (a, s, z)
67    fromResult (Failure   _   e)  =  throwE e
68    fromResult (Committed r)      =  fromResult r
69
70
71instance Applicative (Parser s t) where
72    pure f    = return f
73    --   Apply a parsed function to a parsed value.  This version
74    --   is strict in the result of the function parser, but
75    --   lazy in the result of the argument parser.  (Argument laziness is
76    --   the distinctive feature over other implementations.)
77    (P (P.P pf)) <*> px = P (P.P (\s-> continue . pf s))
78      where
79        continue (Success (z,s) f) = let (x,s',z') = runParser px s z
80                                     in Success (z',s') (f x)
81        continue (Failure zs e)    = Failure zs e
82        continue (Committed r)     = Committed (continue r)
83#if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610
84    p  <*  q  = p `discard` q
85#endif
86
87instance Alternative (Parser s t) where
88    empty     = fail "no parse"
89    p <|> q   = p `onFail` q
90
91instance PolyParse (Parser s t)
92
93------------------------------------------------------------------------
94
95-- | Simply return the next token in the input tokenstream.
96next    ::  Parser s t t
97next    = P P.next
98
99-- | Succeed if the end of file/input has been reached, fail otherwise.
100eof     :: Parser s t ()
101eof     = P P.eof
102
103-- | Return the next token if it satisfies the given predicate.
104satisfy :: (t->Bool) -> Parser s t t
105satisfy = P . P.satisfy
106
107-- | @p `onFail` q@ means parse p, unless p fails, in which case
108--   parse q instead.
109--   Can be chained together to give multiple attempts to parse something.
110--   (Note that q could itself be a failing parser, e.g. to change the error
111--   message from that defined in p to something different.)
112--   However, a severe failure in p cannot be ignored.
113onFail  :: Parser s t a -> Parser s t a -> Parser s t a
114onFail (P a) (P b) = P (a `P.onFail` b)
115
116-- | Push some tokens back onto the front of the input stream and reparse.
117--   This is useful e.g. for recursively expanding macros.  When the
118--   user-parser recognises a macro use, it can lookup the macro
119--   expansion from the parse state, lex it, and then stuff the
120--   lexed expansion back down into the parser.
121reparse :: [t] -> Parser s t ()
122reparse = P . P.reparse
123
124------------------------------------------------------------------------
125-- State handling
126
127-- | Update the internal state.
128stUpdate   :: (s->s) -> Parser s t ()
129stUpdate f  = P (P.stUpdate f)
130
131-- | Query the internal state.
132stQuery    :: (s->a) -> Parser s t a
133stQuery f   = P (P.stQuery f)
134
135-- | Deliver the entire internal state.
136stGet      :: Parser s t s
137stGet       = P (P.stGet)
138
139------------------------------------------------------------------------
140
141
142manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a]
143{-
144manyFinally pp@(P p) pt@(P t) = P (\s ts -> item s ts (p s ts))
145    where
146      item _ _  (Success ts s x) = success ts s x
147      item s ts (Failure _ _ e)  = terminate (t s ts)
148      item s ts (Committed r)    = Committed (within r)
149
150      success ts s x =
151            let (tail,s',ts') = runParser (manyFinally pp pt) s ts
152            in Success ts' s' (x:tail)
153
154      terminate (Success ts s _) = Success ts s []
155      terminate (Failure ts s e) = Failure ts s e
156      terminate (Committed r)    = Committed (terminate r)
157
158      within (Success ts s x)    = success ts s x
159      within (Failure ts s e)    = Failure ts s e
160      within (Committed r)       = within r
161-}
162
163manyFinally p z =
164    (do x <- p; return (x:) `apply` manyFinally p z)
165      `onFail`
166    (do z; return [])
167      `onFail`
168    oneOf' [ ("item in sequence",    (do p; return []))
169           , ("sequence terminator", (do z; return [])) ]
170
171------------------------------------------------------------------------
172