@@ -1,5 +1,6 @@
1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}
1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-}
22{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
34module ProjectM36.Base where
45import ProjectM36.DatabaseContextFunctionError
56import ProjectM36.AtomFunctionError
@@ -14,7 +15,7 @@ import Control.DeepSeq.Generics (genericRnf)
1415import GHC.Generics (Generic)
1516import qualified Data.Vector as V
1617import qualified Data.List as L
17−import Data.Text (Text,unpack)
18+import Data.Text (Text,unpack,pack)
1819import Data.Binary
1920import Data.Vector.Binary()
2021import Data.Time.Clock
@@ -23,6 +24,14 @@ import Data.Time.Calendar (Day,toGregorian,fromGregorian)
2324import Data.Hashable.Time ()
2425import Data.Typeable
2526import Data.ByteString (ByteString)
27+--for generating arbitrary tuples
28+import Test.QuickCheck
29+import Test.QuickCheck.Gen
30+import Test.QuickCheck.Random
31+import Test.QuickCheck.Arbitrary.ADT
32+import qualified Data.ByteString.Char8 as B
33+import Data.Time
34+import Data.Time.Clock
2635
2736type StringType = Text
2837
@@ -336,12 +345,13 @@ data DatabaseContextExpr =
336345
337346type ObjModuleName = StringType
338347type ObjFunctionName = StringType
339−
348+type Range = (Int,Int)
340349-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.
341350data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |
342351 LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |
343352 AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |
344− LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath
353+ LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |
354+ CreateArbitraryRelation RelVarName [AttributeExpr] Range
345355 deriving (Show, Eq, Generic, Binary)
346356
347357type RestrictionPredicateExpr = RestrictionPredicateExprBase ()
@@ -568,3 +578,84 @@ atomTypeVars (IntervalAtomType aType) = atomTypeVars aType
568578atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))
569579atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap
570580atomTypeVars (TypeVariableType nam) = S.singleton nam
581+
582+-- for creating arbitrary relations
583+
584+arbitrary' :: AtomType -> Gen Atom
585+arbitrary' IntegerAtomType = IntegerAtom <$> (arbitrary :: Gen Integer)
586+arbitrary' IntAtomType = IntAtom <$> (arbitrary :: Gen Int)
587+arbitrary' DoubleAtomType = DoubleAtom <$> (arbitrary :: Gen Double)
588+arbitrary' TextAtomType = TextAtom <$> (arbitrary :: Gen Text)
589+arbitrary' DayAtomType = DayAtom <$> (arbitrary :: Gen Day)
590+arbitrary' DateTimeAtomType = DateTimeAtom <$> (arbitrary :: Gen UTCTime)
591+arbitrary' BoolAtomType = BoolAtom <$> (arbitrary :: Gen Bool)
592+arbitrary' (IntervalAtomType atomTy) = IntervalAtom <$> (arbitrary' atomTy) <*> (arbitrary' atomTy) <*> arbitrary <*> arbitrary
593+arbitrary' (RelationAtomType attrs) = arbitraryRel attrs (0,10)
594+arbitrary' (ConstructedAtomType tcname tvmap) = undefined -- ConstructedAtom DataConstructorName AtomType [Atom]
595+--arbitrary' (ConstructedAtomType tcname tvmap) = do
596+arbitrary' (TypeVariableType tvname) = undefined
597+
598+instance Arbitrary Text where
599+ arbitrary = pack <$> elements ["Mary", "Johnny", "Sunny", "Ted"]
600+
601+instance Arbitrary Day where
602+ arbitrary = ModifiedJulianDay <$> (arbitrary :: Gen Integer)
603+
604+instance Arbitrary Attribute where
605+ arbitrary = genericArbitrary
606+
607+instance (Arbitrary a) => Arbitrary (V.Vector a) where
608+ arbitrary = do
609+ maxbound <- choose (0,5)
610+ V.fromList <$> vectorOf maxbound arbitrary
611+
612+--not sure what's use on this one
613+instance {-# OVERLAPPING #-} Arbitrary TypeVarMap where
614+ arbitrary = undefined
615+
616+instance Arbitrary UTCTime where
617+ arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose(0,86400))
618+
619+instance Arbitrary B.ByteString where
620+ arbitrary = B.pack <$> (arbitrary :: Gen String)
621+
622+defAttributeNames = ["Number","People","Time","Thing"]
623+defAtomtypes = [IntAtomType, TextAtomType, DayAtomType, TextAtomType]
624+defAttributes = V.fromList $ zipWith Attribute defAttributeNames defAtomtypes
625+
626+{-
627+instance Arbitrary RelationTuple where
628+ arbitrary = do
629+ a <- IntAtom <$> (arbitrary :: Gen Int)
630+ b <- TextAtom <$> (arbitrary :: Gen Text)
631+ c <- DayAtom <$> (arbitrary :: Gen Day)
632+ d <- TextAtom <$> (arbitrary :: Gen Text)
633+ let sample = V.fromList [a,b,c,d]
634+ return $ RelationTuple defAttributes sample
635+
636+instance Arbitrary Relation where
637+ arbitrary = do
638+ list <- listOf (arbitrary :: Gen RelationTuple)
639+ return $ Relation defAttributes (RelationTupleSet list)
640+-}
641+
642+arbitraryRelationTuple attris = do
643+ let attrisG = V.fromList <$> mapM (arbitrary' . atomType') (V.toList attris)
644+ RelationTuple attris <$> attrisG
645+
646+arbitraryRel attris range@(min,max) = do
647+ num <- choose (min,max)
648+ let tupleListG = vectorOf num (arbitraryRelationTuple attris)
649+ Relation attris <$> (RelationTupleSet <$> tupleListG)
650+
651+instance Arbitrary AtomType where
652+ arbitrary = genericArbitrary
653+
654+instance Arbitrary Atom where
655+ arbitrary = genericArbitrary
656+
657+instance ToADTArbitrary Atom
658+
659+atomType' :: Attribute -> AtomType
660+atomType' (Attribute _ atype) = atype
661+>>>>>>> feature/arbitrary_tupleset-deprecated