{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}

-- |
-- Module: Covenant.Test
-- Copyright: (C) MLabs 2025
-- License: Apache 2.0
-- Maintainer: koz@mlabs.city, sean@mlabs.city
--
-- Various utilities designed to help test Covenant.
--
-- = Note
--
-- This is probably not that useful to end users of Covenant, but needs to be
-- exposed so the tests can use this functionality.
--
-- @since 1.0.0
module Covenant.Test
  ( -- * QuickCheck data wrappers
    Concrete (Concrete),
    DataDeclFlavor (ConcreteDecl, ConcreteNestedDecl, SimpleRecursive, Poly1, Poly1PolyThunks),
    DataDeclSet (DataDeclSet),

    -- * Functions

    -- ** Lifted QuickCheck functions
    chooseInt,
    scale,

    -- ** 'DataDeclSet' functionality
    prettyDeclSet,

    -- ** Test helpers
    checkApp,
    failLeft,
    tyAppTestDatatypes,
    list,
    tree,
    weirderList,
    unsafeTyCon,

    -- ** Datatype checks
    cycleCheck,
    checkDataDecls,
    checkEncodingArgs,

    -- ** Renaming

    -- *** Types
    RenameError (..),
    RenameM,

    -- *** Introduction
    renameValT,
    renameCompT,
    renameDataDecl,

    -- *** Elimination
    runRenameM,
    undoRename,

    -- ** ASG
    DebugASGBuilder (..),
    debugASGBuilder,
    typeIdTest,
  )
where

#if __GLASGOW_HASKELL__==908
import Data.Foldable (foldl')
#endif
import Control.Applicative ((<|>))
import Control.Monad (void)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.HashCons (HashConsT, MonadHashCons, runHashConsT)
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
import Control.Monad.State.Strict
  ( MonadState (get, put),
    State,
    evalState,
    gets,
    modify,
  )
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Covenant.ASG (ASGEnv (ASGEnv), ASGNode, CovenantError (TypeError), CovenantTypeError, Id, ScopeInfo (ScopeInfo))
import Covenant.Data
  ( DatatypeInfo,
    mkDatatypeInfo,
    noPhantomTyVars,
  )
import Covenant.DeBruijn (DeBruijn (Z), asInt)
import Covenant.Index
  ( Count,
    count0,
    count1,
    count2,
    intCount,
    intIndex,
    ix0,
    ix1,
  )
import Covenant.Internal.KindCheck
  ( checkDataDecls,
    checkEncodingArgs,
    cycleCheck,
  )
import Covenant.Internal.Ledger
  ( CtorBuilder (Ctor),
    DeclBuilder (Decl),
    list,
    maybeT,
    mkDecl,
    pair,
    tree,
    weirderList,
  )
import Covenant.Internal.PrettyPrint (ScopeBoundary)
import Covenant.Internal.Rename
  ( RenameError (InvalidAbstractionReference, InvalidScopeReference),
    RenameM,
    renameCompT,
    renameDataDecl,
    renameValT,
    runRenameM,
    undoRename,
  )
import Covenant.Internal.Strategy
  ( DataEncoding (PlutusData, SOP),
    PlutusDataStrategy (ConstrData),
  )
import Covenant.Internal.Term (ASGNodeType (CompNodeType, ValNodeType), typeId)
import Covenant.Internal.Type
  ( AbstractTy (BoundAt),
    BuiltinFlatT
      ( BLS12_381_G1_ElementT,
        BLS12_381_G2_ElementT,
        BLS12_381_MlResultT,
        BoolT,
        ByteStringT,
        IntegerT,
        StringT,
        UnitT
      ),
    Constructor (Constructor),
    ConstructorName (ConstructorName),
    DataDeclaration (DataDeclaration, OpaqueData),
    TyName (TyName),
    ValT (Abstraction, BuiltinFlat, Datatype, ThunkT),
    runConstructorName,
  )
import Covenant.Internal.Unification (checkApp)
import Covenant.Type
  ( CompT (Comp0, CompN),
    CompTBody (ArgsAndResult),
  )
import Covenant.Util (prettyStr)
import Data.Coerce (coerce)
import Data.Functor.Identity (Identity (runIdentity))
import Data.Kind (Type)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Maybe (fromJust, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import GHC.Exts (fromListN)
import GHC.Word (Word32)
import Optics.Core
  ( A_Lens,
    LabelOptic (labelOptic),
    folded,
    lens,
    over,
    preview,
    review,
    set,
    toListOf,
    view,
    (%),
  )
import Test.QuickCheck
  ( Arbitrary (arbitrary, shrink),
    Arbitrary1 (liftArbitrary, liftShrink),
    Gen,
    elements,
    frequency,
    sized,
    suchThat,
    vectorOf,
  )
import Test.QuickCheck qualified as QC (chooseInt)
import Test.QuickCheck.GenT (GenT, MonadGen)
import Test.QuickCheck.GenT qualified as GT
import Test.QuickCheck.Instances.Containers ()
import Test.QuickCheck.Instances.Vector ()
import Test.Tasty.HUnit (assertFailure)

-- | Wrapper for 'ValT' to provide an 'Arbitrary' instance to generate only
-- value types without any type variables.
--
-- @since 1.0.0
newtype Concrete = Concrete (ValT AbstractTy)
  deriving
    ( -- | @since 1.0.0
      Concrete -> Concrete -> Bool
(Concrete -> Concrete -> Bool)
-> (Concrete -> Concrete -> Bool) -> Eq Concrete
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Concrete -> Concrete -> Bool
== :: Concrete -> Concrete -> Bool
$c/= :: Concrete -> Concrete -> Bool
/= :: Concrete -> Concrete -> Bool
Eq
    )
    via (ValT AbstractTy)
  deriving stock
    ( -- | @since 1.0.0
      Int -> Concrete -> ShowS
[Concrete] -> ShowS
Concrete -> [Char]
(Int -> Concrete -> ShowS)
-> (Concrete -> [Char]) -> ([Concrete] -> ShowS) -> Show Concrete
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Concrete -> ShowS
showsPrec :: Int -> Concrete -> ShowS
$cshow :: Concrete -> [Char]
show :: Concrete -> [Char]
$cshowList :: [Concrete] -> ShowS
showList :: [Concrete] -> ShowS
Show
    )

-- | @since 1.0.0
instance Arbitrary Concrete where
  {-# INLINEABLE arbitrary #-}
  arbitrary :: Gen Concrete
arbitrary = ValT AbstractTy -> Concrete
Concrete (ValT AbstractTy -> Concrete)
-> Gen (ValT AbstractTy) -> Gen Concrete
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Gen (ValT AbstractTy)) -> Gen (ValT AbstractTy)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (ValT AbstractTy)
go
    where
      go :: Int -> Gen (ValT AbstractTy)
      go :: Int -> Gen (ValT AbstractTy)
go Int
size
        | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
            BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat
              (BuiltinFlatT -> ValT AbstractTy)
-> Gen BuiltinFlatT -> Gen (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuiltinFlatT] -> Gen BuiltinFlatT
forall a. HasCallStack => [a] -> Gen a
elements
                [ BuiltinFlatT
UnitT,
                  BuiltinFlatT
BoolT,
                  BuiltinFlatT
IntegerT,
                  BuiltinFlatT
StringT,
                  BuiltinFlatT
ByteStringT,
                  BuiltinFlatT
BLS12_381_G1_ElementT,
                  BuiltinFlatT
BLS12_381_G2_ElementT,
                  BuiltinFlatT
BLS12_381_MlResultT
                ]
        | Bool
otherwise =
            [(Int, Gen (ValT AbstractTy))] -> Gen (ValT AbstractTy)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
              [ (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
UnitT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
BoolT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
IntegerT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
StringT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
ByteStringT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
BLS12_381_G1_ElementT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
BLS12_381_G2_ElementT),
                (Int
10, ValT AbstractTy -> Gen (ValT AbstractTy)
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> Gen (ValT AbstractTy))
-> (BuiltinFlatT -> ValT AbstractTy)
-> BuiltinFlatT
-> Gen (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinFlatT -> ValT AbstractTy
forall a. BuiltinFlatT -> ValT a
BuiltinFlat (BuiltinFlatT -> Gen (ValT AbstractTy))
-> BuiltinFlatT -> Gen (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ BuiltinFlatT
BLS12_381_MlResultT),
                (Int
2, CompT AbstractTy -> ValT AbstractTy
forall a. CompT a -> ValT a
ThunkT (CompT AbstractTy -> ValT AbstractTy)
-> (CompTBody AbstractTy -> CompT AbstractTy)
-> CompTBody AbstractTy
-> ValT AbstractTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompTBody AbstractTy -> CompT AbstractTy
forall a. CompTBody a -> CompT a
Comp0 (CompTBody AbstractTy -> ValT AbstractTy)
-> Gen (CompTBody AbstractTy) -> Gen (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (ValT AbstractTy) -> ValT AbstractTy -> CompTBody AbstractTy
forall a. Vector (ValT a) -> ValT a -> CompTBody a
ArgsAndResult (Vector (ValT AbstractTy)
 -> ValT AbstractTy -> CompTBody AbstractTy)
-> Gen (Vector (ValT AbstractTy))
-> Gen (ValT AbstractTy -> CompTBody AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ValT AbstractTy) -> Gen (Vector (ValT AbstractTy))
forall a. Gen a -> Gen (Vector a)
forall (f :: Type -> Type) a. Arbitrary1 f => Gen a -> Gen (f a)
liftArbitrary (Int -> Gen (ValT AbstractTy)
go (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
4)) Gen (ValT AbstractTy -> CompTBody AbstractTy)
-> Gen (ValT AbstractTy) -> Gen (CompTBody AbstractTy)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> Gen (ValT AbstractTy)
go (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
4)))
              ]
  {-# INLINEABLE shrink #-}
  shrink :: Concrete -> [Concrete]
shrink (Concrete ValT AbstractTy
v) =
    ValT AbstractTy -> Concrete
Concrete (ValT AbstractTy -> Concrete) -> [ValT AbstractTy] -> [Concrete]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case ValT AbstractTy
v of
      -- impossible
      Abstraction AbstractTy
_ -> []
      ThunkT (CompN Count "tyvar"
_ (ArgsAndResult Vector (ValT AbstractTy)
args ValT AbstractTy
result)) ->
        CompT AbstractTy -> ValT AbstractTy
forall a. CompT a -> ValT a
ThunkT (CompT AbstractTy -> ValT AbstractTy)
-> (CompTBody AbstractTy -> CompT AbstractTy)
-> CompTBody AbstractTy
-> ValT AbstractTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Count "tyvar" -> CompTBody AbstractTy -> CompT AbstractTy
CompN Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 (CompTBody AbstractTy -> ValT AbstractTy)
-> [CompTBody AbstractTy] -> [ValT AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          let argsList :: [ValT AbstractTy]
argsList = Vector (ValT AbstractTy) -> [ValT AbstractTy]
forall a. Vector a -> [a]
Vector.toList Vector (ValT AbstractTy)
args
          [ValT AbstractTy]
argsList' <- ([Concrete] -> [ValT AbstractTy])
-> [[Concrete]] -> [[ValT AbstractTy]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Concrete] -> [ValT AbstractTy]
forall a b. Coercible a b => a -> b
coerce ([[Concrete]] -> [[ValT AbstractTy]])
-> ([ValT AbstractTy] -> [[Concrete]])
-> [ValT AbstractTy]
-> [[ValT AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Concrete] -> [[Concrete]]
forall a. Arbitrary a => a -> [a]
shrink ([Concrete] -> [[Concrete]])
-> ([ValT AbstractTy] -> [Concrete])
-> [ValT AbstractTy]
-> [[Concrete]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValT AbstractTy -> Concrete) -> [ValT AbstractTy] -> [Concrete]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ValT AbstractTy -> Concrete
Concrete ([ValT AbstractTy] -> [[ValT AbstractTy]])
-> [ValT AbstractTy] -> [[ValT AbstractTy]]
forall a b. (a -> b) -> a -> b
$ [ValT AbstractTy]
argsList
          ValT AbstractTy
result' <- (Concrete -> ValT AbstractTy) -> [Concrete] -> [ValT AbstractTy]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce ([Concrete] -> [ValT AbstractTy])
-> (ValT AbstractTy -> [Concrete])
-> ValT AbstractTy
-> [ValT AbstractTy]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Concrete -> [Concrete]
forall a. Arbitrary a => a -> [a]
shrink (Concrete -> [Concrete])
-> (ValT AbstractTy -> Concrete) -> ValT AbstractTy -> [Concrete]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValT AbstractTy -> Concrete
Concrete (ValT AbstractTy -> [ValT AbstractTy])
-> ValT AbstractTy -> [ValT AbstractTy]
forall a b. (a -> b) -> a -> b
$ ValT AbstractTy
result
          let args' :: Vector (ValT AbstractTy)
args' = [ValT AbstractTy] -> Vector (ValT AbstractTy)
forall a. [a] -> Vector a
Vector.fromList [ValT AbstractTy]
argsList'
          CompTBody AbstractTy -> [CompTBody AbstractTy]
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Vector (ValT AbstractTy) -> ValT AbstractTy -> CompTBody AbstractTy
forall a. Vector (ValT a) -> ValT a -> CompTBody a
ArgsAndResult Vector (ValT AbstractTy)
args' ValT AbstractTy
result) [CompTBody AbstractTy]
-> [CompTBody AbstractTy] -> [CompTBody AbstractTy]
forall a. [a] -> [a] -> [a]
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> CompTBody AbstractTy -> [CompTBody AbstractTy]
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Vector (ValT AbstractTy) -> ValT AbstractTy -> CompTBody AbstractTy
forall a. Vector (ValT a) -> ValT a -> CompTBody a
ArgsAndResult Vector (ValT AbstractTy)
args ValT AbstractTy
result')
      -- Can't shrink this
      BuiltinFlat BuiltinFlatT
_ -> []
      Datatype TyName
tn Vector (ValT AbstractTy)
args ->
        TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
tn (Vector (ValT AbstractTy) -> ValT AbstractTy)
-> [Vector (ValT AbstractTy)] -> [ValT AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          let argsList :: [ValT AbstractTy]
argsList = Vector (ValT AbstractTy) -> [ValT AbstractTy]
forall a. Vector a -> [a]
Vector.toList Vector (ValT AbstractTy)
args
          (([Concrete] -> Vector (ValT AbstractTy))
-> [[Concrete]] -> [Vector (ValT AbstractTy)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ValT AbstractTy] -> Vector (ValT AbstractTy)
forall a. [a] -> Vector a
Vector.fromList ([ValT AbstractTy] -> Vector (ValT AbstractTy))
-> ([Concrete] -> [ValT AbstractTy])
-> [Concrete]
-> Vector (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Concrete] -> [ValT AbstractTy]
forall a b. Coercible a b => a -> b
coerce) ([[Concrete]] -> [Vector (ValT AbstractTy)])
-> ([ValT AbstractTy] -> [[Concrete]])
-> [ValT AbstractTy]
-> [Vector (ValT AbstractTy)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Concrete] -> [[Concrete]]
forall a. Arbitrary a => a -> [a]
shrink ([Concrete] -> [[Concrete]])
-> ([ValT AbstractTy] -> [Concrete])
-> [ValT AbstractTy]
-> [[Concrete]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValT AbstractTy -> Concrete) -> [ValT AbstractTy] -> [Concrete]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ValT AbstractTy -> Concrete
Concrete) [ValT AbstractTy]
argsList

-- | A \'description type\' designed for use with 'DataDeclSet' to describe what
-- kind of types it contains.
--
-- @since 1.1.0
data DataDeclFlavor
  = -- | All constructor arguments are concrete and the declaration is monomorphic.
    --
    -- @since 1.1.0
    ConcreteDecl
  | -- | As 'ConcreteDecl', but can re-use already generated concrete declarations
    -- in the context to make nested types.
    --
    -- @since 1.1.0
    ConcreteNestedDecl
  | -- | Recursive, monomorphic type (such as @data IntList = End | More Int IntList@).
    --
    -- @since 1.1.0
    SimpleRecursive
  | -- | Polymorphic types in one variable, which may or may not be recursive.
    --
    -- @since 1.1.0
    Poly1
  | -- | As 'Poly1', but may have further polymorphism via thunks.
    --
    -- @since 1.1.0
    Poly1PolyThunks

-- | Helper type to generate datatype definitions. Specifically, this stores
-- already-generated datatype declarations for our (re)use when generating.
--
-- @since 1.1.0
newtype DataDeclSet (flavor :: DataDeclFlavor) = DataDeclSet [DataDeclaration AbstractTy]

-- @since 1.1.0
instance Arbitrary (DataDeclSet 'ConcreteDecl) where
  arbitrary :: Gen (DataDeclSet 'ConcreteDecl)
arbitrary = Gen [ConcreteDataDecl] -> Gen (DataDeclSet 'ConcreteDecl)
forall a b. Coercible a b => a -> b
coerce (Gen [ConcreteDataDecl] -> Gen (DataDeclSet 'ConcreteDecl))
-> Gen [ConcreteDataDecl] -> Gen (DataDeclSet 'ConcreteDecl)
forall a b. (a -> b) -> a -> b
$ DataGenM ConcreteDataDecl -> Gen [ConcreteDataDecl]
forall a. DataGenM a -> Gen [a]
genDataList DataGenM ConcreteDataDecl
genConcreteDataDecl
  shrink :: DataDeclSet 'ConcreteDecl -> [DataDeclSet 'ConcreteDecl]
shrink = [[DataDeclaration AbstractTy]] -> [DataDeclSet 'ConcreteDecl]
forall a b. Coercible a b => a -> b
coerce ([[DataDeclaration AbstractTy]] -> [DataDeclSet 'ConcreteDecl])
-> (DataDeclSet 'ConcreteDecl -> [[DataDeclaration AbstractTy]])
-> DataDeclSet 'ConcreteDecl
-> [DataDeclSet 'ConcreteDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls ([DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]])
-> (DataDeclSet 'ConcreteDecl -> [DataDeclaration AbstractTy])
-> DataDeclSet 'ConcreteDecl
-> [[DataDeclaration AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclSet 'ConcreteDecl -> [DataDeclaration AbstractTy]
forall a b. Coercible a b => a -> b
coerce

-- @since 1.1.0
instance Arbitrary (DataDeclSet 'ConcreteNestedDecl) where
  arbitrary :: Gen (DataDeclSet 'ConcreteNestedDecl)
arbitrary = Gen [NestedConcreteDataDecl]
-> Gen (DataDeclSet 'ConcreteNestedDecl)
forall a b. Coercible a b => a -> b
coerce (Gen [NestedConcreteDataDecl]
 -> Gen (DataDeclSet 'ConcreteNestedDecl))
-> Gen [NestedConcreteDataDecl]
-> Gen (DataDeclSet 'ConcreteNestedDecl)
forall a b. (a -> b) -> a -> b
$ DataGenM NestedConcreteDataDecl -> Gen [NestedConcreteDataDecl]
forall a. DataGenM a -> Gen [a]
genDataList DataGenM NestedConcreteDataDecl
genNestedConcrete
  shrink :: DataDeclSet 'ConcreteNestedDecl
-> [DataDeclSet 'ConcreteNestedDecl]
shrink = [[DataDeclaration AbstractTy]] -> [DataDeclSet 'ConcreteNestedDecl]
forall a b. Coercible a b => a -> b
coerce ([[DataDeclaration AbstractTy]]
 -> [DataDeclSet 'ConcreteNestedDecl])
-> (DataDeclSet 'ConcreteNestedDecl
    -> [[DataDeclaration AbstractTy]])
-> DataDeclSet 'ConcreteNestedDecl
-> [DataDeclSet 'ConcreteNestedDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls ([DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]])
-> (DataDeclSet 'ConcreteNestedDecl
    -> [DataDeclaration AbstractTy])
-> DataDeclSet 'ConcreteNestedDecl
-> [[DataDeclaration AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclSet 'ConcreteNestedDecl -> [DataDeclaration AbstractTy]
forall a b. Coercible a b => a -> b
coerce

-- @since 1.1.0
instance Arbitrary (DataDeclSet 'SimpleRecursive) where
  arbitrary :: Gen (DataDeclSet 'SimpleRecursive)
arbitrary = Gen [RecursiveConcreteDataDecl]
-> Gen (DataDeclSet 'SimpleRecursive)
forall a b. Coercible a b => a -> b
coerce (Gen [RecursiveConcreteDataDecl]
 -> Gen (DataDeclSet 'SimpleRecursive))
-> Gen [RecursiveConcreteDataDecl]
-> Gen (DataDeclSet 'SimpleRecursive)
forall a b. (a -> b) -> a -> b
$ DataGenM RecursiveConcreteDataDecl
-> Gen [RecursiveConcreteDataDecl]
forall a. DataGenM a -> Gen [a]
genDataList DataGenM RecursiveConcreteDataDecl
genArbitraryRecursive
  shrink :: DataDeclSet 'SimpleRecursive -> [DataDeclSet 'SimpleRecursive]
shrink = [[DataDeclaration AbstractTy]] -> [DataDeclSet 'SimpleRecursive]
forall a b. Coercible a b => a -> b
coerce ([[DataDeclaration AbstractTy]] -> [DataDeclSet 'SimpleRecursive])
-> (DataDeclSet 'SimpleRecursive -> [[DataDeclaration AbstractTy]])
-> DataDeclSet 'SimpleRecursive
-> [DataDeclSet 'SimpleRecursive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls ([DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]])
-> (DataDeclSet 'SimpleRecursive -> [DataDeclaration AbstractTy])
-> DataDeclSet 'SimpleRecursive
-> [[DataDeclaration AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclSet 'SimpleRecursive -> [DataDeclaration AbstractTy]
forall a b. Coercible a b => a -> b
coerce

-- @since 1.1.0
instance Arbitrary (DataDeclSet 'Poly1) where
  arbitrary :: Gen (DataDeclSet 'Poly1)
arbitrary = Gen [Polymorphic1] -> Gen (DataDeclSet 'Poly1)
forall a b. Coercible a b => a -> b
coerce (Gen [Polymorphic1] -> Gen (DataDeclSet 'Poly1))
-> Gen [Polymorphic1] -> Gen (DataDeclSet 'Poly1)
forall a b. (a -> b) -> a -> b
$ DataGenM Polymorphic1 -> Gen [Polymorphic1]
forall a. DataGenM a -> Gen [a]
genDataList DataGenM Polymorphic1
genPolymorphic1Decl
  shrink :: DataDeclSet 'Poly1 -> [DataDeclSet 'Poly1]
shrink = [[DataDeclaration AbstractTy]] -> [DataDeclSet 'Poly1]
forall a b. Coercible a b => a -> b
coerce ([[DataDeclaration AbstractTy]] -> [DataDeclSet 'Poly1])
-> (DataDeclSet 'Poly1 -> [[DataDeclaration AbstractTy]])
-> DataDeclSet 'Poly1
-> [DataDeclSet 'Poly1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls ([DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]])
-> (DataDeclSet 'Poly1 -> [DataDeclaration AbstractTy])
-> DataDeclSet 'Poly1
-> [[DataDeclaration AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclSet 'Poly1 -> [DataDeclaration AbstractTy]
forall a b. Coercible a b => a -> b
coerce

instance Arbitrary (DataDeclSet 'Poly1PolyThunks) where
  arbitrary :: Gen (DataDeclSet 'Poly1PolyThunks)
arbitrary = Gen [DataDeclaration AbstractTy]
-> Gen (DataDeclSet 'Poly1PolyThunks)
forall a b. Coercible a b => a -> b
coerce (Gen [DataDeclaration AbstractTy]
 -> Gen (DataDeclSet 'Poly1PolyThunks))
-> (DataGenM [DataDeclaration AbstractTy]
    -> Gen [DataDeclaration AbstractTy])
-> DataGenM [DataDeclaration AbstractTy]
-> Gen (DataDeclSet 'Poly1PolyThunks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataGenM [DataDeclaration AbstractTy]
-> Gen [DataDeclaration AbstractTy]
forall a. DataGenM a -> Gen a
runDataGenM (DataGenM [DataDeclaration AbstractTy]
 -> Gen (DataDeclSet 'Poly1PolyThunks))
-> DataGenM [DataDeclaration AbstractTy]
-> Gen (DataDeclSet 'Poly1PolyThunks)
forall a b. (a -> b) -> a -> b
$ do
    -- If we don't have this we can't generate ctor args of the sort we want here.
    -- I *think* we're very unlikely to get 10 unsuitable decls out of this
    DataGenM [Polymorphic1] -> DataGenM ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (DataGenM [Polymorphic1] -> DataGenM ())
-> DataGenM [Polymorphic1] -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Int -> DataGenM Polymorphic1 -> DataGenM [Polymorphic1]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
10 DataGenM Polymorphic1
genPolymorphic1Decl
    DataGenM [DataDeclaration AbstractTy] -> DataGenM ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (DataGenM [DataDeclaration AbstractTy] -> DataGenM ())
-> DataGenM [DataDeclaration AbstractTy] -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ DataGenM (DataDeclaration AbstractTy)
-> DataGenM [DataDeclaration AbstractTy]
forall (m :: Type -> Type) a. MonadGen m => m a -> m [a]
GT.listOf DataGenM (DataDeclaration AbstractTy)
genNonConcreteDecl
    [DataDeclaration AbstractTy]
decls <- Map TyName (DataDeclaration AbstractTy)
-> [DataDeclaration AbstractTy]
forall k a. Map k a -> [a]
M.elems (Map TyName (DataDeclaration AbstractTy)
 -> [DataDeclaration AbstractTy])
-> DataGenM (Map TyName (DataDeclaration AbstractTy))
-> DataGenM [DataDeclaration AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataGen -> Map TyName (DataDeclaration AbstractTy))
-> DataGenM (Map TyName (DataDeclaration AbstractTy))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> DataGen -> Map TyName (DataDeclaration AbstractTy)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls) -- simpler to just pluck them from the monadic context
    [DataDeclaration AbstractTy]
-> DataGenM [DataDeclaration AbstractTy]
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([DataDeclaration AbstractTy]
 -> DataGenM [DataDeclaration AbstractTy])
-> [DataDeclaration AbstractTy]
-> DataGenM [DataDeclaration AbstractTy]
forall a b. (a -> b) -> a -> b
$ (DataDeclaration AbstractTy -> Bool)
-> [DataDeclaration AbstractTy] -> [DataDeclaration AbstractTy]
forall a. (a -> Bool) -> [a] -> [a]
filter DataDeclaration AbstractTy -> Bool
noPhantomTyVars [DataDeclaration AbstractTy]
decls -- TODO/FIXME: We shouldn't have to filter here, better to catch things earlier
  shrink :: DataDeclSet 'Poly1PolyThunks -> [DataDeclSet 'Poly1PolyThunks]
shrink = [[DataDeclaration AbstractTy]] -> [DataDeclSet 'Poly1PolyThunks]
forall a b. Coercible a b => a -> b
coerce ([[DataDeclaration AbstractTy]] -> [DataDeclSet 'Poly1PolyThunks])
-> (DataDeclSet 'Poly1PolyThunks -> [[DataDeclaration AbstractTy]])
-> DataDeclSet 'Poly1PolyThunks
-> [DataDeclSet 'Poly1PolyThunks]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls ([DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]])
-> (DataDeclSet 'Poly1PolyThunks -> [DataDeclaration AbstractTy])
-> DataDeclSet 'Poly1PolyThunks
-> [[DataDeclaration AbstractTy]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclSet 'Poly1PolyThunks -> [DataDeclaration AbstractTy]
forall a b. Coercible a b => a -> b
coerce

-- | Prettyprinter for 'DataDeclSet'.
--
-- @since 1.1.0
prettyDeclSet :: forall (a :: DataDeclFlavor). DataDeclSet a -> String
prettyDeclSet :: forall (a :: DataDeclFlavor). DataDeclSet a -> [Char]
prettyDeclSet (DataDeclSet [DataDeclaration AbstractTy]
decls) =
  (DataDeclaration AbstractTy -> [Char])
-> [DataDeclaration AbstractTy] -> [Char]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (\DataDeclaration AbstractTy
x -> (DataDeclaration Renamed -> [Char]
forall a. Pretty a => a -> [Char]
prettyStr (DataDeclaration Renamed -> [Char])
-> (DataDeclaration AbstractTy -> DataDeclaration Renamed)
-> DataDeclaration AbstractTy
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenameM (DataDeclaration Renamed) -> DataDeclaration Renamed
forall a. RenameM a -> a
unsafeRename (RenameM (DataDeclaration Renamed) -> DataDeclaration Renamed)
-> (DataDeclaration AbstractTy
    -> RenameM (DataDeclaration Renamed))
-> DataDeclaration AbstractTy
-> DataDeclaration Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataDeclaration AbstractTy -> RenameM (DataDeclaration Renamed)
renameDataDecl (DataDeclaration AbstractTy -> [Char])
-> DataDeclaration AbstractTy -> [Char]
forall a b. (a -> b) -> a -> b
$ DataDeclaration AbstractTy
x) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n\n") [DataDeclaration AbstractTy]
decls

-- | The same as 'QC.chooseInt', but lifted to work in any 'MonadGen'.
--
-- @since 1.1.0
chooseInt ::
  forall (m :: Type -> Type).
  (MonadGen m) =>
  (Int, Int) ->
  m Int
chooseInt :: forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int, Int)
bounds = Gen Int -> m Int
forall a. Gen a -> m a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen Int -> m Int) -> Gen Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
QC.chooseInt (Int, Int)
bounds

-- | The same as 'QC.scale', but lifted to work in any 'MonadGen'.
--
-- @since 1.1.0
scale ::
  forall (m :: Type -> Type) (a :: Type).
  (MonadGen m) =>
  (Int -> Int) ->
  m a ->
  m a
scale :: forall (m :: Type -> Type) a.
MonadGen m =>
(Int -> Int) -> m a -> m a
scale Int -> Int
f m a
g = (Int -> m a) -> m a
forall a. (Int -> m a) -> m a
forall (g :: Type -> Type) a. MonadGen g => (Int -> g a) -> g a
GT.sized (\Int
n -> Int -> m a -> m a
forall a. Int -> m a -> m a
forall (g :: Type -> Type) a. MonadGen g => Int -> g a -> g a
GT.resize (Int -> Int
f Int
n) m a
g)

-- | If the argument is a 'Right', pass the assertion; otherwise, fail the
-- assertion.
--
-- @since 1.1.0
failLeft ::
  forall (a :: Type) (b :: Type).
  (Show a) =>
  Either a b ->
  IO b
failLeft :: forall a b. Show a => Either a b -> IO b
failLeft = (a -> IO b) -> (b -> IO b) -> Either a b -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> IO b
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> IO b) -> (a -> [Char]) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show) b -> IO b
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

-- | Small collection of datatypes needed to test type application logic.
--
-- @since 1.1.0
tyAppTestDatatypes :: M.Map TyName (DatatypeInfo AbstractTy)
tyAppTestDatatypes :: Map TyName (DatatypeInfo AbstractTy)
tyAppTestDatatypes =
  (Map TyName (DatatypeInfo AbstractTy)
 -> DataDeclaration AbstractTy
 -> Map TyName (DatatypeInfo AbstractTy))
-> Map TyName (DatatypeInfo AbstractTy)
-> [DataDeclaration AbstractTy]
-> Map TyName (DatatypeInfo AbstractTy)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map TyName (DatatypeInfo AbstractTy)
acc DataDeclaration AbstractTy
decl -> TyName
-> DatatypeInfo AbstractTy
-> Map TyName (DatatypeInfo AbstractTy)
-> Map TyName (DatatypeInfo AbstractTy)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Optic' A_Lens NoIx (DataDeclaration AbstractTy) TyName
-> DataDeclaration AbstractTy -> TyName
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (DataDeclaration AbstractTy) TyName
#datatypeName DataDeclaration AbstractTy
decl) (DataDeclaration AbstractTy -> DatatypeInfo AbstractTy
unsafeMkDatatypeInfo DataDeclaration AbstractTy
decl) Map TyName (DatatypeInfo AbstractTy)
acc) Map TyName (DatatypeInfo AbstractTy)
forall k a. Map k a
M.empty [DataDeclaration AbstractTy]
testDatatypes
  where
    unsafeMkDatatypeInfo :: DataDeclaration AbstractTy -> DatatypeInfo AbstractTy
unsafeMkDatatypeInfo DataDeclaration AbstractTy
d = case DataDeclaration AbstractTy
-> Either BBFError (DatatypeInfo AbstractTy)
mkDatatypeInfo DataDeclaration AbstractTy
d of
      Left BBFError
err -> [Char] -> DatatypeInfo AbstractTy
forall a. HasCallStack => [Char] -> a
error (BBFError -> [Char]
forall a. Show a => a -> [Char]
show BBFError
err)
      Right DatatypeInfo AbstractTy
res -> DatatypeInfo AbstractTy
res

-- | Helper for tests to quickly construct 'Datatype's. This is unsafe, as it
-- allows construction of nonsensical renamings.
--
-- @since 1.1.0
unsafeTyCon :: TyName -> [ValT a] -> ValT a
unsafeTyCon :: forall a. TyName -> [ValT a] -> ValT a
unsafeTyCon TyName
tn [ValT a]
args = TyName -> Vector (ValT a) -> ValT a
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
tn ([ValT a] -> Vector (ValT a)
forall a. [a] -> Vector a
Vector.fromList [ValT a]
args)

-- Helpers

{- The state used by our datatype generators.
-}
data DataGen = DataGen
  { -- Keeps track of decls we've already generated. Used for "nested" generators and also essential for ValT generation (when we get around to implementing it)
    DataGen -> Map TyName (DataDeclaration AbstractTy)
_dgDecls :: Map TyName (DataDeclaration AbstractTy),
    -- All used constructor names. Have to track separately, even though the information eventually ends up in the previous field, to avoid duplicate constructors in the same type.
    DataGen -> Set ConstructorName
_dgCtors :: Set ConstructorName,
    -- Current scope. Needed for generating polymorphic `ValT`s for arguments to constructors . (That's not implemented yet but we 100% will need this )
    DataGen -> ScopeBoundary
_dgCurrentScope :: ScopeBoundary,
    -- NOTE: Needs to maintain the invariant that the Word32 is always >0, since we will use this to select in scope variables for polymorphic args to ctors. (Again, not implemented yet)
    DataGen -> Map ScopeBoundary Word32
_dgBoundVars :: Map ScopeBoundary Word32,
    -- We need this for recursive types. We can't lookup the arity in dgDecls if we want to recurse b/c it won't be there until we've finished generating the whole decl
    DataGen -> Map TyName (Count "tyvar")
_dgArities :: Map TyName (Count "tyvar")
  }

instance
  (k ~ A_Lens, a ~ Map TyName (DataDeclaration AbstractTy), b ~ Map TyName (DataDeclaration AbstractTy)) =>
  LabelOptic "decls" k DataGen DataGen a b
  where
  {-# INLINEABLE labelOptic #-}
  labelOptic :: Optic k NoIx DataGen DataGen a b
labelOptic = (DataGen -> a)
-> (DataGen -> b -> DataGen) -> Lens DataGen DataGen a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
_ ScopeBoundary
_ Map ScopeBoundary Word32
_ Map TyName (Count "tyvar")
_) -> a
Map TyName (DataDeclaration AbstractTy)
a) (\(DataGen Map TyName (DataDeclaration AbstractTy)
_ Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e) b
a -> Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen b
Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e)

instance
  (k ~ A_Lens, a ~ Set ConstructorName, b ~ Set ConstructorName) =>
  LabelOptic "constructors" k DataGen DataGen a b
  where
  {-# INLINEABLE labelOptic #-}
  labelOptic :: Optic k NoIx DataGen DataGen a b
labelOptic = (DataGen -> a)
-> (DataGen -> b -> DataGen) -> Lens DataGen DataGen a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(DataGen Map TyName (DataDeclaration AbstractTy)
_ Set ConstructorName
b ScopeBoundary
_ Map ScopeBoundary Word32
_ Map TyName (Count "tyvar")
_) -> a
Set ConstructorName
b) (\(DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
_ ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e) b
b -> Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen Map TyName (DataDeclaration AbstractTy)
a b
Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e)

instance
  (k ~ A_Lens, a ~ ScopeBoundary, b ~ ScopeBoundary) =>
  LabelOptic "currentScope" k DataGen DataGen a b
  where
  {-# INLINEABLE labelOptic #-}
  labelOptic :: Optic k NoIx DataGen DataGen a b
labelOptic = (DataGen -> a)
-> (DataGen -> b -> DataGen) -> Lens DataGen DataGen a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(DataGen Map TyName (DataDeclaration AbstractTy)
_ Set ConstructorName
_ ScopeBoundary
c Map ScopeBoundary Word32
_ Map TyName (Count "tyvar")
_) -> a
ScopeBoundary
c) (\(DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
_ Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e) b
c -> Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b b
ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e)

instance
  (k ~ A_Lens, a ~ Map ScopeBoundary Word32, b ~ Map ScopeBoundary Word32) =>
  LabelOptic "boundVars" k DataGen DataGen a b
  where
  {-# INLINEABLE labelOptic #-}
  labelOptic :: Optic k NoIx DataGen DataGen a b
labelOptic = (DataGen -> a)
-> (DataGen -> b -> DataGen) -> Lens DataGen DataGen a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(DataGen Map TyName (DataDeclaration AbstractTy)
_ Set ConstructorName
_ ScopeBoundary
_ Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
_) -> a
Map ScopeBoundary Word32
d) (\(DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
_ Map TyName (Count "tyvar")
e) b
d -> Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
c b
Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
e)

instance
  (k ~ A_Lens, a ~ Map TyName (Count "tyvar"), b ~ Map TyName (Count "tyvar")) =>
  LabelOptic "arities" k DataGen DataGen a b
  where
  {-# INLINEABLE labelOptic #-}
  labelOptic :: Optic k NoIx DataGen DataGen a b
labelOptic = (DataGen -> a)
-> (DataGen -> b -> DataGen) -> Lens DataGen DataGen a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(DataGen Map TyName (DataDeclaration AbstractTy)
_ Set ConstructorName
_ ScopeBoundary
_ Map ScopeBoundary Word32
_ Map TyName (Count "tyvar")
e) -> a
Map TyName (Count "tyvar")
e) (\(DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
d Map TyName (Count "tyvar")
_) b
e -> Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen Map TyName (DataDeclaration AbstractTy)
a Set ConstructorName
b ScopeBoundary
c Map ScopeBoundary Word32
d b
Map TyName (Count "tyvar")
e)

{-  Monadic stack for generating monomorphic datatype declarations. Not every generator uses every part of the state, but
    it ought to suffice for generating *any* datatype declaration we choose.

    In theory this could be a reader but it becomes super awkward to work, StateT is easier

    While we don't have any generators for polymorphic `ValT`s yet, the scope stuff will be necessary there.
-}
newtype DataGenM a = DataGenM (GenT (State DataGen) a)
  deriving newtype ((forall a b. (a -> b) -> DataGenM a -> DataGenM b)
-> (forall a b. a -> DataGenM b -> DataGenM a) -> Functor DataGenM
forall a b. a -> DataGenM b -> DataGenM a
forall a b. (a -> b) -> DataGenM a -> DataGenM b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DataGenM a -> DataGenM b
fmap :: forall a b. (a -> b) -> DataGenM a -> DataGenM b
$c<$ :: forall a b. a -> DataGenM b -> DataGenM a
<$ :: forall a b. a -> DataGenM b -> DataGenM a
Functor, Functor DataGenM
Functor DataGenM =>
(forall a. a -> DataGenM a)
-> (forall a b. DataGenM (a -> b) -> DataGenM a -> DataGenM b)
-> (forall a b c.
    (a -> b -> c) -> DataGenM a -> DataGenM b -> DataGenM c)
-> (forall a b. DataGenM a -> DataGenM b -> DataGenM b)
-> (forall a b. DataGenM a -> DataGenM b -> DataGenM a)
-> Applicative DataGenM
forall a. a -> DataGenM a
forall a b. DataGenM a -> DataGenM b -> DataGenM a
forall a b. DataGenM a -> DataGenM b -> DataGenM b
forall a b. DataGenM (a -> b) -> DataGenM a -> DataGenM b
forall a b c.
(a -> b -> c) -> DataGenM a -> DataGenM b -> DataGenM c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> DataGenM a
pure :: forall a. a -> DataGenM a
$c<*> :: forall a b. DataGenM (a -> b) -> DataGenM a -> DataGenM b
<*> :: forall a b. DataGenM (a -> b) -> DataGenM a -> DataGenM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> DataGenM a -> DataGenM b -> DataGenM c
liftA2 :: forall a b c.
(a -> b -> c) -> DataGenM a -> DataGenM b -> DataGenM c
$c*> :: forall a b. DataGenM a -> DataGenM b -> DataGenM b
*> :: forall a b. DataGenM a -> DataGenM b -> DataGenM b
$c<* :: forall a b. DataGenM a -> DataGenM b -> DataGenM a
<* :: forall a b. DataGenM a -> DataGenM b -> DataGenM a
Applicative, Applicative DataGenM
Applicative DataGenM =>
(forall a b. DataGenM a -> (a -> DataGenM b) -> DataGenM b)
-> (forall a b. DataGenM a -> DataGenM b -> DataGenM b)
-> (forall a. a -> DataGenM a)
-> Monad DataGenM
forall a. a -> DataGenM a
forall a b. DataGenM a -> DataGenM b -> DataGenM b
forall a b. DataGenM a -> (a -> DataGenM b) -> DataGenM b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. DataGenM a -> (a -> DataGenM b) -> DataGenM b
>>= :: forall a b. DataGenM a -> (a -> DataGenM b) -> DataGenM b
$c>> :: forall a b. DataGenM a -> DataGenM b -> DataGenM b
>> :: forall a b. DataGenM a -> DataGenM b -> DataGenM b
$creturn :: forall a. a -> DataGenM a
return :: forall a. a -> DataGenM a
Monad)
  deriving (Monad DataGenM
Applicative DataGenM
(Applicative DataGenM, Monad DataGenM) =>
(forall a. Gen a -> DataGenM a)
-> (forall n a. Integral n => n -> DataGenM a -> DataGenM a)
-> (forall a. (Int -> DataGenM a) -> DataGenM a)
-> (forall a. Int -> DataGenM a -> DataGenM a)
-> (forall a. Random a => (a, a) -> DataGenM a)
-> MonadGen DataGenM
forall a. Int -> DataGenM a -> DataGenM a
forall a. Gen a -> DataGenM a
forall a. Random a => (a, a) -> DataGenM a
forall a. (Int -> DataGenM a) -> DataGenM a
forall n a. Integral n => n -> DataGenM a -> DataGenM a
forall (g :: Type -> Type).
(Applicative g, Monad g) =>
(forall a. Gen a -> g a)
-> (forall n a. Integral n => n -> g a -> g a)
-> (forall a. (Int -> g a) -> g a)
-> (forall a. Int -> g a -> g a)
-> (forall a. Random a => (a, a) -> g a)
-> MonadGen g
$cliftGen :: forall a. Gen a -> DataGenM a
liftGen :: forall a. Gen a -> DataGenM a
$cvariant :: forall n a. Integral n => n -> DataGenM a -> DataGenM a
variant :: forall n a. Integral n => n -> DataGenM a -> DataGenM a
$csized :: forall a. (Int -> DataGenM a) -> DataGenM a
sized :: forall a. (Int -> DataGenM a) -> DataGenM a
$cresize :: forall a. Int -> DataGenM a -> DataGenM a
resize :: forall a. Int -> DataGenM a -> DataGenM a
$cchoose :: forall a. Random a => (a, a) -> DataGenM a
choose :: forall a. Random a => (a, a) -> DataGenM a
MonadGen) via GenT (State DataGen)

instance MonadState DataGen DataGenM where
  get :: DataGenM DataGen
get = GenT (State DataGen) DataGen -> DataGenM DataGen
forall a. GenT (State DataGen) a -> DataGenM a
DataGenM (GenT (State DataGen) DataGen -> DataGenM DataGen)
-> GenT (State DataGen) DataGen -> DataGenM DataGen
forall a b. (a -> b) -> a -> b
$ State DataGen DataGen -> GenT (State DataGen) DataGen
forall (m :: Type -> Type) a. Monad m => m a -> GenT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift State DataGen DataGen
forall s (m :: Type -> Type). MonadState s m => m s
get
  put :: DataGen -> DataGenM ()
put = GenT (State DataGen) () -> DataGenM ()
forall a. GenT (State DataGen) a -> DataGenM a
DataGenM (GenT (State DataGen) () -> DataGenM ())
-> (DataGen -> GenT (State DataGen) ()) -> DataGen -> DataGenM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State DataGen () -> GenT (State DataGen) ()
forall (m :: Type -> Type) a. Monad m => m a -> GenT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State DataGen () -> GenT (State DataGen) ())
-> (DataGen -> State DataGen ())
-> DataGen
-> GenT (State DataGen) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataGen -> State DataGen ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put

{- N.B. We don't need this *yet* but we will need it to generate constructors which take polymorphic functions as arguments.
-}
bindVars :: Count "tyvar" -> DataGenM ()
bindVars :: Count "tyvar" -> DataGenM ()
bindVars Count "tyvar"
count'
  | Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DataGenM ()
crossBoundary
  | Bool
otherwise = do
      DataGenM ()
crossBoundary
      ScopeBoundary
here <- (DataGen -> ScopeBoundary) -> DataGenM ScopeBoundary
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
-> DataGen -> ScopeBoundary
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
#currentScope)
      (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map ScopeBoundary Word32)
  (Map ScopeBoundary Word32)
-> (Map ScopeBoundary Word32 -> Map ScopeBoundary Word32)
-> DataGen
-> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map ScopeBoundary Word32)
  (Map ScopeBoundary Word32)
#boundVars (ScopeBoundary
-> Word32 -> Map ScopeBoundary Word32 -> Map ScopeBoundary Word32
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ScopeBoundary
here (Word32 -> Map ScopeBoundary Word32 -> Map ScopeBoundary Word32)
-> Word32 -> Map ScopeBoundary Word32 -> Map ScopeBoundary Word32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count)
  where
    count :: Int
    count :: Int
count = Optic' A_Prism NoIx Int (Count "tyvar") -> Count "tyvar" -> Int
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' A_Prism NoIx Int (Count "tyvar")
forall (ofWhat :: Symbol). Prism' Int (Count ofWhat)
intCount Count "tyvar"
count'

    crossBoundary :: DataGenM ()
    crossBoundary :: DataGenM ()
crossBoundary = (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
-> (ScopeBoundary -> ScopeBoundary) -> DataGen -> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
#currentScope (ScopeBoundary -> ScopeBoundary -> ScopeBoundary
forall a. Num a => a -> a -> a
+ ScopeBoundary
1)

-- performs action in the deeper scope then resets.
withBoundVars :: forall (a :: Type). Count "tyvar" -> DataGenM a -> DataGenM a
withBoundVars :: forall a. Count "tyvar" -> DataGenM a -> DataGenM a
withBoundVars Count "tyvar"
count DataGenM a
act = do
  ScopeBoundary
oldScope <- (DataGen -> ScopeBoundary) -> DataGenM ScopeBoundary
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
-> DataGen -> ScopeBoundary
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
#currentScope)
  Count "tyvar" -> DataGenM ()
bindVars Count "tyvar"
count
  a
res <- DataGenM a
act
  (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
-> ScopeBoundary -> DataGen -> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
#currentScope ScopeBoundary
oldScope
  a -> DataGenM a
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
res

runDataGenM :: forall (a :: Type). DataGenM a -> Gen a
runDataGenM :: forall a. DataGenM a -> Gen a
runDataGenM (DataGenM GenT (State DataGen) a
ma) = (\State DataGen a
x -> State DataGen a -> DataGen -> a
forall s a. State s a -> s -> a
evalState State DataGen a
x (Map TyName (DataDeclaration AbstractTy)
-> Set ConstructorName
-> ScopeBoundary
-> Map ScopeBoundary Word32
-> Map TyName (Count "tyvar")
-> DataGen
DataGen Map TyName (DataDeclaration AbstractTy)
forall k a. Map k a
M.empty Set ConstructorName
forall a. Set a
Set.empty ScopeBoundary
0 Map ScopeBoundary Word32
forall k a. Map k a
M.empty Map TyName (Count "tyvar")
forall k a. Map k a
M.empty)) (State DataGen a -> a) -> Gen (State DataGen a) -> Gen a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT (State DataGen) a -> Gen (State DataGen a)
forall (m :: Type -> Type) a. GenT m a -> Gen (m a)
GT.runGenT GenT (State DataGen) a
ma

-- Stupid helper, saves us from forgetting to update part of the state
returnDecl :: DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl :: DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl od :: DataDeclaration AbstractTy
od@(OpaqueData TyName
tn Set PlutusDataConstructor
_) = (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> (Map TyName (DataDeclaration AbstractTy)
    -> Map TyName (DataDeclaration AbstractTy))
-> DataGen
-> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls (TyName
-> DataDeclaration AbstractTy
-> Map TyName (DataDeclaration AbstractTy)
-> Map TyName (DataDeclaration AbstractTy)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TyName
tn DataDeclaration AbstractTy
od)) DataGenM ()
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM (DataDeclaration AbstractTy)
forall a b. DataGenM a -> DataGenM b -> DataGenM b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DataDeclaration AbstractTy
od
returnDecl decl :: DataDeclaration AbstractTy
decl@(DataDeclaration TyName
tyNm Count "tyvar"
arity Vector (Constructor AbstractTy)
_ DataEncoding
_) = do
  (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> (Map TyName (DataDeclaration AbstractTy)
    -> Map TyName (DataDeclaration AbstractTy))
-> DataGen
-> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls (TyName
-> DataDeclaration AbstractTy
-> Map TyName (DataDeclaration AbstractTy)
-> Map TyName (DataDeclaration AbstractTy)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TyName
tyNm DataDeclaration AbstractTy
decl)
  TyName -> Count "tyvar" -> DataGenM ()
logArity TyName
tyNm Count "tyvar"
arity
  DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DataDeclaration AbstractTy
decl

{- We need this outside of `returnDecl` to construct recursive polymorphic types, i.e. types where an argument to
   a constructor is the parent type applied to the type variables bound at the start of the declaration.
-}
logArity :: TyName -> Count "tyvar" -> DataGenM ()
logArity :: TyName -> Count "tyvar" -> DataGenM ()
logArity TyName
tn Count "tyvar"
cnt = (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
-> (Map TyName (Count "tyvar") -> Map TyName (Count "tyvar"))
-> DataGen
-> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
#arities (TyName
-> Count "tyvar"
-> Map TyName (Count "tyvar")
-> Map TyName (Count "tyvar")
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TyName
tn Count "tyvar"
cnt)

newtype ConcreteDataDecl = ConcreteDataDecl (DataDeclaration AbstractTy)
  deriving (ConcreteDataDecl -> ConcreteDataDecl -> Bool
(ConcreteDataDecl -> ConcreteDataDecl -> Bool)
-> (ConcreteDataDecl -> ConcreteDataDecl -> Bool)
-> Eq ConcreteDataDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConcreteDataDecl -> ConcreteDataDecl -> Bool
== :: ConcreteDataDecl -> ConcreteDataDecl -> Bool
$c/= :: ConcreteDataDecl -> ConcreteDataDecl -> Bool
/= :: ConcreteDataDecl -> ConcreteDataDecl -> Bool
Eq) via (DataDeclaration AbstractTy)
  deriving stock (Int -> ConcreteDataDecl -> ShowS
[ConcreteDataDecl] -> ShowS
ConcreteDataDecl -> [Char]
(Int -> ConcreteDataDecl -> ShowS)
-> (ConcreteDataDecl -> [Char])
-> ([ConcreteDataDecl] -> ShowS)
-> Show ConcreteDataDecl
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConcreteDataDecl -> ShowS
showsPrec :: Int -> ConcreteDataDecl -> ShowS
$cshow :: ConcreteDataDecl -> [Char]
show :: ConcreteDataDecl -> [Char]
$cshowList :: [ConcreteDataDecl] -> ShowS
showList :: [ConcreteDataDecl] -> ShowS
Show)

{- These should never be used in a DataGenM context, we should always use the fresh generators below-}
anyCtorName :: Gen ConstructorName
anyCtorName :: Gen ConstructorName
anyCtorName = Text -> ConstructorName
ConstructorName (Text -> ConstructorName) -> Gen Text -> Gen ConstructorName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
genValidCtorName
  where
    genValidCtorName :: Gen Text
    genValidCtorName :: Gen Text
genValidCtorName = do
      let caps :: [Char]
caps = [Char
'A' .. Char
'Z']
          lower :: [Char]
lower = [Char
'a' .. Char
'z']
      Int
nmLen <- (Int, Int) -> Gen Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
6) -- should be more than enough to ensure `suchThat` doesn't run into clashes all the time
      Char
x <- [Char] -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements [Char]
caps
      [Char]
xs <- Int -> Gen Char -> Gen [Char]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
nmLen (Gen Char -> Gen [Char]) -> Gen Char -> Gen [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements ([Char]
caps [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
lower)
      Text -> Gen Text
forall a. a -> Gen a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> Gen Text) -> ([Char] -> Text) -> [Char] -> Gen Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Gen Text) -> [Char] -> Gen Text
forall a b. (a -> b) -> a -> b
$ (Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
xs)

anyTyName :: Gen TyName
anyTyName :: Gen TyName
anyTyName = Text -> TyName
TyName (Text -> TyName)
-> (ConstructorName -> Text) -> ConstructorName -> TyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorName -> Text
runConstructorName (ConstructorName -> TyName) -> Gen ConstructorName -> Gen TyName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ConstructorName
anyCtorName

{- These ensure that we don't ever duplicate type names or constructor names. We need the DataGenM state
   to ensure that, so these should *always* be used when writing generators, and the arbitrary instances should be avoided.
-}
freshConstructorName :: DataGenM ConstructorName
freshConstructorName :: DataGenM ConstructorName
freshConstructorName = do
  [DataDeclaration AbstractTy]
datatypes <- (DataGen -> [DataDeclaration AbstractTy])
-> DataGenM [DataDeclaration AbstractTy]
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Map TyName (DataDeclaration AbstractTy)
-> [DataDeclaration AbstractTy]
forall k a. Map k a -> [a]
M.elems (Map TyName (DataDeclaration AbstractTy)
 -> [DataDeclaration AbstractTy])
-> (DataGen -> Map TyName (DataDeclaration AbstractTy))
-> DataGen
-> [DataDeclaration AbstractTy]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> DataGen -> Map TyName (DataDeclaration AbstractTy)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls)
  let allCtorNames :: Set ConstructorName
allCtorNames = [ConstructorName] -> Set ConstructorName
forall a. Ord a => [a] -> Set a
Set.fromList ([ConstructorName] -> Set ConstructorName)
-> [ConstructorName] -> Set ConstructorName
forall a b. (a -> b) -> a -> b
$ Optic' A_Fold NoIx [DataDeclaration AbstractTy] ConstructorName
-> [DataDeclaration AbstractTy] -> [ConstructorName]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Fold [DataDeclaration AbstractTy] (DataDeclaration AbstractTy)
forall (f :: Type -> Type) a. Foldable f => Fold (f a) a
folded Fold [DataDeclaration AbstractTy] (DataDeclaration AbstractTy)
-> Optic
     A_Fold
     NoIx
     (DataDeclaration AbstractTy)
     (DataDeclaration AbstractTy)
     (Vector (Constructor AbstractTy))
     (Vector (Constructor AbstractTy))
-> Optic
     A_Fold
     NoIx
     [DataDeclaration AbstractTy]
     [DataDeclaration AbstractTy]
     (Vector (Constructor AbstractTy))
     (Vector (Constructor AbstractTy))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Fold
  NoIx
  (DataDeclaration AbstractTy)
  (DataDeclaration AbstractTy)
  (Vector (Constructor AbstractTy))
  (Vector (Constructor AbstractTy))
#datatypeConstructors Optic
  A_Fold
  NoIx
  [DataDeclaration AbstractTy]
  [DataDeclaration AbstractTy]
  (Vector (Constructor AbstractTy))
  (Vector (Constructor AbstractTy))
-> Optic
     A_Fold
     NoIx
     (Vector (Constructor AbstractTy))
     (Vector (Constructor AbstractTy))
     (Constructor AbstractTy)
     (Constructor AbstractTy)
-> Optic
     A_Fold
     NoIx
     [DataDeclaration AbstractTy]
     [DataDeclaration AbstractTy]
     (Constructor AbstractTy)
     (Constructor AbstractTy)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Fold
  NoIx
  (Vector (Constructor AbstractTy))
  (Vector (Constructor AbstractTy))
  (Constructor AbstractTy)
  (Constructor AbstractTy)
forall (f :: Type -> Type) a. Foldable f => Fold (f a) a
folded Optic
  A_Fold
  NoIx
  [DataDeclaration AbstractTy]
  [DataDeclaration AbstractTy]
  (Constructor AbstractTy)
  (Constructor AbstractTy)
-> Optic
     A_Lens
     NoIx
     (Constructor AbstractTy)
     (Constructor AbstractTy)
     ConstructorName
     ConstructorName
-> Optic' A_Fold NoIx [DataDeclaration AbstractTy] ConstructorName
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Constructor AbstractTy)
  (Constructor AbstractTy)
  ConstructorName
  ConstructorName
#constructorName) [DataDeclaration AbstractTy]
datatypes
  ConstructorName
thisName <- Gen ConstructorName -> DataGenM ConstructorName
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen ConstructorName -> DataGenM ConstructorName)
-> Gen ConstructorName -> DataGenM ConstructorName
forall a b. (a -> b) -> a -> b
$ Gen ConstructorName
anyCtorName Gen ConstructorName
-> (ConstructorName -> Bool) -> Gen ConstructorName
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (ConstructorName -> Set ConstructorName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set ConstructorName
allCtorNames)
  (DataGen -> DataGen) -> DataGenM ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((DataGen -> DataGen) -> DataGenM ())
-> (DataGen -> DataGen) -> DataGenM ()
forall a b. (a -> b) -> a -> b
$ Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Set ConstructorName)
  (Set ConstructorName)
-> (Set ConstructorName -> Set ConstructorName)
-> DataGen
-> DataGen
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Set ConstructorName)
  (Set ConstructorName)
#constructors (ConstructorName -> Set ConstructorName -> Set ConstructorName
forall a. Ord a => a -> Set a -> Set a
Set.insert ConstructorName
thisName)
  ConstructorName -> DataGenM ConstructorName
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ConstructorName
thisName

freshTyName :: DataGenM TyName
freshTyName :: DataGenM TyName
freshTyName = do
  [DataDeclaration AbstractTy]
datatypes <- (DataGen -> [DataDeclaration AbstractTy])
-> DataGenM [DataDeclaration AbstractTy]
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Map TyName (DataDeclaration AbstractTy)
-> [DataDeclaration AbstractTy]
forall k a. Map k a -> [a]
M.elems (Map TyName (DataDeclaration AbstractTy)
 -> [DataDeclaration AbstractTy])
-> (DataGen -> Map TyName (DataDeclaration AbstractTy))
-> DataGen
-> [DataDeclaration AbstractTy]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> DataGen -> Map TyName (DataDeclaration AbstractTy)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls)
  let allDataTypeNames :: Set TyName
allDataTypeNames = [TyName] -> Set TyName
forall a. Ord a => [a] -> Set a
Set.fromList ([TyName] -> Set TyName) -> [TyName] -> Set TyName
forall a b. (a -> b) -> a -> b
$ Optic' A_Fold NoIx [DataDeclaration AbstractTy] TyName
-> [DataDeclaration AbstractTy] -> [TyName]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Fold [DataDeclaration AbstractTy] (DataDeclaration AbstractTy)
forall (f :: Type -> Type) a. Foldable f => Fold (f a) a
folded Fold [DataDeclaration AbstractTy] (DataDeclaration AbstractTy)
-> Optic' A_Lens NoIx (DataDeclaration AbstractTy) TyName
-> Optic' A_Fold NoIx [DataDeclaration AbstractTy] TyName
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic' A_Lens NoIx (DataDeclaration AbstractTy) TyName
#datatypeName) [DataDeclaration AbstractTy]
datatypes
  Gen TyName -> DataGenM TyName
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen TyName -> DataGenM TyName) -> Gen TyName -> DataGenM TyName
forall a b. (a -> b) -> a -> b
$ Gen TyName
anyTyName Gen TyName -> (TyName -> Bool) -> Gen TyName
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (TyName -> Set TyName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TyName
allDataTypeNames)

newtype ConcreteConstructor = ConcreteConstructor (Constructor AbstractTy)
  deriving (ConcreteConstructor -> ConcreteConstructor -> Bool
(ConcreteConstructor -> ConcreteConstructor -> Bool)
-> (ConcreteConstructor -> ConcreteConstructor -> Bool)
-> Eq ConcreteConstructor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConcreteConstructor -> ConcreteConstructor -> Bool
== :: ConcreteConstructor -> ConcreteConstructor -> Bool
$c/= :: ConcreteConstructor -> ConcreteConstructor -> Bool
/= :: ConcreteConstructor -> ConcreteConstructor -> Bool
Eq) via (Constructor AbstractTy)
  deriving stock (Int -> ConcreteConstructor -> ShowS
[ConcreteConstructor] -> ShowS
ConcreteConstructor -> [Char]
(Int -> ConcreteConstructor -> ShowS)
-> (ConcreteConstructor -> [Char])
-> ([ConcreteConstructor] -> ShowS)
-> Show ConcreteConstructor
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConcreteConstructor -> ShowS
showsPrec :: Int -> ConcreteConstructor -> ShowS
$cshow :: ConcreteConstructor -> [Char]
show :: ConcreteConstructor -> [Char]
$cshowList :: [ConcreteConstructor] -> ShowS
showList :: [ConcreteConstructor] -> ShowS
Show)

notAThunk :: Concrete -> Bool
notAThunk :: Concrete -> Bool
notAThunk (Concrete ValT AbstractTy
valT) = case ValT AbstractTy
valT of
  ThunkT CompT AbstractTy
_ -> Bool
False
  ValT AbstractTy
_ -> Bool
True

genConcreteConstructor :: DataGenM ConcreteConstructor
genConcreteConstructor :: DataGenM ConcreteConstructor
genConcreteConstructor = Constructor AbstractTy -> ConcreteConstructor
ConcreteConstructor (Constructor AbstractTy -> ConcreteConstructor)
-> DataGenM (Constructor AbstractTy)
-> DataGenM ConcreteConstructor
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM (Constructor AbstractTy)
go
  where
    go :: DataGenM (Constructor AbstractTy)
    go :: DataGenM (Constructor AbstractTy)
go = do
      ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
      Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
      Vector Concrete
args <- Gen (Vector Concrete) -> DataGenM (Vector Concrete)
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen (Vector Concrete) -> DataGenM (Vector Concrete))
-> Gen (Vector Concrete) -> DataGenM (Vector Concrete)
forall a b. (a -> b) -> a -> b
$ Int -> Gen Concrete -> Gen (Vector Concrete)
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numArgs (forall a. Arbitrary a => Gen a
arbitrary @Concrete Gen Concrete -> (Concrete -> Bool) -> Gen Concrete
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Concrete -> Bool
notAThunk)
      Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Constructor AbstractTy -> DataGenM (Constructor AbstractTy))
-> Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a b. (a -> b) -> a -> b
$ ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm (Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> Vector Concrete -> Vector (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Concrete
args)

genConcreteDataDecl :: DataGenM ConcreteDataDecl
genConcreteDataDecl :: DataGenM ConcreteDataDecl
genConcreteDataDecl =
  DataDeclaration AbstractTy -> ConcreteDataDecl
ConcreteDataDecl (DataDeclaration AbstractTy -> ConcreteDataDecl)
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM ConcreteDataDecl
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TyName
tyNm <- DataGenM TyName
freshTyName
    Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
    Vector (Constructor AbstractTy)
ctors <- Vector ConcreteConstructor -> Vector (Constructor AbstractTy)
forall a b. Coercible a b => a -> b
coerce (Vector ConcreteConstructor -> Vector (Constructor AbstractTy))
-> DataGenM (Vector ConcreteConstructor)
-> DataGenM (Vector (Constructor AbstractTy))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> DataGenM ConcreteConstructor
-> DataGenM (Vector ConcreteConstructor)
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numArgs DataGenM ConcreteConstructor
genConcreteConstructor
    let decl :: DataDeclaration AbstractTy
decl = TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 Vector (Constructor AbstractTy)
ctors DataEncoding
SOP
    DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl DataDeclaration AbstractTy
decl

{- Concrete datatypes which may contain other concrete datatypes as constructor args. (Still no TyVars)

   For example, if you have (in the DataGen context) an already generated:

   data Foo = Foo Integer

   this can generate a datatype like:

   data Bar = Bar Foo | Baz String

   I.e. it generates datatype declarations that use previously generated datatype declarations.

   This isn't useful unless you generate a *set* (or some other collection of them) in the DataGen monad,
   since generating them one at a time will always give you the same thing as a ConcreteDataDecl.
-}
newtype NestedConcreteDataDecl = NestedConcreteDataDecl (DataDeclaration AbstractTy)
  deriving (NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool
(NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool)
-> (NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool)
-> Eq NestedConcreteDataDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool
== :: NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool
$c/= :: NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool
/= :: NestedConcreteDataDecl -> NestedConcreteDataDecl -> Bool
Eq) via (DataDeclaration AbstractTy)
  deriving stock (Int -> NestedConcreteDataDecl -> ShowS
[NestedConcreteDataDecl] -> ShowS
NestedConcreteDataDecl -> [Char]
(Int -> NestedConcreteDataDecl -> ShowS)
-> (NestedConcreteDataDecl -> [Char])
-> ([NestedConcreteDataDecl] -> ShowS)
-> Show NestedConcreteDataDecl
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NestedConcreteDataDecl -> ShowS
showsPrec :: Int -> NestedConcreteDataDecl -> ShowS
$cshow :: NestedConcreteDataDecl -> [Char]
show :: NestedConcreteDataDecl -> [Char]
$cshowList :: [NestedConcreteDataDecl] -> ShowS
showList :: [NestedConcreteDataDecl] -> ShowS
Show)

newtype NestedConcreteCtor = NestedConcreteCtor (Constructor AbstractTy)

genNestedConcrete :: DataGenM NestedConcreteDataDecl
genNestedConcrete :: DataGenM NestedConcreteDataDecl
genNestedConcrete =
  DataDeclaration AbstractTy -> NestedConcreteDataDecl
NestedConcreteDataDecl (DataDeclaration AbstractTy -> NestedConcreteDataDecl)
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM NestedConcreteDataDecl
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TyName
tyNm <- DataGenM TyName
freshTyName
    DataDeclaration AbstractTy
res <- [DataGenM (DataDeclaration AbstractTy)]
-> DataGenM (DataDeclaration AbstractTy)
forall (m :: Type -> Type) a. MonadGen m => [m a] -> m a
GT.oneof [TyName -> DataGenM (DataDeclaration AbstractTy)
nullary TyName
tyNm, TyName -> DataGenM (DataDeclaration AbstractTy)
nonNestedConcrete TyName
tyNm, TyName -> DataGenM (DataDeclaration AbstractTy)
nested TyName
tyNm]
    DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl DataDeclaration AbstractTy
res
  where
    nullary :: TyName -> DataGenM (DataDeclaration AbstractTy)
    nullary :: TyName -> DataGenM (DataDeclaration AbstractTy)
nullary TyName
tyNm = do
      ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
      DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DataDeclaration AbstractTy
 -> DataGenM (DataDeclaration AbstractTy))
-> DataDeclaration AbstractTy
-> DataGenM (DataDeclaration AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 (Constructor AbstractTy -> Vector (Constructor AbstractTy)
forall a. a -> Vector a
Vector.singleton (ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm Vector (ValT AbstractTy)
forall a. Vector a
Vector.empty)) DataEncoding
SOP

    nonNestedConcrete :: TyName -> DataGenM (DataDeclaration AbstractTy)
    nonNestedConcrete :: TyName -> DataGenM (DataDeclaration AbstractTy)
nonNestedConcrete TyName
tyNm = do
      Int
numCtors <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
      Vector (Constructor AbstractTy)
ctors <- (ConcreteConstructor -> Constructor AbstractTy)
-> Vector ConcreteConstructor -> Vector (Constructor AbstractTy)
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteConstructor -> Constructor AbstractTy
forall a b. Coercible a b => a -> b
coerce (Vector ConcreteConstructor -> Vector (Constructor AbstractTy))
-> DataGenM (Vector ConcreteConstructor)
-> DataGenM (Vector (Constructor AbstractTy))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> DataGenM ConcreteConstructor
-> DataGenM (Vector ConcreteConstructor)
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numCtors DataGenM ConcreteConstructor
genConcreteConstructor
      DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DataDeclaration AbstractTy
 -> DataGenM (DataDeclaration AbstractTy))
-> DataDeclaration AbstractTy
-> DataGenM (DataDeclaration AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 Vector (Constructor AbstractTy)
ctors DataEncoding
SOP

    nested :: TyName -> DataGenM (DataDeclaration AbstractTy)
    nested :: TyName -> DataGenM (DataDeclaration AbstractTy)
nested TyName
tyNm = do
      Int
numCtors <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
      Vector NestedConcreteCtor
ctors <- Int
-> DataGenM NestedConcreteCtor
-> DataGenM (Vector NestedConcreteCtor)
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numCtors DataGenM NestedConcreteCtor
nestedCtor
      DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DataDeclaration AbstractTy
 -> DataGenM (DataDeclaration AbstractTy))
-> DataDeclaration AbstractTy
-> DataGenM (DataDeclaration AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 (NestedConcreteCtor -> Constructor AbstractTy
forall a b. Coercible a b => a -> b
coerce (NestedConcreteCtor -> Constructor AbstractTy)
-> Vector NestedConcreteCtor -> Vector (Constructor AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector NestedConcreteCtor
ctors) DataEncoding
SOP

{- It's useful to have access to these outside of the above function because sometimes we want to mix and match
   "simpler" constructors like this with the more complex sorts we generate below.
-}
nestedCtor :: DataGenM NestedConcreteCtor
nestedCtor :: DataGenM NestedConcreteCtor
nestedCtor = do
  -- We want this: Not very much hinges on the # of args to each constructor and having finite bounds like this makes the output easier to read
  Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
  Vector (ValT AbstractTy)
args <- Int
-> DataGenM (ValT AbstractTy)
-> DataGenM (Vector (ValT AbstractTy))
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numArgs DataGenM (ValT AbstractTy)
nestedCtorArg
  ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
  NestedConcreteCtor -> DataGenM NestedConcreteCtor
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NestedConcreteCtor -> DataGenM NestedConcreteCtor)
-> (Constructor AbstractTy -> NestedConcreteCtor)
-> Constructor AbstractTy
-> DataGenM NestedConcreteCtor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructor AbstractTy -> NestedConcreteCtor
forall a b. Coercible a b => a -> b
coerce (Constructor AbstractTy -> DataGenM NestedConcreteCtor)
-> Constructor AbstractTy -> DataGenM NestedConcreteCtor
forall a b. (a -> b) -> a -> b
$ ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm Vector (ValT AbstractTy)
args

nestedCtorArg :: DataGenM (ValT AbstractTy)
nestedCtorArg :: DataGenM (ValT AbstractTy)
nestedCtorArg = do
  [TyName]
userTyNames <- (DataGen -> [TyName]) -> DataGenM [TyName]
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Map TyName (DataDeclaration AbstractTy) -> [TyName]
forall k a. Map k a -> [k]
M.keys (Map TyName (DataDeclaration AbstractTy) -> [TyName])
-> (DataGen -> Map TyName (DataDeclaration AbstractTy))
-> DataGen
-> [TyName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
-> DataGen -> Map TyName (DataDeclaration AbstractTy)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  A_Lens NoIx DataGen (Map TyName (DataDeclaration AbstractTy))
#decls)
  if [TyName] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [TyName]
userTyNames
    then Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> DataGenM Concrete -> DataGenM (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Concrete -> DataGenM Concrete
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (forall a. Arbitrary a => Gen a
arbitrary @Concrete)
    else do
      let userTypes :: [ValT AbstractTy]
userTypes = (TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
`Datatype` Vector (ValT AbstractTy)
forall a. Vector a
Vector.empty) (TyName -> ValT AbstractTy) -> [TyName] -> [ValT AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyName]
userTyNames
      Gen (ValT AbstractTy) -> DataGenM (ValT AbstractTy)
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen (ValT AbstractTy) -> DataGenM (ValT AbstractTy))
-> Gen (ValT AbstractTy) -> DataGenM (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ [(Int, Gen (ValT AbstractTy))] -> Gen (ValT AbstractTy)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
8, [ValT AbstractTy] -> Gen (ValT AbstractTy)
forall a. HasCallStack => [a] -> Gen a
elements [ValT AbstractTy]
userTypes), (Int
2, Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> Gen Concrete -> Gen (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @Concrete)]

newtype RecursiveConcreteDataDecl = RecursiveConcreteDataDecl (DataDeclaration AbstractTy)
  deriving (RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool
(RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool)
-> (RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool)
-> Eq RecursiveConcreteDataDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool
== :: RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool
$c/= :: RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool
/= :: RecursiveConcreteDataDecl -> RecursiveConcreteDataDecl -> Bool
Eq) via (DataDeclaration AbstractTy)
  deriving stock (Int -> RecursiveConcreteDataDecl -> ShowS
[RecursiveConcreteDataDecl] -> ShowS
RecursiveConcreteDataDecl -> [Char]
(Int -> RecursiveConcreteDataDecl -> ShowS)
-> (RecursiveConcreteDataDecl -> [Char])
-> ([RecursiveConcreteDataDecl] -> ShowS)
-> Show RecursiveConcreteDataDecl
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecursiveConcreteDataDecl -> ShowS
showsPrec :: Int -> RecursiveConcreteDataDecl -> ShowS
$cshow :: RecursiveConcreteDataDecl -> [Char]
show :: RecursiveConcreteDataDecl -> [Char]
$cshowList :: [RecursiveConcreteDataDecl] -> ShowS
showList :: [RecursiveConcreteDataDecl] -> ShowS
Show)

{- Non-polymorphic recursive types, i.e. things like:

   data IntList = Empty | ConsInt Int IntList

   The general idea is that we construct a base case constructor (Nil or Empty) and then
   construct a recursive constructor. We can expand this later (e.g. to have multiple recursive constructors, or a polymorphic variant)
   but this will be enough to handle initial testing w/ the base functor / BBF stuff (and we have to ensure we have things like this to test that)
-}
genArbitraryRecursive :: DataGenM RecursiveConcreteDataDecl
genArbitraryRecursive :: DataGenM RecursiveConcreteDataDecl
genArbitraryRecursive =
  DataDeclaration AbstractTy -> RecursiveConcreteDataDecl
RecursiveConcreteDataDecl (DataDeclaration AbstractTy -> RecursiveConcreteDataDecl)
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM RecursiveConcreteDataDecl
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TyName
tyNm <- DataGenM TyName
freshTyName
    Constructor AbstractTy
baseCtor <- ConcreteConstructor -> Constructor AbstractTy
forall a b. Coercible a b => a -> b
coerce (ConcreteConstructor -> Constructor AbstractTy)
-> DataGenM ConcreteConstructor
-> DataGenM (Constructor AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM ConcreteConstructor
genConcreteConstructor -- any concrete ctor - or any ctor that doesn't contain the parent type - will suffice as a base case
    Int
numRecCtors <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
5)
    [Constructor AbstractTy]
recCtor <- Int
-> DataGenM (Constructor AbstractTy)
-> DataGenM [Constructor AbstractTy]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
numRecCtors (DataGenM (Constructor AbstractTy)
 -> DataGenM [Constructor AbstractTy])
-> DataGenM (Constructor AbstractTy)
-> DataGenM [Constructor AbstractTy]
forall a b. (a -> b) -> a -> b
$ TyName -> DataGenM (Constructor AbstractTy)
genRecCtor TyName
tyNm
    DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl (DataDeclaration AbstractTy
 -> DataGenM (DataDeclaration AbstractTy))
-> DataDeclaration AbstractTy
-> DataGenM (DataDeclaration AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0 ([Constructor AbstractTy] -> Vector (Constructor AbstractTy)
forall a. [a] -> Vector a
Vector.fromList (Constructor AbstractTy
baseCtor Constructor AbstractTy
-> [Constructor AbstractTy] -> [Constructor AbstractTy]
forall a. a -> [a] -> [a]
: [Constructor AbstractTy]
recCtor)) DataEncoding
SOP
  where
    genRecCtor :: TyName -> DataGenM (Constructor AbstractTy)
    genRecCtor :: TyName -> DataGenM (Constructor AbstractTy)
genRecCtor TyName
tyNm = do
      ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
      let thisType :: ValT AbstractTy
thisType = TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
tyNm Vector (ValT AbstractTy)
forall a. Vector a
Vector.empty
      Int
numNonRecArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
5) -- need at least one to avoid "bad" types
      [ValT AbstractTy]
args <- DataGenM [ValT AbstractTy] -> DataGenM [ValT AbstractTy]
forall a b. Coercible a b => a -> b
coerce (DataGenM [ValT AbstractTy] -> DataGenM [ValT AbstractTy])
-> DataGenM [ValT AbstractTy] -> DataGenM [ValT AbstractTy]
forall a b. (a -> b) -> a -> b
$ Int -> DataGenM (ValT AbstractTy) -> DataGenM [ValT AbstractTy]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
numNonRecArgs DataGenM (ValT AbstractTy)
nestedCtorArg
      Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Constructor AbstractTy -> DataGenM (Constructor AbstractTy))
-> Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a b. (a -> b) -> a -> b
$ ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm ([ValT AbstractTy] -> Vector (ValT AbstractTy)
forall a. [a] -> Vector a
Vector.fromList (ValT AbstractTy
thisType ValT AbstractTy -> [ValT AbstractTy] -> [ValT AbstractTy]
forall a. a -> [a] -> [a]
: [ValT AbstractTy]
args))

{- Single variable polymorphic datatypes. That is, things like:

   data Foo a = Nope | Yup a

   data Snowk a = Start | More (Snowk a) a
-}
newtype Polymorphic1 = Polymorphic1 (DataDeclaration AbstractTy)
  deriving (Polymorphic1 -> Polymorphic1 -> Bool
(Polymorphic1 -> Polymorphic1 -> Bool)
-> (Polymorphic1 -> Polymorphic1 -> Bool) -> Eq Polymorphic1
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Polymorphic1 -> Polymorphic1 -> Bool
== :: Polymorphic1 -> Polymorphic1 -> Bool
$c/= :: Polymorphic1 -> Polymorphic1 -> Bool
/= :: Polymorphic1 -> Polymorphic1 -> Bool
Eq) via (DataDeclaration AbstractTy)
  deriving stock (Int -> Polymorphic1 -> ShowS
[Polymorphic1] -> ShowS
Polymorphic1 -> [Char]
(Int -> Polymorphic1 -> ShowS)
-> (Polymorphic1 -> [Char])
-> ([Polymorphic1] -> ShowS)
-> Show Polymorphic1
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Polymorphic1 -> ShowS
showsPrec :: Int -> Polymorphic1 -> ShowS
$cshow :: Polymorphic1 -> [Char]
show :: Polymorphic1 -> [Char]
$cshowList :: [Polymorphic1] -> ShowS
showList :: [Polymorphic1] -> ShowS
Show)

{- Generator for single variable polymorphic datatypes, no polymorphic *functions* as arguments to the datatypes yet (that requires something different).

   When run multiple times in the monadic context, will reuse single variable declarations that are "in scope" (i.e. have already been generated and are
   known in the DataGenM state).

   TODO: Rework this to generate declarations with an arbitrary number of tyvar arguments. Doing so would be fairly simple (but isn't needed ATM)
-}
genPolymorphic1Decl :: DataGenM Polymorphic1
genPolymorphic1Decl :: DataGenM Polymorphic1
genPolymorphic1Decl =
  DataDeclaration AbstractTy -> Polymorphic1
Polymorphic1
    (DataDeclaration AbstractTy -> Polymorphic1)
-> DataGenM (DataDeclaration AbstractTy) -> DataGenM Polymorphic1
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM (DataDeclaration AbstractTy)
-> (DataDeclaration AbstractTy -> Bool)
-> DataGenM (DataDeclaration AbstractTy)
forall (m :: Type -> Type) a.
MonadGen m =>
m a -> (a -> Bool) -> m a
GT.suchThat
      ( do
          -- this is a hack to save avoid reworking generator logic. It should be fine cuz we're not super likely to get phantoms anyway
          TyName
tyNm <- DataGenM TyName
freshTyName
          TyName -> Count "tyvar" -> DataGenM ()
logArity TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count1
          Int
numCtors <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
5)
          [Constructor AbstractTy]
polyCtors <- [[Constructor AbstractTy]] -> [Constructor AbstractTy]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Constructor AbstractTy]] -> [Constructor AbstractTy])
-> DataGenM [[Constructor AbstractTy]]
-> DataGenM [Constructor AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> DataGenM [Constructor AbstractTy]
-> DataGenM [[Constructor AbstractTy]]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
numCtors (TyName -> DataGenM [Constructor AbstractTy]
genPolyCtor TyName
tyNm)
          let result :: DataDeclaration AbstractTy
result = TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count1 ([Constructor AbstractTy] -> Vector (Constructor AbstractTy)
forall a. [a] -> Vector a
Vector.fromList [Constructor AbstractTy]
polyCtors) DataEncoding
SOP
          DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl DataDeclaration AbstractTy
result
      )
      DataDeclaration AbstractTy -> Bool
noPhantomTyVars
  where
    -- We return a single constructor UNLESS we're generating a recursive type, in which case we have to return 2 to ensure a base case
    genPolyCtor :: TyName -> DataGenM [Constructor AbstractTy]
    genPolyCtor :: TyName -> DataGenM [Constructor AbstractTy]
genPolyCtor TyName
thisTy = do
      ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
      Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
5)
      [ValT AbstractTy]
argsRaw <- Int -> DataGenM (ValT AbstractTy) -> DataGenM [ValT AbstractTy]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
numArgs DataGenM (ValT AbstractTy)
polyArg
      let recCase :: ValT AbstractTy
recCase = TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
thisTy (ValT AbstractTy -> Vector (ValT AbstractTy)
forall a. a -> Vector a
Vector.singleton (AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
Z Index "tyvar"
forall (ofWhat :: Symbol). Index ofWhat
ix0)))
      if ValT AbstractTy
recCase ValT AbstractTy -> [ValT AbstractTy] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ValT AbstractTy]
argsRaw
        then do
          ConstructorName
baseCtorNm <- DataGenM ConstructorName
freshConstructorName
          let baseCtor :: Constructor AbstractTy
baseCtor = ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
baseCtorNm Vector (ValT AbstractTy)
forall a. Monoid a => a
mempty
              recCtor :: Constructor AbstractTy
recCtor = ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm (Int
-> [Item (Vector (ValT AbstractTy))] -> Vector (ValT AbstractTy)
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
numArgs [Item (Vector (ValT AbstractTy))]
[ValT AbstractTy]
argsRaw)
          [Constructor AbstractTy] -> DataGenM [Constructor AbstractTy]
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Constructor AbstractTy
baseCtor, Constructor AbstractTy
recCtor]
        else [Constructor AbstractTy] -> DataGenM [Constructor AbstractTy]
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm (Int
-> [Item (Vector (ValT AbstractTy))] -> Vector (ValT AbstractTy)
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
numArgs [Item (Vector (ValT AbstractTy))]
[ValT AbstractTy]
argsRaw)]
      where
        arityOne :: Count "tyvar" -> Bool
        arityOne :: Count "tyvar" -> Bool
arityOne Count "tyvar"
c = Count "tyvar"
c Count "tyvar" -> Count "tyvar" -> Bool
forall a. Eq a => a -> a -> Bool
== Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count1

        polyArg :: DataGenM (ValT AbstractTy)
        polyArg :: DataGenM (ValT AbstractTy)
polyArg = do
          -- first we choose a type with an arity >=1. We have to have at least one of those because we've added the parent type to the arity map
          [TyName]
availableArity1 <- (DataGen -> [TyName]) -> DataGenM [TyName]
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Map TyName (Count "tyvar") -> [TyName]
forall k a. Map k a -> [k]
M.keys (Map TyName (Count "tyvar") -> [TyName])
-> (DataGen -> Map TyName (Count "tyvar")) -> DataGen -> [TyName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Count "tyvar" -> Bool)
-> Map TyName (Count "tyvar") -> Map TyName (Count "tyvar")
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Count "tyvar" -> Bool
arityOne (Map TyName (Count "tyvar") -> Map TyName (Count "tyvar"))
-> (DataGen -> Map TyName (Count "tyvar"))
-> DataGen
-> Map TyName (Count "tyvar")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
-> DataGen -> Map TyName (Count "tyvar")
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
#arities)
          TyName
someTyCon1 <- [TyName] -> DataGenM TyName
forall (m :: Type -> Type) a. MonadGen m => [a] -> m a
GT.elements [TyName]
availableArity1
          [DataGenM (ValT AbstractTy)] -> DataGenM (ValT AbstractTy)
forall (m :: Type -> Type) a. MonadGen m => [m a] -> m a
GT.oneof
            [ ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> DataGenM (ValT AbstractTy))
-> ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
Z Index "tyvar"
forall (ofWhat :: Symbol). Index ofWhat
ix0),
              ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> DataGenM (ValT AbstractTy))
-> ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
someTyCon1 (ValT AbstractTy -> Vector (ValT AbstractTy)
forall a. a -> Vector a
Vector.singleton (AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
Z Index "tyvar"
forall (ofWhat :: Symbol). Index ofWhat
ix0))),
              Gen (ValT AbstractTy) -> DataGenM (ValT AbstractTy)
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> Gen Concrete -> Gen (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @Concrete)
            ]

{- Non-concrete ValTs. This needs to be scope- and context-sensitive in order to generate ThunkTs that *use* (but never *bind*) variables.

This will give us things like:

  data Foo a b = Foo Int Bool a (a -> (Int -> b) -> b -> b)
-}

newtype NonConcrete = NonConcrete (ValT AbstractTy)
  deriving
    ( -- | @since 1.0.0
      NonConcrete -> NonConcrete -> Bool
(NonConcrete -> NonConcrete -> Bool)
-> (NonConcrete -> NonConcrete -> Bool) -> Eq NonConcrete
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NonConcrete -> NonConcrete -> Bool
== :: NonConcrete -> NonConcrete -> Bool
$c/= :: NonConcrete -> NonConcrete -> Bool
/= :: NonConcrete -> NonConcrete -> Bool
Eq
    )
    via (ValT AbstractTy)
  deriving stock
    ( -- | @since 1.0.0
      Int -> NonConcrete -> ShowS
[NonConcrete] -> ShowS
NonConcrete -> [Char]
(Int -> NonConcrete -> ShowS)
-> (NonConcrete -> [Char])
-> ([NonConcrete] -> ShowS)
-> Show NonConcrete
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonConcrete -> ShowS
showsPrec :: Int -> NonConcrete -> ShowS
$cshow :: NonConcrete -> [Char]
show :: NonConcrete -> [Char]
$cshowList :: [NonConcrete] -> ShowS
showList :: [NonConcrete] -> ShowS
Show
    )

genNonConcrete :: DataGenM NonConcrete
genNonConcrete :: DataGenM NonConcrete
genNonConcrete = ValT AbstractTy -> NonConcrete
NonConcrete (ValT AbstractTy -> NonConcrete)
-> DataGenM (ValT AbstractTy) -> DataGenM NonConcrete
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> DataGenM (ValT AbstractTy)) -> DataGenM (ValT AbstractTy)
forall a. (Int -> DataGenM a) -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => (Int -> g a) -> g a
GT.sized Int -> DataGenM (ValT AbstractTy)
go
  where
    -- smaller to make output more readable
    genConcrete :: DataGenM Concrete
    genConcrete :: DataGenM Concrete
genConcrete = Gen Concrete -> DataGenM Concrete
forall a. Gen a -> DataGenM a
forall (g :: Type -> Type) a. MonadGen g => Gen a -> g a
GT.liftGen (Gen Concrete -> DataGenM Concrete)
-> Gen Concrete -> DataGenM Concrete
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Gen Concrete -> Gen Concrete
forall (m :: Type -> Type) a.
MonadGen m =>
(Int -> Int) -> m a -> m a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
8) (forall a. Arbitrary a => Gen a
arbitrary @Concrete)

    go :: Int -> DataGenM (ValT AbstractTy)
    go :: Int -> DataGenM (ValT AbstractTy)
go = Int -> DataGenM (ValT AbstractTy)
helper

    -- A polymorphic tycon applied to *either* an in-scope type variable *or* a concrete type.
    -- TODO: Conceivably this could recursively call `helper` to generate "fancier" tycon arguments
    --       but that shouldn't matter much for now & runs the risk of generating unusably large output w/o
    --       careful implementation.
    appliedTyCon :: Int -> DataGenM (ValT AbstractTy)
    appliedTyCon :: Int -> DataGenM (ValT AbstractTy)
appliedTyCon Int
size = do
      ScopeBoundary
currentScope <- (DataGen -> ScopeBoundary) -> DataGenM ScopeBoundary
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
-> DataGen -> ScopeBoundary
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx DataGen DataGen ScopeBoundary ScopeBoundary
#currentScope)
      [(TyName, Count "tyvar")]
tyConsWithArity <- Map TyName (Count "tyvar") -> [(TyName, Count "tyvar")]
forall k a. Map k a -> [(k, a)]
M.toList (Map TyName (Count "tyvar") -> [(TyName, Count "tyvar")])
-> DataGenM (Map TyName (Count "tyvar"))
-> DataGenM [(TyName, Count "tyvar")]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataGen -> Map TyName (Count "tyvar"))
-> DataGenM (Map TyName (Count "tyvar"))
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
-> DataGen -> Map TyName (Count "tyvar")
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map TyName (Count "tyvar"))
  (Map TyName (Count "tyvar"))
#arities)
      [(ScopeBoundary, Word32)]
boundVars <- Map ScopeBoundary Word32 -> [(ScopeBoundary, Word32)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ScopeBoundary Word32 -> [(ScopeBoundary, Word32)])
-> DataGenM (Map ScopeBoundary Word32)
-> DataGenM [(ScopeBoundary, Word32)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataGen -> Map ScopeBoundary Word32)
-> DataGenM (Map ScopeBoundary Word32)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map ScopeBoundary Word32)
  (Map ScopeBoundary Word32)
-> DataGen -> Map ScopeBoundary Word32
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic
  A_Lens
  NoIx
  DataGen
  DataGen
  (Map ScopeBoundary Word32)
  (Map ScopeBoundary Word32)
#boundVars)
      -- We *have* to have some variables bound for this to work. We can't meaningfully return a `Maybe` here
      -- Also we have to have some Arity >= 1 TyCon around
      -- I.e. we cannot run this generator in a "fresh" DataGenM stack and have to both pre-generate
      -- some fresh polymorphic types *and* ensure that we only use this in a context where we have bound variables.
      (TyName
thisTyCon, Count "tyvar"
thisArity) <- [(TyName, Count "tyvar")] -> DataGenM (TyName, Count "tyvar")
forall (m :: Type -> Type) a. MonadGen m => [a] -> m a
GT.elements [(TyName, Count "tyvar")]
tyConsWithArity
      let arityInt :: Int
arityInt = Optic' A_Prism NoIx Int (Count "tyvar") -> Count "tyvar" -> Int
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' A_Prism NoIx Int (Count "tyvar")
forall (ofWhat :: Symbol). Prism' Int (Count ofWhat)
intCount Count "tyvar"
thisArity
      let resolvedArgs :: [ValT AbstractTy]
resolvedArgs = ((ScopeBoundary, Word32) -> [ValT AbstractTy])
-> [(ScopeBoundary, Word32)] -> [ValT AbstractTy]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (ScopeBoundary -> (ScopeBoundary, Word32) -> [ValT AbstractTy]
resolveArgs ScopeBoundary
currentScope) [(ScopeBoundary, Word32)]
boundVars
      let choices :: [DataGenM (ValT AbstractTy)]
choices
            | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> DataGenM Concrete -> DataGenM (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM Concrete
genConcrete]
            | Bool
otherwise = [Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> DataGenM Concrete -> DataGenM (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM Concrete
genConcrete, [ValT AbstractTy] -> DataGenM (ValT AbstractTy)
forall (m :: Type -> Type) a. MonadGen m => [a] -> m a
GT.elements [ValT AbstractTy]
resolvedArgs]
      [ValT AbstractTy]
tyConArgs <- Int -> DataGenM (ValT AbstractTy) -> DataGenM [ValT AbstractTy]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
arityInt (DataGenM (ValT AbstractTy) -> DataGenM [ValT AbstractTy])
-> DataGenM (ValT AbstractTy) -> DataGenM [ValT AbstractTy]
forall a b. (a -> b) -> a -> b
$ [DataGenM (ValT AbstractTy)] -> DataGenM (ValT AbstractTy)
forall (m :: Type -> Type) a. MonadGen m => [m a] -> m a
GT.oneof [DataGenM (ValT AbstractTy)]
choices
      ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> DataGenM (ValT AbstractTy))
-> ValT AbstractTy -> DataGenM (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ TyName -> Vector (ValT AbstractTy) -> ValT AbstractTy
forall a. TyName -> Vector (ValT a) -> ValT a
Datatype TyName
thisTyCon ([ValT AbstractTy] -> Vector (ValT AbstractTy)
forall a. [a] -> Vector a
Vector.fromList [ValT AbstractTy]
tyConArgs)

    resolveArgs :: ScopeBoundary -> (ScopeBoundary, Word32) -> [ValT AbstractTy]
    resolveArgs :: ScopeBoundary -> (ScopeBoundary, Word32) -> [ValT AbstractTy]
resolveArgs ScopeBoundary
currentScope (ScopeBoundary
varScope, Word32
numIndices) =
      let resolvedScope :: DeBruijn
          resolvedScope :: DeBruijn
resolvedScope = Maybe DeBruijn -> DeBruijn
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DeBruijn -> DeBruijn)
-> (ScopeBoundary -> Maybe DeBruijn) -> ScopeBoundary -> DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Prism NoIx Int DeBruijn -> Int -> Maybe DeBruijn
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism NoIx Int DeBruijn
asInt (Int -> Maybe DeBruijn)
-> (ScopeBoundary -> Int) -> ScopeBoundary -> Maybe DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeBoundary -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ScopeBoundary -> DeBruijn) -> ScopeBoundary -> DeBruijn
forall a b. (a -> b) -> a -> b
$ ScopeBoundary
currentScope ScopeBoundary -> ScopeBoundary -> ScopeBoundary
forall a. Num a => a -> a -> a
- ScopeBoundary
varScope
       in (Int -> Maybe (ValT AbstractTy)) -> [Int] -> [ValT AbstractTy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Index "tyvar" -> ValT AbstractTy)
-> Maybe (Index "tyvar") -> Maybe (ValT AbstractTy)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (AbstractTy -> ValT AbstractTy)
-> (Index "tyvar" -> AbstractTy)
-> Index "tyvar"
-> ValT AbstractTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
resolvedScope) (Maybe (Index "tyvar") -> Maybe (ValT AbstractTy))
-> (Int -> Maybe (Index "tyvar")) -> Int -> Maybe (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Prism NoIx Int (Index "tyvar")
-> Int -> Maybe (Index "tyvar")
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism NoIx Int (Index "tyvar")
forall (ofWhat :: Symbol). Prism' Int (Index ofWhat)
intIndex) [Int
0 .. (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numIndices Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

    helper :: Int -> DataGenM (ValT AbstractTy)
    helper :: Int -> DataGenM (ValT AbstractTy)
helper Int
size = do
      [DataGenM (ValT AbstractTy)] -> DataGenM (ValT AbstractTy)
forall (m :: Type -> Type) a. MonadGen m => [m a] -> m a
GT.oneof [Concrete -> ValT AbstractTy
forall a b. Coercible a b => a -> b
coerce (Concrete -> ValT AbstractTy)
-> DataGenM Concrete -> DataGenM (ValT AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataGenM Concrete
genConcrete, Int -> DataGenM (ValT AbstractTy)
appliedTyCon Int
size]

-- NOTE: We have to call this with a "driver" which pre-generates suitable (i.e. polymorphic) data declarations, see notes in `genNonConcrete`
genNonConcreteDecl :: DataGenM (DataDeclaration AbstractTy)
genNonConcreteDecl :: DataGenM (DataDeclaration AbstractTy)
genNonConcreteDecl = (DataGenM (DataDeclaration AbstractTy)
 -> (DataDeclaration AbstractTy -> Bool)
 -> DataGenM (DataDeclaration AbstractTy))
-> (DataDeclaration AbstractTy -> Bool)
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM (DataDeclaration AbstractTy)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DataGenM (DataDeclaration AbstractTy)
-> (DataDeclaration AbstractTy -> Bool)
-> DataGenM (DataDeclaration AbstractTy)
forall (m :: Type -> Type) a.
MonadGen m =>
m a -> (a -> Bool) -> m a
GT.suchThat DataDeclaration AbstractTy -> Bool
noPhantomTyVars (DataGenM (DataDeclaration AbstractTy)
 -> DataGenM (DataDeclaration AbstractTy))
-> (DataGenM (DataDeclaration AbstractTy)
    -> DataGenM (DataDeclaration AbstractTy))
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM (DataDeclaration AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Count "tyvar"
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM (DataDeclaration AbstractTy)
forall a. Count "tyvar" -> DataGenM a -> DataGenM a
withBoundVars Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count1 (DataGenM (DataDeclaration AbstractTy)
 -> DataGenM (DataDeclaration AbstractTy))
-> DataGenM (DataDeclaration AbstractTy)
-> DataGenM (DataDeclaration AbstractTy)
forall a b. (a -> b) -> a -> b
$ do
  -- we need to bind the vars before we're done constructing the type
  TyName
tyNm <- DataGenM TyName
freshTyName
  Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
1, Int
5)
  Vector (Constructor AbstractTy)
ctors <- Int
-> DataGenM (Constructor AbstractTy)
-> DataGenM (Vector (Constructor AbstractTy))
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numArgs DataGenM (Constructor AbstractTy)
genNonConcreteCtor
  let decl :: DataDeclaration AbstractTy
decl = TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
tyNm Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count1 Vector (Constructor AbstractTy)
ctors DataEncoding
SOP
  DataDeclaration AbstractTy -> DataGenM (DataDeclaration AbstractTy)
returnDecl DataDeclaration AbstractTy
decl
  where
    genNonConcreteCtor :: DataGenM (Constructor AbstractTy)
    genNonConcreteCtor :: DataGenM (Constructor AbstractTy)
genNonConcreteCtor = do
      ConstructorName
ctorNm <- DataGenM ConstructorName
freshConstructorName
      Int
numArgs <- (Int, Int) -> DataGenM Int
forall (m :: Type -> Type). MonadGen m => (Int, Int) -> m Int
chooseInt (Int
0, Int
5)
      [NonConcrete]
args <- Int -> DataGenM NonConcrete -> DataGenM [NonConcrete]
forall (m :: Type -> Type) a. MonadGen m => Int -> m a -> m [a]
GT.vectorOf Int
numArgs DataGenM NonConcrete
genNonConcrete
      Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a. a -> DataGenM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Constructor AbstractTy -> DataGenM (Constructor AbstractTy))
-> Constructor AbstractTy -> DataGenM (Constructor AbstractTy)
forall a b. (a -> b) -> a -> b
$ ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm (Vector NonConcrete -> Vector (ValT AbstractTy)
forall a b. Coercible a b => a -> b
coerce (Vector NonConcrete -> Vector (ValT AbstractTy))
-> ([NonConcrete] -> Vector NonConcrete)
-> [NonConcrete]
-> Vector (ValT AbstractTy)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonConcrete] -> Vector NonConcrete
forall a. [a] -> Vector a
Vector.fromList ([NonConcrete] -> Vector (ValT AbstractTy))
-> [NonConcrete] -> Vector (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ [NonConcrete]
args)

{-
   Misc Helpers and the Arbitrary instances
-}

{- NOTE: This is supposed to be a "generic" shrinker for datatypes. It *should* return two paths:
                - One that shrinks the number of constructors
                - One that shrinks the constructors

              This is why I had to add handling for `datatype` into `Concrete`. To use `shrink` recursively
              on the structural components, we need some kind of instance to pivot off of. Since we want to avoid
              writing a generic Arbitrary instance for Constructor or DataDeclaration, this seems like the
              simplest solution.
-}
shrinkDataDecl :: DataDeclaration AbstractTy -> [DataDeclaration AbstractTy]
shrinkDataDecl :: DataDeclaration AbstractTy -> [DataDeclaration AbstractTy]
shrinkDataDecl OpaqueData {} = []
shrinkDataDecl (DataDeclaration TyName
nm Count "tyvar"
cnt Vector (Constructor AbstractTy)
ctors DataEncoding
strat)
  | Vector (Constructor AbstractTy) -> Bool
forall a. Vector a -> Bool
Vector.null Vector (Constructor AbstractTy)
ctors = []
  | Bool
otherwise = (DataDeclaration AbstractTy -> Bool)
-> [DataDeclaration AbstractTy] -> [DataDeclaration AbstractTy]
forall a. (a -> Bool) -> [a] -> [a]
filter DataDeclaration AbstractTy -> Bool
noPhantomTyVars ([DataDeclaration AbstractTy] -> [DataDeclaration AbstractTy])
-> [DataDeclaration AbstractTy] -> [DataDeclaration AbstractTy]
forall a b. (a -> b) -> a -> b
$ [DataDeclaration AbstractTy]
smallerNumCtors [DataDeclaration AbstractTy]
-> [DataDeclaration AbstractTy] -> [DataDeclaration AbstractTy]
forall a. [a] -> [a] -> [a]
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> [DataDeclaration AbstractTy]
smallerCtorArgs
  where
    smallerNumCtors :: [DataDeclaration AbstractTy]
    smallerNumCtors :: [DataDeclaration AbstractTy]
smallerNumCtors = Vector (DataDeclaration AbstractTy) -> [DataDeclaration AbstractTy]
forall a. Vector a -> [a]
Vector.toList (Vector (DataDeclaration AbstractTy)
 -> [DataDeclaration AbstractTy])
-> Vector (DataDeclaration AbstractTy)
-> [DataDeclaration AbstractTy]
forall a b. (a -> b) -> a -> b
$ (\Vector (Constructor AbstractTy)
cs -> TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
nm Count "tyvar"
cnt Vector (Constructor AbstractTy)
cs DataEncoding
strat) (Vector (Constructor AbstractTy) -> DataDeclaration AbstractTy)
-> Vector (Vector (Constructor AbstractTy))
-> Vector (DataDeclaration AbstractTy)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Vector (Constructor AbstractTy))
-> Vector (Vector (Constructor AbstractTy))
forall a. Vector a -> Vector a
Vector.init (Vector (Constructor AbstractTy)
-> Vector (Vector (Constructor AbstractTy))
forall a. Vector a -> Vector (Vector a)
subVectors Vector (Constructor AbstractTy)
ctors)
    smallerCtorArgs :: [DataDeclaration AbstractTy]
smallerCtorArgs = (\Vector (Constructor AbstractTy)
cs -> TyName
-> Count "tyvar"
-> Vector (Constructor AbstractTy)
-> DataEncoding
-> DataDeclaration AbstractTy
forall a.
TyName
-> Count "tyvar"
-> Vector (Constructor a)
-> DataEncoding
-> DataDeclaration a
DataDeclaration TyName
nm Count "tyvar"
cnt Vector (Constructor AbstractTy)
cs DataEncoding
strat) (Vector (Constructor AbstractTy) -> DataDeclaration AbstractTy)
-> [Vector (Constructor AbstractTy)]
-> [DataDeclaration AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Constructor AbstractTy)
-> [Vector (Constructor AbstractTy)]
shrinkCtorsNumArgs Vector (Constructor AbstractTy)
ctors

    -- need a fn which takes a single ctor and just shrinks the args
    -- this is difficult to keep track of: THIS ONE GIVES US IDENTICALLY NAMED CTORS WITH DIFFERENT ARG LISTS
    shrinkNumArgs :: Constructor AbstractTy -> [Constructor AbstractTy]
    shrinkNumArgs :: Constructor AbstractTy -> [Constructor AbstractTy]
shrinkNumArgs (Constructor ConstructorName
ctorNm Vector (ValT AbstractTy)
args) =
      let smallerArgs :: [Vector (ValT AbstractTy)]
          smallerArgs :: [Vector (ValT AbstractTy)]
smallerArgs = [Vector Concrete] -> [Vector (ValT AbstractTy)]
forall a b. Coercible a b => a -> b
coerce ([Vector Concrete] -> [Vector (ValT AbstractTy)])
-> [Vector Concrete] -> [Vector (ValT AbstractTy)]
forall a b. (a -> b) -> a -> b
$ Vector Concrete -> [Vector Concrete]
forall a. Arbitrary a => a -> [a]
shrink ((ValT AbstractTy -> Concrete)
-> Vector (ValT AbstractTy) -> Vector Concrete
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ValT AbstractTy -> Concrete
Concrete Vector (ValT AbstractTy)
args)
       in (Vector (ValT AbstractTy) -> Constructor AbstractTy)
-> [Vector (ValT AbstractTy)] -> [Constructor AbstractTy]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConstructorName
-> Vector (ValT AbstractTy) -> Constructor AbstractTy
forall a. ConstructorName -> Vector (ValT a) -> Constructor a
Constructor ConstructorName
ctorNm) [Vector (ValT AbstractTy)]
smallerArgs

    shrinkCtorsNumArgs :: Vector (Constructor AbstractTy) -> [Vector (Constructor AbstractTy)]
    shrinkCtorsNumArgs :: Vector (Constructor AbstractTy)
-> [Vector (Constructor AbstractTy)]
shrinkCtorsNumArgs Vector (Constructor AbstractTy)
cs =
      let -- the inner lists exhaust the arg-deletion possibilities for each constructor
          cs' :: [[Constructor AbstractTy]]
cs' = Vector [Constructor AbstractTy] -> [[Constructor AbstractTy]]
forall a. Vector a -> [a]
Vector.toList (Vector [Constructor AbstractTy] -> [[Constructor AbstractTy]])
-> Vector [Constructor AbstractTy] -> [[Constructor AbstractTy]]
forall a b. (a -> b) -> a -> b
$ Constructor AbstractTy -> [Constructor AbstractTy]
shrinkNumArgs (Constructor AbstractTy -> [Constructor AbstractTy])
-> Vector (Constructor AbstractTy)
-> Vector [Constructor AbstractTy]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Constructor AbstractTy)
cs
          go :: [[a]] -> [[a]]
go [] = []
          go ([a]
x : [[a]]
xs) = (:) (a -> [a] -> [a]) -> [a] -> [[a] -> [a]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
x [[a] -> [a]] -> [[a]] -> [[a]]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [[a]]
xs
       in [Constructor AbstractTy] -> Vector (Constructor AbstractTy)
forall a. [a] -> Vector a
Vector.fromList ([Constructor AbstractTy] -> Vector (Constructor AbstractTy))
-> [[Constructor AbstractTy]] -> [Vector (Constructor AbstractTy)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Constructor AbstractTy]] -> [[Constructor AbstractTy]]
forall {a}. [[a]] -> [[a]]
go [[Constructor AbstractTy]]
cs'

-- Helper, should probably exist in Data.Vector but doesn't
subVectors :: forall (a :: Type). Vector a -> Vector (Vector a)
subVectors :: forall a. Vector a -> Vector (Vector a)
subVectors Vector a
xs = Vector a -> Vector (Vector a) -> Vector (Vector a)
forall a. a -> Vector a -> Vector a
Vector.cons Vector a
forall a. Vector a
Vector.empty (Vector a -> Vector (Vector a)
forall a. Vector a -> Vector (Vector a)
nonEmptySubVectors Vector a
xs)

nonEmptySubVectors :: forall (a :: Type). Vector a -> Vector (Vector a)
nonEmptySubVectors :: forall a. Vector a -> Vector (Vector a)
nonEmptySubVectors Vector a
v = case Vector a -> Maybe (a, Vector a)
forall a. Vector a -> Maybe (a, Vector a)
Vector.uncons Vector a
v of
  Maybe (a, Vector a)
Nothing -> Vector (Vector a)
forall a. Vector a
Vector.empty
  Just (a
x, Vector a
xs) ->
    let f :: Vector a -> Vector (Vector a) -> Vector (Vector a)
        f :: Vector a -> Vector (Vector a) -> Vector (Vector a)
f Vector a
ys Vector (Vector a)
r = Vector a
ys Vector a -> Vector (Vector a) -> Vector (Vector a)
forall a. a -> Vector a -> Vector a
`Vector.cons` ((a
x a -> Vector a -> Vector a
forall a. a -> Vector a -> Vector a
`Vector.cons` Vector a
ys) Vector a -> Vector (Vector a) -> Vector (Vector a)
forall a. a -> Vector a -> Vector a
`Vector.cons` Vector (Vector a)
r)
     in a -> Vector a
forall a. a -> Vector a
Vector.singleton a
x Vector a -> Vector (Vector a) -> Vector (Vector a)
forall a. a -> Vector a -> Vector a
`Vector.cons` (Vector a -> Vector (Vector a) -> Vector (Vector a))
-> Vector (Vector a) -> Vector (Vector a) -> Vector (Vector a)
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Vector a -> Vector (Vector a) -> Vector (Vector a)
f Vector (Vector a)
forall a. Vector a
Vector.empty (Vector a -> Vector (Vector a)
forall a. Vector a -> Vector (Vector a)
nonEmptySubVectors Vector a
xs)

shrinkDataDecls :: [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls :: [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
shrinkDataDecls [DataDeclaration AbstractTy]
decls = (DataDeclaration AbstractTy -> [DataDeclaration AbstractTy])
-> [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
forall a. (a -> [a]) -> [a] -> [[a]]
forall (f :: Type -> Type) a.
Arbitrary1 f =>
(a -> [a]) -> f a -> [f a]
liftShrink DataDeclaration AbstractTy -> [DataDeclaration AbstractTy]
shrinkDataDecl [DataDeclaration AbstractTy]
decls [[DataDeclaration AbstractTy]]
-> [[DataDeclaration AbstractTy]] -> [[DataDeclaration AbstractTy]]
forall a. [a] -> [a] -> [a]
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (DataDeclaration AbstractTy -> [DataDeclaration AbstractTy]
shrinkDataDecl (DataDeclaration AbstractTy -> [DataDeclaration AbstractTy])
-> [DataDeclaration AbstractTy] -> [[DataDeclaration AbstractTy]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataDeclaration AbstractTy]
decls)

genDataList :: forall (a :: Type). DataGenM a -> Gen [a]
genDataList :: forall a. DataGenM a -> Gen [a]
genDataList = DataGenM [a] -> Gen [a]
forall a. DataGenM a -> Gen a
runDataGenM (DataGenM [a] -> Gen [a])
-> (DataGenM a -> DataGenM [a]) -> DataGenM a -> Gen [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataGenM a -> DataGenM [a]
forall (m :: Type -> Type) a. MonadGen m => m a -> m [a]
GT.listOf

-- ASG Stuff

-- | This is a @newtype@ over 'ASGBuilder' to clearly indicate that it should be used only for testing, as it is
-- useful to have a variant of the 'ASGBuilder' monad which has a \'runner\'.
--
-- @since 1.2.0
newtype DebugASGBuilder (a :: Type)
  = DebugASGBuilder (ReaderT ASGEnv (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity)) a)
  deriving
    ( -- | @since 1.0.0
      (forall a b. (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b)
-> (forall a b. a -> DebugASGBuilder b -> DebugASGBuilder a)
-> Functor DebugASGBuilder
forall a b. a -> DebugASGBuilder b -> DebugASGBuilder a
forall a b. (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
fmap :: forall a b. (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
$c<$ :: forall a b. a -> DebugASGBuilder b -> DebugASGBuilder a
<$ :: forall a b. a -> DebugASGBuilder b -> DebugASGBuilder a
Functor,
      -- | @since 1.0.0
      Functor DebugASGBuilder
Functor DebugASGBuilder =>
(forall a. a -> DebugASGBuilder a)
-> (forall a b.
    DebugASGBuilder (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b)
-> (forall a b c.
    (a -> b -> c)
    -> DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder c)
-> (forall a b.
    DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b)
-> (forall a b.
    DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder a)
-> Applicative DebugASGBuilder
forall a. a -> DebugASGBuilder a
forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder a
forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
forall a b.
DebugASGBuilder (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
forall a b c.
(a -> b -> c)
-> DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> DebugASGBuilder a
pure :: forall a. a -> DebugASGBuilder a
$c<*> :: forall a b.
DebugASGBuilder (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
<*> :: forall a b.
DebugASGBuilder (a -> b) -> DebugASGBuilder a -> DebugASGBuilder b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder c
liftA2 :: forall a b c.
(a -> b -> c)
-> DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder c
$c*> :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
*> :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
$c<* :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder a
<* :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder a
Applicative,
      -- | @since 1.0.0
      Applicative DebugASGBuilder
Applicative DebugASGBuilder =>
(forall a b.
 DebugASGBuilder a -> (a -> DebugASGBuilder b) -> DebugASGBuilder b)
-> (forall a b.
    DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b)
-> (forall a. a -> DebugASGBuilder a)
-> Monad DebugASGBuilder
forall a. a -> DebugASGBuilder a
forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
forall a b.
DebugASGBuilder a -> (a -> DebugASGBuilder b) -> DebugASGBuilder b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
DebugASGBuilder a -> (a -> DebugASGBuilder b) -> DebugASGBuilder b
>>= :: forall a b.
DebugASGBuilder a -> (a -> DebugASGBuilder b) -> DebugASGBuilder b
$c>> :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
>> :: forall a b.
DebugASGBuilder a -> DebugASGBuilder b -> DebugASGBuilder b
$creturn :: forall a. a -> DebugASGBuilder a
return :: forall a. a -> DebugASGBuilder a
Monad,
      -- | @since 1.1.0
      MonadReader ASGEnv,
      -- | @since 1.0.0
      MonadError CovenantTypeError,
      -- | @since 1.0.0
      MonadHashCons Id ASGNode
    )
    via ReaderT ASGEnv (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity))

-- | \'Runner\' for 'DebugASGBuilder'.
--
-- @since 1.2.0
debugASGBuilder ::
  forall (a :: Type).
  Map TyName (DatatypeInfo AbstractTy) ->
  DebugASGBuilder a ->
  Either CovenantError a
debugASGBuilder :: forall a.
Map TyName (DatatypeInfo AbstractTy)
-> DebugASGBuilder a -> Either CovenantError a
debugASGBuilder Map TyName (DatatypeInfo AbstractTy)
tyDict (DebugASGBuilder ReaderT
  ASGEnv
  (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity))
  a
comp) =
  case Identity (Either CovenantTypeError a, Bimap Id ASGNode)
-> (Either CovenantTypeError a, Bimap Id ASGNode)
forall a. Identity a -> a
runIdentity (Identity (Either CovenantTypeError a, Bimap Id ASGNode)
 -> (Either CovenantTypeError a, Bimap Id ASGNode))
-> (ASGEnv
    -> Identity (Either CovenantTypeError a, Bimap Id ASGNode))
-> ASGEnv
-> (Either CovenantTypeError a, Bimap Id ASGNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashConsT Id ASGNode Identity (Either CovenantTypeError a)
-> Identity (Either CovenantTypeError a, Bimap Id ASGNode)
forall r e (m :: Type -> Type) a.
HashConsT r e m a -> m (a, Bimap r e)
runHashConsT (HashConsT Id ASGNode Identity (Either CovenantTypeError a)
 -> Identity (Either CovenantTypeError a, Bimap Id ASGNode))
-> (ASGEnv
    -> HashConsT Id ASGNode Identity (Either CovenantTypeError a))
-> ASGEnv
-> Identity (Either CovenantTypeError a, Bimap Id ASGNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT CovenantTypeError (HashConsT Id ASGNode Identity) a
-> HashConsT Id ASGNode Identity (Either CovenantTypeError a)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity) a
 -> HashConsT Id ASGNode Identity (Either CovenantTypeError a))
-> (ASGEnv
    -> ExceptT CovenantTypeError (HashConsT Id ASGNode Identity) a)
-> ASGEnv
-> HashConsT Id ASGNode Identity (Either CovenantTypeError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  ASGEnv
  (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity))
  a
-> ASGEnv
-> ExceptT CovenantTypeError (HashConsT Id ASGNode Identity) a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  ASGEnv
  (ExceptT CovenantTypeError (HashConsT Id ASGNode Identity))
  a
comp (ASGEnv -> (Either CovenantTypeError a, Bimap Id ASGNode))
-> ASGEnv -> (Either CovenantTypeError a, Bimap Id ASGNode)
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> Map TyName (DatatypeInfo AbstractTy) -> ASGEnv
ASGEnv (Vector (Word32, Vector (ValT AbstractTy)) -> ScopeInfo
ScopeInfo Vector (Word32, Vector (ValT AbstractTy))
forall a. Vector a
Vector.empty) Map TyName (DatatypeInfo AbstractTy)
tyDict of
    (Either CovenantTypeError a
result, Bimap Id ASGNode
bm) -> case Either CovenantTypeError a
result of
      Left CovenantTypeError
err' -> CovenantError -> Either CovenantError a
forall a b. a -> Either a b
Left (CovenantError -> Either CovenantError a)
-> (CovenantTypeError -> CovenantError)
-> CovenantTypeError
-> Either CovenantError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bimap Id ASGNode -> CovenantTypeError -> CovenantError
TypeError Bimap Id ASGNode
bm (CovenantTypeError -> Either CovenantError a)
-> CovenantTypeError -> Either CovenantError a
forall a b. (a -> b) -> a -> b
$ CovenantTypeError
err'
      Right a
a -> a -> Either CovenantError a
forall a. a -> Either CovenantError a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

-- | Looks up the type of a node, wrapping computation node types into a thunk.
--
-- This is /only/ for use in testing!
--
-- @since 1.2.0
typeIdTest ::
  forall (m :: Type -> Type).
  (MonadHashCons Id ASGNode m, MonadError CovenantTypeError m) =>
  Id ->
  m (ValT AbstractTy)
typeIdTest :: forall (m :: Type -> Type).
(MonadHashCons Id ASGNode m, MonadError CovenantTypeError m) =>
Id -> m (ValT AbstractTy)
typeIdTest Id
i =
  Id -> m ASGNodeType
forall (m :: Type -> Type).
(MonadHashCons Id ASGNode m, MonadError CovenantTypeError m) =>
Id -> m ASGNodeType
typeId Id
i m ASGNodeType
-> (ASGNodeType -> m (ValT AbstractTy)) -> m (ValT AbstractTy)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ValNodeType ValT AbstractTy
t -> ValT AbstractTy -> m (ValT AbstractTy)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ValT AbstractTy
t
    -- FIXME: This is quick & dirty but I need it for something
    CompNodeType CompT AbstractTy
t -> ValT AbstractTy -> m (ValT AbstractTy)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ValT AbstractTy -> m (ValT AbstractTy))
-> ValT AbstractTy -> m (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ CompT AbstractTy -> ValT AbstractTy
forall a. CompT a -> ValT a
ThunkT CompT AbstractTy
t
    ASGNodeType
other -> [Char] -> m (ValT AbstractTy)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (ValT AbstractTy)) -> [Char] -> m (ValT AbstractTy)
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a ValT but got: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ASGNodeType -> [Char]
forall a. Show a => a -> [Char]
show ASGNodeType
other

-- For convenience. Don't remove this, necessary for efficient development on future work
unsafeRename :: forall (a :: Type). RenameM a -> a
unsafeRename :: forall a. RenameM a -> a
unsafeRename RenameM a
act = case Vector Word32 -> RenameM a -> Either RenameError a
forall a. Vector Word32 -> RenameM a -> Either RenameError a
runRenameM Vector Word32
forall a. Monoid a => a
mempty RenameM a
act of
  Left RenameError
err -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ RenameError -> [Char]
forall a. Show a => a -> [Char]
show RenameError
err
  Right a
res -> a
res

eitherT :: DataDeclaration AbstractTy
eitherT :: DataDeclaration AbstractTy
eitherT =
  DeclBuilder -> DataDeclaration AbstractTy
mkDecl (DeclBuilder -> DataDeclaration AbstractTy)
-> DeclBuilder -> DataDeclaration AbstractTy
forall a b. (a -> b) -> a -> b
$
    TyName
-> Count "tyvar" -> [CtorBuilder] -> DataEncoding -> DeclBuilder
Decl
      TyName
"Either"
      Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count2
      [ ConstructorName -> [ValT AbstractTy] -> CtorBuilder
Ctor ConstructorName
"Left" [AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
Z Index "tyvar"
forall (ofWhat :: Symbol). Index ofWhat
ix0)],
        ConstructorName -> [ValT AbstractTy] -> CtorBuilder
Ctor ConstructorName
"Right" [AbstractTy -> ValT AbstractTy
forall a. a -> ValT a
Abstraction (DeBruijn -> Index "tyvar" -> AbstractTy
BoundAt DeBruijn
Z Index "tyvar"
forall (ofWhat :: Symbol). Index ofWhat
ix1)]
      ]
      (PlutusDataStrategy -> DataEncoding
PlutusData PlutusDataStrategy
ConstrData)

unitT :: DataDeclaration AbstractTy
unitT :: DataDeclaration AbstractTy
unitT =
  DeclBuilder -> DataDeclaration AbstractTy
mkDecl (DeclBuilder -> DataDeclaration AbstractTy)
-> DeclBuilder -> DataDeclaration AbstractTy
forall a b. (a -> b) -> a -> b
$
    TyName
-> Count "tyvar" -> [CtorBuilder] -> DataEncoding -> DeclBuilder
Decl
      TyName
"Unit"
      Count "tyvar"
forall (ofWhat :: Symbol). Count ofWhat
count0
      [ConstructorName -> [ValT AbstractTy] -> CtorBuilder
Ctor ConstructorName
"Unit" []]
      (PlutusDataStrategy -> DataEncoding
PlutusData PlutusDataStrategy
ConstrData)

testDatatypes :: [DataDeclaration AbstractTy]
testDatatypes :: [DataDeclaration AbstractTy]
testDatatypes = [DataDeclaration AbstractTy
maybeT, DataDeclaration AbstractTy
eitherT, DataDeclaration AbstractTy
unitT, DataDeclaration AbstractTy
pair, DataDeclaration AbstractTy
list]