DOM.hs

{-|
Description:    

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

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


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

import Web.Willow.DOM

import Test.Willow.Property.Common


tests :: [H.Group]
tests = []

laws :: IO Bool
laws = H.C.lawsCheckMany
    [ ("Tree", treeLaws)
    , ("Node", nodeLaws)
    , ("NodeType", nodeTypeLaws)
    , ("QuirksMode", quirksLaws)
    , ("ElementParams", elementLaws)
    , ("AttributeParams", attributeLaws)
    , ("DocumentTypeParams", doctypeLaws)
    ]


basicLaws :: (Eq a, Show a, Read a) => H.Gen a -> [H.C.Laws]
basicLaws gen = map ($ gen)
    [ H.C.eqLaws
    , H.C.showLaws
    , H.C.showReadLaws
    ]


genTree :: H.Gen Tree
genTree = return emptyTree

treeLaws :: [H.C.Laws]
treeLaws = basicLaws genTree


genNode :: H.Gen Node
genNode = H.G.choice
    [ Text <$> genText
    , Comment <$> genText
    , DocumentType <$> genDoctype
    , Element <$> genElement
    , Attribute <$> genAttribute
    , H.G.constant DocumentFragment
    , Document <$> genQuirksMode
    ]

nodeLaws :: [H.C.Laws]
nodeLaws = basicLaws genNode


genNodeType :: H.Gen NodeType
genNodeType = H.G.enumBounded

nodeTypeLaws :: [H.C.Laws]
nodeTypeLaws = map ($ genNodeType)
    [ H.C.eqLaws
    , H.C.ordLaws
    , H.C.showLaws
    , H.C.showReadLaws
    , H.C.boundedEnumLaws
    ]


genQuirksMode :: H.Gen QuirksMode
genQuirksMode = H.G.enumBounded

quirksLaws :: [H.C.Laws]
quirksLaws = map ($ genQuirksMode)
    [ H.C.eqLaws
    , H.C.ordLaws
    , H.C.showLaws
    , H.C.showReadLaws
    , H.C.boundedEnumLaws
    ]


genElement :: H.Gen ElementParams
genElement = ElementParams
    <$> H.G.maybe genText
    <*> genText
    <*> H.G.maybe genText
    <*> fmap fromAttrList (H.G.list (H.R.linear 0 16) genAttribute)

elementLaws :: [H.C.Laws]
elementLaws = basicLaws genElement


genAttribute :: H.Gen AttributeParams
genAttribute = AttributeParams
    <$> H.G.maybe genText
    <*> genText
    <*> H.G.maybe genText
    <*> genText

attributeLaws :: [H.C.Laws]
attributeLaws = basicLaws genAttribute


genDoctype :: H.Gen DocumentTypeParams
genDoctype = DocumentTypeParams
    <$> genText
    <*> genText
    <*> genText

doctypeLaws :: [H.C.Laws]
doctypeLaws = basicLaws genDoctype