4038adf · project-m36 · git.iko.soy

git.iko.soy/project-m36

make attribute specification optional to support extraction of attributes from tuples

commit4038adf52ae20ec68d6deacf4cf30a6bf7cd2804 authorAgentM <agentm@themactionfaction.com> dateSun 20 Mar 2016, 12:42 (11 years ago) parent013a62d

5 files changed+66−28

compare with master

unifiedsplit

ProjectM36/AtomType.hs+44−18 ProjectM36/Base.hs+1−1 ProjectM36/Error.hs+1−1 ProjectM36/RelationalExpression.hs+19−7 TutorialD/Interpreter/RelationalExpr.hs+1−1

ProjectM36/AtomType.hs+44−18

@@ -12,7 +12,7 @@ import qualified Data.List as L

1212import Data.Maybe (isJust)

1313import Control.Monad.Writer

1414import qualified Data.Map as M

15−import Debug.Trace

15+--import Debug.Trace

1616

1717findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)

1818findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

@@ -70,7 +70,6 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes = do

7070 Just (tCons, dCons) -> do

7171 --validate that the type constructor arguments are fulfilled in the data constructor

7272 typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

73− traceShowM typeVars

7473 pure (ConstructedAtomType (TCD.name tCons) typeVars)

7574

7675-- | Walks the data and type constructors to extract the type variable map.

@@ -161,9 +160,9 @@ findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

161160 accum

162161

163162resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

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

165− _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

166− pure orig

163+resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

164+ tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

165+ pure (ConstructedAtomType tConsName tVarMap)

167166resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

168167 Right typeFromRelation

169168 else

@@ -172,19 +171,29 @@ resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresol

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

173172resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

174173resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

175− let lookup' key tMap = case M.lookup key tMap of

174+ {-

175+ let resKeySet = traceShowId $ M.keysSet resolvedTypeMap

176+ unresKeySet = traceShowId $ M.keysSet unresolvedTypeMap

177+ when (resKeySet /= unresKeySet) (Left $ TypeConstructorTypeVarsMismatch resKeySet unresKeySet)

178+

179+

180+ let lookupOrDef key tMap = case M.lookup key tMap of

176181 Nothing -> Left (TypeConstructorTypeVarMissing key)

177182 Just val -> Right val

178− let resolveTypePair unresKey AnyAtomType = do

179− resType <- lookup' unresKey resolvedTypeMap

180− pure (unresKey, resType)

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

182− resType <- lookup' unresKey resolvedTypeMap

183− resAType <- resolveAtomType resType subType

184− pure (unresKey, resAType)

185− resolveTypePair unresKey unresV = pure (unresKey, unresV)

186− mapM_ (uncurry resolveTypePair) (M.toList unresolvedTypeMap)

187− pure resolvedTypeMap

183+ -}

184+ let resolveTypePair resKey resType = do

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

186+ case M.lookup resKey unresolvedTypeMap of

187+ Just unresType -> case unresType of

188+ --do we need to recurse for RelationAtomType?

189+ subType@(ConstructedAtomType _ _) -> do

190+ resSubType <- resolveAtomType resType subType

191+ pure (resKey, resSubType)

192+ otherType -> pure (resKey, otherType)

193+ Nothing -> do

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

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

196+ pure (M.fromList tVarList)

188197

189198-- | See notes at `resolveTypesInTuple`. The typeFromRelation must not include any wildcards.

190199resolveTypeInAtom :: AtomType -> Atom -> Either RelationalError Atom

@@ -197,6 +206,23 @@ resolveTypeInAtom _ atom = Right atom

197206-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.

198207resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

199208resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

200− newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) (map atomType (V.toList resolvedAttrs)))

209+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map atomType (V.toList resolvedAttrs)))

201210 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

202−

211+

212+-- | Validate that the type is provided with complete type variables for type constructors.

213+validateAtomType :: AtomType -> TypeConstructorMapping -> Maybe RelationalError

214+validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do

215+ (tConsDef, _) <- findTypeConstructor tConsName tConss

216+ case tConsDef of

217+ ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames

218+ actualTyVarNames = M.keysSet tVarMap

219+ diff = S.difference expectedTyVarNames actualTyVarNames in

220+ if not (S.null diff) then

221+ Just $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames

222+ else

223+ Nothing

224+ _ -> Just (TypeConstructorAtomTypeMismatch tConsName typ)

225+validateAtomType _ _ = Nothing

226+

227+validateTuple :: RelationTuple -> TypeConstructorMapping -> Maybe RelationalError

228+validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms >>= pure Nothing

ProjectM36/Base.hs+1−1

@@ -235,7 +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− MakeRelationFromExprs :: [AttributeExpr] -> [TupleExpr] -> RelationalExpr

238+ MakeRelationFromExprs :: Maybe [AttributeExpr] -> [TupleExpr] -> RelationalExpr

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

240240 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

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

ProjectM36/Error.hs+1−1

@@ -41,8 +41,8 @@ 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

4544 | TypeConstructorTypeVarMissing TypeVarName

45+ | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

4646 | AtomTypeNameInUseError AtomTypeName

4747 | IncompletelyDefinedAtomTypeWithConstructorError

4848 | AtomTypeNameNotInUseError AtomTypeName

ProjectM36/RelationalExpression.hs+19−7

@@ -57,16 +57,23 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

5757 Right rel -> return $ Right rel

5858 Left err -> return $ Left err

5959

60−evalRelationalExpr (MakeRelationFromExprs attrExprs tupleExprs) = do

60+evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

6161 currentContext <- get

6262 tConss <- liftM typeConstructorMapping get

63− let eAttrs = map (evalAttrExpr tConss) attrExprs

63+ -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

64+ let eAttrs = map (evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

6465 case lefts eAttrs of

6566 [] -> do

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

67− eTuples = map (evalTupleExpr currentContext attrs) tupleExprs

67+ let mAttrs = case mAttrExprs of

68+ Nothing -> Nothing

69+ Just _ -> Just (A.attributesFromList (rights eAttrs))

70+ eTuples = map (evalTupleExpr currentContext mAttrs) tupleExprs

6871 case lefts eTuples of

69− [] -> pure $ mkRelation attrs (RelationTupleSet (rights eTuples))

72+ [] -> do

73+ let attrs = fromMaybe firstTupleAttrs mAttrs

74+ tupList = rights eTuples

75+ firstTupleAttrs = if length tupList == 0 then A.emptyAttributes else tupleAttributes (head tupList)

76+ pure $ mkRelation attrs (RelationTupleSet tupList)

7077 errs -> pure $ Left (MultipleErrors errs)

7178 errs -> pure $ Left (MultipleErrors errs)

7279

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

493500 aType <- atomTypeForTypeConstructor tCons aTypes

494501 Right (Attribute attrName aType)

495502

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

503+evalTupleExpr :: DatabaseContext -> Maybe Attributes -> TupleExpr -> Either RelationalError RelationTuple

497504evalTupleExpr context attrs (TupleExpr tupMap) = do

498505 -- 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+ -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

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

500508 newAtom <- evalAtomExpr emptyTuple context aExpr

501509 newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr

@@ -504,4 +512,8 @@ evalTupleExpr context attrs (TupleExpr tupMap) = do

504512 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

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

506514 tup = mkRelationTuple tupAttrs atoms

507− resolveTypesInTuple attrs tup

515+ tConss = typeConstructorMapping context

516+ tup' <- resolveTypesInTuple (fromMaybe tupAttrs attrs) tup

517+ case validateTuple tup' tConss of

518+ Just err -> Left err

519+ _ -> pure tup'

TutorialD/Interpreter/RelationalExpr.hs+1−1

@@ -22,7 +22,7 @@ attributeListP = do

2222makeRelationP :: Parser RelationalExpr

2323makeRelationP = do

2424 reserved "relation"

25− attrExprs <- makeAttributeExprsP

25+ attrExprs <- try (liftA Just makeAttributeExprsP) <|> pure Nothing

2626 tupleExprs <- braces (sepBy tupleExprP comma)

2727 pure $ MakeRelationFromExprs attrExprs tupleExprs

2828