08e09b6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

replace AnyAtomType with real type variables

08e09b6AgentM10 years ago

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

compare with master

unifiedsplit

@@ -59,9 +59,6 @@ instance FromJSON AtomType

59instance ToJSON TypeConstructor

60instance FromJSON TypeConstructor

62−instance ToJSON TypeConstructorArg

63−instance FromJSON TypeConstructorArg

64−

65instance ToJSON SchemaExpr

62instance ToJSON SchemaExpr

66instance FromJSON SchemaExpr

63instance FromJSON SchemaExpr

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

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

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

97 atype <- o .: "type"

94 atype <- o .: "type"

98 case atype of

95 case atype of

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

96+ TypeVariableType _ -> fail "cannot pass AnyAtomType over the wire"

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

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

101 RelationAtomType _ -> do

98 RelationAtomType _ -> do

102 rel <- o .: "val"

99 rel <- o .: "val"

src/bin/TutorialD/Interpreter/RelationalExpr.hs+1−1

@@ -45,7 +45,7 @@ attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstruc

45adTypeConstructorP :: Parser TypeConstructor

46adTypeConstructorP = do

47 tConsName <- capitalizedIdentifier

48− tConsArgs <- many typeConstructorArgP

48+ tConsArgs <- many typeConstructorP

49 pure $ ADTypeConstructor tConsName tConsArgs

51tupleExprP :: RelationalMarkerExpr a => Parser (TupleExprBase a)

src/bin/TutorialD/Interpreter/Types.hs+6−7

@@ -32,20 +32,19 @@ primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ,

32 tName <- try $ symbol (T.unpack name)

33 pure $ PrimitiveTypeConstructor tName typ)

34 primitiveTypeConstructorMapping)

35−

35+

36-- *Either Int Text*, *Int*

37typeConstructorP :: Parser TypeConstructor

38typeConstructorP = primitiveTypeConstructorP <|>

39+ TypeVariable <$> uncapitalizedIdentifier <|>

39− ADTypeConstructor <$> capitalizedIdentifier <*> many typeConstructorArgP

40+ ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>

41+ monoTypeConstructorP)

41monoTypeConstructorP :: Parser TypeConstructor

43monoTypeConstructorP :: Parser TypeConstructor

42monoTypeConstructorP = primitiveTypeConstructorP <|>

44monoTypeConstructorP = primitiveTypeConstructorP <|>

43− ADTypeConstructor <$> capitalizedIdentifier <*> pure []

45+ ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

46+ TypeVariable <$> uncapitalizedIdentifier

45−typeConstructorArgP :: Parser TypeConstructorArg

46−typeConstructorArgP = TypeConstructorArg <$> monoTypeConstructorP <|>

47− parens (TypeConstructorArg <$> typeConstructorP) <|>

48− TypeConstructorTypeVarArg <$> uncapitalizedIdentifier

src/lib/ProjectM36/AtomFunction.hs+5−6

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

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

20emptyAtomFunction :: AtomFunctionName -> AtomFunction

21emptyAtomFunction name = AtomFunction { atomFuncName = name,

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

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

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

@@ -43,9 +43,8 @@ extractAtomFunctionType typeIn = do

43 lastArg = take 1 (reverse typeIn)

44 case lastArg of

45 (ADTypeConstructor "Either"

46− (TypeConstructorArg

47− (ADTypeConstructor "AtomFunctionError" []):

46+ ((ADTypeConstructor "AtomFunctionError" []):

48− (TypeConstructorArg atomRetArg):[])):[] -> do

47+ atomRetArg:[])):[] -> do

49 pure (atomArgs ++ [atomRetArg])

48 pure (atomArgs ++ [atomRetArg])

50 otherType -> Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))

49 otherType -> Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))

@@ -61,6 +60,6 @@ atomFunctionScript func = case atomFuncBody func of

61createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr

60createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr

62createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (

61createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (

63 argsType ++ [ADTypeConstructor "Either" [

62 argsType ++ [ADTypeConstructor "Either" [

64− TypeConstructorArg (ADTypeConstructor "AtomFunctionError" []),

63+ ADTypeConstructor "AtomFunctionError" [],

65− TypeConstructorArg retType]]) script

64+ retType]]) script

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

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

16 atomFuncType = [IntAtomType, IntAtomType, IntAtomType],

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

18 AtomFunction { atomFuncName = "id",

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

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

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

21 AtomFunction { atomFuncName = "sum",

22 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

24 AtomFunction { atomFuncName = "count",

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

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

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

27 AtomFunction { atomFuncName = "max",

28 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

@@ -11,7 +11,7 @@ import qualified Data.Vector as V

11import qualified Data.Set as S

12import qualified Data.List as L

13import Data.Maybe (isJust)

14−import Data.Either (rights)

14+import Data.Either (rights, lefts)

15import Control.Monad.Writer

16import qualified Data.Map as M

17import qualified Data.Text as T

@@ -49,10 +49,6 @@ atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aT

50atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType --any type is OK

52−isValidAtomTypeForTypeConstructorArg :: AtomType -> TypeConstructorArg -> TypeConstructorMapping -> Maybe RelationalError

53−isValidAtomTypeForTypeConstructorArg aType (TypeConstructorArg tCons) tConsList = isValidAtomTypeForTypeConstructor aType tCons tConsList

54−isValidAtomTypeForTypeConstructorArg _ (TypeConstructorTypeVarArg _) _ = Nothing

55−

56--reconcile the atom-in types with the type constructors

52--reconcile the atom-in types with the type constructors

57isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError

53isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError

58isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing

54isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing

@@ -112,10 +108,11 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

112 Nothing -> Left (NoSuchTypeConstructorName tConsName)

108 Nothing -> Left (NoSuchTypeConstructorName tConsName)

113 Just (tConsDef, _) -> let expectedPVarNames = S.fromList (TCD.typeVars tConsDef) in

109 Just (tConsDef, _) -> let expectedPVarNames = S.fromList (TCD.typeVars tConsDef) in

114 if M.keysSet pVarMap' `S.isSubsetOf` expectedPVarNames then

110 if M.keysSet pVarMap' `S.isSubsetOf` expectedPVarNames then

115− Right pVarMap' -- I wish we could actually resolve this- we are creating temporary AtomTypes which are actually invalid until they are resolved with a second pass of type resolution- not great

111+ Right pVarMap'

116 else

112 else

117 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

113 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

118−resolveTypeConstructorTypeVars _ _ _ = error "Unhandled type vars"

114+resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

115+resolveTypeConstructorTypeVars x y _ = error $ "Unhandled type vars:" ++ show x ++ show y

119

116

120-- check that type vars on the right also appear on the left

117-- check that type vars on the right also appear on the left

121-- check that the data constructor names are unique

118-- check that the data constructor names are unique

@@ -134,17 +131,14 @@ validateTypeConstructorDef tConsDef dConsList = execWriter $ do

134-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

131-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

135atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType

132atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType

136atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType

133atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType

134+atomTypeForTypeConstructor (TypeVariable tvname) _ = Right (TypeVariableType tvname)

137atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of

135atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of

138 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

136 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

139 Just (tConsDef, _) -> do

137 Just (tConsDef, _) -> do

140− tConsArgTypes <- mapM ((flip atomTypeForTypeConstructorArg) tConss) (TC.arguments tCons)

138+ tConsArgTypes <- mapM ((flip atomTypeForTypeConstructor) tConss) (TC.arguments tCons)

141 let pVarNames = TCD.typeVars tConsDef

139 let pVarNames = TCD.typeVars tConsDef

142 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

140 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

143 Right (ConstructedAtomType (TC.name tCons) tConsArgs)

141 Right (ConstructedAtomType (TC.name tCons) tConsArgs)

144−

145−atomTypeForTypeConstructorArg :: TypeConstructorArg -> TypeConstructorMapping -> Either RelationalError AtomType

146−atomTypeForTypeConstructorArg (TypeConstructorTypeVarArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError

147−atomTypeForTypeConstructorArg (TypeConstructorArg tCons) tConsList = atomTypeForTypeConstructor tCons tConsList

148

142

149findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])

143findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])

150findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

144findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

@@ -225,8 +219,8 @@ validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (at

225

219

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

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

227atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

221atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

228−atomTypeVerify (TypeVar _) x = Right x

222+atomTypeVerify (TypeVariableType _) x = Right x

229−atomTypeVerify x (TypeVar _) = Right x

223+atomTypeVerify x (TypeVariableType _) = Right x

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

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

231 if tConsNameA /= tConsNameB then

225 if tConsNameA /= tConsNameB then

232 Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

226 Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

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

257 where

251 where

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

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

259-- 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?)

253-- 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?)

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

254+prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

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

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

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

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

263

257

264prettyAttribute :: Attribute -> T.Text

258prettyAttribute :: Attribute -> T.Text

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

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

266

260

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

261+resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

262+resolveTypeVariables expectedArgTypes actualArgTypes = do

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

263+ let tvmaps = map (uncurry resolveTypeVariable) (zip expectedArgTypes actualArgTypes)

264+ --if there are any new keys which don't have equal values then we have a conflict!

265+ foldM (\acc tvmap -> do

266+ let inter = M.intersectionWithKey (\tvName vala valb ->

267+ if vala /= valb then

268+ Left (AtomFunctionTypeVariableMismatch tvName vala valb)

269+ else

270+ Right vala) acc tvmap

271+ errs = lefts (M.elems inter)

272+ case errs of

269− M.unions tvmaps

273+ [] -> pure (M.unions tvmaps)

274+ errs' -> Left (someErrors errs')) M.empty tvmaps

270

275

271resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

276resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

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

277+resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ

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

278resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

274resolveTypeVariable _ _ = M.empty

279resolveTypeVariable _ _ = M.empty

275

280

@@ -280,7 +285,7 @@ resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = d

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

285 pure (ConstructedAtomType tCons (M.intersection tvMap retMap))

281 else

286 else

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

287 Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))

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

288+resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of

284 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

289 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

285 Just typ -> pure typ

290 Just typ -> pure typ

286−resolveFunctionReturnValue _ _ typ = pure typ

291+resolveFunctionReturnValue _ _ typ = pure typ

src/lib/ProjectM36/Base.hs+5−8

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

73 BoolAtomType |

74 RelationAtomType Attributes |

75 ConstructedAtomType TypeConstructorName TypeVarMap |

76− TypeVar TypeVarName

76+ TypeVariableType TypeVarName

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

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

@@ -230,14 +230,11 @@ data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName]

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

231

232-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int

233−data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |

233+data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

234− PrimitiveTypeConstructor TypeConstructorName AtomType

234+ PrimitiveTypeConstructor TypeConstructorName AtomType |

235+ TypeVariable TypeVarName

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

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

236−

237+

237−data TypeConstructorArg = TypeConstructorArg TypeConstructor |

238− TypeConstructorTypeVarArg TypeVarName

239− deriving (Show, Generic, Binary, Eq, NFData)

240−

241type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

238type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

242

239

243type TypeConstructorName = StringType

240type TypeConstructorName = StringType

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

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

15eitherAtomFunctions :: AtomFunctions

16eitherAtomFunctions = HS.fromList [

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

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

18 ]

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

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

18maybeAtomFunctions = HS.fromList [

19 AtomFunction {

20 atomFuncName ="isJust",

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

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

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

23 },

24 AtomFunction {

25 atomFuncName = "fromMaybe",

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

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

27 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

28 }

29 ]

src/lib/ProjectM36/DatabaseContextFunction.hs+2−2

@@ -49,8 +49,8 @@ databaseContextFunctionScript func = case dbcFuncBody func of

50databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor

51databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [

52− TypeConstructorArg (ADTypeConstructor "DatabaseContextFunctionError" []),

52+ (ADTypeConstructor "DatabaseContextFunctionError" []),

53− TypeConstructorArg tCons]

53+ tCons]

55createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr

56createScriptedDatabaseContextFunction funcName argsIn retArg script = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) script

src/lib/ProjectM36/Error.hs+1

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

55 | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap

56 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

57 | AtomFunctionTypeVariableResolutionError AtomFunctionName TypeVarName

58+ | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType

58 | AtomTypeNameInUseError AtomTypeName

59 | AtomTypeNameInUseError AtomTypeName

59 | IncompletelyDefinedAtomTypeWithConstructorError

60 | IncompletelyDefinedAtomTypeWithConstructorError

60 | AtomTypeNameNotInUseError AtomTypeName

61 | AtomTypeNameNotInUseError AtomTypeName

src/lib/ProjectM36/MiscUtils.hs+1

@@ -6,3 +6,4 @@ dupes [] = []

6dupes (_:[]) = []

7dupes (x:y:[]) = if x == y then [x] else []

8dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs)

src/lib/ProjectM36/RelationalExpression.hs+7−5

@@ -457,7 +457,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

457 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext

458 let last2Args = reverse (take 2 (reverse funcType))

459 atomArgs = take (length funcType - 2) funcType

460− dbContextTypeCons = ADTypeConstructor "Either" [TypeConstructorArg (ADTypeConstructor "DatabaseContextFunctionError" []), TypeConstructorArg (ADTypeConstructor "DatabaseContext" [])]

460+ dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]

461 expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"

462 actualType = show funcType

463 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then

@@ -694,14 +694,16 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

694 Left err -> pure (Left err)

695 Right func -> do

696 let funcRetType = last (atomFuncType func)

697− funcArgTypes = reverse (tail (reverse (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

702+ let eTvMap = resolveTypeVariables funcArgTypes argTypes

703 argTypes = rights eArgTypes

704+ case eTvMap of

705+ Left err -> pure (Left err)

704− pure (resolveFunctionReturnValue funcName tvMap funcRetType)

706+ Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

705typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

707typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

706 rstate <- get

708 rstate <- get

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

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

@@ -766,8 +768,8 @@ evalTupleExpr attrs (TupleExpr tupMap) = runExceptT $ do

766 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

768 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

767 context <- liftM stateContext get

769 context <- liftM stateContext get

768 attrAtoms <- mapM (\(attrName, aExpr) -> do

770 attrAtoms <- mapM (\(attrName, aExpr) -> do

769− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

770 newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)

771 newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)

772+ newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

771 pure (attrName, newAtom, newAtomType)

773 pure (attrName, newAtom, newAtomType)

772 ) (M.toList tupMap)

774 ) (M.toList tupMap)

773 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

775 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

src/lib/ProjectM36/TypeConstructor.hs+5−5

@@ -5,15 +5,15 @@ import qualified Data.Set as S

5name :: TypeConstructor -> TypeConstructorName

6name (ADTypeConstructor name' _) = name'

7name (PrimitiveTypeConstructor name' _) = name'

8+name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only

9−arguments :: TypeConstructor -> [TypeConstructorArg]

10+arguments :: TypeConstructor -> [TypeConstructor]

10arguments (ADTypeConstructor _ args) = args

11arguments (ADTypeConstructor _ args) = args

11arguments (PrimitiveTypeConstructor _ _) = []

12arguments (PrimitiveTypeConstructor _ _) = []

13+arguments (TypeVariable _) = []

13typeVars :: TypeConstructor -> S.Set TypeVarName

15typeVars :: TypeConstructor -> S.Set TypeVarName

14typeVars (PrimitiveTypeConstructor _ _) = S.empty

16typeVars (PrimitiveTypeConstructor _ _) = S.empty

15−typeVars (ADTypeConstructor _ args) = S.unions (map typeVarsForArg args)

17+typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

18+typeVars (TypeVariable v) = S.singleton v

17−typeVarsForArg :: TypeConstructorArg -> S.Set TypeVarName

18−typeVarsForArg (TypeConstructorArg arg) = typeVars arg

19−typeVarsForArg (TypeConstructorTypeVarArg pName) = S.singleton pName

test/TransactionGraph/Persist.hs+2−2

@@ -76,8 +76,8 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

76 let intTCons = PrimitiveTypeConstructor "Int" IntAtomType

77 addfunc = AddAtomFunction "testdisk" [

78 intTCons,

79− ADTypeConstructor "Either" [TypeConstructorArg (ADTypeConstructor "AtomFunctionError" []),

79+ ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [],

80− TypeConstructorArg intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"

80+ intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"

81 Nothing <- executeDatabaseContextIOExpr sess conn addfunc

82 Nothing <- commit sess conn

83 close conn

test/TutorialD/Interpreter/AtomFunctionScript.hs+45−3

@@ -4,7 +4,7 @@ import Test.HUnit

4import ProjectM36.Client

5import ProjectM36.Relation

6import ProjectM36.Error

7−import ProjectM36.Attribute

7+import ProjectM36.DataTypes.Maybe

8import qualified Data.Vector as V

9import qualified Data.Map as M

@@ -14,7 +14,9 @@ main = do

14 testExceptionAtomFunction,

15 testErrorAtomFunction,

16 testNoArgumentAtomFunction,

17− testArgumentTypeMismatch

17+ testArgumentTypeMismatch,

18+ testPolymorphicReturnType,

19+ testScriptedTypeVariable

18 ])

20 ])

19 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

21 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

@@ -69,4 +71,44 @@ testArgumentTypeMismatch = TestCase $ do

69 attrs = [Attribute "x" IntAtomType]

71 attrs = [Attribute "x" IntAtomType]

70 expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)

72 expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)

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

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

72− assertEqual "type mismatch not detected" expectedResult result

74+ assertEqual "type mismatch not detected" expectedResult result

75+

76+testPolymorphicReturnType :: Test

77+testPolymorphicReturnType = TestCase $ do

78+ --test that polymorphic function return type resolves to concrete type using fromMaybe builtin atom function

79+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

80+ let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),

81+ NakedAtomExpr maybeAtom] ()

82+ maybeAtom = ConstructedAtom "Just" (maybeAtomType IntAtomType) [IntAtom 3]

83+ relExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" funcAtomExpr)]

84+ mRelType <- typeForRelationalExpr sess conn relExpr

85+ case mRelType of

86+ Left err -> assertFailure (show err)

87+ Right relType -> do

88+ let expectedRetAttrs = V.fromList [Attribute "x" IntAtomType]

89+ assertEqual "fromMaybe type" expectedRetAttrs (attributes relType)

90+ mRes <- executeRelationalExpr sess conn relExpr

91+ let expectedRel = mkRelationFromList (V.fromList [Attribute "x" IntAtomType]) [[IntAtom 3]]

92+ assertEqual "fromMaybe result" expectedRel mRes

93+ --test that type mismatch occurs for different types appearing in same type variable

94+ let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),

95+ NakedAtomExpr mismatchAtom] ()

96+ mismatchAtom = ConstructedAtom "Just" (maybeAtomType TextAtomType) [TextAtom "fail"]

97+ failRelExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" failFuncAtomExpr)]

98+ mFailRes <- executeRelationalExpr sess conn failRelExpr

99+ let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntAtomType TextAtomType)

100+ assertEqual "expected type variable mismatch" expectedErr mFailRes

101+

102+--test that a user can create a function with a type variable argument

103+testScriptedTypeVariable :: Test

104+testScriptedTypeVariable = TestCase $ do

105+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

106+ executeTutorialD sess conn "addatomfunction \"idTest\" a -> Either AtomFunctionError a \"(\\\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom\""

107+ let attrs = [Attribute "x" IntAtomType]

108+ funcAtomExpr = FunctionAtomExpr "idTest" [NakedAtomExpr (IntAtom 3)] ()

109+ tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

110+ expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]

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

112+

113+ assertEqual "id function equality" expectedResult result

114+