{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans        #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Text.Blaze.Tests
    ( tests
    ) where

import Prelude hiding (div, id, null)
import Data.Monoid (mempty, mappend)
import Control.Monad (replicateM)
import Control.Applicative ((<$>))
import Data.Word (Word8)
import Data.Char (ord)
import qualified Data.List as List

import Test.Framework (Test)
import Test.HUnit (Assertion, (@=?))
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LBC

import Text.Blaze.Internal
import Text.Blaze.Tests.Util

tests :: [Test]
tests = [ testProperty "left identity Monoid law"  monoidLeftIdentity
        , testProperty "right identity Monoid law" monoidRightIdentity
        , testProperty "associativity Monoid law"  monoidAssociativity
        , testProperty "mconcat Monoid law"        monoidConcat
        , testProperty "post escaping characters"  postEscapingCharacters
        , testProperty "valid UTF-8"               isValidUtf8
        , testProperty "external </ sequence"      externalEndSequence
        , testProperty "well nested <>"            wellNestedBrackets
        , testProperty "unsafeByteString id"       unsafeByteStringId

        , testCase     "conditional attributes"    conditionalAttributes
        , testCase     "contents 1"                contents1
        , testCase     "empty 1"                   empty1
        , testCase     "empty 2"                   empty2
        ]

-- | The left identity Monoid law.
--
monoidLeftIdentity :: Markup -> Bool
monoidLeftIdentity h = (return () >> h) == h

-- | The right identity Monoid law.
--
monoidRightIdentity :: Markup -> Bool
monoidRightIdentity h = (h >> return ()) == h

-- | The associativity Monoid law.
--
monoidAssociativity :: Markup -> Markup -> Markup -> Bool
monoidAssociativity x y z = (x >> (y >> z)) == ((x >> y) >> z)

-- | Concatenation Monoid law.
--
monoidConcat :: [Markup] -> Bool
monoidConcat xs = sequence_ xs == foldr (>>) (return ()) xs

-- | Escaped content cannot contain certain characters.
--
postEscapingCharacters :: String -> Bool
postEscapingCharacters str =
    LB.all (`notElem` forbidden) $ renderUsingUtf8 (string str)
  where
    forbidden = map (fromIntegral . ord) "\"'<>"

-- | Check if the produced bytes are valid UTF-8
--
isValidUtf8 :: Markup -> Bool
isValidUtf8 = isValidUtf8' . LB.unpack . renderUsingUtf8
  where
    isIn x y z = (x <= z) && (z <= y)
    isValidUtf8' :: [Word8] -> Bool
    isValidUtf8' [] = True
    isValidUtf8' (x:t)
        -- One byte
        | isIn 0x00 0x7f x = isValidUtf8' t
        -- Two bytes
        | isIn 0xc0 0xdf x = case t of
            (y:t') -> isIn 0x80 0xbf y && isValidUtf8' t'
            _      -> False
        -- Three bytes
        | isIn 0xe0 0xef x = case t of
            (y:z:t') -> all (isIn 0x80 0xbf) [y, z] && isValidUtf8' t'
            _        -> False
        -- Four bytes
        | isIn 0xf0 0xf7 x = case t of
            (y:z:u:t') -> all (isIn 0x80 0xbf) [y, z, u] && isValidUtf8' t'
            _          -> False
        | otherwise = False

-- | Rendering an unsafe bytestring should not do anything
--
unsafeByteStringId :: [Word8] -> Bool
unsafeByteStringId ws =
    LB.pack ws == renderUsingUtf8 (unsafeByteString $ SB.pack ws)

-- | Check if the "</" sequence does not appear in @<script>@ or @<style>@ tags.
--
externalEndSequence :: String -> Bool
externalEndSequence = not . List.isInfixOf "</" . LBC.unpack
                    . renderUsingUtf8 . external . string

-- | Check that the "<>" characters are well-nested.
--
wellNestedBrackets :: Markup -> Bool
wellNestedBrackets = wellNested False . LBC.unpack . renderUsingUtf8
  where
    wellNested isOpen [] = not isOpen
    wellNested isOpen (x:xs) = case x of
        '<' -> if isOpen then False else wellNested True xs
        '>' -> if isOpen then wellNested False xs else False
        _   -> wellNested isOpen xs

conditionalAttributes :: Assertion
conditionalAttributes =
    "<p class=\"foo\">Hello</p><p id=\"2nd\">World</p>" @=? renderUsingUtf8 html
  where
    html = do
        p !? (4 > length [()], class_ "foo") $ "Hello"
        p !? (List.null [()], class_ "bar") !? (True, id "2nd") $ "World"

contents1 :: Assertion
contents1 = "Hello World!" @=? renderUsingUtf8 (contents html)
  where
    html :: Markup
    html = div $ do
        p ! id "para" $ "Hello "
        img ! name "An image"
        p "World!"

empty1 :: Assertion
empty1 = True @=? null html
  where
    html :: Markup
    html = do
        ""
        ""
        mempty

empty2 :: Assertion
empty2 = False @=? null html
  where
    html :: Markup
    html = "" `mappend` "" `mappend` p "a"

-- Show instance for the HTML type, so we can debug.
--
instance Show Markup where
    show = show . renderUsingUtf8

-- Eq instance for the HTML type, so we can compare the results.
--
instance Eq Markup where
    x == y =  renderUsingString x == renderUsingString y
           && renderUsingText x   == renderUsingText y
           && renderUsingUtf8 x   == renderUsingUtf8 y
           -- Some cross-checks
           && renderUsingString x == renderUsingText y
           && renderUsingText x   == renderUsingUtf8 y

-- Arbitrary instance for the HTML type.
--
instance Arbitrary Markup where
    arbitrary = arbitraryMarkup 4

-- | Auxiliary function for the arbitrary instance of the HTML type, used
-- to limit the depth and size of the type.
--
arbitraryMarkup :: Int       -- ^ Maximum depth.
              -> Gen Markup  -- ^ Resulting arbitrary HTML snippet.
arbitraryMarkup depth = do
    -- Choose the size (width) of this element.
    size <- choose (0, 3)

    -- Generate `size` new HTML snippets.
    children <- replicateM size arbitraryChild

    -- Return a concatenation of these children.
    return $ sequence_ children
  where
    -- Generate an arbitrary child. Do not take a parent when we have no depth
    -- left, obviously.
    arbitraryChild = do
        child <- oneof $  [arbitraryLeaf, arbitraryString, return mempty]
                       ++ [arbitraryParent | depth > 0]

        -- Generate some attributes for the child.
        size <- choose (0, 4)
        attributes <- replicateM size arbitraryAttribute
        return $ foldl (!) child attributes

    -- Generate an arbitrary parent element.
    arbitraryParent = do
        parent <- elements [p, div, table]
        parent <$> arbitraryMarkup (depth - 1)

    -- Generate an arbitrary leaf element.
    arbitraryLeaf = oneof $ map return [img, br, area]

    -- Generate arbitrary string element.
    arbitraryString = do
        s <- arbitrary
        return $ string s

    -- Generate an arbitrary HTML attribute.
    arbitraryAttribute = do
        attr <- elements [id, class_, name]
        value <- arbitrary
        return $ attr $ stringValue value