{-# LANGUAGE BangPatterns, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}
module QC.Monoid (tests) where

import Prelude hiding (null, takeWhile)

import Control.Applicative ((<$>), (<*>), (*>), many, pure)
import Data.Monoid (Monoid, Sum(..), mempty, (<>))
import Data.Word (Word8)
import Test.Tasty.QuickCheck (testProperty)
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.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Monoid.Null (null)
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode)

instance Arbitrary B.ByteString where
    arbitrary   = B.pack <$> arbitrary

instance Arbitrary L.ByteString where
    arbitrary   = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))
                  ((L.fromChunks . map (B.pack . nonEmpty)) <$> arbitrary)
      where nonEmpty (NonEmpty a) = a

instance Arbitrary T.Text where
    arbitrary   = T.pack <$> arbitrary

-- Naming.

{-
label (NonEmpty s) = case parse (anyToken <?> s) B.empty of
                            (_, Left err) -> s `isInfixOf` err
                            _             -> False
-}

-- Basic byte-level combinators.

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

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

defP p = flip P.feed mempty . P.parse p

satisfy :: Word8 -> B.ByteString -> Bool
satisfy w s = maybeP (P.satisfy (<=b)) (b <> s) == Just b
   where b = B.singleton w

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 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 s
    | L.null s  = p == Nothing
    | otherwise = p == Just (L.take 1 s)
  where p = maybeP P.anyToken s

anyChar s
    | T.null s  = p == Nothing
    | otherwise = p == Just (T.head s)
  where p = maybeP P.anyChar s

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 s
    | L.null s  = p == Just (L.empty, s)
    | otherwise = p == Just (L.take 1 s, s)
  where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s

string s t = maybeP (P.string s) (s `L.append` t) == Just s

skipWhile w s =
    let t = L.dropWhile (<= w) s
    in case defP (P.skipWhile (<= L.singleton w)) s of
         P.Done t' () -> t == t'
         _            -> False

takeCount (Positive k) s =
    case maybeP (P.take k) s of
      Nothing -> fromIntegral k > L.length s
      Just s' -> fromIntegral k <= L.length s'

takeWhile w s =
    let (h,t) = L.span (<=w) s
    in case defP (P.takeWhile (<= L.singleton w)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeCharsWhile c s =
    let (h,t) = T.span (<=c) s
    in case defP (P.takeCharsWhile (<= c)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takePartialCharsWhile c s (NonNegative n) = 
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where (h,t) = T.span (<=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 w s =
    let s'    = L.cons w s
        (h,t) = L.span (<=w) s'
    in case defP (P.takeWhile1 (<= L.singleton w)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeCharsWhile1 c s =
    let s'    = T.cons c s
        (h,t) = T.span (<=c) s'
    in case defP (P.takeWhile1 (<= T.singleton c)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

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 (<=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 w s =
    let (h,t) = L.break (== w) s
    in case defP (P.takeTill (== L.singleton w)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeCharsTill c s =
    let (h,t) = T.break (== c) s
    in case defP (P.takeCharsTill (== c)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False
takeTillChar c s =
    let (h,t) = T.break (<= c) s
    in case defP (P.takeTillChar (<= c)) s of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeTillPartialChar c s (NonNegative n) =
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where (h,t) = T.break (<= 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 c s =
    let s'    = T.cons c s
        (h,t) = T.break (< c) s'
    in case defP (P.takeTillChar1 (< c)) s' of
         P.Done t' h' -> t == t' && h == h'
         _            -> False

takeTillPartialChar1 c s (NonNegative n) =
   case p' of
      P.Done t' h' -> utf8 t == t' && utf8 h == h'
      _            -> False
   where s'    = T.cons c s
         (h,t) = T.break (< 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 = maybeP (P.takeWhile1 undefined) L.empty == Nothing

endOfInput s = maybeP P.endOfInput s == if B.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))

tests = [
    testProperty "satisfy" satisfy,
    testProperty "satisfyChar" satisfyChar,
    testProperty "satisfyPartialChar" satisfyPartialChar,
    testProperty "anyToken" anyToken,
    testProperty "anyChar" anyChar,
    testProperty "anyPartialChar" anyPartialChar,
    testProperty "peekToken" peekToken,
    testProperty "string" string,
    testProperty "skipWhile" skipWhile,
    testProperty "takeCount" takeCount,
    testProperty "takeWhile" takeWhile,
    testProperty "takeCharsWhile" takeCharsWhile,
    testProperty "takePartialCharsWhile" takePartialCharsWhile,
    testProperty "takeWhile1" takeWhile1,
    testProperty "takeWhile1_empty" takeWhile1_empty,
    testProperty "takeCharsWhile1" takeCharsWhile1,
    testProperty "takePartialCharsWhile1" takePartialCharsWhile1,
    testProperty "takeTill" takeTill,
    testProperty "takeCharsTill" takeCharsTill,
    testProperty "takeTillChar" takeTillChar,
    testProperty "takeTillPartialChar" takeTillPartialChar,
    testProperty "takeTillChar1" takeTillChar1,
    testProperty "takeTillPartialChar1" takeTillPartialChar1,
    testProperty "endOfInput" endOfInput,
    testProperty "stateful" stateful
  ]