TestUtils.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS -Wno-orphans #-}

module Hasmin.TestUtils
    ( module Hasmin.TestUtils
    , module Test.QuickCheck
    , module Test.Hspec
    , module Test.Hspec.Attoparsec
    ) where

import Test.Hspec
import Test.QuickCheck hiding (NonZero)
import Test.QuickCheck.Instances()
import Test.Hspec.Attoparsec (parseSatisfies, (~>))

import Control.Applicative (liftA2, liftA3)
import Control.Monad (liftM4)
import Control.Monad.Reader (runReader)
import Data.Text (Text, unpack, singleton)
import Data.Attoparsec.Text (Parser)

import Hasmin.Types.BgSize
import Hasmin.Class
import Hasmin.Config
import Hasmin.Types.Color
import Hasmin.Types.Declaration
import Hasmin.Types.Dimension
import Hasmin.Types.FilterFunction
import Hasmin.Types.Numeric
import Hasmin.Types.Position
import Hasmin.Types.TimingFunction
import Hasmin.Types.RepeatStyle
import Hasmin.Types.BasicShape
import Hasmin.Types.BorderRadius
import Hasmin.Utils


minifyWithTestConfig :: Minifiable a => a -> a
minifyWithTestConfig x = runReader (minify x) cfg
  where cfg = defaultConfig { dimensionSettings = DimMinOn }

-- | Check that a color is equivalent to their minified representation form
prop_minificationEq :: (Minifiable a, Eq a) => a -> Bool
prop_minificationEq d = minifyWithTestConfig d == d

-- Given a parser and a 3-tuple, prints a test description,
-- applies the parser, and compares its result with the expected result
matchSpecWithDesc :: ToText a => Parser a -> (String, Text, Text) -> Spec
matchSpecWithDesc parser (description, textToParse, expectedResult) =
  it description $
    (toText <$> (textToParse ~> parser)) `parseSatisfies` (== expectedResult)

matchSpec :: ToText a => Parser a -> (Text, Text) -> Spec
matchSpec parser (textToParse, expectedResult) =
  it (unpack textToParse) $
    (toText <$> (textToParse ~> parser)) `parseSatisfies` (== expectedResult)

chooseConstructor :: (Enum a, Bounded a) => Gen a
chooseConstructor = oneof $ fmap pure [minBound..]

newtype Declarations = Declarations [Declaration]
instance ToText Declarations where
  toText (Declarations ds) = mconcatIntersperse toText (singleton ';') ds

instance Arbitrary Length where
  arbitrary = liftA2 Length arbitrary chooseConstructor

instance Arbitrary Angle where
  arbitrary = liftA2 Angle arbitrary chooseConstructor

instance Arbitrary Time where
  arbitrary = liftA2 Time arbitrary chooseConstructor

instance Arbitrary Frequency where
  arbitrary = liftA2 Frequency arbitrary chooseConstructor

instance Arbitrary Resolution where
  arbitrary = liftA2 Resolution arbitrary chooseConstructor

instance Arbitrary Number where
  arbitrary = toNumber <$> (arbitrary :: Gen Rational)

instance Arbitrary PosKeyword where
  arbitrary = chooseConstructor

instance Arbitrary Percentage where
  arbitrary = fmap Percentage (arbitrary :: Gen Rational)

instance Arbitrary FilterFunction where
  arbitrary = oneof
    [ Blur <$> arbitrary
    , Brightness <$> arbitrary
    , Contrast <$> arbitrary
    , Grayscale <$> arbitrary
    , Invert <$> arbitrary
    , Opacity <$> arbitrary
    , Saturate <$> arbitrary
    , Sepia <$> arbitrary
    , HueRotate <$> arbitrary
    , liftM4 DropShadow arbitrary arbitrary arbitrary arbitrary
    ]

instance Arbitrary BgSize where
  arbitrary = oneof [ liftA2 BgSize2 arbitrary arbitrary
                    , fmap BgSize1 arbitrary
                    ]

instance Arbitrary Auto where
  arbitrary = pure Auto

instance Arbitrary StepPosition where
  arbitrary = chooseConstructor

instance Arbitrary TimingFunction where
  arbitrary = oneof [ liftM4 CubicBezier arbitrary arbitrary arbitrary arbitrary
                    , liftA2 Steps arbitrary arbitrary
                    , pure Ease
                    , pure EaseIn
                    , pure EaseInOut
                    , pure EaseOut
                    , pure Linear
                    , pure StepEnd
                    , pure StepStart
                    ]

instance Arbitrary Color where
  arbitrary = oneof [ fmap Named colorKeyword
                    , liftA3 mkHex3 hexChar hexChar hexChar
                    , liftA3 mkHex6 hexString hexString hexString
                    , liftM4 mkHex4 hexChar hexChar hexChar hexChar
                    , liftM4 mkHex8 hexString hexString hexString hexString
                    , liftA3 mkRGBInt intRange intRange intRange
                    , liftA3 mkRGBPer ratRange ratRange ratRange
                    , liftM4 mkRGBAInt intRange intRange intRange alphaRange
                    , liftM4 mkRGBAPer ratRange ratRange ratRange alphaRange
                    , liftA3 mkHSL hueRange ratRange ratRange
                    , liftM4 mkHSLA hueRange ratRange ratRange alphaRange
                    ]
    where intRange   = choose (0, 255)
          ratRange   = toPercentage <$> (choose (0, 100) :: Gen Float)
          alphaRange = toAlphavalue <$> (choose (0, 1) :: Gen Float)
          hueRange   = choose (0, 360)

instance Arbitrary RepeatStyle where
  arbitrary = frequency [(1, pure RepeatX)
                        ,(1, pure RepeatY)
                        ,(8, liftA2 RepeatStyle2 arbitrary arbitrary)
                        ,(8, fmap RepeatStyle1 arbitrary)
                        ]

instance Arbitrary RSKeyword where
  arbitrary = oneof $ fmap pure [minBound..]

instance Arbitrary BasicShape where
  arbitrary = oneof
      [liftA2 Inset arbitrary arbitrary
      ,liftA2 Circle arbitrary arbitrary
      ,liftA2 Ellipse arbitrary arbitrary
      ,liftA2 Polygon arbitrary arbitrary
      ]

instance Arbitrary FillRule where
  arbitrary = oneof [pure NonZero, pure EvenOdd]

instance Arbitrary a => Arbitrary (AtMost2 a) where
  arbitrary = oneof
      [pure None
      ,One <$> arbitrary
      ,liftA2 Two arbitrary arbitrary
      ]

instance Arbitrary ShapeRadius where
  arbitrary = oneof
      [SRLength <$> arbitrary
      ,SRPercentage <$> arbitrary
      ,pure SRClosestSide
      ,pure SRFarthestSide
      ]

instance Arbitrary Position where
  arbitrary = Position <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

instance Arbitrary BorderRadius where
  arbitrary = BorderRadius <$> arbitrary <*> arbitrary

-- | Generates color keywords uniformly distributed
colorKeyword :: Gen Text
colorKeyword = oneof $ fmap (pure . fst) keywordColors

-- | Generates a hexadecimal character uniformly distributed
hexChar :: Gen Char
hexChar = oneof $ fmap pure hexadecimals

hexString :: Gen String
hexString = liftA2 (\x y -> [x,y]) hexChar hexChar

hexadecimals :: String
hexadecimals = "0123456789abcdef"