013a62d · project-m36 · git.iko.soy

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

013a62dAgentM11 years ago

ProjectM36/AtomType.hs+17−12

compare with master

unifiedsplit

@@ -1,11 +1,9 @@

1{-# LANGUAGE OverloadedStrings #-}

2module ProjectM36.AtomType where

3import ProjectM36.Base

4−import ProjectM36.DataTypes.Primitive

5import qualified ProjectM36.TypeConstructorDef as TCD

4import qualified ProjectM36.TypeConstructorDef as TCD

6import qualified ProjectM36.TypeConstructor as TC

5import qualified ProjectM36.TypeConstructor as TC

7import qualified ProjectM36.DataConstructorDef as DCD

6import qualified ProjectM36.DataConstructorDef as DCD

8−import qualified Data.Text as T

9import ProjectM36.Error

7import ProjectM36.Error

10import ProjectM36.Attribute

8import ProjectM36.Attribute

11import qualified Data.Vector as V

9import qualified Data.Vector as V

@@ -79,11 +77,18 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes = do

79resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

77resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

80resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

78resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

81 maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

79 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!

80+ --if any two maps have the same key and different values, this indicates a type arg mismatch

83− let typeVarMapFolder

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)

84− foldr typeVarMapFolder (Right M.empty) maps

87+ case foldr typeVarMapFolder (Right M.empty) maps of

88+ Left err -> Left err

89+ Right typeVarMaps -> pure typeVarMaps

85 --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.

90 --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+

88-- | Attempt to match the data constructor argument to a type constructor type variable.

93-- | Attempt to match the data constructor argument to a type constructor type variable.

89resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

94resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

@@ -92,13 +97,13 @@ resolveDataConstructorArgTypeVars (DataConstructorDefTypeConstructorArg tCons) a

92resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)

97resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)

94resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

99resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

95−resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType tConss =

100+resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType _ =

96 if aType /= pType then

101 if aType /= pType then

97 Left (AtomTypeMismatchError pType aType)

102 Left (AtomTypeMismatchError pType aType)

98 else

103 else

99 Right M.empty

104 Right M.empty

100

105

101−resolveTypeConstructorTypeVars (ADTypeConstructor tConsName tConsArgs) (ConstructedAtomType tConsName' pVarMap') tConss =

106+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomType tConsName' pVarMap') tConss =

102 if tConsName /= tConsName' then

107 if tConsName /= tConsName' then

103 Left (TypeConstructorNameMismatch tConsName tConsName')

108 Left (TypeConstructorNameMismatch tConsName tConsName')

104 else

109 else

@@ -156,7 +161,7 @@ findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

156 accum

161 accum

157

162

158resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

163resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

159−resolveAtomType orig@(ConstructedAtomType dConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

164+resolveAtomType orig@(ConstructedAtomType _ resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

160 _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

165 _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

161 pure orig

166 pure orig

162resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

167resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

@@ -167,14 +172,14 @@ resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresol

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

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

168resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

173resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

169resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

174resolveAtomTypesInTypeVarMap 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

171 Nothing -> Left (TypeConstructorTypeVarMissing key)

176 Nothing -> Left (TypeConstructorTypeVarMissing key)

172 Just val -> Right val

177 Just val -> Right val

173 let resolveTypePair unresKey AnyAtomType = do

178 let resolveTypePair unresKey AnyAtomType = do

174− resType <- lookup unresKey resolvedTypeMap

179+ resType <- lookup' unresKey resolvedTypeMap

175 pure (unresKey, resType)

180 pure (unresKey, resType)

176 resolveTypePair unresKey subType@(ConstructedAtomType _ _) = do --recurse

181 resolveTypePair unresKey subType@(ConstructedAtomType _ _) = do --recurse

177− resType <- lookup unresKey resolvedTypeMap

182+ resType <- lookup' unresKey resolvedTypeMap

178 resAType <- resolveAtomType resType subType

183 resAType <- resolveAtomType resType subType

179 pure (unresKey, resAType)

184 pure (unresKey, resAType)

180 resolveTypePair unresKey unresV = pure (unresKey, unresV)

185 resolveTypePair unresKey unresV = pure (unresKey, unresV)

ProjectM36/Base.hs+1−3

@@ -235,9 +235,7 @@ type RelVarName = StringType

235-- | A relational expression represents query (read) operations on a database.

236data RelationalExpr where

237 --- | 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

241 --- | Create and reference a relation from attributes and a tuple set.

239 --- | Create and reference a relation from attributes and a tuple set.

242 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

240 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

243 --- | Reference an existing relation in Haskell-space.

241 --- | Reference an existing relation in Haskell-space.

ProjectM36/Error.hs+1

@@ -41,6 +41,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

41 | DataConstructorNameInUseError DataConstructorName

42 | DataConstructorUsesUndeclaredTypeVariable TypeVarName

43 | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)

44+ | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

44 | TypeConstructorTypeVarMissing TypeVarName

45 | TypeConstructorTypeVarMissing TypeVarName

45 | AtomTypeNameInUseError AtomTypeName

46 | AtomTypeNameInUseError AtomTypeName

46 | IncompletelyDefinedAtomTypeWithConstructorError

47 | IncompletelyDefinedAtomTypeWithConstructorError

ProjectM36/RelationalExpression.hs+14−21

@@ -57,25 +57,18 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

57 Right rel -> return $ Right rel

58 Left err -> return $ Left err

60−evalRelationalExpr (MakeEmptyRelation attrExprs) = do

60+evalRelationalExpr (MakeRelationFromExprs attrExprs tupleExprs) = do

61 currentContext <- get

62+ tConss <- liftM typeConstructorMapping get

62− let eAttrs = map (evalAttrExpr (typeConstructorMapping currentContext)) attrExprs

63+ let eAttrs = map (evalAttrExpr tConss) attrExprs

63 case lefts eAttrs of

64 case lefts eAttrs of

64− err:_ -> pure (Left err)

65+ [] -> do

65− [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet

66+ let attrs = A.attributesFromList (rights eAttrs)

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

67+ eTuples = map (evalTupleExpr currentContext attrs) tupleExprs

73 case lefts eTuples of

68 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)

80evalRelationalExpr (ExistingRelation rel) = return (Right rel)

73evalRelationalExpr (ExistingRelation rel) = return (Right rel)

@@ -500,15 +493,15 @@ evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do

500 aType <- atomTypeForTypeConstructor tCons aTypes

493 aType <- atomTypeForTypeConstructor tCons aTypes

501 Right (Attribute attrName aType)

494 Right (Attribute attrName aType)

502

495

503−evalTupleExpr :: DatabaseContext -> TupleExpr -> Either RelationalError RelationTuple

496+evalTupleExpr :: DatabaseContext -> Attributes -> TupleExpr -> Either RelationalError RelationTuple

504−evalTupleExpr context (TupleExpr tupMap) = do

497+evalTupleExpr context attrs (TupleExpr tupMap) = do

505 -- 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

498 -- 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

506 attrAtoms <- mapM (\(attrName, aExpr) -> do

499 attrAtoms <- mapM (\(attrName, aExpr) -> do

507 newAtom <- evalAtomExpr emptyTuple context aExpr

500 newAtom <- evalAtomExpr emptyTuple context aExpr

508 newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr

501 newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr

509 pure (attrName, newAtom, newAtomType)

502 pure (attrName, newAtom, newAtomType)

510 ) (M.toList tupMap)

503 ) (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

512 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

505 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

513− pure $ mkRelationTuple (A.attributesFromList attrs) atoms

506+ tup = mkRelationTuple tupAttrs atoms

514−

507+ resolveTypesInTuple attrs tup

ProjectM36/StaticOptimizer.hs+1−3

@@ -15,12 +15,10 @@ import Data.Either (rights, lefts)

15applyStaticRelationalOptimization :: RelationalExpr -> DatabaseState (Either RelationalError RelationalExpr)

16applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e

18−applyStaticRelationalOptimization e@(MakeRelationFromTupleExprs _) = return $ Right e

18+applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = return $ Right e

20applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e

22−applyStaticRelationalOptimization e@(MakeEmptyRelation _) = return $ Right e

23−

24applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

22applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

26--remove project of attributes which removes no attributes

24--remove project of attributes which removes no attributes

TutorialD/Interpreter/RelationalExpr.hs+3−6

@@ -22,12 +22,9 @@ attributeListP = do

22makeRelationP :: Parser RelationalExpr

23makeRelationP = do

24 reserved "relation"

25− attrExprs <- (try makeAttributeExprsP <|> pure [])

25+ attrExprs <- makeAttributeExprsP

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 []

26+ tupleExprs <- braces (sepBy tupleExprP comma)

30− pure $ MakeRelationFromTupleExprs tupleExprs

27+ pure $ MakeRelationFromExprs attrExprs tupleExprs

32--used in relation creation

29--used in relation creation

33makeAttributeExprsP :: Parser [AttributeExpr]

30makeAttributeExprsP :: Parser [AttributeExpr]