git.iko.soy/project-m36
on master help sign in
fix usage of MultipleErrors when there is only one error

fix inverted error logic in tuple type validation- oops- the improper use of the Maybe Monad is probably causing bugs elsewhere, I should audit such usage

commit5377a374ba53ee43c2e11e8a71ee118107bd6262 authorAgentM <agentm@themactionfaction.com> dateSat 2 Apr 2016, 15:05 (11 years ago) parent68f2827
3 files changed+27−21
compare with master
unifiedsplit
ProjectM36/AtomType.hs+15−14 ProjectM36/Error.hs+7−1 ProjectM36/RelationalExpression.hs+5−6
ProjectM36/AtomType.hs+15−14
@@ -209,19 +209,20 @@ resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do
209209 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))
210210
211211-- | Validate that the type is provided with complete type variables for type constructors.
212−validateAtomType :: AtomType -> TypeConstructorMapping -> Maybe RelationalError
212+validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError ()
213213validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do
214− (tConsDef, _) <- findTypeConstructor tConsName tConss
215− case tConsDef of
216− ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames
217− actualTyVarNames = M.keysSet tVarMap
218− diff = S.difference expectedTyVarNames actualTyVarNames in
219− if not (S.null diff) then
220− Just $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
221− else
222− Nothing
223− _ -> Just (TypeConstructorAtomTypeMismatch tConsName typ)
224−validateAtomType _ _ = Nothing
214+ case findTypeConstructor tConsName tConss of
215+ Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)
216+ Just (tConsDef, _) -> 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+ Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
222+ else
223+ Right ()
224+ _ -> Right ()
225+validateAtomType _ _ = Right ()
225226
226−validateTuple :: RelationTuple -> TypeConstructorMapping -> Maybe RelationalError
227−validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms >>= pure Nothing
227+validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()
228+validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms
ProjectM36/Error.hs+7−1
@@ -68,4 +68,10 @@ data PersistenceError = InvalidDirectoryError FilePath |
6868 MissingTransactionError U.UUID
6969 deriving (Show, Eq)
7070
71−
71+--collapse list of errors into normal error- if there is just one, just return one
72+someErrors :: [RelationalError] -> RelationalError
73+someErrors [] = error "no errors in error list: function misuse"
74+someErrors errList = if length errList == 1 then
75+ head errList
76+ else
77+ MultipleErrors errList
ProjectM36/RelationalExpression.hs+5−6
@@ -83,8 +83,8 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
8383 tupList = rights eTuples
8484 firstTupleAttrs = if length tupList == 0 then A.emptyAttributes else tupleAttributes (head tupList)
8585 pure $ mkRelation attrs (RelationTupleSet tupList)
86− errs -> pure $ Left (MultipleErrors errs)
87− errs -> pure $ Left (MultipleErrors errs)
86+ errs -> pure $ Left (someErrors errs)
87+ errs -> pure $ Left (someErrors errs)
8888
8989evalRelationalExpr (ExistingRelation rel) = return (Right rel)
9090
@@ -293,7 +293,7 @@ evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
293293 tConsName = TCD.name tConsDef
294294 -- validate that the constructor's types exist
295295 case validateTypeConstructorDef tConsDef dConsDefList of
296− errs@(_:_) -> pure $ Just (MultipleErrors errs)
296+ errs@(_:_) -> pure $ Just (someErrors errs)
297297 [] -> do
298298 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
299299 pure $ Just (InvalidAtomTypeName tConsName)
@@ -526,6 +526,5 @@ evalTupleExpr context attrs (TupleExpr tupMap) = do
526526 tConss = typeConstructorMapping context
527527 finalAttrs = fromMaybe tupAttrs attrs
528528 tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)
529− case validateTuple tup' tConss of
530− Just err -> Left err
531− _ -> pure tup'
529+ _ <- validateTuple tup' tConss
530+ pure tup'