Utf16.hs

{-|
Description:    

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

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


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

import Web.Willow.Common.Encoding

import Test.Willow.Property.Common


tests :: H.Group
tests = packGroup "Web.Willow.Common.Encoding.Utf16"
    [ decodeEndOfStream
    , decodeFourByteInvalid
    , decodeTwoByteLookup
    , decodeFourByteLookup
    ]


decodeEndOfStream :: Test
decodeEndOfStream = packTest "incomplete character" $ do
    enc <- H.forAll $ H.G.element [Utf16be, Utf16le]
    char <- H.forAll $ H.G.choice
        [ fmap pure $ H.G.word8 H.R.linearBounded
        , do
            high <- H.G.word8 $ H.R.linear 0xD8 0xDB
            low <- H.G.word8 H.R.linearBounded
            return $ if enc == Utf16be
                then [high, low]
                else [low, high]
        , do
            high <- H.G.word8 $ H.R.linear 0xD8 0xDB
            low <- H.G.word8 H.R.linearBounded
            b3 <- H.G.word8 H.R.linearBounded
            return $ if enc == Utf16be
                then [high, low, b3]
                else [low, high, b3]
        ]
    checkEndOfStream enc char


decodeFourByteInvalid :: Test
decodeFourByteInvalid = packTest "invalid second surrogate" $ do
    enc <- H.forAll $ H.G.element [Utf16be, Utf16le]
    char <- H.forAll $ do
        h1 <- H.G.word8 $ H.R.linear 0xD8 0xDB
        l1 <- H.G.word8 H.R.linearBounded
        h2 <- H.G.choice $ map H.G.word8
            [ H.R.linear 0x00 0xDB
            , H.R.linear 0xE0 0xFF
            ]
        l2 <- H.G.word8 H.R.linearBounded
        return $ if enc == Utf16be
            then [h1, l1, h2, l2]
            else [l1, h1, l2, h2]
    checkTrailingInit 2 enc char


decodeTwoByteLookup :: Test
decodeTwoByteLookup = packTest "two-byte sequence" $ do
    enc <- H.forAll $ H.G.element [Utf16be, Utf16le]
    char <- H.forAll $ do
        high <- H.G.choice $ map H.G.word8
            [ H.R.linear 0x00 0xC7
            , H.R.linear 0xDC 0xFF
            ]
        low <- H.G.word8 H.R.linearBounded
        return $ if enc == Utf16be
            then [high, low]
            else [low, high]
    checkTrailingAll enc char

decodeFourByteLookup :: Test
decodeFourByteLookup = packTest "four-byte sequence" $ do
    enc <- H.forAll $ H.G.element [Utf16be, Utf16le]
    char <- H.forAll $ do
        h1 <- H.G.word8 $ H.R.linear 0xD8 0xDB
        l1 <- H.G.word8 H.R.linearBounded
        h2 <- H.G.word8 $ H.R.linear 0xDC 0xDF
        l2 <- H.G.word8 H.R.linearBounded
        return $ if enc == Utf16be
            then [h1, l1, h2, l2]
            else [l1, h1, l2, h2]
    checkTrailingInit 2 enc char