-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.ReadP
get, -- :: ReadP Char
look, -- :: ReadP String
(+++), -- :: ReadP a -> ReadP a -> ReadP a
+ (<++), -- :: ReadP a -> ReadP a -> ReadP a
gather, -- :: ReadP a -> ReadP (String, a)
-- * Other operations
import GHC.Show( isSpace )
import GHC.Base
--- ---------------------------------------------------------------------------
--- The ReadP type
+-- We define a local version of ReadS here,
+-- because its "real" definition site is in GHC.Read
+type ReadS a = String -> [(a,String)]
-newtype ReadP a = R (forall b . (a -> P b) -> P b)
+-- ---------------------------------------------------------------------------
+-- The P type
+-- is representation type -- should be kept abstract
data P a
= Get (Char -> P a)
| Look (String -> P a)
| Fail
| Result a (P a)
- | ReadS (ReadS a)
+ | Final [(a,String)] -- invariant: list is non-empty!
--- We define a local version of ReadS here,
--- because its "real" definition site is in GHC.Read
-type ReadS a = String -> [(a,String)]
+-- Monad, MonadPlus
+
+instance Monad P where
+ return x = Result x Fail
+
+ (Get f) >>= k = Get (\c -> f c >>= k)
+ (Look f) >>= k = Look (\s -> f s >>= k)
+ Fail >>= k = Fail
+ (Result x p) >>= k = k x `mplus` (p >>= k)
+ (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
+
+ fail _ = Fail
+
+instance MonadPlus P where
+ mzero = Fail
+
+ -- most common case: two gets are combined
+ Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
+
+ -- results are delivered as soon as possible
+ Result x p `mplus` q = Result x (p `mplus` q)
+ p `mplus` Result x q = Result x (p `mplus` q)
+
+ -- fail disappears
+ Fail `mplus` p = p
+ p `mplus` Fail = p
+
+ -- two finals are combined
+ -- final + look becomes one look and one final (=optimization)
+ -- final + sthg else becomes one look and one final
+ Final r `mplus` Final t = Final (r ++ t)
+ Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
+ Final r `mplus` p = Look (\s -> Final (r ++ run p s))
+ Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
+ p `mplus` Final r = Look (\s -> Final (run p s ++ r))
+
+ -- two looks are combined (=optimization)
+ -- look + sthg else floats upwards
+ Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
+ Look f `mplus` p = Look (\s -> f s `mplus` p)
+ p `mplus` Look f = Look (\s -> p `mplus` f s)
+
+-- ---------------------------------------------------------------------------
+-- The ReadP type
+
+newtype ReadP a = R (forall b . (a -> P b) -> P b)
-- Functor, Monad, MonadPlus
mplus = (+++)
-- ---------------------------------------------------------------------------
+-- Operations over P
+
+final :: [(a,String)] -> P a
+-- Maintains invariant for Final constructor
+final [] = Fail
+final r = Final r
+
+run :: P a -> ReadS a
+run (Get f) (c:s) = run (f c) s
+run (Look f) s = run (f s) s
+run (Result x p) s = (x,s) : run p s
+run (Final r) _ = r
+run _ _ = []
+
+-- ---------------------------------------------------------------------------
-- Operations over ReadP
get :: ReadP Char
-get = R (\k -> Get k)
+get = R Get
look :: ReadP String
-look = R (\k -> Look k)
+look = R Look
+
+pfail :: ReadP a
+pfail = R (\_ -> Fail)
(+++) :: ReadP a -> ReadP a -> ReadP a
-R f1 +++ R f2 = R (\k -> f1 k >|< f2 k)
+-- ^ Symmetric choice.
+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
+
+(<++) :: ReadP a -> ReadP a -> ReadP a
+-- ^ Local, exclusive, left-biased choice: If left parser
+-- locally produces any result at all, then right parser is
+-- not used.
+R f <++ q =
+ do s <- look
+ probe (f return) s 0#
+ where
+ probe (Get f) (c:s) n = probe (f c) s (n+#1#)
+ probe (Look f) s n = probe (f s) s n
+ probe p@(Result _ _) s n = discard n >> R (p >>=)
+ probe (Final r) _ _ = R (Final r >>=)
+ probe _ _ _ = q
+
+ discard 0# = return ()
+ discard n = get >> discard (n-#1#)
gather :: ReadP a -> ReadP (String, a)
-- ^ Transforms a parser into one that does the same, but
-- in addition returns the exact characters read.
-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
-- is built using any occurrences of readS_to_P.
-gather (R m)
- = R (\k -> gath id (m (\a -> Result (\s -> k (s,a)) Fail)))
- where
- gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
- gath l Fail = Fail
- gath l (Look f) = Look (\s -> gath l (f s))
- gath l (Result k p) = k (l []) >|< gath l p
- gath l (ReadS r) = error "do not use ReadS in gather!"
-
-(>|<) :: P a -> P a -> P a
--- Not exported! Works over the representation type
-Get f1 >|< Get f2 = Get (\c -> f1 c >|< f2 c)
-Fail >|< p = p
-p >|< Fail = p
-Look f >|< Look g = Look (\s -> f s >|< g s)
-Result x p >|< q = Result x (p >|< q)
-p >|< Result x q = Result x (p >|< q)
-Look f >|< p = Look (\s -> f s >|< p)
-p >|< Look f = Look (\s -> p >|< f s)
-p >|< q = ReadS (\s -> run p s ++ run q s)
-
-run :: P a -> ReadS a
-run (Get f) [] = []
-run (Get f) (c:s) = run (f c) s
-run (Look f) s = run (f s) s
-run (Result x p) s = (x,s) : run p s
-run (ReadS r) s = r s
-run Fail _ = []
+gather (R m) =
+ R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
+ where
+ gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
+ gath l Fail = Fail
+ gath l (Look f) = Look (\s -> gath l (f s))
+ gath l (Result k p) = k (l []) `mplus` gath l p
+ gath l (Final r) = error "do not use readS_to_P in gather!"
-- ---------------------------------------------------------------------------
-- Derived operations
-pfail :: ReadP a
-pfail = fail ""
-
satisfy :: (Char -> Bool) -> ReadP Char
satisfy p = do c <- get; if p c then return c else pfail
if p c then do s <- munch p; return (c:s) else pfail
choice :: [ReadP a] -> ReadP a
-choice ps = foldr (+++) pfail ps
+choice [] = pfail
+choice [p] = p
+choide (p:ps) = p +++ choice ps
skipSpaces :: ReadP ()
skipSpaces =
-- Converting between ReadP and Read
readP_to_S :: ReadP a -> ReadS a
-readP_to_S (R f) = run (f (\x -> Result x Fail))
+readP_to_S (R f) = run (f return)
readS_to_P :: ReadS a -> ReadP a
-readS_to_P r = R (\k -> ReadS (\s -> [ bs''
- | (a,s') <- r s
- , bs'' <- run (k a) s'
- ]))
+readS_to_P r =
+ R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+
+-- ---------------------------------------------------------------------------
+-- QuickCheck properties that are supposed to hold
+
+{-
+type Bag a = [a]
+
+(=~) :: Ord a => Bag a -> Bag a -> Bool
+xs =~ ys = sort xs == sort ys
+
+prop_Get_Nil =
+ readP_to_S get [] =~ []
+
+prop_Get_Cons c s =
+ readP_to_S get (c:s) =~ [(c,s)]
+
+prop_Look s =
+ readP_to_S look s =~ [(s,s)]
+
+prop_Fail s =
+ readP_to_S pfail s =~ ([] :: Bag (Int,String))
+
+prop_Return x s =
+ readP_to_S (return x) s =~ ([(x,s)] :: Bag (Int,String))
+
+prop_ReadS r s =
+ readP_to_S (readS_to_P r) s =~ (r s :: Bag (Int,String))
+
+prop_Bind p k s =
+ readP_to_S ((p :: ReadP Int) >>= k) s =~
+ ([ ys'' | (x,s') <- readP_to_S p s, ys'' <- readP_to_S (k x) s' ]
+ :: Bag (Int,String)
+ )
+
+prop_Plus p q s =
+ readP_to_S ((p :: ReadP Int) +++ q) s =~
+ (readP_to_S p s ++ readP_to_S q s)
+
+prop_LeftPlus p q s =
+ readP_to_S ((p :: ReadP Int) <++ q) s =~
+ (readP_to_S p s +<+ readP_to_S q s)
+ where
+ [] +<+ ys = ys
+ xs +<+ _ = xs
+-}
projects / haskell-directory.git / commitdiff