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