6aac95d · project-m36 · git.iko.soy

git.iko.soy/project-m36

use AtomType resolution for primitive types instead of attempting to parse primitive types separately which lead to conflicts

resolves #205

commit6aac95d2d7802e4235718318649134a592f070c2 authorAgentM <agentm@themactionfaction.com> dateThu 31 May 2018, 14:38 (8 years ago) parent8827c0f

7 files changed+38−28

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/Types.hs+3−15 src/lib/ProjectM36/AtomType.hs+11−5 src/lib/ProjectM36/DataTypes/Basic.hs+3−1 src/lib/ProjectM36/DataTypes/Day.hs−3 src/lib/ProjectM36/DataTypes/Interval.hs+4 src/lib/ProjectM36/DataTypes/Primitive.hs+3−1 test/TutorialD/Interpreter.hs+14−3

src/bin/TutorialD/Interpreter/Types.hs+3−15

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

44import Text.Megaparsec.Text

55import Text.Megaparsec

66import TutorialD.Interpreter.Base

7−import ProjectM36.DataTypes.Primitive

8−import qualified Data.Text as T

108class RelationalMarkerExpr a where

119 parseMarkerP :: Parser a

@@ -31,14 +29,6 @@ dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeCo

3129 DataConstructorDefTypeConstructorArg <$> typeConstructorP <|>

3230 DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier

3331

34−--built-in, nullary type constructors

35−-- Int, Text, etc.

36−primitiveTypeConstructorP :: Parser TypeConstructor

37−primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do

38− tName <- try $ symbol (T.unpack name)

39− pure $ PrimitiveTypeConstructor tName typ)

40− primitiveTypeConstructorMapping)

41−

4232-- relation{a Int} in type construction (no tuples parsed)

4333relationTypeConstructorP :: Parser TypeConstructor

4434relationTypeConstructorP = do

@@ -55,16 +45,14 @@ attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstruc

5545

5646-- *Either Int Text*, *Int*

5747typeConstructorP :: Parser TypeConstructor

58−typeConstructorP = primitiveTypeConstructorP <|>

59− relationTypeConstructorP <|>

48+typeConstructorP = relationTypeConstructorP <|>

6049 TypeVariable <$> uncapitalizedIdentifier <|>

6150 ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>

6251 monoTypeConstructorP)

6352

6453monoTypeConstructorP :: Parser TypeConstructor

65−monoTypeConstructorP = primitiveTypeConstructorP <|>

66− ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

67− TypeVariable <$> uncapitalizedIdentifier

54+monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

55+ TypeVariable <$> uncapitalizedIdentifier

6856

6957

7058

src/lib/ProjectM36/AtomType.hs+11−5

@@ -106,7 +106,13 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

106106 else

107107 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

108108resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

109+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName []) typ tConss = case findTypeConstructor tConsName tConss of

110+ --resolve ADT constructor to primitive type, if necessary

111+ Just (PrimitiveTypeConstructorDef _ _, _) -> Right M.empty

112+ _ -> Left (TypeConstructorAtomTypeMismatch tConsName typ)

113+

109114resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)

115+

110116resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =

111117 case typ of

112118 RelationAtomType attrs ->

@@ -145,11 +151,12 @@ atomTypeForTypeConstructor (RelationAtomTypeConstructor attrExprs) tConsMap tvMa

145151 pure (RelationAtomType (A.attributesFromList attrs))

146152atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of

147153 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

154+ Just (PrimitiveTypeConstructorDef _ aType, _) -> Right aType

148155 Just (tConsDef, _) -> do

149− tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons)

150− let pVarNames = TCD.typeVars tConsDef

151− tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

152− Right (ConstructedAtomType (TC.name tCons) tConsArgs)

156+ tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons)

157+ let pVarNames = TCD.typeVars tConsDef

158+ tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

159+ Right (ConstructedAtomType (TC.name tCons) tConsArgs)

153160

154161atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

155162atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)

@@ -336,4 +343,3 @@ resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameA

336343 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

337344 Just typ -> Right typ

338345

339−

src/lib/ProjectM36/DataTypes/Basic.hs+3−1

@@ -2,9 +2,11 @@

22module ProjectM36.DataTypes.Basic where

33import ProjectM36.DataTypes.Primitive

44import ProjectM36.DataTypes.Day

5+import ProjectM36.DataTypes.DateTime

56import ProjectM36.DataTypes.Either

67import ProjectM36.DataTypes.Maybe

78import ProjectM36.DataTypes.List

9+import ProjectM36.DataTypes.Interval

810import ProjectM36.Base

911

1012basicTypeConstructorMapping :: TypeConstructorMapping

@@ -12,6 +14,6 @@ basicTypeConstructorMapping = primitiveTypeConstructorMapping ++

1214 maybeTypeConstructorMapping ++

1315 eitherTypeConstructorMapping ++

1416 listTypeConstructorMapping ++

15− dayTypeConstructorMapping

17+ intervalTypeConstructorMapping

1618

1719

src/lib/ProjectM36/DataTypes/Day.hs−3

@@ -15,6 +15,3 @@ dayAtomFunctions = HS.fromList [

1515 atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))

1616 }

1717 ]

18−

19−dayTypeConstructorMapping :: TypeConstructorMapping

20−dayTypeConstructorMapping = [] -- use fromGregorian

src/lib/ProjectM36/DataTypes/Interval.hs+4

@@ -105,3 +105,7 @@ intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAto

105105 pure (startcmp cmp1 && endcmp cmp2)

106106intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError

107107

108+intervalTypeConstructorMapping :: TypeConstructorMapping

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

110+

111+

src/lib/ProjectM36/DataTypes/Primitive.hs+3−1

@@ -10,7 +10,9 @@ primitiveTypeConstructorMapping = map (\(name, aType) ->

1010 ("Text", TextAtomType),

1111 ("Double", DoubleAtomType),

1212 ("Bool", BoolAtomType),

13− ("ByteString", ByteStringAtomType)

13+ ("ByteString", ByteStringAtomType),

14+ ("DateTime", DateTimeAtomType),

15+ ("Day", DayAtomType)

1416 ]

1517

1618intTypeConstructor :: TypeConstructor

test/TutorialD/Interpreter.hs+14−3

@@ -36,14 +36,15 @@ main = do

3636 tcounts <- runTestTT (TestList tests)

3737 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

3838 where

39− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [

39+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++

40+ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [

4041 transactionGraphBasicTest,

4142 transactionGraphAddCommitTest,

4243 transactionRollbackTest,

4344 transactionJumpTest,

4445 transactionBranchTest,

4546 simpleJoinTest,

46− testNotification,

47+ testNotification,

4748 testTypeConstructors,

4849 testMergeTransactions,

4950 testComments,

@@ -63,7 +64,8 @@ main = do

6364 testAntijoin,

6465 testRelationAttributeDefinition,

6566 testAssignWithTypeVar,

66− testDefineWithTypeVar

67+ testDefineWithTypeVar,

68+ testIntervalType

6769 ]

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

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

@@ -568,3 +570,12 @@ testDefineWithTypeVar = TestCase $ do

568570 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

569571 let err1 = "TypeConstructorTypeVarMissing"

570572 expectTutorialDErr sessionId dbconn (T.isInfixOf err1) "y::{a int, b invalidtype}"

573+

574+testIntervalType :: Test

575+testIntervalType = TestCase $ do

576+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

577+ executeTutorialD sessionId dbconn "x:=relation{a Interval Integer}"

578+ eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

579+ let expectedIntervalInt = mkRelationFromList expectedAttrs []

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

581+ assertEqual "Interval Int attribute" expectedIntervalInt eX