{-# LANGUAGE GADTs #-}
module Problem2 where
import Control.Monad
import Test.QuickCheck

data Parser tok a where
  Zero     ::                                   Parser tok  ()
  One      ::                                   Parser tok  ()
  Check    ::  (tok   -> Bool) ->               Parser tok  tok
  Satisfy  ::  ([tok] -> Bool) ->               Parser tok  [tok]
  Push     ::  tok -> Parser tok a ->           Parser tok  a
  Plus     ::  Parser tok a -> Parser tok b ->  Parser tok  (Either a b)
  Times    ::  Parser tok a -> Parser tok b ->  Parser tok  (a, b)
  Star     ::  Parser tok a ->                  Parser tok  [a]
    
parse :: MonadPlus m => Parser tok a -> [tok] -> m a
 
-- |Zero| always fails.
parse Zero ts = mzero
 
-- |One| matches only the empty string.
parse One []  =  return ()
parse One _   =  mzero
 
-- |Check p| matches a string with exactly one token |t| such that |p t| holds.
parse (Check p) [t]  =  if p t then return t else mzero
parse (Check p) _    =  mzero
 
-- |Satisfy p| matches any string such that |p ts| holds.
parse (Satisfy p) xs = if p xs then return xs else mzero
 
-- |Push t p| matches a string |ts| when |p| matches |(t:ts)|.
parse (Push t p) ts = parse p (t:ts)
 
-- |Plus p q| matches when either |p| or |q| does.
parse (Plus p q) ts =  liftM Left   (parse p ts) `mplus` 
                       liftM Right  (parse q ts)
 
----------------------------------------------------------------
-- Solution to 3a)

-- |Times p q| matches the concatenation of |p| and |q|.
parse (Times p q) ts = parseTimes p q ts
 
-- |Star p| matches zero or more copies of |p|.
parse (Star p) ts = parseStar p ts

parseStar :: MonadPlus m => Parser tok a -> [tok] -> m [a]
parseStar p []      = return []
parseStar p (t:ts)  = do
    (v,vs) <- parse (Times p (Star p)) (t:ts)
    return (v:vs)
    
parseTimes :: MonadPlus m =>
  Parser tok a -> Parser tok b -> [tok] -> m (a, b)
parseTimes p q []      = liftM2 (,) (parse p []) (parse q [])
parseTimes p q (t:ts)  = 
    parse (Times (Push t p) q) ts  `mplus`
    liftM2 (,) (parse p []) (parse q (t:ts))
 
----------------------------------------------------------------
-- Solution to 3b)
    
newtype P m tok a = P {runP :: [tok] -> m a}
 
zero     :: MonadPlus m =>                                   P m tok  ()
one      :: MonadPlus m =>                                   P m tok  ()
check    :: MonadPlus m =>  (tok   -> Bool) ->               P m tok  tok
satisfy  :: MonadPlus m =>  ([tok] -> Bool) ->               P m tok  [tok]
plus     :: MonadPlus m =>  P m tok a -> P m tok b ->  P m tok  (Either a b)
zero    = P (const mzero)
one     = P (\xs -> if null xs then return () else mzero)
check   p = P (\xs -> let n = length xs; x = head xs 
                      in if n==1 && p x then return x else mzero)
satisfy p = P (\xs -> if p xs then return xs else mzero)
plus    (P p) (P q) = P (\xs -> liftM Left (p xs) `mplus` liftM Right (q xs))

----------------------------------------------------------------
-- Below is some testing code and some variant solutions copied from
-- students (not guaranteed to work).

-- Examples: (not part of the exam question)

-- Looping test:
test :: Maybe [()]
test = parse (Star One) "I really must get to the bottom of this..."

token x = Check (x ==)
string xs = Satisfy (xs ==)
 
p   =  Times (token 'a') (token 'b')
p1  =  Times (Star (token 'a')) (Star (token 'b'))
p2  =  Star p1
 
blocks :: (Eq tok) => Parser tok [[tok]]
blocks = Star (Satisfy allEqual)
    where allEqual xs = and (zipWith (==) xs (drop 1 xs))
 
evenOdd = Plus (Star (Times (Check even) (Check odd)))
               (Star (Times (Check odd) (Check even)))
          

----------------
-- a very rudimentary test suite:
test1 xs = parse p xs  ==  if xs == "ab" then Just ('a','b') else Nothing
test2 xs = if null rest 
           then label "Just" $ Just (as, bs) == parse p1 xs
           else label "triv" $ Nothing == parse p1 xs
    where (as, bs') = (takeWhile ('a'==) xs, dropWhile ('a'==) xs)
          (bs, rest)= (takeWhile ('b'==) xs, dropWhile ('b'==) xs)

-- This test depends on the choice / order of matches
test3 = parse p2 "aaabbbbaabbbbbbbaaabbabab" ==  
        Just [("aaa","bbbb"),("aa","bbbbbbb"),("aaa","bb"),("a","b"),("a","b")]
-- This test depends on the choice / order of matches
test4 = parse blocks "aaaabbbbbbbbcccccddd" ==
        Just ["aaaa","bbbbbbbb","ccccc","ddd"]
test5 = parse evenOdd [0..9] ==
        Just (Left [(0,1),(2,3),(4,5),(6,7),(8,9)])
test6 = parse evenOdd [1..10] ==
        Just (Right [(1,2),(3,4),(5,6),(7,8),(9,10)])

main = do quickCheck test1
          quickCheck test2
          print $ test3 && test4 && test5 && test6
          
mconcat :: MonadPlus m => [m a] -> m a
mconcat = foldr mplus mzero

parseTimes2 :: MonadPlus m => 
  Parser tok a -> Parser tok b -> [tok] -> m (a, b)
parseTimes2 p q ts = mconcat as
  where as = [ liftM2 (,) (parse p pre) (parse q suf)
             | (pre,suf) <- preAndSuf ts
             ]

preAndSuf :: [a] -> [([a],[a])]
preAndSuf xs = [ splitAt n xs | n <- [0..length xs] ]

parseTimes3 :: MonadPlus m => 
  Parser tok a -> Parser tok b -> [tok] -> m (a, b)
parseTimes3 p q ts = mconcat [ do a <- parse p (take i ts)
                                  b <- parse q (drop i ts)
                                  return (a, b)
                             | i <- [0..length ts] ]


parseStar2 :: MonadPlus m => Parser tok a -> [tok] -> m [a]
parseStar2 p ts = 
    (if null ts then return [] else mzero) `mplus` 
    liftM (uncurry (:)) (parse (Times p (Star p)) ts)

parseStar3 :: MonadPlus m => Parser tok a -> [tok] -> m [a]
parseStar3 p [] = return []
parseStar3 p ts = mconcat [ do a  <- parse p        (take i ts)
                               as <- parse (Star p) (drop i ts)
                               return (a:as)
                          | i <- [1..length ts] ]


test7 xs = parseTimes3 p q xs == (parseTimes p q xs :: Maybe (Char, Char))
  where p = Check ('o'<)
        q = Check ('o'>=)

test8 xs = parseStar p xs == (parseStar3 p xs :: Maybe String)
  where p = Check ('o'<)