1 files changed, 74 insertions, 0 deletions

diff --git a/lib/ScanningParser.hs b/lib/ScanningParser.hs
new file mode 100644
index 0000000..f99e120
--- /dev/null
+++ b/lib/ScanningParser.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module ScanningParser
+ ( ScanningParser(..)
+ , scanAndParse
+ , scanAndParse1
+ ) where
+
+import Data.Maybe
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+-- | This type provides the means to parse a stream of 'tok' and extract all
+-- the 'obj' parses that occur.
+--
+-- Use Functor and Monoid interfaces to combine parsers.  For example,
+--
+-- > parserAorB = fmap Left parserA <> fmap Right parserB
+--
+data ScanningParser tok obj = forall partial. ScanningParser
+    { findFirst :: tok -> Maybe partial
+    -- ^ If the token starts an object, returns a partial parse.
+    , parseBody :: partial -> [tok] -> (Maybe obj,[tok])
+    -- ^ Given a partial parse and the stream of tokens that follow, attempt to
+    -- parse an object and return the unconsumed tokens.
+    }
+
+instance Functor (ScanningParser a) where
+    fmap f (ScanningParser ffst pbody)
+        = ScanningParser ffst (\b -> first (fmap f) . pbody b)
+     where
+        first f (x,y) = (f x, y)
+
+
+instance Monoid (ScanningParser a b) where
+    mempty = ScanningParser (const Nothing) (const $ const (Nothing,[]))
+    mappend (ScanningParser ffstA pbdyA)
+            (ScanningParser ffstB pbdyB)
+     = ScanningParser ffst pbody
+     where
+        ffst x = mplus (Left  <$> ffstA x)
+                       (Right <$> ffstB x)
+        pbody (Left apart)  = pbdyA apart
+        pbody (Right bpart) = pbdyB bpart
+
+
+-- | Apply a 'ScanningParser' to a list of tokens, yielding a list of parsed
+-- objects.
+scanAndParse :: ScanningParser a c -> [a] -> [c]
+scanAndParse psr [] = []
+scanAndParse psr@(ScanningParser ffst pbdy) ts = do
+    (b,xs) <- take 1 $ mapMaybe findfst' tss
+    let (mc,ts') = pbdy b xs
+        rec = scanAndParse psr ts'
+    maybe rec (:rec) mc
+ where
+    tss = tails ts
+    findfst' ts = do
+        x <- listToMaybe ts
+        b <- ffst x
+        return (b,drop 1 ts)
+
+scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a])
+scanAndParse1 psr@(ScanningParser ffst pbdy) ts = 
+    maybe (Nothing,[]) (uncurry pbdy) mb
+ where
+    mb = listToMaybe $ mapMaybe findfst' tss
+    tss = tails ts
+    findfst' ts = do
+        x <- listToMaybe ts
+        b <- ffst x
+        return (b,drop 1 ts)