@@ -1,266 +0,0 @@
1−{-# LANGUAGE Rank2Types #-}
2−
3−module Main where
4−
5−import Control.Applicative
6−import System.Environment
7−import Control.Monad
8−import Data.Monoid (Monoid(..))
9−import qualified Data.ByteString.Lazy.Char8 as L
10−import qualified Data.ByteString as B8
11−import qualified Data.ByteString.Char8 as B
12−import qualified Data.ByteString.Unsafe as B
13−import qualified Data.ByteString.Internal as B
14−import Foreign.Ptr (castPtr, plusPtr)
15−import Foreign.ForeignPtr (withForeignPtr)
16−import Foreign.Storable (Storable(peek, sizeOf))
17−import Data.Word (Word8)
18−import Prelude hiding (getChar, takeWhile)
19−
20−data Result r = Fail S [String] String
21− | Partial (B.ByteString -> Result r)
22− | Done S r
23−
24−-- | The Parser monad is an Exception and State monad.
25−newtype Parser a = Parser {
26− runParser :: forall r. S
27− -> Failure r
28− -> Success a r
29− -> Result r
30− }
31−
32−type Failure r = S -> [String] -> String -> Result r
33−type Success a r = S -> a -> Result r
34−
35−data More = Complete | Incomplete
36− deriving (Eq, Ord, Show)
37−
38−plusMore :: More -> More -> More
39−plusMore Complete _ = Complete
40−plusMore _ Complete = Complete
41−plusMore _ _ = Incomplete
42−{-# INLINE plusMore #-}
43−
44−instance Monoid More where
45− mempty = Incomplete
46− mappend = plusMore
47−
48−data S = S {
49− input :: !B.ByteString
50− , added :: !B.ByteString
51− , more :: !More
52− } deriving (Show)
53−
54−instance Show r => Show (Result r) where
55− show (Fail _ stack msg) = "Fail " ++ show stack ++ " " ++ show msg
56− show (Partial _) = "Partial _"
57− show (Done bs r) = "Done " ++ show bs ++ " " ++ show r
58−
59−feed :: Result r -> B.ByteString -> Result r
60−feed f@(Fail _ _ _) _ = f
61−feed (Partial k) d = k d
62−feed (Done (S s a c) r) d = Done (S (s +++ d) a c) r
63−
64−bindP :: Parser a -> (a -> Parser b) -> Parser b
65−bindP m g =
66− Parser (\st0 kf ks -> runParser m st0 kf (\s a -> runParser (g a) s kf ks))
67−{-# INLINE bindP #-}
68−
69−returnP :: a -> Parser a
70−returnP a = Parser (\st0 _kf ks -> ks st0 a)
71−{-# INLINE returnP #-}
72−
73−instance Monad Parser where
74− return = returnP
75− (>>=) = bindP
76− fail = failDesc
77−
78−plus :: Parser a -> Parser a -> Parser a
79−plus a b = Parser $ \(S s0 a0 c0) kf ks ->
80− let kf' (S _s1 a1 c1) _ _ = runParser b st1 kf ks
81− where st1 = S (s0 +++ a1) (a0 +++ a1) (mappend c0 c1)
82− in runParser a (S s0 B.empty c0) kf' ks
83−{-# INLINE plus #-}
84−
85−instance MonadPlus Parser where
86− mzero = failDesc "mzero"
87− mplus = plus
88−
89−fmapP :: (a -> b) -> Parser a -> Parser b
90−fmapP p m = Parser (\st0 f k -> runParser m st0 f (\s a -> k s (p a)))
91−{-# INLINE fmapP #-}
92−
93−instance Functor Parser where
94− fmap = fmapP
95−
96−apP :: Parser (a -> b) -> Parser a -> Parser b
97−apP d e = do
98− b <- d
99− a <- e
100− return (b a)
101−{-# INLINE apP #-}
102−
103−instance Applicative Parser where
104− pure = returnP
105− (<*>) = apP
106−
107−instance Alternative Parser where
108− empty = failDesc "empty"
109− (<|>) = mplus
110−
111−failDesc :: String -> Parser a
112−failDesc err = Parser (\st0 kf _ks -> kf st0 [] msg)
113− where msg = "Failed reading: " ++ err
114−{-# INLINE failDesc #-}
115−
116−ensure :: Int -> Parser ()
117−ensure n = Parser $ \st0@(S s0 _a0 _c0) kf ks ->
118− if B.length s0 >= n
119− then ks st0 ()
120− else runParser (requireInput >> ensure n) st0 kf ks
121−
122−requireInput :: Parser ()
123−requireInput = Parser $ \st0@(S s0 a0 c0) kf ks ->
124− if c0 == Complete
125− then kf st0 ["requireInput"] "not enough bytes"
126− else Partial $ \s ->
127− if B.null s
128− then kf (S s0 a0 Complete) ["requireInput"] "not enough bytes"
129− else let st1 = S (s0 +++ s) (a0 +++ s) Incomplete
130− in ks st1 ()
131−
132−failK :: Failure a
133−failK st0 stack msg = Fail st0 stack msg
134−
135−successK :: Success a a
136−successK state a = Done state a
137−
138−get :: Parser B.ByteString
139−get = Parser (\st0 _kf ks -> ks st0 (input st0))
140−
141−put :: B.ByteString -> Parser ()
142−put s = Parser (\(S _s0 a0 c0) _kf ks -> ks (S s a0 c0) ())
143−
144−getBytes :: Int -> Parser B.ByteString
145−getBytes n = do
146− ensure n
147− s <- get
148− let (consume,rest) = B.splitAt n s
149− put rest
150− return consume
151−
152−getWord8 :: Parser Word8
153−getWord8 = getPtr (sizeOf (undefined :: Word8))
154−
155−getChar :: Parser Char
156−getChar = B.w2c `fmapP` getWord8
157−
158−(+++) :: B.ByteString -> B.ByteString -> B.ByteString
159−(+++) = B.append
160−{-# INLINE (+++) #-}
161−
162−try :: Parser a -> Parser a
163−try p = Parser $ \(S s0 a0 c0) kf ks ->
164− let kf' (S _s1 a1 c1) = kf (S (s0 +++ a1) (a0 +++ a1) (mappend c0 c1))
165− in runParser p (S s0 B.empty c0) kf' ks
166−
167−satisfy :: (Char -> Bool) -> Parser Char
168−satisfy p = do
169− ensure 1
170− s <- get
171− let c = B.w2c (B.unsafeHead s)
172− if p c
173− then put (B.unsafeTail s) >> return c
174− else fail "satisfy"
175−{-# INLINE satisfy #-}
176−
177−letter :: Parser Char
178−letter = satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
179−
180−letter1 :: Parser Char
181−letter1 = try $ do
182− c <- getChar
183− if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
184− then return c
185− else fail "letter"
186−
187−digit :: Parser Char
188−digit = satisfy $ \c -> c >= '0' && c <= '9'
189−
190−digit1 :: Parser Char
191−digit1 = try $ do
192− c <- getChar
193− if (c >= '0' && c <= '9')
194− then return c
195− else fail "digit"
196−
197−getPtr :: Storable a => Int -> Parser a
198−getPtr n = do
199− (fp,o,_) <- B.toForeignPtr `fmapP` getBytes n
200− return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
201−
202−parse :: Parser a -> B.ByteString -> Result a
203−parse m s = runParser m (S s B.empty Incomplete) failK successK
204−
205−manyP :: Parser a -> Parser [a]
206−manyP v = many_v
207− where many_v = some_v <|> pure []
208− some_v = (:) <$> v <*> many_v
209−
210−many_ :: Parser a -> Parser ()
211−many_ v = many_v
212− where many_v = some_v <|> pure ()
213− some_v = v *> many_v
214−
215−many1 :: Parser a -> Parser [a]
216−many1 p = do
217− a <- p
218− as <- manyP p
219− return (a:as)
220−
221−takeWhile8 :: (Word8 -> Bool) -> Parser B.ByteString
222−takeWhile8 p = do
223− (`when` requireInput) =<< B.null <$> get
224− (h,t) <- B8.span p <$> get
225− when (B.null h) $ failDesc "takeWhile8"
226− put t
227− if B.null t
228− then (h+++) `fmapP` (takeWhile8 p <|> return B.empty)
229− else return h
230−
231−takeWhile :: (Char -> Bool) -> Parser B.ByteString
232−takeWhile p = takeWhile8 (p . B.w2c)
233−
234−letters :: Parser B.ByteString
235−letters = takeWhile $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
236−
237−digits :: Parser B.ByteString
238−digits = takeWhile $ \c -> c >= '0' && c <= '9'
239−
240−chunksOf :: Int -> B.ByteString -> [B.ByteString]
241−chunksOf n = go
242− where go s | B.null s = []
243− | otherwise = let (h,t) = B.splitAt n s
244− in h : go t
245−
246−parseAll :: Parser a -> [B.ByteString] -> Result a
247−parseAll p ss = case ss of
248− [] -> go (parse p B.empty) []
249− (c:cs) -> go (parse p c) cs
250− where go (Partial k) (c:cs) = go (k c) cs
251− go (Partial k) [] = k B.empty
252− go r _ = r
253−
254−main = do
255− args <- getArgs
256− forM_ args $ \arg -> do
257− chunks <- if False
258− then L.toChunks `fmap` L.readFile arg
259− else do
260− content <- B.readFile arg
261− return $ if False
262− then [content]
263− else chunksOf 24 content
264− let p1 = manyP (many1 letter `mplus` many1 digit)
265− p2 = manyP (letters `mplus` digits)
266− print (parseAll p2 chunks)