git.iko.soy/project-m36
on master help sign in
fix usage of MultipleErrors when there is only one error
5377a37AgentM
ProjectM36/AtomType.hs+15−14
compare with master
unifiedsplit
@@ -209,19 +209,20 @@ resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do
209 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))
209 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))
210
210
211-- | Validate that the type is provided with complete type variables for type constructors.
211-- | 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 ()
213validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do
213validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do
214− (tConsDef, _) <- findTypeConstructor tConsName tConss
214+ case findTypeConstructor tConsName tConss of
215+ Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)
215− case tConsDef of
216+ Just (tConsDef, _) -> case tConsDef of
216− ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames
217+ ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames
217− actualTyVarNames = M.keysSet tVarMap
218+ actualTyVarNames = M.keysSet tVarMap
218− diff = S.difference expectedTyVarNames actualTyVarNames in
219+ diff = S.difference expectedTyVarNames actualTyVarNames in
219− if not (S.null diff) then
220+ if not (S.null diff) then
220− Just $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
221+ Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
221− else
222+ else
222− Nothing
223+ Right ()
223− _ -> Just (TypeConstructorAtomTypeMismatch tConsName typ)
224+ _ -> Right ()
224−validateAtomType _ _ = Nothing
225+validateAtomType _ _ = Right ()
225
226
226−validateTuple :: RelationTuple -> TypeConstructorMapping -> Maybe RelationalError
227+validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()
227−validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms >>= pure Nothing
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 |
68 MissingTransactionError U.UUID
68 MissingTransactionError U.UUID
69 deriving (Show, Eq)
69 deriving (Show, Eq)
70
70
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
83 tupList = rights eTuples
83 tupList = rights eTuples
84 firstTupleAttrs = if length tupList == 0 then A.emptyAttributes else tupleAttributes (head tupList)
84 firstTupleAttrs = if length tupList == 0 then A.emptyAttributes else tupleAttributes (head tupList)
85 pure $ mkRelation attrs (RelationTupleSet tupList)
85 pure $ mkRelation attrs (RelationTupleSet tupList)
86− errs -> pure $ Left (MultipleErrors errs)
86+ errs -> pure $ Left (someErrors errs)
87− errs -> pure $ Left (MultipleErrors errs)
87+ errs -> pure $ Left (someErrors errs)
88
88
89evalRelationalExpr (ExistingRelation rel) = return (Right rel)
89evalRelationalExpr (ExistingRelation rel) = return (Right rel)
90
90
@@ -293,7 +293,7 @@ evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
293 tConsName = TCD.name tConsDef
293 tConsName = TCD.name tConsDef
294 -- validate that the constructor's types exist
294 -- validate that the constructor's types exist
295 case validateTypeConstructorDef tConsDef dConsDefList of
295 case validateTypeConstructorDef tConsDef dConsDefList of
296− errs@(_:_) -> pure $ Just (MultipleErrors errs)
296+ errs@(_:_) -> pure $ Just (someErrors errs)
297 [] -> do
297 [] -> do
298 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
298 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
299 pure $ Just (InvalidAtomTypeName tConsName)
299 pure $ Just (InvalidAtomTypeName tConsName)
@@ -526,6 +526,5 @@ evalTupleExpr context attrs (TupleExpr tupMap) = do
526 tConss = typeConstructorMapping context
526 tConss = typeConstructorMapping context
527 finalAttrs = fromMaybe tupAttrs attrs
527 finalAttrs = fromMaybe tupAttrs attrs
528 tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)
528 tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)
529− case validateTuple tup' tConss of
529+ _ <- validateTuple tup' tConss
530− Just err -> Left err
531− _ -> pure tup'
530+ pure tup'