ScanningParser module

1 files changed, 96 insertions, 0 deletions

diff --git a/ScanningParser.hs b/ScanningParser.hs
new file mode 100644
index 0000000..9eed080
--- /dev/null
+++ b/ScanningParser.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module ScanningParser
+ ( ScanningParser(..)
+ ) where
+
+import Data.Maybe
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+-- | Utility to operate on the first item of a pair.
+first :: (a->b) -> (a,c) -> (b,c)
+first f (x,y) = (f x, y)
+
+-- | 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.
+    }
+
+-- | 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
+    maybe [] (:scanAndParse psr ts') mc
+ where
+    tss = tails ts
+    findfst' ts = do
+        x <- listToMaybe ts
+        b <- ffst x
+        return (b,drop 1 ts)
+
+instance Functor (ScanningParser a) where
+    fmap f (ScanningParser ffst pbody)
+        = ScanningParser ffst (\b -> first (fmap f) . pbody b)
+
+instance Monoid (ScanningParser a b) where
+    mempty = ScanningParser (const Nothing) (const $ const (Nothing,[]))
+    mappend a b = a <+> b
+
+-- | Combine two parsers into one that tries either.
+(<+>) ::
+    ScanningParser tok obj
+    -> ScanningParser tok obj
+    -> ScanningParser tok obj
+parserA@(ScanningParser ffstA pbdyA) <+> parserB@(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
+
+{-
+
+-- | Map a parser into a sum type. This is useful for combining multiple
+-- 'ScanningParser's for a single pass scan.
+--
+-- HELP: Can this be done with one function argument instead of three?
+mapParser ::
+    (c -> y)
+    -> (b -> x)
+    -> (x -> b)
+    -> ScanningParser a b c
+    -> ScanningParser a x y
+mapParser g f invf psr =
+    psr { findFirst = fmap f . findFirst psr
+        , parseBody = \b as -> first (fmap g) $ parseBody psr (invf b) as
+        }
+
+-- | map 'Right' over a 'ScanningParser'
+--
+-- > mapRight = mapParser Right Right (\(Right x)->x)
+mapRight :: ScanningParser a b c -> ScanningParser a (Either x b) (Either y c)
+mapRight = mapParser Right Right (\(Right x)->x)
+
+-- | map 'Left' over a 'ScanningParser'
+--
+-- > mapLeft = mapParser Left Left (\(Left x)->x)
+mapLeft :: ScanningParser a b c -> ScanningParser a (Either b x) (Either c y)
+mapLeft  = mapParser Left Left (\(Left x)->x)
+
+-}