git.iko.soy/project-m36
on master help sign in
WIP definition of subrelation attributes
commit14a9d9a784b7647ca0a5130b48e36bf9d1ca01f2 authorAgentM <agentm@themactionfaction.com> dateWed 23 May 2018, 18:15 (8 years ago) parent015506f
7 files changed+80−19
compare with master
unifiedsplit
src/bin/TutorialD/Interpreter/RelationalExpr.hs−6 src/bin/TutorialD/Interpreter/Types.hs+15−1 src/lib/ProjectM36/AtomType.hs+17−2 src/lib/ProjectM36/Attribute.hs+2−1 src/lib/ProjectM36/Base.hs+40 src/lib/ProjectM36/DataConstructorDef.hs+2−3 src/lib/ProjectM36/TypeConstructor.hs+4−6
src/bin/TutorialD/Interpreter/RelationalExpr.hs−6
@@ -33,12 +33,6 @@ makeRelationP = do
3333 tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []
3434 pure $ MakeRelationFromExprs attrExprs tupleExprs
3535
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
4236
4337--abstract data type parser- in this context, the type constructor must not include any type arguments
4438--Either Text Int
src/bin/TutorialD/Interpreter/Types.hs+15−1
@@ -28,11 +28,25 @@ dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeCo
2828--built-in, nullary type constructors
2929-- Int, Text, etc.
3030primitiveTypeConstructorP :: Parser TypeConstructor
31−primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do
31+primitiveTypeConstructorP = choice (relationTypeP ++ map (\(PrimitiveTypeConstructorDef name typ, _) -> do
3232 tName <- try $ symbol (T.unpack name)
3333 pure $ PrimitiveTypeConstructor tName typ)
3434 primitiveTypeConstructorMapping)
3535
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+
3650-- *Either Int Text*, *Int*
3751typeConstructorP :: Parser TypeConstructor
3852typeConstructorP = primitiveTypeConstructorP <|>
src/lib/ProjectM36/AtomType.hs+17−2
@@ -116,6 +116,18 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT
116116 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))
117117resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)
118118resolveTypeConstructorTypeVars (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
119131
120132-- check that type vars on the right also appear on the left
121133-- check that the data constructor names are unique
@@ -161,7 +173,7 @@ resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresol
161173 else
162174 Left (AtomTypeMismatchError typeFromRelation unresolvedType)
163175
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
165177resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap
166178resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do
167179 {-
@@ -215,7 +227,8 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =
215227 Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
216228 else
217229 Right ()
218− _ -> Right ()
230+ _ -> Right ()
231+validateAtomType (RelationAtomType attrs) = error "poop"
219232validateAtomType _ _ = Right ()
220233
221234validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()
@@ -307,3 +320,5 @@ resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap (DataConstructorDefTypeC
307320resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of
308321 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)
309322 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)
149149intersection :: Attributes -> Attributes -> Attributes
150150intersection attrsA attrsB = V.fromList (M.elems intersected)
151151 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]
240240-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int
241241data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |
242242 PrimitiveTypeConstructor TypeConstructorName AtomType |
243+ RelationAtomTypeConstructor AttributeExpr |
243244 TypeVariable TypeVarName
244245 deriving (Show, Generic, Binary, Eq, NFData)
245246
@@ -527,3 +528,42 @@ instance Hashable DatabaseContextFunction where
527528
528529instance Eq DatabaseContextFunction where
529530 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 @@
11module ProjectM36.DataConstructorDef where
2−import ProjectM36.Base
3−import qualified ProjectM36.TypeConstructor as TC
2+import ProjectM36.Base as B
43import qualified Data.Set as S
54
65emptyDataConstructor :: DataConstructorName -> DataConstructorDef
@@ -16,6 +15,6 @@ typeVars :: DataConstructorDef -> S.Set TypeVarName
1615typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs
1716
1817typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName
19−typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons
18+typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = B.typeVars tCons
2019typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName
2120
src/lib/ProjectM36/TypeConstructor.hs+4−6
@@ -1,19 +1,17 @@
11module ProjectM36.TypeConstructor where
22import ProjectM36.Base
3−import qualified Data.Set as S
43
54name :: TypeConstructor -> TypeConstructorName
65name (ADTypeConstructor name' _) = name'
76name (PrimitiveTypeConstructor name' _) = name'
8−name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only
7+name (RelationAtomTypeConstructor _) = error "name called on RelationAtomTypeConstructor"
8+name (TypeVariable _) = error "name called on TypeVariable" --v --not really the name, but this is used for display only
99
1010arguments :: TypeConstructor -> [TypeConstructor]
1111arguments (ADTypeConstructor _ args) = args
1212arguments (PrimitiveTypeConstructor _ _) = []
13+arguments (RelationAtomTypeConstructor _) = []
1314arguments (TypeVariable _) = []
1415
15−typeVars :: TypeConstructor -> S.Set TypeVarName
16−typeVars (PrimitiveTypeConstructor _ _) = S.empty
17−typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)
18−typeVars (TypeVariable v) = S.singleton v
16+
1917