2fbb67a · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

fix tuple type resolution when the tuples exhaustively complete the type variables

2fbb67aAgentM7 years ago

src/lib/ProjectM36/AtomType.hs+51−9

compare with master

unifiedsplit

@@ -198,14 +198,23 @@ findTypeConstructor name = foldr tConsFolder Nothing

198 Just (tCons, dConsList)

199 else

200 accum

201−

201+

202+resolveAttributes :: Attribute -> Attribute -> Either RelationalError Attribute

203+resolveAttributes attrA attrB =

204+ if A.attributeName attrA /= A.attributeName attrB then

205+ Left $ AttributeNamesMismatchError (S.fromList (map A.attributeName [attrA, attrB]))

206+ else

207+ Attribute (A.attributeName attrA) <$> resolveAtomType (A.atomType attrA) (A.atomType attrB)

208+

209+--given two atom types, try to resolve type variables

202resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

210resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

203resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

211resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

204 ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

212 ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

205−resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

213+resolveAtomType typeFromRelation unresolvedType =

214+ if typeFromRelation == unresolvedType then

206− Right typeFromRelation

215+ Right typeFromRelation

207− else

216+ else

208− Left (AtomTypeMismatchError typeFromRelation unresolvedType)

217+ Left (AtomTypeMismatchError typeFromRelation unresolvedType)

209

218

210{-

219{-

211--walk an `AtomType` and apply the type variables in the map

220--walk an `AtomType` and apply the type variables in the map

@@ -229,12 +238,14 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

229 let resolveTypePair resKey resType =

238 let resolveTypePair resKey resType =

230 -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map

239 -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map

231 case M.lookup resKey unresolvedTypeMap of

240 case M.lookup resKey unresolvedTypeMap of

232− Just unresType -> case unresType of

241+ Just unresType -> case unresType of

233 --do we need to recurse for RelationAtomType?

242 --do we need to recurse for RelationAtomType?

234 subType@(ConstructedAtomType _ _) -> do

243 subType@(ConstructedAtomType _ _) -> do

235− resSubType <- resolveAtomType resType subType

244+ resSubType <- resolveAtomType resType subType

236− pure (resKey, resSubType)

245+ pure (resKey, resSubType)

246+ typ ->

247+ let typ' = if isResolvedType typ then typ else resType in

237− _ -> pure (resKey, resType)

248+ pure (resKey, typ')

238 Nothing ->

249 Nothing ->

239 pure (resKey, resType) --swipe the missing type var from the expected map

250 pure (resKey, resType) --swipe the missing type var from the expected map

240 tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)

251 tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)

@@ -283,6 +294,15 @@ validateAtomType (RelationAtomType attrs) tConss =

283validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)

294validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)

284validateAtomType _ _ = pure ()

295validateAtomType _ _ = pure ()

285

296

297+validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError ()

298+validateAttributes tConss attrs =

299+ if length errs > 0 then

300+ Left (someErrors errs)

301+ else

302+ pure ()

303+ where

304+ errs = lefts $ map ((`validateAtomType` tConss) . A.atomType) (V.toList attrs)

305+

286--ensure that all type vars are fully resolved

306--ensure that all type vars are fully resolved

287validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()

307validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()

288validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap

308validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap

@@ -382,3 +402,25 @@ resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameA

382 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

402 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

383 Just typ -> Right typ

403 Just typ -> Right typ

384

404

405+isResolvedType :: AtomType -> Bool

406+isResolvedType typ =

407+ case typ of

408+ IntAtomType -> True

409+ IntegerAtomType -> True

410+ DoubleAtomType -> True

411+ TextAtomType -> True

412+ DayAtomType -> True

413+ DateTimeAtomType -> True

414+ ByteStringAtomType -> True

415+ BoolAtomType -> True

416+ RelationAtomType attrs -> isResolvedAttributes attrs

417+ ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap)

418+ TypeVariableType _ -> False

419+

420+isResolvedAttributes :: Attributes -> Bool

421+isResolvedAttributes attrs = all isResolvedAttribute (V.toList attrs)

422+

423+isResolvedAttribute :: Attribute -> Bool

424+isResolvedAttribute = isResolvedType . A.atomType

425+

426+--given two AtomTypes x,y

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

@@ -81,7 +81,8 @@ data AtomType = IntAtomType |

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

83instance Ord AtomType where

84− compare = undefined

84+ compare = undefined

85+

85type TypeVarMap = M.Map TypeVarName AtomType

86type TypeVarMap = M.Map TypeVarName AtomType

87instance Hashable TypeVarMap where

88instance Hashable TypeVarMap where

src/lib/ProjectM36/RelationalExpression.hs+42−13

@@ -399,13 +399,10 @@ evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

399 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

400 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

401 case eAttrs of

402− Left err -> dbErr err

402+ Left err -> dbErr err

403 Right attrsList -> do

404− let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList

404+ lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)

405− if not (null atomTypeErrs) then

406− dbErr (someErrors atomTypeErrs)

407− else

408− case M.member relVarName relvars of

405+ case M.member relVarName relvars of

409 True -> dbErr (RelVarAlreadyDefinedError relVarName)

406 True -> dbErr (RelVarAlreadyDefinedError relVarName)

410 False -> setRelVar relVarName (ExistingRelation emptyRelation)

407 False -> setRelVar relVarName (ExistingRelation emptyRelation)

411 where

408 where

@@ -418,15 +415,17 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

418 graph <- re_graph <$> dbcRelationalExprEnv

415 graph <- re_graph <$> dbcRelationalExprEnv

419 context <- getStateContext

416 context <- getStateContext

420 let existingRelVar = M.lookup relVarName (relationVariables context)

417 let existingRelVar = M.lookup relVarName (relationVariables context)

421− reEnv = freshGraphRefRelationalExprEnv (Just context) graph

418+ reEnv = freshGraphRefRelationalExprEnv (Just context) graph

419+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

422 case existingRelVar of

420 case existingRelVar of

423 Nothing -> do

421 Nothing -> do

424 case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of

422 case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of

425 Left err -> dbErr err

423 Left err -> dbErr err

424+ Right reltype -> do

425+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)

426− Right _ -> setRelVar relVarName expr

426+ setRelVar relVarName expr

427 Just existingRel -> do

428 let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)

429− eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

430 case eExpectedType of

429 case eExpectedType of

431 Left err -> dbErr err

430 Left err -> dbErr err

432 Right expectedType ->

431 Right expectedType ->

@@ -434,6 +433,7 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

434 Left err -> dbErr err

433 Left err -> dbErr err

435 Right newExprType -> do

434 Right newExprType -> do

436 if newExprType == expectedType then do

435 if newExprType == expectedType then do

436+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)

437 setRelVar relVarName expr

438 else

439 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))

@@ -1128,7 +1128,36 @@ evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1128 pure $ Attribute attrName aType

1129

1130evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr

1131−

1131+

1132+-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types

1133+evalGraphRefTupleExprs :: Maybe Attributes -> [GraphRefTupleExpr] -> GraphRefRelationalExprM [RelationTuple]

1134+evalGraphRefTupleExprs mAttrs tupleExprs = do

1135+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1136+ finalAttrs <- case mAttrs of

1137+ Just attrs -> pure attrs

1138+ Nothing ->

1139+ case tuples of

1140+ [] -> pure emptyAttributes

1141+ (headTuple:tailTuples) -> do

1142+ --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])

1143+ let mostResolvedTypes =

1144+ foldr (\tup acc ->

1145+ fmap (\(tupAttr,accAttr) -> --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables

1146+ if isResolvedAttribute accAttr then

1147+ accAttr

1148+ else

1149+ case resolveAttributes accAttr tupAttr of

1150+ Left _ -> accAttr

1151+ Right val -> val) (zip (V.toList $ tupleAttributes tup) acc)) (V.toList $ tupleAttributes headTuple) tailTuples

1152+ pure (A.attributesFromList mostResolvedTypes)

1153+ --is it OK to get the tConsMap like this and use it uniformly across the tuples- couldn't the tuple expressions use types from other parts of the graph? Maybe it's OK because this is only used

1154+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker UncommittedContextMarker

1155+ lift $ except $ validateAttributes tConsMap finalAttrs

1156+ mapM (\tup -> lift $ except $ resolveTypesInTuple finalAttrs tConsMap tup) tuples

1157+

1158+

1159+--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))

1160+

1132evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple

1161evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple

1133evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1162evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1134 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

1163 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

@@ -1153,7 +1182,7 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1153 --verify that the attributes match

1182 --verify that the attributes match

1154 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)

1183 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)

1155 --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held

1184 --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held

1156−-- tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

1185+ --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

1157 let tup' = reorderTuple finalAttrs tup

1186 let tup' = reorderTuple finalAttrs tup

1158 --TODO: restore type resolution

1187 --TODO: restore type resolution

1159-- _ <- lift $ except (validateTuple tup' tConss)

1188-- _ <- lift $ except (validateTuple tup' tConss)

@@ -1216,7 +1245,7 @@ evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1216 Just _ ->

1245 Just _ ->

1217 Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

1246 Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

1218 Nothing -> pure Nothing

1247 Nothing -> pure Nothing

1219− tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1248+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

1220 let attrs = fromMaybe firstTupleAttrs mAttrs

1249 let attrs = fromMaybe firstTupleAttrs mAttrs

1221 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

1250 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

1222 lift $ except $ mkRelation attrs (RelationTupleSet tuples)

1251 lift $ except $ mkRelation attrs (RelationTupleSet tuples)

@@ -1301,7 +1330,7 @@ typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1301 attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1330 attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1302 pure (Just (attributesFromList attrs))

1331 pure (Just (attributesFromList attrs))

1303 Nothing -> pure Nothing

1332 Nothing -> pure Nothing

1304− tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1333+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

1305 let retAttrs = case tuples of

1334 let retAttrs = case tuples of

1306 (tup:_) -> tupleAttributes tup

1335 (tup:_) -> tupleAttributes tup

1307 [] -> fromMaybe A.emptyAttributes mAttrs

1336 [] -> fromMaybe A.emptyAttributes mAttrs