14a9d9a · project-m36 · git.iko.soy

src/bin/TutorialD/Interpreter/RelationalExpr.hs−6

compare with master

unifiedsplit

@@ -33,12 +33,6 @@ makeRelationP = do

33 tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []

34 pure $ MakeRelationFromExprs attrExprs tupleExprs

35

36−--used in relation creation

37−makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

38−makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

39−

40−attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)

41−attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP

42

36

43--abstract data type parser- in this context, the type constructor must not include any type arguments

37--abstract data type parser- in this context, the type constructor must not include any type arguments

44--Either Text Int

38--Either Text Int

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

@@ -28,11 +28,25 @@ dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeCo

28--built-in, nullary type constructors

29-- Int, Text, etc.

30primitiveTypeConstructorP :: Parser TypeConstructor

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

31+primitiveTypeConstructorP = choice (relationTypeP ++ map (\(PrimitiveTypeConstructorDef name typ, _) -> do

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

33 pure $ PrimitiveTypeConstructor tName typ)

34 primitiveTypeConstructorMapping)

35

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

37+relationTypeP :: Parser TypeConstructor

38+relationTypeP = do

39+ reserved "relation"

40+ RelationAtomTypeConstructor <$> braces makeAttributeExprsP

41+

42+--used in relation creation

43+makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

44+makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

45+

46+attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)

47+attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP

48+

49+

36-- *Either Int Text*, *Int*

50-- *Either Int Text*, *Int*

37typeConstructorP :: Parser TypeConstructor

51typeConstructorP :: Parser TypeConstructor

38typeConstructorP = primitiveTypeConstructorP <|>

52typeConstructorP = primitiveTypeConstructorP <|>

src/lib/ProjectM36/AtomType.hs+17−2

@@ -116,6 +116,18 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

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

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

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

119+resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExpr) typ tConsMap =

120+ case typ of

121+ RelationAtomType attrs -> do

122+ resolvedAttrs <- mapM (\atomtype' -> resolveAttributeExprTypeVars attrExpr atomtype' tConsMap) (map A.atomType (V.toList attrs))

123+ error "poop"

124+

125+--used when recursing down sub-relation type definition

126+resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

127+resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = do

128+ resolvedType <- resolveAtomType (A.atomType attr) aType

129+

130+resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap

119

131

120-- check that type vars on the right also appear on the left

132-- check that type vars on the right also appear on the left

121-- check that the data constructor names are unique

133-- check that the data constructor names are unique

@@ -161,7 +173,7 @@ resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresol

161 else

173 else

162 Left (AtomTypeMismatchError typeFromRelation unresolvedType)

174 Left (AtomTypeMismatchError typeFromRelation unresolvedType)

163

175

164−-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap

176+-- this could be optimized to reduce new tuple creation

165resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

177resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

166resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

178resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

167 {-

179 {-

@@ -215,7 +227,8 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

215 Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames

227 Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames

216 else

228 else

217 Right ()

229 Right ()

218− _ -> Right ()

230+ _ -> Right ()

231+validateAtomType (RelationAtomType attrs) = error "poop"

219validateAtomType _ _ = Right ()

232validateAtomType _ _ = Right ()

220

233

221validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()

234validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()

@@ -307,3 +320,5 @@ resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap (DataConstructorDefTypeC

307resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of

320resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of

308 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

321 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

309 Just typ -> Right typ

322 Just typ -> Right typ

323+

324+

src/lib/ProjectM36/Attribute.hs+2−1

@@ -149,4 +149,5 @@ union attrsA attrsB = V.fromList (M.elems unioned)

149intersection :: Attributes -> Attributes -> Attributes

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

151 where

152− intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

152+ intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

153+

src/lib/ProjectM36/Base.hs+40

@@ -240,6 +240,7 @@ data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName]

240-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int

241data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

242 PrimitiveTypeConstructor TypeConstructorName AtomType |

243+ RelationAtomTypeConstructor AttributeExpr |

243 TypeVariable TypeVarName

244 TypeVariable TypeVarName

244 deriving (Show, Generic, Binary, Eq, NFData)

245 deriving (Show, Generic, Binary, Eq, NFData)

245

246

@@ -527,3 +528,42 @@ instance Hashable DatabaseContextFunction where

527

528

528instance Eq DatabaseContextFunction where

529instance Eq DatabaseContextFunction where

529 f1 == f2 = dbcFuncName f1 == dbcFuncName f2

530 f1 == f2 = dbcFuncName f1 == dbcFuncName f2

531+

532+attrTypeVars :: Attribute -> S.Set TypeVarName

533+attrTypeVars (Attribute _ aType) = case aType of

534+ IntAtomType -> S.empty

535+ IntegerAtomType -> S.empty

536+ DoubleAtomType -> S.empty

537+ TextAtomType -> S.empty

538+ DayAtomType -> S.empty

539+ DateTimeAtomType -> S.empty

540+ ByteStringAtomType -> S.empty

541+ BoolAtomType -> S.empty

542+ (IntervalAtomType atomtyp) -> atomTypeVars atomtyp

543+ (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))

544+ (ConstructedAtomType _ tvMap) -> M.keysSet tvMap

545+ (TypeVariableType nam) -> S.singleton nam

546+

547+typeVars :: TypeConstructor -> S.Set TypeVarName

548+typeVars (PrimitiveTypeConstructor _ _) = S.empty

549+typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

550+typeVars (TypeVariable v) = S.singleton v

551+typeVars (RelationAtomTypeConstructor attrExpr) = attrExprTypeVars attrExpr

552+

553+attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName

554+attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons

555+attrExprTypeVars (NakedAttributeExpr attr) = attrTypeVars attr

556+

557+atomTypeVars :: AtomType -> S.Set TypeVarName

558+atomTypeVars IntAtomType = S.empty

559+atomTypeVars IntegerAtomType = S.empty

560+atomTypeVars DoubleAtomType = S.empty

561+atomTypeVars TextAtomType = S.empty

562+atomTypeVars DayAtomType = S.empty

563+atomTypeVars DateTimeAtomType = S.empty

564+atomTypeVars ByteStringAtomType = S.empty

565+atomTypeVars BoolAtomType = S.empty

566+atomTypeVars (IntervalAtomType aType) = atomTypeVars aType

567+atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

568+atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

569+atomTypeVars (TypeVariableType nam) = S.singleton nam

src/lib/ProjectM36/DataConstructorDef.hs+2−3

@@ -1,6 +1,5 @@

1module ProjectM36.DataConstructorDef where

2−import ProjectM36.Base

2+import ProjectM36.Base as B

3−import qualified ProjectM36.TypeConstructor as TC

4import qualified Data.Set as S

3import qualified Data.Set as S

5

4

6emptyDataConstructor :: DataConstructorName -> DataConstructorDef

5emptyDataConstructor :: DataConstructorName -> DataConstructorDef

@@ -16,6 +15,6 @@ typeVars :: DataConstructorDef -> S.Set TypeVarName

16typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs

15typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs

17

16

18typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName

17typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName

19−typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons

18+typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = B.typeVars tCons

20typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName

19typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName

21

20

src/lib/ProjectM36/TypeConstructor.hs+4−6

@@ -1,19 +1,17 @@

1module ProjectM36.TypeConstructor where

2import ProjectM36.Base

3−import qualified Data.Set as S

4

3

5name :: TypeConstructor -> TypeConstructorName

4name :: TypeConstructor -> TypeConstructorName

6name (ADTypeConstructor name' _) = name'

5name (ADTypeConstructor name' _) = name'

7name (PrimitiveTypeConstructor name' _) = name'

6name (PrimitiveTypeConstructor name' _) = name'

7+name (RelationAtomTypeConstructor _) = error "name called on RelationAtomTypeConstructor"

8−name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only

8+name (TypeVariable _) = error "name called on TypeVariable" --v --not really the name, but this is used for display only

9

10arguments :: TypeConstructor -> [TypeConstructor]

11arguments (ADTypeConstructor _ args) = args

12arguments (PrimitiveTypeConstructor _ _) = []

13+arguments (RelationAtomTypeConstructor _) = []

13arguments (TypeVariable _) = []

14arguments (TypeVariable _) = []

14

15

15−typeVars :: TypeConstructor -> S.Set TypeVarName

16+

16−typeVars (PrimitiveTypeConstructor _ _) = S.empty

17−typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

18−typeVars (TypeVariable v) = S.singleton v

19

17