{-# 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 Semigroup (ScanningParser a b) where
    (<>) = mappend
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)