f09f894 · project-m36 · git.iko.soy

git.iko.soy/project-m36

polymorphic return values for functions now resolves to concrete types

commitf09f894f90db1631f92c239c05d58d2ccb6dbb41 authorAgentM <agentm@themactionfaction.com> dateFri 14 Apr 2017, 11:52 (10 years ago) parent067b382

12 files changed+54−24

compare with master

unifiedsplit

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1−1

@@ -96,7 +96,7 @@ instance FromJSON Atom where

9696 parseJSON = withObject "atom" $ \o -> do

9797 atype <- o .: "type"

9898 case atype of

99− AnyAtomType -> fail "cannot pass AnyAtomType over the wire"

99+ TypeVar _ -> fail "cannot pass AnyAtomType over the wire"

100100 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

101101 RelationAtomType _ -> do

102102 rel <- o .: "val"

src/lib/ProjectM36/AtomFunction.hs+1−1

@@ -19,7 +19,7 @@ atomFunctionForName funcName funcSet = if HS.null foundFunc then

1919-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.

2020emptyAtomFunction :: AtomFunctionName -> AtomFunction

2121emptyAtomFunction name = AtomFunction { atomFuncName = name,

22− atomFuncType = [AnyAtomType, AnyAtomType],

22+ atomFuncType = [TypeVar "a", TypeVar "a"],

2323 atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }

2424

2525

src/lib/ProjectM36/AtomFunctionError.hs+1−1

@@ -8,4 +8,4 @@ data AtomFunctionError = AtomFunctionUserError String |

88 AtomFunctionTypeMismatchError |

99 AtomFunctionBytesDecodingError String

1010 deriving(Generic, Eq, Show, Binary, NFData)

11−

11+

src/lib/ProjectM36/AtomFunctions/Primitive.hs+2−2

@@ -16,13 +16,13 @@ primitiveAtomFunctions = HS.fromList [

1616 atomFuncType = [IntAtomType, IntAtomType, IntAtomType],

1717 atomFuncBody = body (\((IntAtom i1):(IntAtom i2):_) -> pure (IntAtom (i1 + i2)))},

1818 AtomFunction { atomFuncName = "id",

19− atomFuncType = [AnyAtomType, AnyAtomType],

19+ atomFuncType = [TypeVar "a", TypeVar "a"],

2020 atomFuncBody = body (\(x:_) -> pure x)},

2121 AtomFunction { atomFuncName = "sum",

2222 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

2323 atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},

2424 AtomFunction { atomFuncName = "count",

25− atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,

25+ atomFuncType = foldAtomFuncType (TypeVar "a") IntAtomType,

2626 atomFuncBody = body (\((RelationAtom relIn):_) -> relationCount relIn)},

2727 AtomFunction { atomFuncName = "max",

2828 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

src/lib/ProjectM36/AtomType.hs+26−7

@@ -15,7 +15,6 @@ import Data.Either (rights)

1515import Control.Monad.Writer

1616import qualified Data.Map as M

1717import qualified Data.Text as T

18−--import Debug.Trace

1918

2019findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)

2120findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

@@ -89,7 +88,7 @@ resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

8988 case foldr typeVarMapFolder (Right M.empty) maps of

9089 Left err -> Left err

9190 Right typeVarMaps -> pure typeVarMaps

92− --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.

91+ --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 TypeVar which is resolved when the relation is constructed- the relation must contain all resolved atom types.

9392

9493

9594-- | Attempt to match the data constructor argument to a type constructor type variable.

@@ -198,7 +197,7 @@ resolveTypeInAtom typeFromRelation atomIn@(ConstructedAtom dConsName _ args) = d

198197 pure (ConstructedAtom dConsName newType args)

199198resolveTypeInAtom _ atom = Right atom

200199

201−-- | 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.

200+-- | When creating a tuple, the data constructor may not complete the type constructor arguments, so the wildcard "TypeVar x" fills in the type constructor's argument. The tuple type must be resolved before it can be part of a relation, however.

202201-- 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.

203202resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

204203resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

@@ -224,10 +223,10 @@ validateAtomType _ _ = Right ()

224223validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()

225224validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms

226225

227−-- | Determine if two types are equal or compatible (including special handling for AnyAtomType).

226+-- | Determine if two types are equal or compatible (including special handling for TypeVar x).

228227atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

229−atomTypeVerify AnyAtomType x = Right x

230−atomTypeVerify x AnyAtomType = Right x

228+atomTypeVerify (TypeVar _) x = Right x

229+atomTypeVerify x (TypeVar _) = Right x

231230atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) =

232231 if tConsNameA /= tConsNameB then

233232 Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

@@ -258,10 +257,30 @@ prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append`

258257 where

259258 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

260259-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

261−prettyAtomType AnyAtomType = "?AnyAtomType?"

260+prettyAtomType (TypeVar x) = "?TypeVar " <> x <> "?"

262261prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

263262 where fullName = (T.pack . show) aType

264263

265264prettyAttribute :: Attribute -> T.Text

266265prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

267266

267+resolveTypeVariables :: [AtomType] -> [AtomType] -> TypeVarMap

268+resolveTypeVariables expectedArgTypes actualArgTypes = let tvmaps = map (uncurry resolveTypeVariable) (zip expectedArgTypes actualArgTypes) in

269+ M.unions tvmaps

270+

271+resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

272+resolveTypeVariable (TypeVar tv) typ = M.singleton tv typ

273+resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

274+resolveTypeVariable _ _ = M.empty

275+

276+resolveFunctionReturnValue :: AtomFunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType

277+resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = do

278+ let diff = M.difference retMap tvMap

279+ if M.null diff then

280+ pure (ConstructedAtomType tCons (M.intersection tvMap retMap))

281+ else

282+ Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))

283+resolveFunctionReturnValue funcName tvMap (TypeVar tvName) = case M.lookup tvName tvMap of

284+ Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

285+ Just typ -> pure typ

286+resolveFunctionReturnValue _ _ typ = pure typ

src/lib/ProjectM36/Base.hs+1−1

@@ -73,7 +73,7 @@ data AtomType = IntAtomType |

7373 BoolAtomType |

7474 RelationAtomType Attributes |

7575 ConstructedAtomType TypeConstructorName TypeVarMap |

76− AnyAtomType

76+ TypeVar TypeVarName

7777 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

7878 deriving (Eq, NFData, Generic, Binary, Show)

7979

src/lib/ProjectM36/DataTypes/Either.hs+1−1

@@ -14,5 +14,5 @@ eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],

1414

1515eitherAtomFunctions :: AtomFunctions

1616eitherAtomFunctions = HS.fromList [

17− compiledAtomFunction "isLeft" [eitherAtomType AnyAtomType AnyAtomType, BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> pure (BoolAtom (dConsName == "Left"))

17+ compiledAtomFunction "isLeft" [eitherAtomType (TypeVar "a") (TypeVar "b"), BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> pure (BoolAtom (dConsName == "Left"))

1818 ]

src/lib/ProjectM36/DataTypes/Maybe.hs+2−2

@@ -18,12 +18,12 @@ maybeAtomFunctions :: AtomFunctions

1818maybeAtomFunctions = HS.fromList [

1919 AtomFunction {

2020 atomFuncName ="isJust",

21− atomFuncType = [maybeAtomType AnyAtomType, BoolAtomType],

21+ atomFuncType = [maybeAtomType (TypeVar "a"), BoolAtomType],

2222 atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> pure $ BoolAtom (dConsName /= "Nothing")

2323 },

2424 AtomFunction {

2525 atomFuncName = "fromMaybe",

26− atomFuncType = [AnyAtomType, maybeAtomType AnyAtomType, AnyAtomType], -- this really should be more specific, but we don't have type checker handling for this yet

26+ atomFuncType = [TypeVar "a", maybeAtomType (TypeVar "a"), TypeVar "a"],

2727 atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:(ConstructedAtom dConsName _ (atomVal:_)):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal

2828 }

2929 ]

src/lib/ProjectM36/Error.hs+1

@@ -54,6 +54,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

5454 | TypeConstructorTypeVarMissing TypeVarName

5555 | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap

5656 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

57+ | AtomFunctionTypeVariableResolutionError AtomFunctionName TypeVarName

5758 | AtomTypeNameInUseError AtomTypeName

5859 | IncompletelyDefinedAtomTypeWithConstructorError

5960 | AtomTypeNameNotInUseError AtomTypeName

src/lib/ProjectM36/RelationalExpression.hs+15−6

@@ -619,8 +619,8 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE

619619 Left err -> pure (Left err)

620620 Right _ -> runExceptT $ do

621621 atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)

622− _ <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

623− let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]

622+ atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

623+ let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

624624 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

625625 pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case evalState (evalAtomExpr tup atomExpr) substate of

626626 Left err -> Left err

@@ -687,12 +687,21 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

687687 Right atom -> pure (Right (atomTypeForAtom atom))

688688 Left err -> pure (Left err)

689689typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))

690−typeFromAtomExpr _ (FunctionAtomExpr funcName _ _) = do

690+typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

691691 context <- liftM stateContext get

692692 let funcs = atomFunctions context

693− runExceptT $ do

694− func <- either throwE pure (atomFunctionForName funcName funcs)

695− pure (last (atomFuncType func))

693+ case atomFunctionForName funcName funcs of

694+ Left err -> pure (Left err)

695+ Right func -> do

696+ let funcRetType = last (atomFuncType func)

697+ funcArgTypes = reverse (tail (reverse (atomFuncType func)))

698+ eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs

699+ case lefts eArgTypes of

700+ errs@(_:_) -> pure (Left (someErrors errs))

701+ [] -> do

702+ let tvMap = resolveTypeVariables funcArgTypes argTypes

703+ argTypes = rights eArgTypes

704+ pure (resolveFunctionReturnValue funcName tvMap funcRetType)

696705typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

697706 rstate <- get

698707 relType <- either throwE pure (evalState (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))

test/Relation/Basic.hs+2−1

@@ -80,8 +80,9 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe

8080--mkRelation tests

8181--test tupleset key mismatch failure

8282testMkRelation1 :: Test

83−testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTypeMismatchError A.emptyAttributes) (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types

83+testMkRelation1 = TestCase $ assertEqual "key mismatch" expectedError (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types

8484 where

85+ expectedError = Left (AtomTypeMismatchError TextAtomType IntAtomType)

8586 testAttrs = A.attributesFromList [Attribute "a" TextAtomType]

8687 testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [TextAtom "v"],

8788 mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]

test/TutorialD/Interpreter/AtomFunctionScript.hs+1−1

@@ -67,6 +67,6 @@ testArgumentTypeMismatch = TestCase $ do

6767 let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

6868 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)] ()

6969 attrs = [Attribute "x" IntAtomType]

70− expectedResult = Left (TupleAttributeTypeMismatchError emptyAttributes)

70+ expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)

7171 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

7272 assertEqual "type mismatch not detected" expectedResult result