haskell/tests/Instances.hs

{-|
Module: Instances
Description: Instances of Arbitrary for various types.

In particular, stuff from:

* "Capnp.Untyped.Pure"
* "Capnp.Gen.Capnp.Schema.Pure"
-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards       #-}
module Instances () where

import Data.Word
import Test.QuickCheck

import Test.QuickCheck.Instances ()

import qualified Data.Vector as V

import Capnp.Gen.Capnp.Schema.Pure

import qualified Capnp.Untyped.Pure as PU

-- 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 Node where
    shrink = genericShrink
    arbitrary = do
        id <- arbitrary
        displayName <- arbitrary
        displayNamePrefixLength <- arbitrary
        scopeId <- arbitrary
        parameters <- arbitrarySmallerVec
        isGeneric <- arbitrary
        nestedNodes <- arbitrarySmallerVec
        annotations <- arbitrarySmallerVec
        union' <- arbitrary
        pure Node{..}

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

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

instance Arbitrary 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 Node'enum where
    shrink = genericShrink
    arbitrary = Node'enum' <$> arbitrarySmallerVec

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

instance Arbitrary Node'interface where
    shrink = genericShrink
    arbitrary = Node'interface' <$> arbitrarySmallerVec <*> arbitrarySmallerVec

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

instance Arbitrary 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 Node'NestedNode where
    shrink = genericShrink
    arbitrary = Node'NestedNode
        <$> arbitrary
        <*> arbitrary

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

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

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

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

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

instance Arbitrary Enumerant where
    shrink = genericShrink
    arbitrary = Enumerant
        <$> arbitrary
        <*> arbitrary
        <*> arbitrarySmallerVec

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

instance Arbitrary 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 CapnpVersion where
    shrink = genericShrink
    arbitrary = CapnpVersion
        <$> arbitrary
        <*> arbitrary
        <*> arbitrary

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

instance Arbitrary Brand where
    shrink = genericShrink
    arbitrary = Brand <$> arbitrarySmallerVec

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

instance Arbitrary Brand'Scope' where
    shrink = genericShrink
    arbitrary = oneof
        [ Brand'Scope'bind <$> arbitrarySmallerVec
        , pure Brand'Scope'inherit
        , Brand'Scope'unknown' <$> arbitraryTag 2
        ]

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

instance Arbitrary 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 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 Type'anyPointer where
    shrink = genericShrink
    arbitrary = oneof
        [ Type'anyPointer'unconstrained <$> arbitrary
        , Type'anyPointer'parameter <$> arbitrary
        , Type'anyPointer'implicitMethodParameter <$> arbitrary
        ]

instance Arbitrary 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 Type'anyPointer'parameter where
    shrink = genericShrink
    arbitrary =
        Type'anyPointer'parameter' <$> arbitrary <*> arbitrary

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

instance Arbitrary 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 Type'list where
    shrink = genericShrink
    arbitrary = Type'list' <$> arbitrary

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

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

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

instance Arbitrary CodeGeneratorRequest where
    shrink = genericShrink
    arbitrary = do
        capnpVersion <- arbitrary
        nodes <- arbitrarySmallerVec
        requestedFiles <- arbitrarySmallerVec
        sourceInfo <- arbitrarySmallerVec
        pure CodeGeneratorRequest{..}

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

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

instance Arbitrary a => Arbitrary (PU.Slice a) where
    shrink = genericShrink
    arbitrary = PU.Slice <$> arbitrarySmallerVec

arbitrarySmallerVec :: Arbitrary a => Gen (V.Vector a)
arbitrarySmallerVec = sized $ \size -> do
    -- Make sure the elements are scaled down relative to
    -- the size of the vector:
    vec <- arbitrary :: Gen (V.Vector ())
    let gen = resize (size `div` V.length vec) arbitrary
    traverse (const gen) vec

instance Arbitrary PU.Struct where
    shrink = genericShrink
    arbitrary = sized $ \_ -> PU.Struct
        <$> arbitrary
        <*> arbitrary

instance Arbitrary PU.List where
    shrink = genericShrink
    arbitrary = oneof
        [ PU.List0 <$> arbitrarySmallerVec
        , PU.List1 <$> arbitrarySmallerVec
        , PU.List8 <$> arbitrarySmallerVec
        , PU.List16 <$> arbitrarySmallerVec
        , PU.List32 <$> arbitrarySmallerVec
        , PU.List64 <$> arbitrarySmallerVec
        , PU.ListPtr <$> arbitrarySmallerVec
        , PU.ListStruct <$> arbitrarySmallerVec
        ]

instance Arbitrary PU.Ptr where
    shrink (PU.PtrStruct s) = PU.PtrStruct <$> shrink s
    shrink (PU.PtrList   l) = PU.PtrList   <$> shrink l
    shrink (PU.PtrCap    _) = []
    arbitrary = oneof
        [ PU.PtrStruct <$> arbitrary
        , PU.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.
        ]