890fb96 · project-m36 · git.iko.soy

git.iko.soy/project-m36

I acccidentally merge it with an old upstream branch. When I try to merge with new one. It asks me commit first.

commit890fb9643f44d4a4363910820f1a52ddd6f0e1d9 authorJohnny Liao <dycan0716@gmail.com> dateSun 3 Jun 2018, 05:55 (8 years ago) parent32563be 02c5d25

7 files changed+119−48

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+4−5 src/lib/ProjectM36/Arbitrary.hs+22−36 src/lib/ProjectM36/Attribute.hs−1 src/lib/ProjectM36/Base.hs+73−1 src/lib/ProjectM36/DataTypes/Interval.hs+8−1 src/lib/ProjectM36/RelationalExpression.hs+2−2 test/TutorialD/Interpreter.hs+10−2

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+4−5

@@ -4,7 +4,6 @@ import ProjectM36.Base

55import TutorialD.Interpreter.Base

66import TutorialD.Interpreter.Types

7−import TutorialD.Interpreter.RelationalExpr

87import Text.Megaparsec

98import Text.Megaparsec.Text

109import Data.Text

@@ -21,10 +20,10 @@ createArbitraryRelationP = do

2120 reserved "createarbitraryrelation"

2221 relVarName <- identifier

2322 attrExprs <- makeAttributeExprsP :: Parser [AttributeExpr]

24− min <- fromInteger <$> integer

25− symbol "-"

26− max <- fromInteger <$> integer

27− pure $ CreateArbitraryRelation relVarName attrExprs (min,max)

23+ min' <- fromInteger <$> integer

24+ _ <- symbol "-"

25+ max' <- fromInteger <$> integer

26+ pure $ CreateArbitraryRelation relVarName attrExprs (min',max')

2827

2928dbioexprP :: String -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr

3029dbioexprP res adt = do

src/lib/ProjectM36/Arbitrary.hs+22−36

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-}

1+{-# LANGUAGE ExistentialQuantification,FlexibleInstances,OverloadedStrings #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

44module ProjectM36.Arbitrary where

@@ -7,27 +7,16 @@ import ProjectM36.Error

77import ProjectM36.AtomType

88import ProjectM36.Attribute (atomType,attributeName)

99import ProjectM36.DataConstructorDef as DCD

10−import qualified Data.Map as M

11−import qualified Data.Set as S

1210import qualified Data.Vector as V

13−import qualified Data.List as L

14−import Data.Text (Text,unpack,pack)

11+import Data.Text (Text,pack)

1512import Test.QuickCheck

16−import Test.QuickCheck.Gen

17−import Test.QuickCheck.Random

18−import Test.QuickCheck.Arbitrary

1913import qualified Data.ByteString.Char8 as B

2014import Data.Time

21−import Data.Time.Clock

22−import Debug.Trace

2315import Control.Monad.Reader

24−import Data.Either

25−import Data.Either.Combinators

2616

2717arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom)

28−arbitrary' IntegerAtomType = do

29− i <- lift (arbitrary :: Gen Integer)

30− pure $ Right $ IntegerAtom i

18+arbitrary' IntegerAtomType =

19+ Right . IntegerAtom <$> lift (arbitrary :: Gen Integer)

3120

3221arbitrary' (RelationAtomType attrs) = do

3322 tcMap <-ask

@@ -36,29 +25,26 @@ arbitrary' (RelationAtomType attrs) = do

3625 Left err -> pure $ Left err

3726 Right rel -> pure $ Right $ RelationAtom rel

3827

39−arbitrary' IntAtomType = do

40− i <- lift (arbitrary :: Gen Int)

41− pure $ Right $ IntAtom i

28+arbitrary' IntAtomType =

29+ Right . IntAtom <$> lift (arbitrary :: Gen Int)

4230

43−arbitrary' DoubleAtomType = do

44− i <- lift (arbitrary :: Gen Double)

45− pure $ Right $ DoubleAtom i

31+arbitrary' DoubleAtomType =

32+ Right . DoubleAtom <$> lift (arbitrary :: Gen Double)

4633

47−arbitrary' TextAtomType = do

48− i <- lift (arbitrary :: Gen Text)

49− pure $ Right $ TextAtom i

34+arbitrary' TextAtomType =

35+ Right . TextAtom <$> lift (arbitrary :: Gen Text)

5036

51−arbitrary' DayAtomType = do

52− i <- lift (arbitrary :: Gen Day)

53− pure $ Right $ DayAtom i

37+arbitrary' DayAtomType =

38+ Right . DayAtom <$> lift (arbitrary :: Gen Day)

5439

55−arbitrary' DateTimeAtomType = do

56− i <- lift (arbitrary :: Gen UTCTime)

57− pure $ Right $ DateTimeAtom i

40+arbitrary' DateTimeAtomType =

41+ Right . DateTimeAtom <$> lift (arbitrary :: Gen UTCTime)

42+

43+arbitrary' ByteStringAtomType =

44+ Right . ByteStringAtom <$> lift (arbitrary :: Gen B.ByteString)

5845

59−arbitrary' BoolAtomType = do

60− i <- lift (arbitrary :: Gen Bool)

61− pure $ Right $ BoolAtom i

46+arbitrary' BoolAtomType =

47+ Right . BoolAtom <$> lift (arbitrary :: Gen Bool)

6248

6349arbitrary' (IntervalAtomType atomTy) = do

6450 tcMap <- ask

@@ -81,7 +67,7 @@ arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) = do

8167 case eitherGenDCDef of

8268 Left err -> pure $ Left err

8369 Right genDCDef -> do

84− dcDef <- lift $ genDCDef

70+ dcDef <- lift genDCDef

8571 case resolvedAtomTypesForDataConstructorDefArgs tcMap tvMap dcDef of

8672 Left err -> pure $ Left err

8773 Right atomTypes -> do

@@ -91,7 +77,7 @@ arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) = do

9177 case eitherListOfAtom of

9278 Left err -> pure $ Left err

9379 Right listOfAtom -> pure $ Right $ ConstructedAtom (DCD.name dcDef) constructedAtomType listOfAtom

94−arbitrary' (TypeVariableType tvName) = undefined

80+arbitrary' (TypeVariableType _) = error "arbitrary on type variable"

9581

9682maybeToRight :: b -> Maybe a -> Either b a

9783maybeToRight _ (Just x) = Right x

@@ -112,7 +98,7 @@ instance Arbitrary B.ByteString where

11298arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)

11399arbitraryRelationTuple attris = do

114100 tcMap <- ask

115− listOfMaybeAType <- lift $ sequence $ map ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)

101+ listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)

116102 case sequence listOfMaybeAType of

117103 Left err -> pure $ Left err

118104 Right listOfAttr -> do

src/lib/ProjectM36/Attribute.hs−1

@@ -153,4 +153,3 @@ intersection :: Attributes -> Attributes -> Attributes

153153intersection attrsA attrsB = V.fromList (M.elems intersected)

154154 where

155155 intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

156−

src/lib/ProjectM36/Base.hs+73−1

@@ -531,6 +531,79 @@ instance Hashable DatabaseContextFunction where

531531instance Eq DatabaseContextFunction where

532532 f1 == f2 = dbcFuncName f1 == dbcFuncName f2

533533

534+{-

535+-- for creating arbitrary tuples

536+instance Arbitrary Text where

537+ arbitrary = pack <$> elements ["Mary", "Johnny", "Sunny", "Ted"]

538+

539+instance Arbitrary Day where

540+ arbitrary = ModifiedJulianDay <$> (arbitrary :: Gen Integer)

541+

542+instance Arbitrary Attribute where

543+ arbitrary = genericArbitrary

544+

545+instance (Arbitrary a) => Arbitrary (V.Vector a) where

546+ arbitrary = do

547+ maxbound <- choose (0,5)

548+ V.fromList <$> vectorOf maxbound arbitrary

549+

550+--not sure what's use on this one

551+instance {-# OVERLAPPING #-} Arbitrary TypeVarMap where

552+ arbitrary = undefined

553+

554+instance Arbitrary UTCTime where

555+ arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> arbitrary)

556+

557+instance Arbitrary B.ByteString where

558+ arbitrary = B.pack <$> (arbitrary :: Gen String)

559+

560+defAttributeNames = ["Number","People","Time","Thing"]

561+defAtomtypes = [IntAtomType, TextAtomType, DayAtomType, TextAtomType]

562+defAttributes = V.fromList $ zipWith Attribute defAttributeNames defAtomtypes

563+

564+instance Arbitrary RelationTuple where

565+ arbitrary = do

566+ a <- IntAtom <$> (arbitrary :: Gen Int)

567+ b <- TextAtom <$> (arbitrary :: Gen Text)

568+ c <- DayAtom <$> (arbitrary :: Gen Day)

569+ d <- TextAtom <$> (arbitrary :: Gen Text)

570+ let sample = V.fromList [a,b,c,d]

571+ return $ RelationTuple defAttributes sample

572+

573+instance Arbitrary Relation where

574+ arbitrary = do

575+ list <- listOf (arbitrary :: Gen RelationTuple)

576+ return $ Relation defAttributes (RelationTupleSet list)

577+

578+arbitraryRelationTuple attris = do

579+ let attrisG = V.fromList <$> mapM (arbitrary'.getAtomType) (V.toList attris)

580+ RelationTuple attris <$> attrisG

581+

582+arbitraryRel attris bound@(min,max) = do

583+ num <- choose (min,max)

584+ let tupleListG = vectorOf num (arbitraryRelationTuple attris)

585+ Relation attris <$> (RelationTupleSet <$> tupleListG)

586+

587+instance Arbitrary AtomType where

588+ arbitrary = genericArbitrary

589+

590+instance Arbitrary Atom where

591+ arbitrary = genericArbitrary

592+

593+instance ToADTArbitrary Atom

594+

595+arbitrary' :: AtomType -> Gen Atom

596+arbitrary' IntAtomType = IntAtom <$> (arbitrary :: Gen Int)

597+arbitrary' IntegerAtomType = IntegerAtom <$> (arbitrary :: Gen Integer)

598+arbitrary' TextAtomType = TextAtom <$> (arbitrary :: Gen Text)

599+arbitrary' DayAtomType = DayAtom <$> (arbitrary :: Gen Day)

600+arbitrary' BoolAtomType = BoolAtom <$> (arbitrary :: Gen Bool)

601+arbitrary' _ = undefined

602+

603+getAtomType :: Attribute -> AtomType

604+getAtomType (Attribute _ atomType) = atomType

605+-}

606+

534607attrTypeVars :: Attribute -> S.Set TypeVarName

535608attrTypeVars (Attribute _ aType) = case aType of

536609 IntAtomType -> S.empty

@@ -570,4 +643,3 @@ atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList att

570643atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

571644atomTypeVars (TypeVariableType nam) = S.singleton nam

572645

573−

src/lib/ProjectM36/DataTypes/Interval.hs+8−1

@@ -106,4 +106,11 @@ intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAto

106106intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError

107107

108108intervalTypeConstructorMapping :: TypeConstructorMapping

109−intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]

109+--intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]

110+intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"],

111+ [DataConstructorDef "Interval" [DataConstructorDefTypeVarNameArg "a",

112+ DataConstructorDefTypeVarNameArg "a",

113+ ]])

114+ ]

115+

116+

src/lib/ProjectM36/RelationalExpression.hs+2−2

@@ -585,7 +585,7 @@ evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName

585585 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

586586 in pure (Right newContext)

587587

588−evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) = do

588+evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =

589589 --Define

590590 case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of

591591 (Left err,_) -> pure (Left err)

@@ -601,7 +601,7 @@ evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName a

601601 eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

602602 case eitherRel of

603603 Left err -> pure $ Left err

604− Right rel -> do

604+ Right rel ->

605605 case runState (setRelVar relVarName rel) elems of

606606 (Left err,_) -> pure (Left err)

607607 (Right (), (ctx',_,_)) -> pure $ Right ctx'

test/TutorialD/Interpreter.hs+10−2

@@ -65,7 +65,8 @@ main = do

6565 testRelationAttributeDefinition,

6666 testAssignWithTypeVar,

6767 testDefineWithTypeVar,

68− testIntervalType

68+ testIntervalType,

69+ testArbitraryRelation

6970 ]

7071 simpleRelTests = [("x:=true", Right relationTrue),

7172 ("x:=false", Right relationFalse),

@@ -578,4 +579,11 @@ testIntervalType = TestCase $ do

578579 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

579580 let expectedIntervalInt = mkRelationFromList expectedAttrs []

580581 expectedAttrs = A.attributesFromList [Attribute "a" (ConstructedAtomType "Interval" (M.singleton "a" IntegerAtomType))]

581− assertEqual "Interval Int attribute" expectedIntervalInt eX

582+ assertEqual "Interval Int attribute" expectedIntervalInt eX

583+

584+testArbitraryRelation :: Test

585+testArbitraryRelation = TestCase $ do

586+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

587+ executeTutorialD sessionId dbconn "createarbitraryrelation rv1 {a Integer} 5-10"

588+ executeTutorialD sessionId dbconn "createarbitraryrelation rv2 {a Integer, b relation{c Integer}} 10-100"

589+ executeTutorialD sessionId dbconn "createarbitraryrelation rv3 {a Int, b relation{c Interval Int}} 3-100"