module ProjectM36.AtomType where
import ProjectM36.Base
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified ProjectM36.TypeConstructor as TC
import qualified ProjectM36.DataConstructorDef as DCD
import ProjectM36.MiscUtils
import ProjectM36.Error
import ProjectM36.DataTypes.Primitive
import ProjectM36.AttributeExpr as AE
import qualified ProjectM36.Attribute as A
import qualified Data.Vector as V
import qualified Data.Set as S
import qualified Data.List as L
import Data.Maybe (isJust)
import Data.Either (rights, lefts)
import Control.Monad.Writer
import qualified Data.Map as M
import qualified Data.Text as T
findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)
findDataConstructor dName = foldr tConsFolder Nothing
where
tConsFolder (tCons, dConsList) accum = if isJust accum then
accum
else
case findDCons dConsList of
Just dCons -> Just (tCons, dCons)
Nothing -> Nothing
findDCons dConsList = case filter (\dCons -> DCD.name dCons == dName) dConsList of
[] -> Nothing
[dCons] -> Just dCons
_ -> error "More than one data constructor with the same name found"
atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType
atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = do
isValidAtomTypeForTypeConstructor aType tCons tConss
pure aType
atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType
atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType
atomTypeForDataConstructor tConss dConsName atomArgTypes =
case findDataConstructor dConsName tConss of
Nothing -> Left (NoSuchDataConstructorError dConsName)
Just (tCons, dCons) -> do
dConsVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss
let tConsVars = M.fromList (map (\v -> (v, TypeVariableType v)) (TCD.typeVars tCons))
allVars = M.union dConsVars tConsVars
unresolvedType = ConstructedAtomType (TCD.name tCons) allVars
pure unresolvedType
resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap
resolveDataConstructorTypeVars dCons@(DataConstructorDef _ defArgs) aTypeArgs tConss = do
let defCount = length defArgs
argCount = length aTypeArgs
if defCount /= argCount then
Left (ConstructedAtomArgumentCountMismatchError defCount argCount)
else do
maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)
let typeVarMapFolder valMap acc = case acc of
Left err -> Left err
Right accMap ->
case resolveAtomTypesInTypeVarMap valMap accMap of
Left (TypeConstructorTypeVarMissing _) -> Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)
Left err -> Left err
Right ok -> pure ok
case foldr typeVarMapFolder (Right M.empty) maps of
Left err -> Left err
Right typeVarMaps -> pure typeVarMaps
resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
resolveDataConstructorArgTypeVars (DataConstructorDefTypeConstructorArg tCons) aType tConss = resolveTypeConstructorTypeVars tCons aType tConss
resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)
resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType _ =
if aType /= pType then
Left (AtomTypeMismatchError pType aType)
else
Right M.empty
resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomType tConsName' pVarMap') tConss =
if tConsName /= tConsName' then
Left (TypeConstructorNameMismatch tConsName tConsName')
else
case findTypeConstructor tConsName tConss of
Nothing -> Left (NoSuchTypeConstructorName tConsName)
Just (tConsDef, _) -> let expectedPVarNames = S.fromList (TCD.typeVars tConsDef) in
if M.keysSet pVarMap' `S.isSubsetOf` expectedPVarNames then
Right pVarMap'
else
Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))
resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = case typ of
TypeVariableType nam -> Left (TypeConstructorTypeVarMissing nam)
_ -> Right (M.singleton tvName typ)
resolveTypeConstructorTypeVars (ADTypeConstructor tConsName []) typ tConss = case findTypeConstructor tConsName tConss of
Just (PrimitiveTypeConstructorDef _ _, _) -> Right M.empty
_ -> Left (TypeConstructorAtomTypeMismatch tConsName typ)
resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)
resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =
case typ of
RelationAtomType attrs ->
M.unions <$> mapM (\(expectedAtomType, attrExpr) -> resolveAttributeExprTypeVars attrExpr expectedAtomType tConsMap) (zip (A.atomTypesList attrs) attrExprs)
otherType -> Left (AtomTypeMismatchError typ otherType)
resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap
resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = pure $ resolveTypeVariable (A.atomType attr) aType
resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap
validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]
validateTypeConstructorDef tConsDef dConsList = execWriter $ do
let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))
mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]
let leftSideVars = S.fromList (TCD.typeVars tConsDef)
rightSideVars = S.unions (map DCD.typeVars dConsList)
varsDiff = S.difference leftSideVars rightSideVars
mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]
atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType
atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False
atomTypeForTypeConstructorValidate :: Bool -> TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType
atomTypeForTypeConstructorValidate _ (PrimitiveTypeConstructor _ aType) _ _ = Right aType
atomTypeForTypeConstructorValidate validate (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of
Nothing -> if validate then
Left (TypeConstructorTypeVarMissing tvname)
else
pure (TypeVariableType tvname)
Just typ -> Right typ
atomTypeForTypeConstructorValidate _ (RelationAtomTypeConstructor attrExprs) tConsMap tvMap = do
resolvedAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap tvMap) attrExprs
let attrs = zipWith Attribute (map AE.attributeName attrExprs) resolvedAtomTypes
pure (RelationAtomType (A.attributesFromList attrs))
atomTypeForTypeConstructorValidate val tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of
Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))
Just (PrimitiveTypeConstructorDef _ aType, _) -> Right aType
Just (tConsDef, _) -> do
tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructorValidate val tConsArg tConss tvMap) (TC.arguments tCons)
let pVarNames = TCD.typeVars tConsDef
tConsArgs = M.fromList (zip pVarNames tConsArgTypes)
Right (ConstructedAtomType (TC.name tCons) tConsArgs)
atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType
atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)
atomTypeForAttributeExpr (AttributeAndTypeNameExpr _ tCons _) tConsMap tvMap = atomTypeForTypeConstructorValidate True tCons tConsMap tvMap
isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Either RelationalError ()
isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Left (AtomTypeMismatchError expectedAType aType) else pure ()
isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Left (TypeConstructorNameMismatch expectedTConsName tConsName) else pure ()
isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do
evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs
mapM_ (uncurry resolveAtomType) (zip (map A.atomType (V.toList attrs)) evaldAtomTypes)
isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))
findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])
findTypeConstructor name = foldr tConsFolder Nothing
where
tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then
Just (tCons, dConsList)
else
accum
resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType
resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =
ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap
resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then
Right typeFromRelation
else
Left (AtomTypeMismatchError typeFromRelation unresolvedType)
resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap
resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do
let resolveTypePair resKey resType =
case M.lookup resKey unresolvedTypeMap of
Just unresType -> case unresType of
subType@(ConstructedAtomType _ _) -> do
resSubType <- resolveAtomType resType subType
pure (resKey, resSubType)
_ -> pure (resKey, resType)
Nothing ->
pure (resKey, resType)
tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)
pure (M.fromList tVarList)
resolveTypeInAtom :: AtomType -> Atom -> TypeConstructorMapping -> Either RelationalError Atom
resolveTypeInAtom typeFromRelation@(ConstructedAtomType _ tvMap) atomIn@(ConstructedAtom dConsName _ args) tConss = do
newType <- resolveAtomType typeFromRelation (atomTypeForAtom atomIn)
case findDataConstructor dConsName tConss of
Nothing ->
pure atomIn
Just (_, dConsDef) -> do
atomArgTypes <- resolvedAtomTypesForDataConstructorDefArgs tConss tvMap dConsDef
newArgs <- mapM (\(atom, atomTyp) -> resolveTypeInAtom atomTyp atom tConss) (zip args atomArgTypes)
pure (ConstructedAtom dConsName newType newArgs)
resolveTypeInAtom (RelationAtomType attrs) (RelationAtom (Relation _ tupSet)) tConss = do
let newTups = mapM (resolveTypesInTuple attrs tConss) (asList tupSet)
RelationAtom . Relation attrs . RelationTupleSet <$> newTups
resolveTypeInAtom _ atom _ = Right atom
resolveTypesInTuple :: Attributes -> TypeConstructorMapping -> RelationTuple -> Either RelationalError RelationTuple
resolveTypesInTuple resolvedAttrs tConss (RelationTuple _ tupAtoms) = do
newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))
Right (RelationTuple resolvedAttrs (V.fromList newAtoms))
validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError ()
validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =
case findTypeConstructor tConsName tConss of
Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)
Just (tConsDef, _) -> case tConsDef of
ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames
actualTyVarNames = M.keysSet tVarMap
diff = S.difference expectedTyVarNames actualTyVarNames in
if not (S.null diff) then
Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames
else
validateTypeVarMap tVarMap tConss
_ -> Right ()
validateAtomType (RelationAtomType attrs) tConss =
mapM_ (\attr ->
validateAtomType (A.atomType attr) tConss) (V.toList attrs)
validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)
validateAtomType _ _ = pure ()
validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()
validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap
validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()
validateTuple (RelationTuple _ atoms) tConss = mapM_ (`validateAtom` tConss) atoms
validateAtom :: Atom -> TypeConstructorMapping -> Either RelationalError ()
validateAtom (RelationAtom (Relation _ tupSet)) tConss = mapM_ (`validateTuple` tConss) (asList tupSet)
validateAtom (ConstructedAtom _ dConsType atomArgs) tConss = do
validateAtomType dConsType tConss
mapM_ (`validateAtom` tConss) atomArgs
validateAtom _ _ = pure ()
atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify (TypeVariableType _) x = Right x
atomTypeVerify x (TypeVariableType _) = Right x
atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB)
| tConsNameA /= tConsNameB = Left (TypeConstructorNameMismatch tConsNameA tConsNameB)
| not (typeVarMapsVerify tVarMapA tVarMapB) = Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB)
| otherwise = Right x
atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do
mapM_ (\(attr1,attr2) -> let name1 = A.attributeName attr1
name2 = A.attributeName attr2 in
if notElem "_" [name1, name2] && name1 /= name2 then
Left $ AtomTypeMismatchError x y
else
atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)
return x
atomTypeVerify x y = if x == y then
Right x
else
Left $ AtomTypeMismatchError x y
typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool
typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a
prettyAtomType :: AtomType -> T.Text
prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"
prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))
where
showTypeVars (_, TypeVariableType x) = " " <> x
showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"
prettyAtomType (TypeVariableType x) = x
prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName
where fullName = (T.pack . show) aType
prettyAttribute :: Attribute -> T.Text
prettyAttribute (Attribute _ (TypeVariableType x)) = x
prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)
resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap
resolveTypeVariables expectedArgTypes actualArgTypes = do
let tvmaps = zipWith resolveTypeVariable expectedArgTypes actualArgTypes
foldM (\acc tvmap -> do
let inter = M.intersectionWithKey (\tvName vala valb ->
if vala /= valb then
Left (AtomFunctionTypeVariableMismatch tvName vala valb)
else
Right vala) acc tvmap
errs = lefts (M.elems inter)
case errs of
[] -> pure (M.unions tvmaps)
errs' -> Left (someErrors errs')) M.empty tvmaps
resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap
resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ
resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap
resolveTypeVariable _ _ = M.empty
resolveFunctionReturnValue :: AtomFunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType
resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = do
let diff = M.difference retMap tvMap
if M.null diff then
pure (ConstructedAtomType tCons (M.intersection tvMap retMap))
else
Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))
resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of
Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)
Just typ -> pure typ
resolveFunctionReturnValue _ _ typ = pure typ
resolvedAtomTypesForDataConstructorDefArgs :: TypeConstructorMapping -> TypeVarMap -> DataConstructorDef -> Either RelationalError [AtomType]
resolvedAtomTypesForDataConstructorDefArgs tConsMap tvMap (DataConstructorDef _ args) = mapM (resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap) args
resolvedAtomTypeForDataConstructorDefArg :: TypeConstructorMapping -> TypeVarMap -> DataConstructorDefArg -> Either RelationalError AtomType
resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap (DataConstructorDefTypeConstructorArg typCons) = atomTypeForTypeConstructor typCons tConsMap tvMap
resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of
Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)
Just typ -> Right typ