purescript-0.15.9: tests/TestAst.hs

{-# LANGUAGE TypeApplications #-}
module TestAst where

import Protolude hiding (Constraint, Type, (:+))

import Control.Lens ((+~))
import Control.Newtype (ala')
import Generic.Random (genericArbitraryRecG, genericArbitraryUG, listOf', uniform, withBaseCase, (:+)(..))
import Test.Hspec (Spec, describe, it)
import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, forAllShrink, subterms, (===))

import Language.PureScript.Label (Label(..))
import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..))
import Language.PureScript.PSString (PSString)
import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType)

spec :: Spec
spec = do
  describe "Language.PureScript.Types" $ do
    describe "everywhereOnTypes" $ do
      everywhereOnTypesSpec everywhereOnTypes
    describe "everywhereOnTypesM" $ do
      everywhereOnTypesSpec $ ala' Identity everywhereOnTypesM
    describe "everywhereOnTypesTopDownM" $ do
      everywhereOnTypesSpec $ ala' Identity everywhereOnTypesTopDownM
    describe "everythingOnTypes" $ do
      everythingOnTypesSpec everythingOnTypes
    describe "everythingWithContextOnTypes" $ do
      everythingOnTypesSpec $ \f g -> everythingWithContextOnTypes () [] f $ \s -> (s, ) . g

everywhereOnTypesSpec :: ((Type Int -> Type Int) -> Type Int -> Type Int) -> Spec
everywhereOnTypesSpec everywhereOnTypesUnderTest = do
  it "should visit each type once" $
    forAllShrink (genTypeAnnotatedWith (pure 0) (pure 1)) subterms $ \t ->
      all (== 1) `isSatisfiedBy` everywhereOnTypesUnderTest (annForType +~ 1) t

everythingOnTypesSpec :: (([Int] -> [Int] -> [Int]) -> (Type Int -> [Int]) -> Type Int -> [Int]) -> Spec
everythingOnTypesSpec everythingOnTypesUnderTest = do
  it "should visit each type once" $
    forAllShrink (genTypeAnnotatedWith (pure 1) (pure 0)) subterms $ \t ->
      everythingOnTypesUnderTest (++) (pure . getAnnForType) t ===
        filter (== 1) (toList t)


infixr 0 `isSatisfiedBy`
isSatisfiedBy :: forall a p. Show a => Testable p => (a -> p) -> a -> Property
isSatisfiedBy = liftA2 counterexample show

genTypeAnnotatedWith :: forall a. Gen a -> Gen a -> Gen (Type a)
genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where
  generatorEnvironment
    =  genConstraint
    :+ maybeOf genConstraintData
    :+ Label <$> genPSString
    :+ genPSString
    :+ genQualified (OpName @'TypeOpName)
    :+ genQualified (ProperName @'ClassName)
    :+ genQualified (ProperName @'TypeName)
    :+ genSkolemScope
    :+ maybeOf genSkolemScope
    :+ genText
    :+ listOf' (listOf' genText)
    :+ maybeOf genText
    :+ genType
    :+ listOf' genType
    :+ maybeOf genType
    :+ genWildcardData

  genConstraint :: Gen (Constraint a)
  genConstraint = genericArbitraryUG (genConstraintAnn :+ generatorEnvironment)

  genConstraintData :: Gen ConstraintData
  genConstraintData = genericArbitraryUG generatorEnvironment

  genQualified :: forall b. (Text -> b) -> Gen (Qualified b)
  genQualified ctor = Qualified ByNullSourcePos . ctor <$> genText

  genSkolemScope :: Gen SkolemScope
  genSkolemScope = SkolemScope <$> arbitrary

  genType :: Gen (Type a)
  genType = genericArbitraryRecG (genTypeAnn :+ generatorEnvironment) uniform `withBaseCase` (TypeVar <$> genTypeAnn <*> genText)

  genWildcardData :: Gen WildcardData
  genWildcardData = genericArbitraryUG genText

  maybeOf :: forall b. Gen b -> Gen (Maybe b)
  maybeOf = genericArbitraryUG

  genText :: Gen Text
  genText = pure "x" -- Feel free to make this random if it matters at some point.

  genPSString :: Gen PSString
  genPSString = pure "x" -- Ditto.