@@ -1,6 +1,7 @@
11{-# LANGUAGE Rank2Types #-}
22
33module Main (main) where
4+import Control.Applicative
45import Control.Monad
56import qualified Data.ByteString.Char8 as B
67import qualified Data.ByteString.Internal as B
@@ -51,9 +52,35 @@ instance Monad Parser where
5152 (>>=) = bindP
5253 fail = failDesc
5354
55+plus :: Parser a -> Parser a -> Parser a
56+plus a b = Parser (\s0 kf ks -> runParser a s0 (\_ _ -> runParser b s0 kf ks) ks)
57+{-# INLINE plus #-}
58+
5459instance MonadPlus Parser where
5560 mzero = failDesc "mzero"
56− mplus a b = Parser (\s0 kf ks -> runParser a s0 (\_ _ -> runParser b s0 kf ks) ks)
61+ mplus = plus
62+
63+fmapP :: (a -> b) -> Parser a -> Parser b
64+fmapP p m = Parser (\s0 f k -> runParser m s0 f (\s a -> k s (p a)))
65+{-# INLINE fmapP #-}
66+
67+instance Functor Parser where
68+ fmap = fmapP
69+
70+apP :: Parser (a -> b) -> Parser a -> Parser b
71+apP d e = do
72+ b <- d
73+ a <- e
74+ return (b a)
75+{-# INLINE apP #-}
76+
77+instance Applicative Parser where
78+ pure = returnP
79+ (<*>) = apP
80+
81+instance Alternative Parser where
82+ empty = failDesc "empty"
83+ (<|>) = mplus
5784
5885failDesc :: String -> Parser a
5986failDesc err = Parser (\_s0 kf _ks -> kf [] msg)
@@ -75,15 +102,15 @@ successK :: Success a a
75102successK state a = Done state a
76103
77104get :: Parser B.ByteString
78−get = Parser (\s0 _ k -> k s0 s0)
105+get = Parser (\s0 _kf ks -> ks s0 s0)
79106
80107put :: B.ByteString -> Parser ()
81−put s = Parser (\_ _ k -> k s ())
108+put s = Parser (\_s0 _kf ks -> ks s ())
82109
83110getBytes :: Int -> Parser B.ByteString
84111getBytes n = do
112+ ensure n
85113 s <- get
86− when (n > B.length s) (fail "too few bytes")
87114 let (consume,rest) = B.splitAt n s
88115 put rest
89116 return consume
@@ -92,7 +119,7 @@ getWord8 :: Parser Word8
92119getWord8 = getPtr (sizeOf (undefined :: Word8))
93120
94121getChar :: Parser Char
95−getChar = B.w2c `liftM` getWord8
122+getChar = B.w2c `fmapP` getWord8
96123
97124letter :: Parser Char
98125letter = do
@@ -110,25 +137,25 @@ digit = do
110137
111138getPtr :: Storable a => Int -> Parser a
112139getPtr n = do
113− (fp,o,_) <- B.toForeignPtr `liftM` getBytes n
140+ (fp,o,_) <- B.toForeignPtr `fmapP` getBytes n
114141 return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
115142
116143parse :: Parser a -> B.ByteString -> Result a
117144parse m s = runParser m s failK successK
118145
119−many :: Parser a -> Parser [a]
120−many v = many_v
121− where many_v = some_v `mplus` return []
122− some_v = (:) `liftM` v `ap` many_v
146+manyP :: Parser a -> Parser [a]
147+manyP v = many_v
148+ where many_v = some_v <|> pure []
149+ some_v = (:) <$> v <*> many_v
123150
124151many1 :: Parser a -> Parser [a]
125152many1 p = do
126153 a <- p
127− as <- many p
154+ as <- manyP p
128155 return (a:as)
129156
130157x = "asnoteubaoe8u9823bnaotebusnt823bsoeut98234nbaoetu29234"
131158yS = take 570000 $ cycle x
132159yB = B.pack yS
133160
134−main = print (parse (many (many1 letter `mplus` many1 digit)) yB)
161+main = print (parse (manyP (many1 letter `mplus` many1 digit)) yB)