@@ -399,7 +399,7 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
399 errs@(_:_) -> pure $ Just (someErrors errs)
399 errs@(_:_) -> pure $ Just (someErrors errs)
400 [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName)
400 [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName)
401 | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName)
401 | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName)
402− | otherwise -> do
402+ | otherwise -> do
403 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
403 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
404 putStateContext $ currentContext { typeConstructorMapping = newTypes }
404 putStateContext $ currentContext { typeConstructorMapping = newTypes }
405 pure Nothing
405 pure Nothing
@@ -766,11 +766,11 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
766 Right aType -> pure (Right aType)
766 Right aType -> pure (Right aType)
767 Left err@(NoSuchAttributeNamesError _) -> case rstate of
767 Left err@(NoSuchAttributeNamesError _) -> case rstate of
768 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
768 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
769− Left err' -> pure (error "SPAMMO2" $ Left err')
769+ Left err' -> pure (Left err')
770 Right attr -> pure (Right (A.atomType attr))
770 Right attr -> pure (Right (A.atomType attr))
771− RelationalExprStateElems _ -> pure (error (show attrs) $ Left err)
771+ RelationalExprStateElems _ -> pure (Left err)
772 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
772 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
773− Left err' -> pure (error "STAMP" $ Left err')
773+ Left err' -> pure (Left err')
774 Right atom -> pure (Right (atomTypeForAtom atom))
774 Right atom -> pure (Right (atomTypeForAtom atom))
775 Left err -> pure (Left err)
775 Left err -> pure (Left err)
776typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
776typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
@@ -808,12 +808,12 @@ verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (
808verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
808verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
809 rstate <- lift ask
809 rstate <- lift ask
810 case A.atomTypeForAttributeName attrName (attributes relIn) of
810 case A.atomTypeForAttributeName attrName (attributes relIn) of
811− Right aType -> pure aType
811+ Right aType -> either throwE pure (atomTypeVerify expectedType aType)
812 (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
812 (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
813 RelationalExprStateTupleElems _ _ -> throwE err
813 RelationalExprStateTupleElems _ _ -> throwE err
814 RelationalExprStateElems _ -> throwE err
814 RelationalExprStateElems _ -> throwE err
815 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
815 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
816− Left err' -> throwE (error "GONK" err')
816+ Left err' -> throwE err'
817 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
817 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
818 Left err -> throwE err
818 Left err -> throwE err
819verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
819verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))