@@ -1,7 +1,6 @@
11{-# LANGUAGE OverloadedStrings #-}
22module ProjectM36.AtomType where
33import ProjectM36.Base
4−import ProjectM36.Relation
54import ProjectM36.DataTypes.Primitive
65import qualified ProjectM36.TypeConstructorDef as TCD
76import qualified ProjectM36.TypeConstructor as TC
@@ -9,30 +8,14 @@ import qualified ProjectM36.DataConstructorDef as DCD
98import qualified Data.Text as T
109import ProjectM36.Error
1110import ProjectM36.Attribute
12−import ProjectM36.Atom
1311import qualified Data.Vector as V
1412import qualified Data.Set as S
1513import qualified Data.List as L
1614import Data.Maybe (isJust)
1715import Control.Monad.Writer
1816import qualified Data.Map as M
19−--import Debug.Trace
17+import Debug.Trace
2018
21−typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
22−typesAsRelation types = mkRelationFromTuples attrs tuples
23− where
24− attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,
25− Attribute "DataConstructors" dConsType]
26− subAttrs = attributesFromList [Attribute "DataConstructor" textAtomType]
27− dConsType = RelationAtomType subAttrs
28− tuples = map mkTypeConsDescription types
29−
30− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TCD.name tCons), mkDataConsRelation dConsList])
31−
32− mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of
33− Left err -> error ("mkRelationFromTuples pooped " ++ show err)
34− Right rel -> Atom rel
35−
3619findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)
3720findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList
3821 where
@@ -89,6 +72,7 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes = do
8972 Just (tCons, dCons) -> do
9073 --validate that the type constructor arguments are fulfilled in the data constructor
9174 typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss
75+ traceShowM typeVars
9276 pure (ConstructedAtomType (TCD.name tCons) typeVars)
9377
9478-- | Walks the data and type constructors to extract the type variable map.
@@ -96,6 +80,9 @@ resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstr
9680resolveDataConstructorTypeVars dCons aTypeArgs tConss = do
9781 maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)
9882 --if any two maps have the same key and different values- bail!
83+ let typeVarMapFolder
84+ foldr typeVarMapFolder (Right M.empty) maps
85+ --if the data constructor cannot complete a type constructor variables (ex. "Nothing" could be Maybe Int or Maybe Text, etc.), then fill that space with AnyAtomType which is resolved when the relation is constructed- the relation must contain all resolved atom types.
9986 pure (M.unions maps)
10087
10188-- | Attempt to match the data constructor argument to a type constructor type variable.
@@ -147,6 +134,7 @@ dupes (x:y:xs) = dupes(x:[y]) ++ dupes(xs)
147134-- | Create an atom type iff all type variables are provided.
148135-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}
149136atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType
137+atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType
150138atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of
151139 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))
152140 Just (tConsDef, _) -> do
@@ -166,4 +154,44 @@ findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList
166154 Just (tCons, dConsList)
167155 else
168156 accum
169−
157+
158+resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType
159+resolveAtomType orig@(ConstructedAtomType dConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do
160+ _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap
161+ pure orig
162+resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then
163+ Right typeFromRelation
164+ else
165+ Left (AtomTypeMismatchError typeFromRelation unresolvedType)
166+
167+-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap
168+resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap
169+resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do
170+ let lookup key tMap = case M.lookup key tMap of
171+ Nothing -> Left (TypeConstructorTypeVarMissing key)
172+ Just val -> Right val
173+ let resolveTypePair unresKey AnyAtomType = do
174+ resType <- lookup unresKey resolvedTypeMap
175+ pure (unresKey, resType)
176+ resolveTypePair unresKey subType@(ConstructedAtomType _ _) = do --recurse
177+ resType <- lookup unresKey resolvedTypeMap
178+ resAType <- resolveAtomType resType subType
179+ pure (unresKey, resAType)
180+ resolveTypePair unresKey unresV = pure (unresKey, unresV)
181+ mapM_ (uncurry resolveTypePair) (M.toList unresolvedTypeMap)
182+ pure resolvedTypeMap
183+
184+-- | See notes at `resolveTypesInTuple`. The typeFromRelation must not include any wildcards.
185+resolveTypeInAtom :: AtomType -> Atom -> Either RelationalError Atom
186+resolveTypeInAtom typeFromRelation atomIn@(ConstructedAtom dConsName _ args) = do
187+ newType <- resolveAtomType typeFromRelation (atomTypeForAtom atomIn)
188+ pure (ConstructedAtom dConsName newType args)
189+resolveTypeInAtom _ atom = Right atom
190+
191+-- | When creating a tuple, the data constructor may not complete the type constructor arguments, so the wildcard "AnyAtomType" fills in the type constructor's argument. The tuple type must be resolved before it can be part of a relation, however.
192+-- 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.
193+resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple
194+resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do
195+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) (map atomType (V.toList resolvedAttrs)))
196+ Right (RelationTuple resolvedAttrs (V.fromList newAtoms))
197+