@@ -17,6 +17,8 @@ import Control.Monad.Writer
1717import qualified Data.Map as M
1818import qualified Data.Text as T
1919
20+import Debug.Trace
21+
2022findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)
2123findDataConstructor dName = foldr tConsFolder Nothing
2224 where
@@ -42,23 +44,12 @@ atomTypeForDataConstructorName dConsName atomTypesIn tConsList =
4244 ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomTypesIn tConsList
4345
4446atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType
45−atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =
46− case isValidAtomTypeForTypeConstructor aType tCons tConss of
47− Just err -> Left err
48− Nothing -> Right aType
47+atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = do
48+ isValidAtomTypeForTypeConstructor aType tCons tConss
49+ pure aType
4950
5051atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType --any type is OK
5152
52−--reconcile the atom-in types with the type constructors
53−isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError
54−isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing
55−
56−--lookup constructor name and check if the incoming atom types are valid
57−isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing
58−
59−isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) _ = error "poopla"
60−isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))
61−
6253-- | Used to determine if the atom arguments can be used with the data constructor.
6354-- | This is the entry point for type-checking from RelationalExpression.hs.
6455atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType
@@ -119,15 +110,16 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT
119110resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)
120111resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)
121112resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =
122− case typ of
113+ case traceShowId typ of
123114 RelationAtomType attrs -> do
124115 --resolve any typevars in the attrExprs
125− error "poop4"
126− otherType -> error "poop5"
116+ tvMaps <- mapM (\(expectedAtomType, attrExpr) -> resolveAttributeExprTypeVars attrExpr expectedAtomType tConsMap) (zip (A.atomTypesList attrs) attrExprs)
117+ pure (M.unions tvMaps)
118+ otherType -> Left (AtomTypeMismatchError typ otherType)
127119
128120--used when recursing down sub-relation type definition
129121resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
130−resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = error "poop2"
122+resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = error "poop5"
131123resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap
132124
133125-- check that type vars on the right also appear on the left
@@ -166,6 +158,19 @@ atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> Typ
166158atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)
167159atomTypeForAttributeExpr (AttributeAndTypeNameExpr _ tCons _) tConsMap tvMap = atomTypeForTypeConstructor tCons tConsMap tvMap
168160
161+--reconcile the atom-in types with the type constructors
162+isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Either RelationalError ()
163+isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Left (AtomTypeMismatchError expectedAType aType) else pure ()
164+
165+--lookup constructor name and check if the incoming atom types are valid
166+isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Left (TypeConstructorNameMismatch expectedTConsName tConsName) else pure ()
167+
168+isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do
169+ evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs
170+ mapM_ (uncurry resolveAtomType) (zip (map A.atomType (V.toList attrs)) evaldAtomTypes)
171+ pure ()
172+isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))
173+
169174findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])
170175findTypeConstructor name = foldr tConsFolder Nothing
171176 where
@@ -237,8 +242,11 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =
237242 else
238243 Right ()
239244 _ -> Right ()
240−validateAtomType (RelationAtomType attrs) _ = error "poop"
241−validateAtomType _ _ = Right ()
245+validateAtomType (RelationAtomType attrs) tConss = do
246+ mapM_ (\attr ->
247+ validateAtomType (A.atomType attr) tConss) (V.toList attrs)
248+ pure ()
249+validateAtomType _ _ = pure ()
242250
243251validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()
244252validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms