CommonReader.hs

{-|
Description:    

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

Stability:      experimental
Portability:    portable
-}
module Test.Willow.WebPlatformTests.Manual.CommonReader
    ( dataFile
    , allEncodings
    , allEncodingLabels
    , someEncodings
    , someEncodingLabels
    , module Test.Willow.WebPlatformTests.Manual.Common
    ) where


import qualified Data.Aeson as J
import qualified Data.Maybe as Y
import qualified Data.Text as T

import qualified Test.HUnit as U

import Paths_willow

import Web.Willow.Common.Encoding
import Web.Willow.Common.Encoding.Labels

import Data.Aeson ( (.:) )
import Test.HUnit ( (~:) )
import System.FilePath ( (</>), (<.>) )

import Test.Willow.WebPlatformTests.Manual.Common


dataFile :: FilePath -> IO FilePath
dataFile f = getDataFileName $ dataDir </> f
  where dataDir = "test" </> "wpt"


encodingList :: IO [EncodingTable]
encodingList = do
    -- Repeat loading this, as the tests /do/ care about the "heading" value.
    path <- getDataFileName $ "encodings" <.> "json"
    Y.fromMaybe [] <$> J.decodeFileStrict' path

allEncodings :: (Encoding -> U.Test) -> IO U.Test
allEncodings = someEncodings $ const True

allEncodingLabels :: (T.Text -> U.Test) -> IO U.Test
allEncodingLabels = someEncodingLabels $ const True

someEncodings :: ((String, String, T.Text) -> Bool) -> (Encoding -> U.Test) -> IO U.Test
someEncodings p f = someEncodingLabels p $
    maybe (U.TestCase $ U.assertFailure "lookup failed for label") f . lookupEncoding

someEncodingLabels :: ((String, String, T.Text) -> Bool) -> (T.Text -> U.Test) -> IO U.Test
someEncodingLabels p f = U.TestList . map allTables <$> encodingList
  where allTables t = heading t ~: U.TestList (map (allDescs $ heading t) $ encodings t)
        allDescs t d = encoding d ~: U.TestList (map allLabels . filter (\l -> p (t, encoding d, l)) $ labels d)
        allLabels l = T.unpack l ~: f l


data EncodingTable = EncodingTable
    { encodings :: [EncodingDesc]
    , heading :: String
    }
instance J.FromJSON EncodingTable where
    parseJSON = J.withObject "table" $ \v -> EncodingTable
        <$> v .: T.pack "encodings"
        <*> v .: T.pack "heading"

data EncodingDesc = EncodingDesc
    { labels :: [T.Text]
    , encoding :: String
    }
instance J.FromJSON EncodingDesc where
    parseJSON = J.withObject "encoding" $ \v -> EncodingDesc
        <$> v .: T.pack "labels"
        <*> v .: T.pack "name"