liblawless-0.18.2: Tests/TestAesonEncoding.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module:             TestAesonEncoding
Description:        Tests that our encoding/decoding options produce the correct results.
Copyright:          © 2016 All rights reserved.
License:            GPL-3
Maintainer:         Evan Cofsky <>
Stability:          experimental
Portability:        POSIX
-}

module TestAesonEncoding where

import Test.Framework
import Test.Framework.TH
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck

import Lawless hiding (elements)
import Aeson
import Data.Char (toLower)
import Text

default (Text)

data FieldLabel = FieldLabel {
    _flPrefix ∷ [Char],
    _flMiddle ∷ [Char],
    _flSuffix ∷ [Char]
    } deriving (Eq, Ord, Show)
makeLenses ''FieldLabel

flLabel ∷ Getter FieldLabel [Char]
flLabel  = to (\f → concatOf traversed ["_", f ^. flPrefix, f ^. flMiddle, f ^. flSuffix])

flModLabel ∷ Getter FieldLabel [Char]
flModLabel = to (fieldLabelModifier lawlessJSONOptions ∘ view flLabel)

lowers ∷ Gen Char
lowers = elements ['a'..'z']

uppers ∷ Gen Char
uppers = elements ['A'..'Z']

others ∷ Gen Char
others = elements $ concatOf traversed [['a'..'z'], ['A'..'Z'], ['0'..'9'], "_"]

instance Arbitrary FieldLabel where
    arbitrary = FieldLabel <$> listOf1 lowers <*> ((:[]) <$> uppers) <*> listOf others

prop_TestDropLens :: FieldLabel -> Property
prop_TestDropLens fl =
    let
        efl = fl ^. flModLabel
    in
        collect "Test dropping the Lens prefix" $
        (toLower <$> (fl ^. flMiddle) ^.. taking 1 traversed) === efl ^.. taking 1 traversed

properties ∷ Test
properties = $(testGroupGenerator)