{-# LANGUAGE ExistentialQuantification,FlexibleInstances,OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module ProjectM36.Arbitrary where
import ProjectM36.Base
import qualified ProjectM36.Attribute as A
import ProjectM36.Error
import ProjectM36.AtomFunctionError
import ProjectM36.AtomType
import ProjectM36.Attribute (atomType)
import ProjectM36.DataConstructorDef as DCD
import ProjectM36.DataTypes.Interval
import ProjectM36.Relation
import qualified Data.Vector as V
import Data.Text (Text)
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import qualified Data.ByteString.Char8 as B
import Data.Time
import Control.Monad.Reader
import Data.UUID
import Data.Scientific

arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' AtomType
IntegerAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Atom
IntegerAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Integer)

arbitrary' AtomType
ScientificAtomType =
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Atom
ScientificAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Scientific)

arbitrary' (RelationAtomType Attributes
attrs)  = do
  TypeConstructorMapping
tcMap <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Either RelationalError Relation
maybeRel <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Attributes
-> Range
-> ReaderT
     TypeConstructorMapping Gen (Either RelationalError Relation)
arbitraryRelation Attributes
attrs (Int
0,Int
5)) TypeConstructorMapping
tcMap
  case Either RelationalError Relation
maybeRel of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
    Right Relation
rel -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Relation -> Atom
RelationAtom Relation
rel

arbitrary' (SubrelationFoldAtomType AtomType
typ) = do
  TypeConstructorMapping
tcMap <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Either RelationalError Relation
maybeRel <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Attributes
-> Range
-> ReaderT
     TypeConstructorMapping Gen (Either RelationalError Relation)
arbitraryRelation ([Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"a" AtomType
typ]) (Int
0,Int
5)) TypeConstructorMapping
tcMap
  case Either RelationalError Relation
maybeRel of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
    Right Relation
rel -> do
      AttributeName
anAttr <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen a
elements (Attributes -> [AttributeName]
A.attributeNamesList (Relation -> Attributes
attributes Relation
rel))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (Relation -> AttributeName -> Atom
SubrelationFoldAtom Relation
rel AttributeName
anAttr))

arbitrary' AtomType
IntAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Atom
IntAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Int)

arbitrary' AtomType
DoubleAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Atom
DoubleAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Double)

arbitrary' AtomType
TextAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeName -> Atom
TextAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Text)

arbitrary' AtomType
DayAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Atom
DayAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Day)

arbitrary' AtomType
DateTimeAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Atom
DateTimeAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen UTCTime)
  
arbitrary' AtomType
ByteStringAtomType =
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Atom
ByteStringAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen B.ByteString)

arbitrary' AtomType
BoolAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Atom
BoolAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Bool)

arbitrary' AtomType
UUIDAtomType = 
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Atom
UUIDAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen UUID)

arbitrary' AtomType
RelationalExprAtomType =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (RelationalExpr -> Atom
RelationalExprAtom (forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
relationTrue))) -- don't bother with arbitrary relational expressions

arbitrary' constructedAtomType :: AtomType
constructedAtomType@(ConstructedAtomType AttributeName
tcName TypeVarMap
tvMap)
  --special-casing for Interval type
  | AtomType -> Bool
isIntervalAtomType AtomType
constructedAtomType = AtomType -> WithTCMap Gen (Either RelationalError Atom)
createArbitraryInterval (AtomType -> AtomType
intervalSubType AtomType
constructedAtomType)
  | Bool
otherwise = do 
  TypeConstructorMapping
tcMap <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let maybeTCons :: Maybe (TypeConstructorDef, [DataConstructorDef])
maybeTCons = AttributeName
-> TypeConstructorMapping
-> Maybe (TypeConstructorDef, [DataConstructorDef])
findTypeConstructor AttributeName
tcName TypeConstructorMapping
tcMap
  let eitherTCons :: Either RelationalError (TypeConstructorDef, [DataConstructorDef])
eitherTCons = forall b a. b -> Maybe a -> Either b a
maybeToRight (AttributeName -> RelationalError
NoSuchTypeConstructorName AttributeName
tcName) Maybe (TypeConstructorDef, [DataConstructorDef])
maybeTCons
  let eitherDCDefs :: Either RelationalError [DataConstructorDef]
eitherDCDefs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either RelationalError (TypeConstructorDef, [DataConstructorDef])
eitherTCons
  let eitherGenDCDef :: Either RelationalError (Gen DataConstructorDef)
eitherGenDCDef = forall a. [a] -> Gen a
elements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either RelationalError [DataConstructorDef]
eitherDCDefs
  case Either RelationalError (Gen DataConstructorDef)
eitherGenDCDef of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
    Right Gen DataConstructorDef
genDCDef -> do
      DataConstructorDef
dcDef <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen DataConstructorDef
genDCDef
      case TypeConstructorMapping
-> TypeVarMap
-> DataConstructorDef
-> Either RelationalError [AtomType]
resolvedAtomTypesForDataConstructorDefArgs TypeConstructorMapping
tcMap TypeVarMap
tvMap DataConstructorDef
dcDef of
        Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
        Right [AtomType]
atomTypes -> do
          let genListOfEitherAtom :: Gen [Either RelationalError Atom]
genListOfEitherAtom = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\AtomType
aTy->forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' AtomType
aTy) TypeConstructorMapping
tcMap) [AtomType]
atomTypes
          [Either RelationalError Atom]
listOfEitherAtom <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen [Either RelationalError Atom]
genListOfEitherAtom
          let eitherListOfAtom :: Either RelationalError [Atom]
eitherListOfAtom = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either RelationalError Atom]
listOfEitherAtom
          case Either RelationalError [Atom]
eitherListOfAtom of 
            Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
            Right [Atom]
listOfAtom -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ AttributeName -> AtomType -> [Atom] -> Atom
ConstructedAtom (DataConstructorDef -> AttributeName
DCD.name DataConstructorDef
dcDef) AtomType
constructedAtomType [Atom]
listOfAtom
arbitrary' (TypeVariableType AttributeName
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"arbitrary on type variable"

maybeToRight :: b -> Maybe a -> Either b a
maybeToRight :: forall b a. b -> Maybe a -> Either b a
maybeToRight b
_ (Just a
x) = forall a b. b -> Either a b
Right a
x
maybeToRight b
y Maybe a
Nothing  = forall a b. a -> Either a b
Left b
y

arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)
arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)
arbitraryRelationTuple Attributes
attris = do
  TypeConstructorMapping
tcMap <- forall r (m :: * -> *). MonadReader r m => m r
ask
  [Either RelationalError Atom]
listOfMaybeAType <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\AtomType
aTy -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' AtomType
aTy) TypeConstructorMapping
tcMap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> AtomType
atomType) (forall a. Vector a -> [a]
V.toList (Attributes -> Vector Attribute
attributesVec Attributes
attris))
  case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either RelationalError Atom]
listOfMaybeAType of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
    Right [Atom]
listOfAttr -> do
      let vectorOfAttr :: Vector Atom
vectorOfAttr = forall a. [a] -> Vector a
V.fromList [Atom]
listOfAttr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attris Vector Atom
vectorOfAttr

arbitraryWithRange :: Gen (Either RelationalError RelationTuple) -> Range -> Gen [Either RelationalError RelationTuple]
arbitraryWithRange :: Gen (Either RelationalError RelationTuple)
-> Range -> Gen [Either RelationalError RelationTuple]
arbitraryWithRange Gen (Either RelationalError RelationTuple)
genEitherTuple Range
range = do
  Int
num <- forall a. Random a => (a, a) -> Gen a
choose Range
range
  forall a. Int -> Gen a -> Gen [a]
vectorOf Int
num Gen (Either RelationalError RelationTuple)
genEitherTuple

arbitraryRelation :: Attributes -> Range -> WithTCMap Gen (Either RelationalError Relation)
arbitraryRelation :: Attributes
-> Range
-> ReaderT
     TypeConstructorMapping Gen (Either RelationalError Relation)
arbitraryRelation Attributes
attris Range
range = do
  TypeConstructorMapping
tcMap <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let genEitherTuple :: Gen (Either RelationalError RelationTuple)
genEitherTuple = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)
arbitraryRelationTuple Attributes
attris) TypeConstructorMapping
tcMap
  [Either RelationalError RelationTuple]
listOfEitherTuple <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Gen (Either RelationalError RelationTuple)
-> Range -> Gen [Either RelationalError RelationTuple]
arbitraryWithRange Gen (Either RelationalError RelationTuple)
genEitherTuple Range
range
  let eitherTupleList :: Either RelationalError [RelationTuple]
eitherTupleList = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either RelationalError RelationTuple]
listOfEitherTuple
  case Either RelationalError [RelationTuple]
eitherTupleList of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left RelationalError
err
    Right [RelationTuple]
tupleList ->  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
attris forall a b. (a -> b) -> a -> b
$ [RelationTuple] -> RelationTupleSet
RelationTupleSet [RelationTuple]
tupleList

type WithTCMap a = ReaderT TypeConstructorMapping a 

createArbitraryInterval :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
createArbitraryInterval :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
createArbitraryInterval AtomType
subType = if AtomType -> Bool
supportsInterval AtomType
subType then do
  Either RelationalError Atom
eBegin <- AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' AtomType
subType
  Either RelationalError Atom
eEnd <- AtomType -> WithTCMap Gen (Either RelationalError Atom)
arbitrary' AtomType
subType
  Bool
beginopen <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Bool)
  Bool
endopen <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen Bool)
  case Either RelationalError Atom
eBegin of
    Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
    Right Atom
begin -> 
      case Either RelationalError Atom
eEnd of
        Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
        Right Atom
end -> 
          case Atom -> Atom -> Bool -> Bool -> Either AtomFunctionError Atom
createInterval Atom
begin Atom
end Bool
beginopen Bool
endopen of
            Left AtomFunctionError
_ -> AtomType -> WithTCMap Gen (Either RelationalError Atom)
createArbitraryInterval AtomType
subType
            Right Atom
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right Atom
val)
  else
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (AtomFunctionError -> RelationalError
ProjectM36.Error.AtomFunctionUserError (AttributeName -> AtomFunctionError
AtomTypeDoesNotSupportIntervalError (AtomType -> AttributeName
prettyAtomType AtomType
subType)))