{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

{-|
Description:    

Copyright:      (c) 2020 Samuel May
License:        MPL-2.0
Maintainer:     ag.eitilt@gmail.com

Stability:      experimental
Portability:    portable
-}
module Test.Willow.Property.Parser
    ( tests
    ) where


import qualified Control.Applicative as A
import qualified Control.Monad as N
import qualified Control.Monad.Fail as N.F
-- import qualified Control.Monad.Fix as N.FX
-- import qualified Control.Monad.IO.Class as N.IO
import qualified Control.Monad.Trans.Class as N.T

import qualified Data.Semigroup as SG

import qualified Hedgehog as H
import qualified Hedgehog.Gen as H.G
import qualified Hedgehog.Range as H.R

import Control.Applicative ( (<|>) )
import Hedgehog ( (===) )

import Web.Willow.Common.Parser

import Test.Willow.Property.Common


tests :: [H.Group]
tests = map laws
    [ ("ByteString.Lazy", H.G.bytes $ H.R.linear 0 32, H.G.word8 H.R.linearBounded)
    ]


laws ::
    ( Stream stream token
    , Eq stream, Show stream, Monoid stream
    , Eq token, Show token
    ) => (String, H.Gen stream, H.Gen token) -> H.Group
laws (name, genStream, genToken) = packGroup ("Web.Willow.Common.Parser " ++ name) . concat $
    map (\f -> f genStream genToken)
        [ semigroupLaws
        , monoidLaws
        , alternativeLaws
        , applicativeLaws
        , functorLaws
        , monadLaws
     -- , monIoLaws
        , monPlusLaws
        , monFailLaws
     -- , monFixLaws
        , monTransLaws
        ]


data ParserFunc stream token = ParserFunc
    { parserIndex :: String
    , parser :: Parser stream token
    }

instance Eq (ParserFunc stream token) where
    l == r = parserIndex l == parserIndex r

instance Show (ParserFunc stream token) where
    show p = "(parser: " ++ parserIndex p ++ ")"

genParser ::
    ( Stream stream token
    , Eq token
    ) => H.Gen token -> H.Gen (ParserFunc stream token)
genParser x' = H.G.choice
    [ return $ ParserFunc "empty" A.empty
    , do
        x <- x'
        return . ParserFunc "pure" $ pure x
    , return $ ParserFunc "next" next
    , do
        x <- x'
        return . ParserFunc "token" $ token x
    , do
        x <- x'
        return . ParserFunc "push *> next" $ push x *> next
    ]

genParserList ::
    ( Stream stream token
    , Eq stream
    , Eq token
    ) => H.Gen token -> H.Gen (ParserFunc stream [token])
genParserList x' = H.G.choice
    [ return $ ParserFunc "empty []" A.empty
    , do
        xs <- H.G.list (H.R.linear 0 16) x'
        let xs' = foldr cons mempty xs
        return . ParserFunc "pure []" $ pure xs'
    , do
        n <- H.G.word $ H.R.linear 0 16
        return . ParserFunc "nextChunk" . chunkToList $ nextChunk n
    , do
        xs <- H.G.list (H.R.linear 0 16) x'
        let xs' = foldr cons mempty xs
        return . ParserFunc "chunk" . chunkToList $ chunk xs'
    , do
        xs <- H.G.list (H.R.linear 0 16) x'
        n <- H.G.word $ H.R.linear 0 16
        let xs' = foldr cons mempty xs
        return . ParserFunc "pushChunk *> nextChunk" . chunkToList $ pushChunk xs' *> nextChunk n
    ]
  where chunkToList = fmap chunkToList'
        chunkToList' stream = case uncons stream of
            Just (tok, stream') -> tok : chunkToList' stream'
            Nothing -> []


data TokenFunc token = TokenFunc
    { tokIndex :: String
    , tokFunc :: token -> token
    }

instance Eq (TokenFunc token) where
    l == r = tokIndex l == tokIndex r

instance Show (TokenFunc token) where
    show f = "(token function: " ++ tokIndex f ++ ")"

genTokenFunc :: H.Gen token -> H.Gen (TokenFunc token)
genTokenFunc _ = H.G.choice
    [ return $ TokenFunc "id" id
    ]


{-
data TwoTokenFunc token = TwoTokenFunc
    { tokIndex2 :: String
    , tokFunc2 :: token -> token -> token
    }

instance Eq (TwoTokenFunc token) where
    l == r = tokIndex2 l == tokIndex2 r

instance Show (TwoTokenFunc token) where
    show f = "(two-token function: " ++ tokIndex2 f ++ ")"

genTwoTokenFunc :: H.Gen token -> H.Gen (TwoTokenFunc token)
genTwoTokenFunc _ = H.G.choice
    [ return $ TwoTokenFunc "const" const
    ]
-}


type Laws stream token =
    ( Stream stream token
    , Eq stream, Show stream, Monoid stream
    , Eq token, Show token
    ) => H.Gen stream -> H.Gen token -> [Test]
type Law stream token =
    ( Stream stream token
    , Eq stream, Show stream, Monoid stream
    , Eq token, Show token
    ) => H.Gen stream -> H.Gen token -> Test


semigroupLaws :: Laws stream token
semigroupLaws genStream genToken = map (\f -> f genStream genToken)
    [ semiAssoc
    , semiConcat
    , semiTimes
    ]

semiAssoc :: Law stream token
semiAssoc genStream genToken = packTest "Semigroup: associativity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParserList genToken
    b' <- H.forAll $ genParserList genToken
    c' <- H.forAll $ genParserList genToken
    let a = parser a'
        b = parser b'
        c = parser c'
    
    let l = runParser (a <> (b <> c)) stream
        r = runParser ((a <> b) <> c) stream
    l === r

semiConcat :: Law stream token
semiConcat genStream genToken = packTest "Semigroup: concatenation" $ do
    stream <- H.forAll genStream
    ps' <- H.forAll . H.G.nonEmpty (H.R.linear 1 16) $ genParserList genToken
    let ps = parser <$> ps'
    
    let l = runParser (SG.sconcat ps) stream
        r = runParser (foldr1 (<>) ps) stream
    l === r

semiTimes :: Law stream token
semiTimes genStream genToken = packTest "Semigroup: times" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParserList genToken
    n <- H.forAll . H.G.int $ H.R.linear 1 16
    let a = parser a'
    
    let l = runParser (SG.stimes n a) stream
        r = runParser (foldr1 (<>) $ replicate n a) stream
    l === r


monoidLaws :: Laws stream token
monoidLaws genStream genToken = map (\f -> f genStream genToken)
    [ monoidLeft
    , monoidRight
    , monoidAssoc
    , monoidConcat
    ]

monoidLeft :: Law stream token
monoidLeft genStream genToken = packTest "Monoid: left identity" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParserList genToken
    let p = parser p'
    
    let l = runParser (mempty <> p) stream
        r = runParser p stream
    l === r

monoidRight :: Law stream token
monoidRight genStream genToken = packTest "Monoid: right identity" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParserList genToken
    let p = parser p'
    
    let l = runParser (p <> mempty) stream
        r = runParser p stream
    l === r

monoidAssoc :: Law stream token
monoidAssoc genStream genToken = packTest "Monoid: associativity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParserList genToken
    b' <- H.forAll $ genParserList genToken
    c' <- H.forAll $ genParserList genToken
    let a = parser a'
        b = parser b'
        c = parser c'
    
    let l = runParser (a <> (b <> c)) stream
        r = runParser ((a <> b) <> c) stream
    l === r

monoidConcat :: Law stream token
monoidConcat genStream genToken = packTest "Monoid: concatenation" $ do
    stream <- H.forAll genStream
    ps' <- H.forAll . H.G.list (H.R.linear 0 16) $ genParserList genToken
    let ps = parser <$> ps'
    
    let l = runParser (mconcat ps) stream
        r = runParser (foldr mappend mempty ps) stream
    l === r


alternativeLaws :: Laws stream token
alternativeLaws genStream genToken = map (\f -> f genStream genToken)
    [ altLeft
    , altRight
    , altAssoc
    ]

altLeft :: Law stream token
altLeft genStream genToken = packTest "Alternative: left identity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParser genToken
    let a = parser a'
    
    let l = runParser (A.empty <|> a) stream
        r = runParser a stream
    l === r

altRight :: Law stream token
altRight genStream genToken = packTest "Alternative: right identity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParser genToken
    let a = parser a'
    
    let l = runParser (a <|> A.empty) stream
        r = runParser a stream
    l === r

altAssoc :: Law stream token
altAssoc genStream genToken = packTest "Alternative: associativity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParser genToken
    b' <- H.forAll $ genParser genToken
    c' <- H.forAll $ genParser genToken
    let a = parser a'
        b = parser b'
        c = parser c'
    
    let l = runParser (a <|> (b <|> c)) stream
        r = runParser ((a <|> b) <|> c) stream
    l === r


applicativeLaws :: Laws stream token
applicativeLaws genStream genToken = map (\f -> f genStream genToken)
    [ appId
    , appComp
    , appHomo
    , appInter
    , appLift_1
    , appLift_2
    ]

appId :: Law stream token
appId genStream genToken = packTest "Applicative: identity" $ do
    stream <- H.forAll genStream
    v' <- H.forAll $ genParser genToken
    let v = parser v'
    
    let l = runParser (pure id <*> v) stream
        r = runParser v stream
    l === r

appComp :: Law stream token
appComp genStream genToken = packTest "Applicative: composition" $ do
    stream <- H.forAll genStream
    u' <- H.forAll $ genTokenFunc genToken
    v' <- H.forAll $ genTokenFunc genToken
    w' <- H.forAll $ genParser genToken
    let u = pure $ tokFunc u'
        v = pure $ tokFunc v'
        w = parser w'
    
    let l = runParser (pure (.) <*> u <*> v <*> w) stream
        r = runParser (u <*> (v <*> w)) stream
    l === r

appHomo :: Law stream token
appHomo genStream genToken = packTest "Applicative: homomorphism" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    x <- H.forAll genToken
    let f = tokFunc f'
    
    let l = runParser (pure f <*> pure x) stream
        r = runParser (pure $ f x) stream
    l === r

appInter :: Law stream token
appInter genStream genToken = packTest "Applicative: interchange" $ do
    stream <- H.forAll genStream
    u' <- H.forAll $ genTokenFunc genToken
    y <- H.forAll genToken
    let u = pure $ tokFunc u'
    
    let l = runParser (u <*> pure y) stream
        r = runParser (pure ($ y) <*> u) stream
    l === r

appLift_1 :: Law stream token
appLift_1 genStream genToken = packTest "Applicative: liftA2 (1)" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    x' <- H.forAll $ genParser genToken
    let f = pure $ tokFunc f'
        x = parser x'
    
    let l = runParser (A.liftA2 id f x) stream
        r = runParser (f <*> x) stream
    l === r

appLift_2 :: Law stream token
appLift_2 genStream genToken = packTest "Applicative: liftA2 (2)" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    x' <- H.forAll $ genParser genToken
    y' <- H.forAll $ genParser genToken
    let f = pure . tokFunc f'
        x = parser x'
        y = parser y'
    
    let l = runParser (A.liftA2 f x y) stream
        r = runParser (f <$> x <*> y) stream
    l === r


functorLaws :: Laws stream token
functorLaws genStream genToken = map (\f -> f genStream genToken)
    [ funId
    , funComp
    , funConst
    ]

funId :: Law stream token
funId genStream genToken = packTest "Functor: identity" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    let p = parser p'
    
    let l = runParser (fmap id p) stream
        r = runParser p stream
    l === r

funComp :: Law stream token
funComp genStream genToken = packTest "Functor: composition" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    f' <- H.forAll $ genTokenFunc genToken
    g' <- H.forAll $ genTokenFunc genToken
    let p = parser p'
        f = tokFunc f'
        g = tokFunc g'
    
    let l = runParser (fmap f $ fmap g p) stream
        r = runParser (fmap (f . g) p) stream
    l === r

funConst :: Law stream token
funConst genStream genToken = packTest "Functor: composition" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    x <- H.forAll genToken
    let p = parser p'
    
    let l = runParser (fmap (const x) p) stream
        r = runParser (x <$ p) stream
    l === r


monadLaws :: Laws stream token
monadLaws genStream genToken = map (\f -> f genStream genToken)
    [ monadLeft
    , monadRight
    , monadAssoc
    , monadRet
    , monadAp
    ]

monadLeft :: Law stream token
monadLeft genStream genToken = packTest "Monad: left identity" $ do
    stream <- H.forAll genStream
    a <- H.forAll genToken
    k' <- H.forAll $ genTokenFunc genToken
    let k = pure . tokFunc k'
    
    let l = runParser (return a >>= k) stream
        r = runParser (k a) stream
    l === r

monadRight :: Law stream token
monadRight genStream genToken = packTest "Monad: right identity" $ do
    stream <- H.forAll genStream
    m' <- H.forAll $ genParser genToken
    let m = parser m'
    
    let l = runParser (m >>= return) stream
        r = runParser m stream
    l === r

monadAssoc :: Law stream token
monadAssoc genStream genToken = packTest "Monad: associativity" $ do
    stream <- H.forAll genStream
    m' <- H.forAll $ genParser genToken
    k' <- H.forAll $ genTokenFunc genToken
    h' <- H.forAll $ genTokenFunc genToken
    let m = parser m'
        k = pure . tokFunc k'
        h = pure . tokFunc h'
    
    let l = runParser (m >>= (\x -> k x >>= h)) stream
        r = runParser ((m >>= k) >>= h) stream
    l === r

monadRet :: Law stream token
monadRet genStream genToken = packTest "Monad: return" $ do
    stream <- H.forAll genStream
    a <- H.forAll genToken
    
    let l = runParser (return a) stream
        r = runParser (pure a) stream
    l === r

monadAp :: Law stream token
monadAp genStream genToken = packTest "Monad: ap" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    x' <- H.forAll $ genParser genToken
    let f = pure $ tokFunc f'
        x = parser x'
    
    let l = runParser (N.ap f x) stream
        r = runParser (f <*> x) stream
    l === r


{- Type errors
monIoLaws :: Laws stream token
monIoLaws genStream genToken = map (\f -> f genStream genToken)
    [ monIoRet
    , monIoLift
    ]

monIoRet :: Law stream token
monIoRet genStream genToken = packTest "MonadIO: return" $ do
    stream <- H.forAll genStream
    x <- H.forAll genToken
    
    let l = runParser (N.IO.liftIO $ return x) stream
        r = runParser (return x) stream
    l === r

monIoLift :: Law stream token
monIoLift genStream genToken = packTest "MonadIO: lift" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    f' <- H.forAll $ genTokenFunc genToken
    let p = parser p'
        f = pure . tokFunc f'
    
    let l' = runParser (N.IO.liftIO $ p >>= f) stream
        r' = runParser (N.IO.liftIO p >>= (N.IO.liftIO . f)) stream
    l <- l'
    r <- r'
    l === r
-}


monPlusLaws :: Laws stream token
monPlusLaws genStream genToken = map (\f -> f genStream genToken)
    [ monPlusLeftId
    , monPlusRightId
    , monPlusAssoc
    , monPlusLeft0
    , monPlusRight0
    ]

monPlusLeftId :: Law stream token
monPlusLeftId genStream genToken = packTest "MonadPlus: left identity" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    let p = parser p'
    
    let l = runParser (N.mplus N.mzero p) stream
        r = runParser p stream
    l === r

monPlusRightId :: Law stream token
monPlusRightId genStream genToken = packTest "MonadPlus: right identity" $ do
    stream <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    let p = parser p'
    
    let l = runParser (flip N.mplus N.mzero p) stream
        r = runParser p stream
    l === r

monPlusAssoc :: Law stream token
monPlusAssoc genStream genToken = packTest "MonadPlus: associativity" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParser genToken
    b' <- H.forAll $ genParser genToken
    c' <- H.forAll $ genParser genToken
    let a = parser a'
        b = parser b'
        c = parser c'
    
    let l = runParser (N.mplus a $ N.mplus b c) stream
        r = runParser (N.mplus (N.mplus a b) c) stream
    l === r

monPlusLeft0 :: Law stream token
monPlusLeft0 genStream genToken = packTest "MonadPlus: left zero" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    let f = pure . tokFunc f'
    
    let l = runParser (N.mzero >>= f) stream
        r = runParser N.mzero stream
    l === r

monPlusRight0 :: Law stream token
monPlusRight0 genStream genToken = packTest "MonadPlus: right zero" $ do
    stream <- H.forAll genStream
    v' <- H.forAll $ genParser genToken
    let v = parser v'
    
    let l = runParser (v >> N.mzero) stream
        r = runParser (N.mzero :: Parser stream ()) stream
    l === r


monFailLaws :: Laws stream token
monFailLaws genStream genToken = map (\f -> f genStream genToken)
    [ monFailLeft0
    ]

monFailLeft0 :: Law stream token
monFailLeft0 genStream genToken = packTest "MonadFail: left zero" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    s <- H.forAll $ H.G.string (H.R.linear 0 16) H.G.ascii
    let f = pure . tokFunc f'
    
    let l = runParser (N.F.fail s >>= f) stream
        r = runParser (N.F.fail s) stream
    l === r


{- Hangs
monFixLaws :: Laws stream token
monFixLaws genStream genToken = map (\f -> f genStream genToken)
    [ monFixPure
    , monFixShrink
    , monFixSlide
    , monFixNest
    ]

monFixPure :: Law stream token
monFixPure genStream genToken = packTest "MonadFix: purity" $ do
    stream <- H.forAll genStream
    h' <- H.forAll $ genTokenFunc genToken
    let h = tokFunc h'
    
    let l = runParser (N.FX.mfix $ return . h) stream
        r = runParser (return $ N.FX.fix h) stream
    l === r

monFixShrink :: Law stream token
monFixShrink genStream genToken = packTest "MonadFix: left shrinking" $ do
    stream <- H.forAll genStream
    a' <- H.forAll $ genParser genToken
    f' <- H.forAll $ genTwoTokenFunc genToken
    let a = parser a'
        f x = pure . (tokFunc2 f') x
    
    let l = runParser (N.FX.mfix $ \x -> a >>= \y -> f x y) stream
        r = runParser (a >>= \y -> N.FX.mfix (\x -> f x y)) stream
    l === r

monFixSlide :: Law stream token
monFixSlide genStream genToken = packTest "MonadFix: sliding" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTokenFunc genToken
    h' <- H.forAll $ genTokenFunc genToken
    let f = pure . tokFunc f'
        h = tokFunc h'
    
    let l = runParser (N.FX.mfix $ N.liftM h . f) stream
        r = runParser (N.liftM h $ N.FX.mfix (f . h)) stream
    l === r

monFixNest :: Law stream token
monFixNest genStream genToken = packTest "MonadFix: nesting" $ do
    stream <- H.forAll genStream
    f' <- H.forAll $ genTwoTokenFunc genToken
    let f x = pure . (tokFunc2 f') x
    
    let l = runParser (N.FX.mfix $ \x -> N.FX.mfix (\y -> f x y)) stream
        r = runParser (N.FX.mfix $ \x -> f x x) stream
    l === r
-}


monTransLaws :: Laws stream token
monTransLaws genStream genToken = map (\f -> f genStream genToken)
    [ monTransRet
    , monTransLift
    ]

monTransRet :: Law stream token
monTransRet genStream genToken = packTest "MonadTrans: return" $ do
    stream <- H.forAll genStream
    x <- H.forAll genToken
    
    let l = runParser (N.T.lift $ return x) stream
        r = runParser (return x) stream
    l === r

monTransLift :: Law stream token
monTransLift genStream genToken = packTest "MonadTrans: lift" $ do
    stream1 <- H.forAll genStream
    stream2 <- H.forAll genStream
    p' <- H.forAll $ genParser genToken
    f' <- H.forAll $ genTokenFunc genToken
    let p = parser p'
        f = pure . tokFunc f'
    
    let l' = runParserT (N.T.lift $ p >>= f) stream1
        r' = runParserT (N.T.lift p >>= (N.T.lift . f)) stream1
        l = runParser l' stream2
        r = runParser r' stream2
    l === r