-----------------------------------------------------------------------------
-- |
-- 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) +++ :: 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
   <*> :: 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 :: a -> Match e a
pure = a -> Match e a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Functor (Match e) where
   fmap :: (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 :: 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) >>= :: 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 :: 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 :: 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 (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 :: 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 :: 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 :: 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 :: (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 (m :: * -> *) a. Monad m => a -> m a
return (a
e, b
b)

gManyMatch :: Match e a -> Match e [a]
gManyMatch :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return [])

manyMatch :: Match e a -> Match e [a]
manyMatch :: Match e a -> Match e [a]
manyMatch Match e a
m = ([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 (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 :: [[a] -> [a]] -> [a] -> [a]
foldComp = (([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a])
-> ([a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
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 :: [a] -> [a]
unzip1 = [a] -> [a]
forall a. a -> a
id

unzip2 :: [(a,b)] -> ([a],[b])
unzip2 :: [(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
-}