git.iko.soy/project-m36
on master help sign in
very basic type "inference" supports "Left 4" in tuple and relation declarations must now include full types

-type inference from tuples when relation attributes are unknown is no longer supported

commit013a62d8808459a6b3d5a16572331d9accd21f02 authorAgentM <agentm@themactionfaction.com> dateFri 18 Mar 2016, 23:37 (11 years ago) parenta8da548
6 files changed+37−45
compare with master
unifiedsplit
ProjectM36/AtomType.hs+17−12 ProjectM36/Base.hs+1−3 ProjectM36/Error.hs+1 ProjectM36/RelationalExpression.hs+14−21 ProjectM36/StaticOptimizer.hs+1−3 TutorialD/Interpreter/RelationalExpr.hs+3−6
ProjectM36/AtomType.hs+17−12
@@ -1,11 +1,9 @@
11{-# LANGUAGE OverloadedStrings #-}
22module ProjectM36.AtomType where
33import ProjectM36.Base
4−import ProjectM36.DataTypes.Primitive
54import qualified ProjectM36.TypeConstructorDef as TCD
65import qualified ProjectM36.TypeConstructor as TC
76import qualified ProjectM36.DataConstructorDef as DCD
8−import qualified Data.Text as T
97import ProjectM36.Error
108import ProjectM36.Attribute
119import qualified Data.Vector as V
@@ -79,11 +77,18 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes = do
7977resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap
8078resolveDataConstructorTypeVars dCons aTypeArgs tConss = do
8179 maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)
82− --if any two maps have the same key and different values- bail!
83− let typeVarMapFolder
84− foldr typeVarMapFolder (Right M.empty) maps
80+ --if any two maps have the same key and different values, this indicates a type arg mismatch
81+ let typeVarMapFolder valMap acc = case acc of
82+ Left err -> Left err
83+ Right accMap -> if accMap `M.isSubmapOf` valMap then
84+ Right (M.union accMap valMap)
85+ else
86+ Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)
87+ case foldr typeVarMapFolder (Right M.empty) maps of
88+ Left err -> Left err
89+ Right typeVarMaps -> pure typeVarMaps
8590 --if the data constructor cannot complete a type constructor variables (ex. "Nothing" could be Maybe Int or Maybe Text, etc.), then fill that space with AnyAtomType which is resolved when the relation is constructed- the relation must contain all resolved atom types.
86− pure (M.unions maps)
91+
8792
8893-- | Attempt to match the data constructor argument to a type constructor type variable.
8994resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
@@ -92,13 +97,13 @@ resolveDataConstructorArgTypeVars (DataConstructorDefTypeConstructorArg tCons) a
9297resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)
9398
9499resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
95−resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType tConss =
100+resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType _ =
96101 if aType /= pType then
97102 Left (AtomTypeMismatchError pType aType)
98103 else
99104 Right M.empty
100105
101−resolveTypeConstructorTypeVars (ADTypeConstructor tConsName tConsArgs) (ConstructedAtomType tConsName' pVarMap') tConss =
106+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomType tConsName' pVarMap') tConss =
102107 if tConsName /= tConsName' then
103108 Left (TypeConstructorNameMismatch tConsName tConsName')
104109 else
@@ -156,7 +161,7 @@ findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList
156161 accum
157162
158163resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType
159−resolveAtomType orig@(ConstructedAtomType dConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do
164+resolveAtomType orig@(ConstructedAtomType _ resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do
160165 _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap
161166 pure orig
162167resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then
@@ -167,14 +172,14 @@ resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresol
167172-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap
168173resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap
169174resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do
170− let lookup key tMap = case M.lookup key tMap of
175+ let lookup' key tMap = case M.lookup key tMap of
171176 Nothing -> Left (TypeConstructorTypeVarMissing key)
172177 Just val -> Right val
173178 let resolveTypePair unresKey AnyAtomType = do
174− resType <- lookup unresKey resolvedTypeMap
179+ resType <- lookup' unresKey resolvedTypeMap
175180 pure (unresKey, resType)
176181 resolveTypePair unresKey subType@(ConstructedAtomType _ _) = do --recurse
177− resType <- lookup unresKey resolvedTypeMap
182+ resType <- lookup' unresKey resolvedTypeMap
178183 resAType <- resolveAtomType resType subType
179184 pure (unresKey, resAType)
180185 resolveTypePair unresKey unresV = pure (unresKey, unresV)
ProjectM36/Base.hs+1−3
@@ -235,9 +235,7 @@ type RelVarName = StringType
235235-- | A relational expression represents query (read) operations on a database.
236236data RelationalExpr where
237237 --- | Create a relation from tuple expressions.
238− MakeRelationFromTupleExprs :: [TupleExpr] -> RelationalExpr
239− --- | Create an empty relation with the given attributes.
240− MakeEmptyRelation :: [AttributeExpr] -> RelationalExpr
238+ MakeRelationFromExprs :: [AttributeExpr] -> [TupleExpr] -> RelationalExpr
241239 --- | Create and reference a relation from attributes and a tuple set.
242240 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr
243241 --- | Reference an existing relation in Haskell-space.
ProjectM36/Error.hs+1
@@ -41,6 +41,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)
4141 | DataConstructorNameInUseError DataConstructorName
4242 | DataConstructorUsesUndeclaredTypeVariable TypeVarName
4343 | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)
44+ | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap
4445 | TypeConstructorTypeVarMissing TypeVarName
4546 | AtomTypeNameInUseError AtomTypeName
4647 | IncompletelyDefinedAtomTypeWithConstructorError
ProjectM36/RelationalExpression.hs+14−21
@@ -57,25 +57,18 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
5757 Right rel -> return $ Right rel
5858 Left err -> return $ Left err
5959
60−evalRelationalExpr (MakeEmptyRelation attrExprs) = do
60+evalRelationalExpr (MakeRelationFromExprs attrExprs tupleExprs) = do
6161 currentContext <- get
62− let eAttrs = map (evalAttrExpr (typeConstructorMapping currentContext)) attrExprs
62+ tConss <- liftM typeConstructorMapping get
63+ let eAttrs = map (evalAttrExpr tConss) attrExprs
6364 case lefts eAttrs of
64− err:_ -> pure (Left err)
65− [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet
66−
67−evalRelationalExpr (MakeRelationFromTupleExprs tupleExprs) = do
68− currentContext <- get
69− if null tupleExprs then
70− pure $ Left CouldNotInferAttributes
71− else
72− let eTuples = map (evalTupleExpr currentContext) tupleExprs in
65+ [] -> do
66+ let attrs = A.attributesFromList (rights eAttrs)
67+ eTuples = map (evalTupleExpr currentContext attrs) tupleExprs
7368 case lefts eTuples of
74− err:_ -> pure (Left err)
75− [] -> case head eTuples of
76− Left err -> error $ "impossible Right err " ++ show err
77− --extract potential attributes from first tuple
78− Right firstTuple -> pure $ mkRelation (tupleAttributes firstTuple) (RelationTupleSet (rights eTuples))
69+ [] -> pure $ mkRelation attrs (RelationTupleSet (rights eTuples))
70+ errs -> pure $ Left (MultipleErrors errs)
71+ errs -> pure $ Left (MultipleErrors errs)
7972
8073evalRelationalExpr (ExistingRelation rel) = return (Right rel)
8174
@@ -500,15 +493,15 @@ evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do
500493 aType <- atomTypeForTypeConstructor tCons aTypes
501494 Right (Attribute attrName aType)
502495
503−evalTupleExpr :: DatabaseContext -> TupleExpr -> Either RelationalError RelationTuple
504−evalTupleExpr context (TupleExpr tupMap) = do
496+evalTupleExpr :: DatabaseContext -> Attributes -> TupleExpr -> Either RelationalError RelationTuple
497+evalTupleExpr context attrs (TupleExpr tupMap) = do
505498 -- 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
506499 attrAtoms <- mapM (\(attrName, aExpr) -> do
507500 newAtom <- evalAtomExpr emptyTuple context aExpr
508501 newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr
509502 pure (attrName, newAtom, newAtomType)
510503 ) (M.toList tupMap)
511− let attrs = map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
504+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
512505 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
513− pure $ mkRelationTuple (A.attributesFromList attrs) atoms
514−
506+ tup = mkRelationTuple tupAttrs atoms
507+ resolveTypesInTuple attrs tup
ProjectM36/StaticOptimizer.hs+1−3
@@ -15,12 +15,10 @@ import Data.Either (rights, lefts)
1515applyStaticRelationalOptimization :: RelationalExpr -> DatabaseState (Either RelationalError RelationalExpr)
1616applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e
1717
18−applyStaticRelationalOptimization e@(MakeRelationFromTupleExprs _) = return $ Right e
18+applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = return $ Right e
1919
2020applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e
2121
22−applyStaticRelationalOptimization e@(MakeEmptyRelation _) = return $ Right e
23−
2422applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e
2523
2624--remove project of attributes which removes no attributes
TutorialD/Interpreter/RelationalExpr.hs+3−6
@@ -22,12 +22,9 @@ attributeListP = do
2222makeRelationP :: Parser RelationalExpr
2323makeRelationP = do
2424 reserved "relation"
25− attrExprs <- (try makeAttributeExprsP <|> pure [])
26− if not (null attrExprs) then do
27− pure $ MakeEmptyRelation attrExprs
28− else do -- empty attributes, assume tuple expressions
29− tupleExprs <- try (braces (sepBy tupleExprP comma)) <|> pure []
30− pure $ MakeRelationFromTupleExprs tupleExprs
25+ attrExprs <- makeAttributeExprsP
26+ tupleExprs <- braces (sepBy tupleExprP comma)
27+ pure $ MakeRelationFromExprs attrExprs tupleExprs
3128
3229--used in relation creation
3330makeAttributeExprsP :: Parser [AttributeExpr]