git.iko.soy/project-m36
on master help sign in
fix Interval type.
commit32563bec141d117200f1995d738928bdeefd6dc9 authorJohnny Liao <dycan0716@gmail.com> dateSat 2 Jun 2018, 10:26 (8 years ago) parent30d99e9
6 files changed+18−12
compare with master
unifiedsplit
src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+1 src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+1 src/lib/ProjectM36/Arbitrary.hs+10−8 src/lib/ProjectM36/AtomType.hs+4−1 src/lib/ProjectM36/DataTypes/Interval.hs+1−3 src/lib/ProjectM36/RelationalExpression.hs+1
src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+1
@@ -16,6 +16,7 @@ import ProjectM36.Key
1616import ProjectM36.FunctionalDependency
1717import Data.Monoid
1818import Data.Functor
19+import Debug.Trace
1920
2021--parsers which create "database expressions" which modify the database context (such as relvar assignment)
2122databaseContextExprP :: Parser DatabaseContextExpr
src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+1
@@ -8,6 +8,7 @@ import TutorialD.Interpreter.RelationalExpr
88import Text.Megaparsec
99import Text.Megaparsec.Text
1010import Data.Text
11+import Debug.Trace
1112
1213addAtomFunctionExprP :: Parser DatabaseContextIOExpr
1314addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction
src/lib/ProjectM36/Arbitrary.hs+10−8
@@ -5,7 +5,7 @@ module ProjectM36.Arbitrary where
55import ProjectM36.Base
66import ProjectM36.Error
77import ProjectM36.AtomType
8−import ProjectM36.Attribute (atomType)
8+import ProjectM36.Attribute (atomType,attributeName)
99import ProjectM36.DataConstructorDef as DCD
1010import qualified Data.Map as M
1111import qualified Data.Set as S
@@ -62,13 +62,15 @@ arbitrary' BoolAtomType = do
6262
6363arbitrary' (IntervalAtomType atomTy) = do
6464 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
65+ eitherAtomTypeA <- lift $ runReaderT (arbitrary' atomTy) tcMap
66+ eitherAtomTypeB <- lift $ runReaderT (arbitrary' atomTy) tcMap
67+ case (eitherAtomTypeA,eitherAtomTypeB) of
68+ (Right a, Right b) -> do
69+ l <- lift $ (arbitrary :: Gen Bool)
70+ r <- lift $ (arbitrary :: Gen Bool)
71+ pure $ Right $ IntervalAtom a b l r
72+ (Left err,_) -> pure $ Left err
73+ (Right _, Left err) -> pure $ Left err
7274
7375arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) = do
7476 tcMap <- ask
src/lib/ProjectM36/AtomType.hs+4−1
@@ -156,7 +156,10 @@ atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.nam
156156 tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons)
157157 let pVarNames = TCD.typeVars tConsDef
158158 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)
159− Right (ConstructedAtomType (TC.name tCons) tConsArgs)
159+ case TC.name tCons of
160+ "Interval" -> Right (IntervalAtomType (head tConsArgTypes))
161+ _ -> Right (ConstructedAtomType (TC.name tCons) tConsArgs)
162+
160163
161164atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType
162165atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)
src/lib/ProjectM36/DataTypes/Interval.hs+1−3
@@ -106,6 +106,4 @@ intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAto
106106intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError
107107
108108intervalTypeConstructorMapping :: TypeConstructorMapping
109−intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"],[])]
110−
111−
109+intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]
src/lib/ProjectM36/RelationalExpression.hs+1
@@ -29,6 +29,7 @@ import Control.Monad.Trans.Reader
2929import Test.QuickCheck
3030import GHC
3131import GHC.Paths
32+import Debug.Trace
3233
3334data DatabaseContextExprDetails = CountUpdatedTuples
3435