@@ -0,0 +1,129 @@
1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module ProjectM36.Arbitrary where
5+import ProjectM36.Base
6+import ProjectM36.Error
7+import ProjectM36.AtomType
8+import ProjectM36.Attribute (atomType)
9+import ProjectM36.DataConstructorDef as DCD
10+import qualified Data.Vector as V
11+import Data.Text (Text,pack)
12+import Test.QuickCheck
13+import qualified Data.ByteString.Char8 as B
14+import Data.Time
15+import Control.Monad.Reader
16+
17+arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom)
18+arbitrary' IntegerAtomType = do
19+ i <- lift (arbitrary :: Gen Integer)
20+ pure $ Right $ IntegerAtom i
21+
22+arbitrary' (RelationAtomType attrs) = do
23+ tcMap <-ask
24+ maybeRel <- lift $ runReaderT (arbitraryRelation attrs (0,5)) tcMap
25+ case maybeRel of
26+ Left err -> pure $ Left err
27+ Right rel -> pure $ Right $ RelationAtom rel
28+
29+arbitrary' IntAtomType = do
30+ i <- lift (arbitrary :: Gen Int)
31+ pure $ Right $ IntAtom i
32+
33+arbitrary' DoubleAtomType = do
34+ i <- lift (arbitrary :: Gen Double)
35+ pure $ Right $ DoubleAtom i
36+
37+arbitrary' TextAtomType = do
38+ i <- lift (arbitrary :: Gen Text)
39+ pure $ Right $ TextAtom i
40+
41+arbitrary' DayAtomType = do
42+ i <- lift (arbitrary :: Gen Day)
43+ pure $ Right $ DayAtom i
44+
45+arbitrary' DateTimeAtomType = do
46+ i <- lift (arbitrary :: Gen UTCTime)
47+ pure $ Right $ DateTimeAtom i
48+
49+arbitrary' ByteStringAtomType = do
50+ bs <- lift (arbitrary :: Gen B.ByteString)
51+ pure $ Right $ ByteStringAtom bs
52+
53+arbitrary' BoolAtomType = do
54+ i <- lift (arbitrary :: Gen Bool)
55+ pure $ Right $ BoolAtom i
56+
57+arbitrary' (IntervalAtomType atomTy) = do
58+ tcMap <- ask
59+ eitherAtomType <- lift $ runReaderT (arbitrary' atomTy) tcMap
60+ case eitherAtomType of
61+ Left err -> pure $ Left err
62+ Right atomType' -> do
63+ a <- lift $ (arbitrary :: Gen Bool)
64+ b <- lift $ (arbitrary :: Gen Bool)
65+ pure $ Right $ IntervalAtom atomType' atomType' a b
66+
67+arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) = do
68+ tcMap <- ask
69+ let maybeTCons = findTypeConstructor tcName tcMap
70+ let eitherTCons = maybeToRight (NoSuchTypeConstructorName tcName) maybeTCons
71+ let eitherDCDefs = snd <$> eitherTCons
72+ let eitherGenDCDef = elements <$> eitherDCDefs
73+ case eitherGenDCDef of
74+ Left err -> pure $ Left err
75+ Right genDCDef -> do
76+ dcDef <- lift $ genDCDef
77+ case resolvedAtomTypesForDataConstructorDefArgs tcMap tvMap dcDef of
78+ Left err -> pure $ Left err
79+ Right atomTypes -> do
80+ let genListOfEitherAtom = mapM (\aTy->runReaderT (arbitrary' aTy) tcMap) atomTypes
81+ listOfEitherAtom <- lift genListOfEitherAtom
82+ let eitherListOfAtom = sequence listOfEitherAtom
83+ case eitherListOfAtom of
84+ Left err -> pure $ Left err
85+ Right listOfAtom -> pure $ Right $ ConstructedAtom (DCD.name dcDef) constructedAtomType listOfAtom
86+arbitrary' (TypeVariableType _) = error "arbitrary on type variable"
87+
88+maybeToRight :: b -> Maybe a -> Either b a
89+maybeToRight _ (Just x) = Right x
90+maybeToRight y Nothing = Left y
91+
92+instance Arbitrary Text where
93+ arbitrary = pack <$> elements ["Mary", "Johnny", "Sunny", "Ted"]
94+
95+instance Arbitrary Day where
96+ arbitrary = ModifiedJulianDay <$> (arbitrary :: Gen Integer)
97+
98+instance Arbitrary UTCTime where
99+ arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose(0,86400))
100+
101+instance Arbitrary B.ByteString where
102+ arbitrary = B.pack <$> (arbitrary :: Gen String)
103+
104+arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)
105+arbitraryRelationTuple attris = do
106+ tcMap <- ask
107+ listOfMaybeAType <- lift $ sequence $ map ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)
108+ case sequence listOfMaybeAType of
109+ Left err -> pure $ Left err
110+ Right listOfAttr -> do
111+ let vectorOfAttr = V.fromList listOfAttr
112+ pure $ Right $ RelationTuple attris vectorOfAttr
113+
114+arbitraryWithRange :: Gen (Either RelationalError RelationTuple) -> Range -> Gen [Either RelationalError RelationTuple]
115+arbitraryWithRange genEitherTuple range = do
116+ num <- choose range
117+ vectorOf num genEitherTuple
118+
119+arbitraryRelation :: Attributes -> Range -> WithTCMap Gen (Either RelationalError Relation)
120+arbitraryRelation attris range = do
121+ tcMap <- ask
122+ let genEitherTuple = runReaderT (arbitraryRelationTuple attris) tcMap
123+ listOfEitherTuple <- lift $ arbitraryWithRange genEitherTuple range
124+ let eitherTupleList = sequence listOfEitherTuple
125+ case eitherTupleList of
126+ Left err -> pure $ Left err
127+ Right tupleList -> pure $ Right $ Relation attris $ RelationTupleSet tupleList
128+
129+type WithTCMap a = ReaderT TypeConstructorMapping a