@@ -1,7 +1,10 @@
11{-# LANGUAGE Rank2Types #-}
22
3−module Main (main) where
3+--module Main (main) where
4+
5+import Debug.Trace
46import Control.Applicative
7+import Data.Monoid
58import Control.Monad
69import qualified Data.ByteString.Char8 as B
710import qualified Data.ByteString.Internal as B
@@ -11,9 +14,9 @@ import Foreign.Storable (Storable(peek, sizeOf))
1114import Data.Word (Word8)
1215import Prelude hiding (getChar)
1316
14−data Result r = Fail [String] String
17+data Result r = Fail S [String] String
1518 | Partial (B.ByteString -> Result r)
16− | Done B.ByteString r
19+ | Done S r
1720
1821-- | The Parser monad is an Exception and State monad.
1922newtype Parser a = Parser {
@@ -23,20 +26,45 @@ newtype Parser a = Parser {
2326 -> Result r
2427 }
2528
26−type Failure r = [String] -> String -> Result r
29+type Failure r = S -> [String] -> String -> Result r
2730type Success a r = S -> a -> Result r
2831
29−type S = B.ByteString
32+data Feed = Empty
33+ | Fed !B.ByteString
34+ deriving (Eq, Ord, Show)
35+
36+instance Monoid Feed where
37+ mempty = Empty
38+ mappend Empty b = b
39+ mappend a Empty = a
40+ mappend (Fed a) (Fed b) = Fed (B.append a b)
41+
42+augment :: B.ByteString -> Feed -> B.ByteString
43+augment bs Empty = bs
44+augment bs (Fed s) = B.append bs s
45+
46+shove :: Feed -> B.ByteString -> Feed
47+shove Empty bs = Fed bs
48+shove (Fed s) bs = Fed (B.append s bs)
49+
50+isEOF :: Feed -> Bool
51+isEOF (Fed s) = B.null s
52+isEOF _ = False
53+
54+data S = S {
55+ input :: B.ByteString
56+ , fed :: Feed
57+ } deriving (Show)
3058
3159instance Show r => Show (Result r) where
32− show (Fail stack msg) = "Fail " ++ show stack ++ " " ++ show msg
60+ show (Fail _ stack msg) = "Fail " ++ show stack ++ " " ++ show msg
3361 show (Partial _) = "Partial _"
3462 show (Done bs r) = "Done " ++ show bs ++ " " ++ show r
3563
3664feed :: Result r -> B.ByteString -> Result r
37−feed f@(Fail _ _) _ = f
38−feed (Partial k) s = k s
39−feed (Done bs r) s = Done (B.append bs s) r
65+feed f@(Fail _ _ _) _ = f
66+feed (Partial k) s = trace "k" k s
67+feed (Done bs r) s = Done (S (B.append (input bs) s) (fed bs)) r
4068
4169bindP :: Parser a -> (a -> Parser b) -> Parser b
4270bindP m g =
@@ -52,8 +80,10 @@ instance Monad Parser where
5280 (>>=) = bindP
5381 fail = failDesc
5482
83+merge (S i1 a1) (S i2 a2) = S i1 (mappend a1 a2)
84+
5585plus :: Parser a -> Parser a -> Parser a
56−plus a b = Parser (\s0 kf ks -> runParser a s0 (\_ _ -> runParser b s0 kf ks) ks)
86+plus a b = Parser (\s0@(S i j) kf ks -> runParser a s0 (\s1@(S x y) _ _ -> trace (show ("+",s0,s1)) runParser b (S (augment i y) (mappend j y)) kf ks) ks)
5787{-# INLINE plus #-}
5888
5989instance MonadPlus Parser where
@@ -83,29 +113,32 @@ instance Alternative Parser where
83113 (<|>) = mplus
84114
85115failDesc :: String -> Parser a
86−failDesc err = Parser (\_s0 kf _ks -> kf [] msg)
116+failDesc err = Parser (\s0 kf _ks -> trace (show ("fail",err,s0)) kf s0 [] msg)
87117 where msg = "Failed reading: " ++ err
88118{-# INLINE failDesc #-}
89119
90120ensure :: Int -> Parser ()
91−ensure n = Parser $ \s0 kf ks ->
92− if B.length s0 >= n
121+ensure n = Parser $ \s0@(S a b) kf ks ->
122+ if B.length (input s0) >= n
93123 then ks s0 ()
94− else Partial $ \s -> if B.null s
95− then kf ["ensure"] "not enough bytes"
96− else runParser (ensure n) (B.append s0 s) kf ks
124+ else if isEOF b
125+ then kf s0 ["ensure"] "not enough bytes"
126+ else trace "p" Partial $ \s -> trace (show ("partial",s)) $ if B.null s
127+ then trace "kf" kf (S a (shove b s)) ["ensure"] "not enough bytes"
128+ else let s1 = S (B.append a s) (shove b s)
129+ in trace (show ("resume",s1)) runParser (ensure n) s1 kf ks
97130
98131failK :: Failure a
99−failK stack msg = Fail stack msg
132+failK s0 stack msg = Fail s0 stack msg
100133
101134successK :: Success a a
102135successK state a = Done state a
103136
104137get :: Parser B.ByteString
105−get = Parser (\s0 _kf ks -> ks s0 s0)
138+get = Parser (\s0 _kf ks -> ks s0 (input s0))
106139
107140put :: B.ByteString -> Parser ()
108−put s = Parser (\_s0 _kf ks -> ks s ())
141+put s = Parser (\s0 _kf ks -> ks (S s (fed s0)) ())
109142
110143getBytes :: Int -> Parser B.ByteString
111144getBytes n = do
@@ -121,15 +154,18 @@ getWord8 = getPtr (sizeOf (undefined :: Word8))
121154getChar :: Parser Char
122155getChar = B.w2c `fmapP` getWord8
123156
157+try :: Parser a -> Parser a
158+try p = Parser (\s0@(S i j) kf ks -> trace (show ("trying",s0)) runParser p s0 (\(S x y) a b -> let s1 = S (augment i y) (mappend j y) in trace (show ("tried",s1)) kf s1 a b) ks)
159+
124160letter :: Parser Char
125−letter = do
161+letter = try $ do
126162 c <- getChar
127163 if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
128164 then return c
129165 else fail "letter"
130166
131167digit :: Parser Char
132−digit = do
168+digit = try $ do
133169 c <- getChar
134170 if (c >= '0' && c <= '9')
135171 then return c
@@ -141,7 +177,7 @@ getPtr n = do
141177 return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
142178
143179parse :: Parser a -> B.ByteString -> Result a
144−parse m s = runParser m s failK successK
180+parse m s = runParser m (S s mempty) failK successK
145181
146182manyP :: Parser a -> Parser [a]
147183manyP v = many_v
@@ -158,4 +194,4 @@ x = "asnoteubaoe8u9823bnaotebusnt823bsoeut98234nbaoetu29234"
158194yS = take 570000 $ cycle x
159195yB = B.pack yS
160196
161−main = print (parse (manyP (many1 letter `mplus` many1 digit)) yB)
197+main = print (parse (manyP (many1 letter `mplus` many1 digit)) yB `feed` B.empty)