{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module QC.Monoid (tests) where

import Prelude hiding (null, take, takeWhile)

import Control.Applicative ((<$>), (<*>), (*>), many, pure)
import Data.Monoid (Monoid, Sum(..), mempty, (<>))
import Data.String (fromString)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)
import QC.Common (liftOp, parse)
import Test.QuickCheck
import Test.QuickCheck.Modifiers ()
import qualified Data.Picoparsec as P
import qualified Data.Picoparsec.State as PS
import qualified Data.ByteString as B
import qualified Data.Text as T hiding (break, singleton, span)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Encoding as TE
import Data.Monoid.Null (MonoidNull(null))
import Data.Monoid.Cancellative (LeftGCDMonoid)
import Data.Monoid.Factorial (FactorialMonoid(primePrefix, splitPrimePrefix))
import qualified Data.Monoid.Factorial as F
import qualified Data.Monoid.Textual as T
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode)

data Witness a where
   ByteStringWitness :: Witness B.ByteString
   StringWitness :: Witness String
   TextWitness :: Witness T.Text

-- Basic byte-level combinators.

utf8 :: T.Text -> ByteStringUTF8
utf8 = ByteStringUTF8 . TE.encodeUtf8

satisfy :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property
satisfy _ s = not (null w) ==> parse (P.satisfy (<= w)) s === Just w
  where w = primePrefix s

maybeP :: Monoid t => P.Parser t r -> t -> Maybe r
maybeP p = P.maybeResult . flip P.feed mempty . P.parse p

satisfyWith :: forall i. (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> i -> Property
satisfyWith _ p s = not (null p) ==> parse (P.satisfyWith id (<=c)) (c <> s) === Just c
  where c = primePrefix p

defP :: Monoid i => P.Parser i r -> i -> P.IResult i r
defP p = flip P.feed mempty . P.parse p

char :: Char -> LT.Text -> Property
char w s = parse (P.char w) (LT.cons w s) === Just w

skip :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property
skip _ ws = not (null ws) ==>
  case (parse (P.skip (<w)) s, splitPrimePrefix s) of
    (Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs
    (Just _,  mcs) -> maybe (property False) it mcs
  where it cs = liftOp "<" (<) (fst cs) w
        Just (w, s) = splitPrimePrefix ws

satisfyChar :: Char -> T.Text -> Bool
satisfyChar c s = maybeP (P.satisfyChar (<=c)) (t <> s) == Just c
                  && maybeP (P.satisfyChar (<=c)) (utf8 t <> utf8 s) == Just c
   where t = T.singleton c

satisfyPartialChar :: (T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
satisfyPartialChar _ c s (NonNegative n) = P.maybeResult p' == Just c
   where b = TE.encodeUtf8 (T.cons c s)
         (b1, b2) = B.splitAt (n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.satisfyChar (<=c)
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

anyToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Bool
anyToken _ s
    | null s  = p == Nothing
    | otherwise = p == Just (F.take 1 s)
  where p = maybeP P.anyToken s

anyChar :: T.TextualMonoid i => Witness i -> i -> Bool
anyChar _ s = maybeP P.anyChar s == T.characterPrefix s

notChar :: forall a. T.TextualMonoid a => Witness a -> Char -> NonEmptyList Char -> Property
notChar _ w (NonEmpty s) = parse (P.notChar w) bs === if v == Just w
                                                      then Nothing
                                                      else v
    where v = T.characterPrefix bs
          bs = fromString s :: a

peekChar :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Property
peekChar _ s
    | null s  = p === Just (Nothing, s)
    | otherwise = p === Just (T.characterPrefix s, s)
  where p = maybeP ((,) <$> P.peekChar <*> P.takeRest) s

peekChar' :: T.TextualMonoid i => Witness i -> i -> Property
peekChar' _ s = parse P.peekChar' s === (fst <$> T.splitCharacterPrefix s)

string :: (Eq i, LeftGCDMonoid i, MonoidNull i, Show i) => Witness i -> i -> i -> Property
string _ s t = parse (P.string s) (s <> t) === Just s

anyPartialChar :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> i -> NonNegative Int -> Bool
anyPartialChar _ s (NonNegative n)
    | T.null s  = maybeP p0 (ByteStringUTF8 b) == Nothing
    | otherwise = P.maybeResult p' == Just (T.head s)
   where b = TE.encodeUtf8 s
         (b1, b2) = B.splitAt (n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.anyChar
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

peekToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property
peekToken _ s
    | null s  = p === Just (mempty, s)
    | otherwise = p === Just (F.take 1 s, s)
  where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s

skipWhile :: Char -> LT.Text -> Property
skipWhile w s =
    let t = LT.dropWhile (<= w) s
    in case defP (P.skipWhile (<= LT.singleton w)) s of
         P.Done t' () -> t === t'
         _            -> property False

take :: (Eq i, FactorialMonoid i, Show i) => Witness i -> Int -> i -> Property
take _ n s = maybe (liftOp "<" (<) (F.length s) (fromIntegral n))
             (=== F.take n s) $
             parse (P.take n) s

takeRest :: (Eq i, MonoidNull i, Show i) => Witness i -> i -> Property
takeRest _ s = maybe (property False) (=== s) . maybeP P.takeRest $ s

takeCount :: FactorialMonoid i => Witness i -> Positive Int -> i -> Property
takeCount _ (Positive k) s = not (null s) ==>
    case parse (P.take k) s of
      Nothing -> liftOp ">" (>) (fromIntegral k) (F.length s)
      Just _s -> liftOp "<=" (<=) (fromIntegral k) (F.length s)

takeWhile :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property
takeWhile _ ws = not (null ws) ==>
    let (h,t) = F.span (==w) s
        Just (w,s) = splitPrimePrefix ws
    in case maybeP ((,) <$> P.takeWhile (==w) <*> P.takeRest) s of
         Just (h', t') -> t === t' .&&. h === h'
         _             -> property False

takeCharsWhile :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Property
takeCharsWhile _ w s =
    let (h,t) = T.span (const False) (==w) s
    in case maybeP ((,) <$> P.takeCharsWhile (==w) <*> P.takeRest) s of
         Just (h', t') -> t === t' .&&. h === h'
         _             -> property False

takePartialCharsWhile :: (Ord i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takePartialCharsWhile _ c s (NonNegative n) = 
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where (h,t) = T.span (const False) (<=c) s
         b = TE.encodeUtf8 s
         (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.takeCharsWhile (<= c)
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

takeWhile1 :: (Ord i, FactorialMonoid i) => Witness i -> i -> Property
takeWhile1 _ ws = not (null ws) ==>
  let s'    = w <> s
      (h,t) = F.span (<=w) s'
      Just (w, s) = splitPrimePrefix ws
    in case defP (P.takeWhile1 (<= w)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeCharsWhile1 :: (Ord i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Bool
takeCharsWhile1 _ c s =
    let s'    = T.singleton c <> s
        (h,t) = T.span (const False) (<=c) s'
    in case defP (P.takeCharsWhile1 (<= c)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takePartialCharsWhile1 :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takePartialCharsWhile1 _ c s (NonNegative n) = 
   case p' of
     P.Done t' h' -> utf8 t == t' && utf8 h == h'
     _            -> False
   where b = TE.encodeUtf8 s'
         s' = T.cons c s
         (h,t) = T.span (const False) (<=c) s'
         (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.takeCharsWhile1 (<= c)
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

takeTill :: (Eq i, FactorialMonoid i) => Witness i -> i -> Property
takeTill _ ws = not (null ws) ==> 
    let (h,t) = F.break (== w) s
        Just (w, s) = splitPrimePrefix ws
    in case defP (P.takeTill (== w)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeCharsTill :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeCharsTill _ c s =
    let (h,t) = T.break (const False) (== c) s
    in case defP (P.takeCharsTill (== c)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeTillChar :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeTillChar _ c s =
    let (h,t) = T.break (const False) (<= c) s
    in case defP (P.takeTillChar (<= c)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeTillPartialChar :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takeTillPartialChar _ c s (NonNegative n) =
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where (h,t) = T.break (const False) (<= c) s
         b = TE.encodeUtf8 s
         (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.takeTillChar (<= c)
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

takeTillChar1 :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeTillChar1 _ c s =
    let s'    = T.singleton c <> s
        (h,t) = T.break (const False) (< c) s'
    in case defP (P.takeTillChar1 (< c)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeTillPartialChar1 :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takeTillPartialChar1 _ c s (NonNegative n) =
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where s'    = T.singleton c <> s
         (h,t) = T.break (const False) (< c) s'
         b = TE.encodeUtf8 s'
         (b1, b2) = B.splitAt (n `mod` B.length b + 1) b
         (u1, b1') = decode b1
         u2 = ByteStringUTF8 (b1' <> b2)
         p0 = P.takeTillChar1 (< c)
         p1 = P.parse p0 u1
         p2 = if null u2 then p1 else P.feed p1 u2
         p' = P.feed p2 mempty

takeWhile1_empty :: forall i. (Eq i, FactorialMonoid i) => Witness i -> Bool
takeWhile1_empty _ = maybeP (P.takeWhile1 undefined) (mempty :: i) == Nothing

endOfInput :: (Eq i, MonoidNull i) => Witness i -> i -> Property
endOfInput _ s = maybeP P.endOfInput s === if null s
                                           then Just ()
                                           else Nothing

stateful :: String -> Bool
stateful s = maybeP (many (PS.modifyState (+ (Sum 1)) *> P.anyChar) *> PS.getState) (pure s)
             == Just (Sum (length s))

endOfLine :: (Eq i, T.TextualMonoid i) => Witness i -> i -> Property
endOfLine _ s =
  case (parse P.endOfLine s, T.splitCharacterPrefix s) of
    (Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs
    (Just _,  mcs) -> maybe (property False) eol mcs
  where eol (c,s') = c === '\n' .||.
                     (c, fst <$> T.splitCharacterPrefix s') === ('\r', Just '\n')

scan :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Positive Int -> Property
scan _ s (Positive k) = maybeP p s === Just (F.take k s)
  where p = P.scan k $ \ n _ ->
            if n > 0 then let !n' = n - 1 in Just n' else Nothing

tests :: [TestTree]
tests = [
   testProperty "anyChar" (anyChar TextWitness)
    , testProperty "char" char
       , testProperty "notChar" (notChar TextWitness),
    testProperty "satisfyChar" satisfyChar,
    testProperty "satisfyPartialChar" (satisfyPartialChar TextWitness),
    testProperty "anyToken" (anyToken ByteStringWitness),
    testProperty "endOfLine" (endOfLine TextWitness),
    testProperty "anyPartialChar" (anyPartialChar TextWitness),
    testProperty "peekToken" (peekToken ByteStringWitness)
    , testProperty "peekChar" (peekChar TextWitness)
    , testProperty "peekChar'" (peekChar' TextWitness)
    , testProperty "satisfy" (satisfy ByteStringWitness)
    , testProperty "satisfyWith" (satisfyWith ByteStringWitness)
    , testProperty "scan" (scan TextWitness)
    , testProperty "skip" (skip ByteStringWitness)
    , testProperty "skipWhile" skipWhile
    , testProperty "string" (string TextWitness)
    , testProperty "take" (take ByteStringWitness)
    , testProperty "takeRest" (takeRest ByteStringWitness)
    , testProperty "takeCount" (takeCount ByteStringWitness)
    , testProperty "takeTill" (takeTill ByteStringWitness),
    testProperty "takeCharsTill" (takeCharsTill TextWitness),
    testProperty "takeTillChar" (takeTillChar TextWitness),
    testProperty "takeTillPartialChar" (takeTillPartialChar TextWitness),
    testProperty "takeTillChar1" (takeTillChar1 TextWitness),
    testProperty "takeTillPartialChar1" (takeTillPartialChar1 TextWitness)
    , testProperty "takeWhile" (takeWhile ByteStringWitness)
    , testProperty "takeWhile1" (takeWhile1 ByteStringWitness)
    , testProperty "takeWhile1_empty" (takeWhile1_empty ByteStringWitness),
    testProperty "takeCharsWhile" (takeCharsWhile TextWitness),
    testProperty "takeCharsWhile1" (takeCharsWhile1 TextWitness),
    testProperty "takePartialCharsWhile" (takePartialCharsWhile TextWitness),
    testProperty "takePartialCharsWhile1" (takePartialCharsWhile1 TextWitness),
    testProperty "endOfInput" (endOfInput ByteStringWitness),
    testProperty "stateful" stateful
  ]