    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Harp.Match
    -- Copyright   :  (c) Niklas Broberg 2004,
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Functions that simulate the behavior of regular patterns
    -- using a Match monad for parsing lists.
    -----------------------------------------------------------------------------

    {-# LANGUAGE CPP #-}

    module Harp.Match (
            Match           -- Match e a
            , runMatch      -- Match e a -> [e] -> Maybe a
            , baseMatch     -- (a -> Maybe b) -> Match a (a, b)
            , manyMatch     -- Match e a -> Match e [a]
            , gManyMatch    -- Match e a -> Match e [a]
            , foldComp      -- [[a] -> [a]] -> ([a] -> [a])
            , unzip0, unzip1, unzip2, unzip3, unzip4, unzip5, unzip6, unzip7
            , (+++)
            ) where

    #if MIN_VERSION_base(4,8,0)
    import Control.Monad (ap, liftM)
    #endif
    import Data.List (unzip3, unzip4, unzip5, unzip6, unzip7)

    --------------------------------------------------------------
    -- | The Match monad

    newtype Match e a = Match ([e] -> [(a, [e])])

    (+++) :: Match e a -> Match e a -> Match e a
    (Match [e] -> [(a, [e])]
    f) +++ :: forall e a. Match e a -> Match e a -> Match e a
    +++ (Match [e] -> [(a, [e])]
    g) = ([e] -> [(a, [e])]) -> Match e a
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (\[e]
    es -> let aes1 :: [(a, [e])]
    aes1 = [e] -> [(a, [e])]
    f [e]
    es
                                                aes2 :: [(a, [e])]
    aes2 = [e] -> [(a, [e])]
    g [e]
    es
                                             in [(a, [e])]
    aes1 [(a, [e])] -> [(a, [e])] -> [(a, [e])]
    forall a. [a] -> [a] -> [a]
    ++ [(a, [e])]
    aes2)

    #if MIN_VERSION_base(4,8,0)
    instance Applicative (Match e) where
       <*> :: forall a b. Match e (a -> b) -> Match e a -> Match e b
    (<*>) = Match e (a -> b) -> Match e a -> Match e b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap
       pure :: forall a. a -> Match e a
    pure = a -> Match e a
    forall a. a -> Match e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    instance Functor (Match e) where
       fmap :: forall a b. (a -> b) -> Match e a -> Match e b
    fmap = (a -> b) -> Match e a -> Match e b
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM
    #endif

    instance Monad (Match e) where
      return :: forall a. a -> Match e a
    return a
    x = ([e] -> [(a, [e])]) -> Match e a
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (\[e]
    es -> [(a
    x, [e]
    es)])

      (Match [e] -> [(a, [e])]
    f) >>= :: forall a b. Match e a -> (a -> Match e b) -> Match e b
    >>= a -> Match e b
    k = ([e] -> [(b, [e])]) -> Match e b
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (\[e]
    es -> let aes :: [(a, [e])]
    aes = [e] -> [(a, [e])]
    f [e]
    es
                                       in ((a, [e]) -> [(b, [e])]) -> [(a, [e])] -> [(b, [e])]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (a, [e]) -> [(b, [e])]
    help [(a, [e])]
    aes)
        where help :: (a, [e]) -> [(b, [e])]
    help (a
    a, [e]
    es) = let Match [e] -> [(b, [e])]
    g = a -> Match e b
    k a
    a
                              in [e] -> [(b, [e])]
    g [e]
    es

    mfail :: Match e a
    mfail :: forall e a. Match e a
    mfail = ([e] -> [(a, [e])]) -> Match e a
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (([e] -> [(a, [e])]) -> Match e a)
    -> ([e] -> [(a, [e])]) -> Match e a
    forall a b. (a -> b) -> a -> b
    $ \[e]
    _ -> []

    runM :: Match e a -> [e] -> [a]
    runM :: forall e a. Match e a -> [e] -> [a]
    runM (Match [e] -> [(a, [e])]
    f) [e]
    es = let aes :: [(a, [e])]
    aes = [e] -> [(a, [e])]
    f [e]
    es
                         in ((a, [e]) -> a) -> [(a, [e])] -> [a]
    forall a b. (a -> b) -> [a] -> [b]
    map (a, [e]) -> a
    forall a b. (a, b) -> a
    fst ([(a, [e])] -> [a]) -> [(a, [e])] -> [a]
    forall a b. (a -> b) -> a -> b
    $ ((a, [e]) -> Bool) -> [(a, [e])] -> [(a, [e])]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ([e] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([e] -> Bool) -> ((a, [e]) -> [e]) -> (a, [e]) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a, [e]) -> [e]
    forall a b. (a, b) -> b
    snd) [(a, [e])]
    aes

    getElement :: Match e e
    getElement :: forall e. Match e e
    getElement = ([e] -> [(e, [e])]) -> Match e e
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (([e] -> [(e, [e])]) -> Match e e)
    -> ([e] -> [(e, [e])]) -> Match e e
    forall a b. (a -> b) -> a -> b
    $ \[e]
    es -> case [e]
    es of
                                 [] -> []
                                 (e
    x:[e]
    xs) -> [(e
    x,e
    xe -> [e] -> [e]
    forall a. a -> [a] -> [a]
    :[e]
    xs)]

    discard :: Match e ()
    discard :: forall e. Match e ()
    discard = ([e] -> [((), [e])]) -> Match e ()
    forall e a. ([e] -> [(a, [e])]) -> Match e a
    Match (([e] -> [((), [e])]) -> Match e ())
    -> ([e] -> [((), [e])]) -> Match e ()
    forall a b. (a -> b) -> a -> b
    $ \[e]
    es -> case [e]
    es of
                               [] -> []
                               (e
    _:[e]
    xs) -> [((), [e]
    xs)]

    runMatch :: Match e a -> [e] -> Maybe a
    runMatch :: forall e a. Match e a -> [e] -> Maybe a
    runMatch Match e a
    m [e]
    es = case Match e a -> [e] -> [a]
    forall e a. Match e a -> [e] -> [a]
    runM Match e a
    m [e]
    es of
                     []     -> Maybe a
    forall a. Maybe a
    Nothing
                     (a
    a:[a]
    _) -> a -> Maybe a
    forall a. a -> Maybe a
    Just a
    a

    baseMatch :: (a -> Maybe b) -> Match a (a, b)
    baseMatch :: forall a b. (a -> Maybe b) -> Match a (a, b)
    baseMatch a -> Maybe b
    f = do a
    e <- Match a a
    forall e. Match e e
    getElement
                     case a -> Maybe b
    f a
    e of
                      Maybe b
    Nothing -> Match a (a, b)
    forall e a. Match e a
    mfail
                      Just b
    b -> do Match a ()
    forall e. Match e ()
    discard
                                   (a, b) -> Match a (a, b)
    forall a. a -> Match a a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    e, b
    b)

    gManyMatch :: Match e a -> Match e [a]
    gManyMatch :: forall e a. Match e a -> Match e [a]
    gManyMatch Match e a
    m = (do a
    a <- Match e a
    m
                       [a]
    as <- Match e a -> Match e [a]
    forall e a. Match e a -> Match e [a]
    gManyMatch Match e a
    m
                       [a] -> Match e [a]
    forall a. a -> Match e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    aa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    as))
                  Match e [a] -> Match e [a] -> Match e [a]
    forall e a. Match e a -> Match e a -> Match e a
    +++ ([a] -> Match e [a]
    forall a. a -> Match e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [])

    manyMatch :: Match e a -> Match e [a]
    manyMatch :: forall e a. Match e a -> Match e [a]
    manyMatch Match e a
    m = ([a] -> Match e [a]
    forall a. a -> Match e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Match e [a] -> Match e [a] -> Match e [a]
    forall e a. Match e a -> Match e a -> Match e a
    +++
                    (do a
    a <- Match e a
    m
                        [a]
    as <- Match e a -> Match e [a]
    forall e a. Match e a -> Match e [a]
    manyMatch Match e a
    m
                        [a] -> Match e [a]
    forall a. a -> Match e a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    aa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    as))

    foldComp :: [[a] -> [a]] -> ([a] -> [a])
    foldComp :: forall a. [[a] -> [a]] -> [a] -> [a]
    foldComp = (([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a])
    -> ([a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) [a] -> [a]
    forall a. a -> a
    id

    unzip0 :: [()] -> ()
    unzip0 :: [()] -> ()
    unzip0 = () -> [()] -> ()
    forall a b. a -> b -> a
    const ()

    unzip1 :: [a] -> [a]
    unzip1 :: forall a. [a] -> [a]
    unzip1 = [a] -> [a]
    forall a. a -> a
    id

    unzip2 :: [(a,b)] -> ([a],[b])
    unzip2 :: forall a b. [(a, b)] -> ([a], [b])
    unzip2 = [(a, b)] -> ([a], [b])
    forall a b. [(a, b)] -> ([a], [b])
    unzip

    {-
    data M e a = Element (e -> M e a)
               | Fail
               | Return a (M e a)

    instance Monad (M e) where
      return x = Return x Fail

      (Element f)  >>= k = Element (\e -> f e >>= k)
      Fail         >>= k = Fail
      (Return x m) >>= k = k x ++++ (m >>= k)

    infix 5 ++++

    (++++) :: M e a -> M e a -> M e a
    Fail       ++++ n          = n
    m          ++++ Fail       = m
    Return x m ++++ n          = Return x (m ++++ n)
    m          ++++ Return x n = Return x (m ++++ n)
    Element f  ++++ Element g  = Element (\e -> f e ++++ g e)

    runM :: M e a -> [e] -> [a]
    runM (Element f)  (e:es) = runM (f e) es
    runM (Element _)  []     = []
    runM Fail         _      = []
    runM (Return x m) []     = x : runM m []
    runM (Return _ m) es     = runM m es

    -- the continuation trick
    newtype Match e a = Match ()

    instance Monad (Match e) where
      return x = Match (\k -> k x)

      (Match f) >>= k = Match (\h -> f (\a -> let Match g = k a
                                               in g h))

    runMatch :: Match e a -> [e] -> [a]
    runMatch (Match f) = runM (f return)

    mfail :: Match e a
    mfail = Match $ \_ -> Fail
    -}