@@ -4,9 +4,11 @@
44module ProjectM36.Arbitrary where
55import ProjectM36.Base
66import ProjectM36.Error
7+import ProjectM36.AtomFunctionError
78import ProjectM36.AtomType
89import ProjectM36.Attribute (atomType)
910import ProjectM36.DataConstructorDef as DCD
11+import ProjectM36.DataTypes.Interval
1012import qualified Data.Vector as V
1113import Data.Text (Text,pack)
1214import Test.QuickCheck
@@ -45,7 +47,10 @@ arbitrary' ByteStringAtomType =
4547
4648arbitrary' BoolAtomType =
4749 Right . BoolAtom <$> lift (arbitrary :: Gen Bool)
48−arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) = do
50+arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap)
51+ --special-casing for Interval type
52+ | isIntervalAtomType constructedAtomType = createArbitraryInterval (intervalSubType constructedAtomType)
53+ | otherwise = do
4954 tcMap <- ask
5055 let maybeTCons = findTypeConstructor tcName tcMap
5156 let eitherTCons = maybeToRight (NoSuchTypeConstructorName tcName) maybeTCons
@@ -108,3 +113,21 @@ arbitraryRelation attris range = do
108113 Right tupleList -> pure $ Right $ Relation attris $ RelationTupleSet tupleList
109114
110115type WithTCMap a = ReaderT TypeConstructorMapping a
116+
117+createArbitraryInterval :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
118+createArbitraryInterval subType = if supportsInterval subType then do
119+ eBegin <- arbitrary' subType
120+ eEnd <- arbitrary' subType
121+ beginopen <- lift (arbitrary :: Gen Bool)
122+ endopen <- lift (arbitrary :: Gen Bool)
123+ case eBegin of
124+ Left err -> pure (Left err)
125+ Right begin ->
126+ case eEnd of
127+ Left err -> pure (Left err)
128+ Right end ->
129+ case createInterval begin end beginopen endopen of
130+ Left _ -> createArbitraryInterval subType
131+ Right val -> pure (Right val)
132+ else
133+ pure $ Left (ProjectM36.Error.AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError (prettyAtomType subType)))