haskell/zap-tests/tests/Instances.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module: Instances
-- Description: Instances of Arbitrary for various types.
--
-- In particular, stuff from:
--
-- * "Zap.Basics"
-- * "Zap.Gen.Zap.Schema"
module Instances () where

import Zap (Which)
import qualified Zap.Basics as B
import Zap.Gen.Zap.Schema
import qualified Data.Vector as V
import Data.Word
import Test.QuickCheck
import Test.QuickCheck.Instances ()

-- Generate an arbitrary "unknown" tag, i.e. one with a value unassigned
-- by the schema. The parameter is the number of tags assigned by the schema.
arbitraryTag :: Word16 -> Gen Word16
arbitraryTag numTags = max numTags <$> arbitrary

instance Arbitrary (Parsed Node) where
  shrink = genericShrink
  arbitrary = do
    id <- arbitrary
    displayName <- arbitrary
    displayNamePrefixLength <- arbitrary
    scopeId <- arbitrary
    parameters <- arbitrarySmallerList
    isGeneric <- arbitrary
    nestedNodes <- arbitrarySmallerList
    annotations <- arbitrarySmallerList
    union' <- arbitrary
    pure Node {..}

instance Arbitrary (Parsed Node'SourceInfo) where
  shrink = genericShrink
  arbitrary = do
    id <- arbitrary
    docComment <- arbitrary
    members <- arbitrarySmallerList
    pure Node'SourceInfo {..}

instance Arbitrary (Parsed Node'SourceInfo'Member) where
  shrink = genericShrink
  arbitrary = Node'SourceInfo'Member <$> arbitrary

instance Arbitrary (Parsed (Which Node)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Node'file,
        Node'struct <$> arbitrary,
        Node'enum <$> arbitrary,
        Node'interface <$> arbitrary,
        Node'const <$> arbitrary,
        Node'annotation <$> arbitrary,
        Node'unknown' <$> arbitraryTag 6
      ]

instance Arbitrary (Parsed Node'enum) where
  shrink = genericShrink
  arbitrary = Node'enum' <$> arbitrarySmallerList

instance Arbitrary (Parsed Node'struct) where
  shrink = genericShrink
  arbitrary = do
    dataWordCount <- arbitrary
    pointerCount <- arbitrary
    preferredListEncoding <- arbitrary
    isGroup <- arbitrary
    discriminantCount <- arbitrary
    discriminantOffset <- arbitrary
    fields <- arbitrarySmallerList
    pure Node'struct' {..}

instance Arbitrary (Parsed Node'interface) where
  shrink = genericShrink
  arbitrary = Node'interface' <$> arbitrarySmallerList <*> arbitrarySmallerList

instance Arbitrary (Parsed Node'const) where
  shrink = genericShrink
  arbitrary = Node'const' <$> arbitrary <*> arbitrary

instance Arbitrary (Parsed Node'annotation) where
  shrink = genericShrink
  arbitrary = do
    type_ <- arbitrary
    targetsFile <- arbitrary
    targetsConst <- arbitrary
    targetsEnum <- arbitrary
    targetsEnumerant <- arbitrary
    targetsStruct <- arbitrary
    targetsField <- arbitrary
    targetsUnion <- arbitrary
    targetsGroup <- arbitrary
    targetsInterface <- arbitrary
    targetsMethod <- arbitrary
    targetsParam <- arbitrary
    targetsAnnotation <- arbitrary
    pure Node'annotation' {..}

instance Arbitrary (Parsed Node'NestedNode) where
  shrink = genericShrink
  arbitrary =
    Node'NestedNode
      <$> arbitrary
      <*> arbitrary

instance Arbitrary (Parsed Field) where
  shrink = genericShrink
  arbitrary = do
    name <- arbitrary
    codeOrder <- arbitrary
    annotations <- arbitrary
    discriminantValue <- arbitrary
    union' <- arbitrary
    ordinal <- arbitrary
    pure Field {..}

instance Arbitrary (Parsed (Which Field)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ Field'slot <$> arbitrary,
        Field'group <$> arbitrary
      ]

instance Arbitrary (Parsed Field'slot) where
  shrink = genericShrink
  arbitrary = do
    offset <- arbitrary
    type_ <- arbitrary
    defaultValue <- arbitrary
    hadExplicitDefault <- arbitrary
    pure Field'slot' {..}

instance Arbitrary (Parsed Field'group) where
  shrink = genericShrink
  arbitrary = Field'group' <$> arbitrary

instance Arbitrary (Parsed Field'ordinal) where
  shrink = genericShrink
  arbitrary = Field'ordinal' <$> arbitrary

instance Arbitrary (Parsed (Which Field'ordinal)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Field'ordinal'implicit,
        Field'ordinal'explicit <$> arbitrary
      ]

instance Arbitrary (Parsed Enumerant) where
  shrink = genericShrink
  arbitrary =
    Enumerant
      <$> arbitrary
      <*> arbitrary
      <*> arbitrarySmallerList

instance Arbitrary (Parsed Superclass) where
  shrink = genericShrink
  arbitrary =
    Superclass
      <$> arbitrary
      <*> arbitrary

instance Arbitrary (Parsed Method) where
  shrink = genericShrink
  arbitrary = do
    name <- arbitrary
    codeOrder <- arbitrary
    implicitParameters <- arbitrary
    paramStructType <- arbitrary
    paramBrand <- arbitrary
    resultStructType <- arbitrary
    resultBrand <- arbitrary
    annotations <- arbitrary
    pure Method {..}

instance Arbitrary (Parsed ZapVersion) where
  shrink = genericShrink
  arbitrary =
    ZapVersion
      <$> arbitrary
      <*> arbitrary
      <*> arbitrary

instance Arbitrary (Parsed Node'Parameter) where
  shrink = genericShrink
  arbitrary = Node'Parameter <$> arbitrary

instance Arbitrary (Parsed Brand) where
  shrink = genericShrink
  arbitrary = Brand <$> arbitrarySmallerList

instance Arbitrary (Parsed Brand'Scope) where
  shrink = genericShrink
  arbitrary =
    Brand'Scope
      <$> arbitrary
      <*> arbitrary

instance Arbitrary (Parsed (Which Brand'Scope)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ Brand'Scope'bind <$> arbitrarySmallerList,
        pure Brand'Scope'inherit,
        Brand'Scope'unknown' <$> arbitraryTag 2
      ]

instance Arbitrary (Parsed Brand'Binding) where
  shrink = genericShrink
  arbitrary = Brand'Binding <$> arbitrary

instance Arbitrary (Parsed (Which Brand'Binding)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Brand'Binding'unbound,
        Brand'Binding'type_ <$> arbitrary,
        Brand'Binding'unknown' <$> arbitraryTag 2
      ]

instance Arbitrary (Parsed Value) where
  shrink = genericShrink
  arbitrary = Value <$> arbitrary

instance Arbitrary (Parsed (Which Value)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Value'void,
        Value'bool <$> arbitrary,
        Value'int8 <$> arbitrary,
        Value'int16 <$> arbitrary,
        Value'int32 <$> arbitrary,
        Value'int64 <$> arbitrary,
        Value'uint8 <$> arbitrary,
        Value'uint16 <$> arbitrary,
        Value'uint32 <$> arbitrary,
        Value'uint64 <$> arbitrary,
        Value'float32 <$> arbitrary,
        Value'float64 <$> arbitrary,
        Value'text <$> arbitrary,
        Value'data_ <$> arbitrary,
        Value'list <$> arbitrary,
        Value'enum <$> arbitrary,
        Value'struct <$> arbitrary,
        pure Value'interface,
        Value'anyPointer <$> arbitrary,
        Value'unknown' <$> arbitraryTag 19
      ]

instance Arbitrary (Parsed Annotation) where
  shrink = genericShrink
  arbitrary =
    Annotation
      <$> arbitrary
      <*> arbitrary
      <*> arbitrary

instance Arbitrary ElementSize where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure ElementSize'empty,
        pure ElementSize'bit,
        pure ElementSize'byte,
        pure ElementSize'twoBytes,
        pure ElementSize'fourBytes,
        pure ElementSize'eightBytes,
        pure ElementSize'pointer,
        pure ElementSize'inlineComposite,
        ElementSize'unknown' <$> arbitraryTag 8
      ]

instance Arbitrary (Parsed Type'anyPointer) where
  shrink = genericShrink
  arbitrary = Type'anyPointer' <$> arbitrary

instance Arbitrary (Parsed (Which Type'anyPointer)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ Type'anyPointer'unconstrained <$> arbitrary,
        Type'anyPointer'parameter <$> arbitrary,
        Type'anyPointer'implicitMethodParameter <$> arbitrary
      ]

instance Arbitrary (Parsed Type'anyPointer'unconstrained) where
  shrink = genericShrink
  arbitrary = Type'anyPointer'unconstrained' <$> arbitrary

instance Arbitrary (Parsed (Which Type'anyPointer'unconstrained)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Type'anyPointer'unconstrained'anyKind,
        pure Type'anyPointer'unconstrained'struct,
        pure Type'anyPointer'unconstrained'list,
        pure Type'anyPointer'unconstrained'capability
      ]

instance Arbitrary (Parsed Type'anyPointer'parameter) where
  shrink = genericShrink
  arbitrary =
    Type'anyPointer'parameter' <$> arbitrary <*> arbitrary

instance Arbitrary (Parsed Type'anyPointer'implicitMethodParameter) where
  shrink = genericShrink
  arbitrary =
    Type'anyPointer'implicitMethodParameter' <$> arbitrary

instance Arbitrary (Parsed Type) where
  shrink = genericShrink
  arbitrary = Type <$> arbitrary

instance Arbitrary (Parsed (Which Type)) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ pure Type'void,
        pure Type'bool,
        pure Type'int8,
        pure Type'int16,
        pure Type'int32,
        pure Type'int64,
        pure Type'uint8,
        pure Type'uint16,
        pure Type'uint32,
        pure Type'uint64,
        pure Type'float32,
        pure Type'float64,
        pure Type'text,
        pure Type'data_,
        Type'list <$> arbitrary,
        Type'enum <$> arbitrary,
        Type'struct <$> arbitrary,
        Type'interface <$> arbitrary,
        Type'anyPointer <$> arbitrary,
        Type'unknown' <$> arbitraryTag 21
      ]

instance Arbitrary (Parsed Type'list) where
  shrink = genericShrink
  arbitrary = Type'list' <$> arbitrary

instance Arbitrary (Parsed Type'enum) where
  shrink = genericShrink
  arbitrary = Type'enum' <$> arbitrary <*> arbitrary

instance Arbitrary (Parsed Type'struct) where
  shrink = genericShrink
  arbitrary = Type'struct' <$> arbitrary <*> arbitrary

instance Arbitrary (Parsed Type'interface) where
  shrink = genericShrink
  arbitrary = Type'interface' <$> arbitrary <*> arbitrary

instance Arbitrary (Parsed CodeGeneratorRequest) where
  shrink = genericShrink
  arbitrary = do
    zapVersion <- arbitrary
    nodes <- arbitrarySmallerList
    requestedFiles <- arbitrarySmallerList
    sourceInfo <- arbitrarySmallerList
    pure CodeGeneratorRequest {..}

instance Arbitrary (Parsed CodeGeneratorRequest'RequestedFile) where
  shrink = genericShrink
  arbitrary =
    CodeGeneratorRequest'RequestedFile
      <$> arbitrary
      <*> arbitrary
      <*> arbitrary

instance Arbitrary (Parsed CodeGeneratorRequest'RequestedFile'Import) where
  shrink = genericShrink
  arbitrary =
    CodeGeneratorRequest'RequestedFile'Import
      <$> arbitrary
      <*> arbitrary

arbitrarySmallerList :: Arbitrary a => Gen [a]
arbitrarySmallerList = sized $ \size -> do
  -- Make sure the elements are scaled down relative to
  -- the size of the list:
  vec <- arbitrary :: Gen [()]
  let gen = resize (size `div` length vec) arbitrary
  traverse (const gen) vec

instance Arbitrary (Parsed B.AnyStruct) where
  shrink = genericShrink
  arbitrary = sized $ \_ ->
    B.Struct
      <$> (V.fromList <$> arbitrarySmallerList)
      <*> (V.fromList <$> arbitrarySmallerList)

instance Arbitrary (Parsed B.AnyList) where
  shrink = genericShrink
  arbitrary =
    oneof
      [ B.List0 <$> arbitrarySmallerList,
        B.List1 <$> arbitrarySmallerList,
        B.List8 <$> arbitrarySmallerList,
        B.List16 <$> arbitrarySmallerList,
        B.List32 <$> arbitrarySmallerList,
        B.List64 <$> arbitrarySmallerList,
        B.ListPtr <$> arbitrarySmallerList,
        B.ListStruct <$> arbitrarySmallerList
      ]

instance Arbitrary (Parsed B.AnyPointer) where
  shrink (B.PtrStruct s) = B.PtrStruct <$> shrink s
  shrink (B.PtrList l) = B.PtrList <$> shrink l
  shrink (B.PtrCap _) = []
  arbitrary =
    oneof
      [ B.PtrStruct <$> arbitrary,
        B.PtrList <$> arbitrary
        -- We never generate capabilites, as we can't marshal Clients back in,
        -- so many of the invariants we check don't hold for caps.
      ]