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

git.iko.soy/project-m36

replace AnyAtomType with real type variables

remove useless TypeConstructorArg allow atom functions to have polymorphic types

commit08e09b6e71c03b254934d326f6a9389f851644f5 authorAgentM <agentm@themactionfaction.com> dateSat 15 Apr 2017, 13:04 (10 years ago) parentf09f894

16 files changed+112−69

compare with master

unifiedsplit

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

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

5959instance ToJSON TypeConstructor

6060instance FromJSON TypeConstructor

6161

62−instance ToJSON TypeConstructorArg

63−instance FromJSON TypeConstructorArg

64−

6562instance ToJSON SchemaExpr

6663instance FromJSON SchemaExpr

6764

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

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

9794 atype <- o .: "type"

9895 case atype of

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

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

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

10198 RelationAtomType _ -> do

10299 rel <- o .: "val"

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

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

4545adTypeConstructorP :: Parser TypeConstructor

4646adTypeConstructorP = do

4747 tConsName <- capitalizedIdentifier

48− tConsArgs <- many typeConstructorArgP

48+ tConsArgs <- many typeConstructorP

4949 pure $ ADTypeConstructor tConsName tConsArgs

5050

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

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

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

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

3333 pure $ PrimitiveTypeConstructor tName typ)

3434 primitiveTypeConstructorMapping)

35−

35+

3636-- *Either Int Text*, *Int*

3737typeConstructorP :: Parser TypeConstructor

3838typeConstructorP = primitiveTypeConstructorP <|>

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

39+ TypeVariable <$> uncapitalizedIdentifier <|>

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

41+ monoTypeConstructorP)

4042

4143monoTypeConstructorP :: Parser TypeConstructor

4244monoTypeConstructorP = primitiveTypeConstructorP <|>

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

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

46+ TypeVariable <$> uncapitalizedIdentifier

4447

45−typeConstructorArgP :: Parser TypeConstructorArg

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

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

48− TypeConstructorTypeVarArg <$> uncapitalizedIdentifier

4948

5049

5150

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

@@ -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 = [TypeVar "a", TypeVar "a"],

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

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

2424

2525

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

4343 lastArg = take 1 (reverse typeIn)

4444 case lastArg of

4545 (ADTypeConstructor "Either"

46− (TypeConstructorArg

47− (ADTypeConstructor "AtomFunctionError" []):

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

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

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

4948 pure (atomArgs ++ [atomRetArg])

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

5150

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

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

6261createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (

6362 argsType ++ [ADTypeConstructor "Either" [

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

65− TypeConstructorArg retType]]) script

63+ ADTypeConstructor "AtomFunctionError" [],

64+ retType]]) script

6665

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 = [TypeVar "a", TypeVar "a"],

19+ atomFuncType = [TypeVariableType "a", TypeVariableType "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 (TypeVar "a") IntAtomType,

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

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

2727 AtomFunction { atomFuncName = "max",

2828 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

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

1111import qualified Data.Set as S

1212import qualified Data.List as L

1313import Data.Maybe (isJust)

14−import Data.Either (rights)

14+import Data.Either (rights, lefts)

1515import Control.Monad.Writer

1616import qualified Data.Map as M

1717import qualified Data.Text as T

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

4949

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

5151

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

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

54−isValidAtomTypeForTypeConstructorArg _ (TypeConstructorTypeVarArg _) _ = Nothing

55−

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

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

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

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

112108 Nothing -> Left (NoSuchTypeConstructorName tConsName)

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

114110 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'

116112 else

117113 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

119116

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

121118-- check that the data constructor names are unique

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

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

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

136133atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType

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

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

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

139137 Just (tConsDef, _) -> do

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

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

141139 let pVarNames = TCD.typeVars tConsDef

142140 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

143141 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

148142

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

150144findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

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

225219

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

227221atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

228−atomTypeVerify (TypeVar _) x = Right x

229−atomTypeVerify x (TypeVar _) = Right x

222+atomTypeVerify (TypeVariableType _) x = Right x

223+atomTypeVerify x (TypeVariableType _) = Right x

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

231225 if tConsNameA /= tConsNameB then

232226 Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

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

257251 where

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

259253-- 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 <> "?"

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

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

263257

264258prettyAttribute :: Attribute -> T.Text

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

266260

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

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

269− M.unions tvmaps

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

262+resolveTypeVariables expectedArgTypes actualArgTypes = do

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

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

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

270275

271276resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

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

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

273278resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

274279resolveTypeVariable _ _ = M.empty

275280

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

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

281286 else

282287 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

284289 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

285290 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 |

7373 BoolAtomType |

7474 RelationAtomType Attributes |

7575 ConstructedAtomType TypeConstructorName TypeVarMap |

76− TypeVar TypeVarName

76+ TypeVariableType 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

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

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

231231

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

233−data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |

234− PrimitiveTypeConstructor TypeConstructorName AtomType

233+data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

234+ PrimitiveTypeConstructor TypeConstructorName AtomType |

235+ TypeVariable TypeVarName

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

236−

237−data TypeConstructorArg = TypeConstructorArg TypeConstructor |

238− TypeConstructorTypeVarArg TypeVarName

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

240−

237+

241238type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

242239

243240type TypeConstructorName = StringType

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 (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"))

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 (TypeVar "a"), BoolAtomType],

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

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

2323 },

2424 AtomFunction {

2525 atomFuncName = "fromMaybe",

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

26+ atomFuncType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "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/DatabaseContextFunction.hs+2−2

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

4949

5050databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor

5151databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [

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

53− TypeConstructorArg tCons]

52+ (ADTypeConstructor "DatabaseContextFunctionError" []),

53+ tCons]

5454

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

5656createScriptedDatabaseContextFunction 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)

5555 | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap

5656 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

5757 | AtomFunctionTypeVariableResolutionError AtomFunctionName TypeVarName

58+ | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType

5859 | AtomTypeNameInUseError AtomTypeName

5960 | IncompletelyDefinedAtomTypeWithConstructorError

6061 | AtomTypeNameNotInUseError AtomTypeName

src/lib/ProjectM36/MiscUtils.hs+1

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

66dupes (_:[]) = []

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

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

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

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

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

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

459459 atomArgs = take (length funcType - 2) funcType

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

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

461461 expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"

462462 actualType = show funcType

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

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

694694 Left err -> pure (Left err)

695695 Right func -> do

696696 let funcRetType = last (atomFuncType func)

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

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

698698 eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs

699699 case lefts eArgTypes of

700700 errs@(_:_) -> pure (Left (someErrors errs))

701701 [] -> do

702− let tvMap = resolveTypeVariables funcArgTypes argTypes

702+ let eTvMap = resolveTypeVariables funcArgTypes argTypes

703703 argTypes = rights eArgTypes

704− pure (resolveFunctionReturnValue funcName tvMap funcRetType)

704+ case eTvMap of

705+ Left err -> pure (Left err)

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

705707typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

706708 rstate <- get

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

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

766768 -- 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

767769 context <- liftM stateContext get

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

769− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

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

772+ newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

771773 pure (attrName, newAtom, newAtomType)

772774 ) (M.toList tupMap)

773775 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

55name :: TypeConstructor -> TypeConstructorName

66name (ADTypeConstructor name' _) = name'

77name (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]

1011arguments (ADTypeConstructor _ args) = args

1112arguments (PrimitiveTypeConstructor _ _) = []

13+arguments (TypeVariable _) = []

1214

1315typeVars :: TypeConstructor -> S.Set TypeVarName

1416typeVars (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

1619

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

7676 let intTCons = PrimitiveTypeConstructor "Int" IntAtomType

7777 addfunc = AddAtomFunction "testdisk" [

7878 intTCons,

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

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

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

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

8181 Nothing <- executeDatabaseContextIOExpr sess conn addfunc

8282 Nothing <- commit sess conn

8383 close conn

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

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

44import ProjectM36.Client

55import ProjectM36.Relation

66import ProjectM36.Error

7−import ProjectM36.Attribute

7+import ProjectM36.DataTypes.Maybe

88import qualified Data.Vector as V

99import qualified Data.Map as M

1010

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

1414 testExceptionAtomFunction,

1515 testErrorAtomFunction,

1616 testNoArgumentAtomFunction,

17− testArgumentTypeMismatch

17+ testArgumentTypeMismatch,

18+ testPolymorphicReturnType,

19+ testScriptedTypeVariable

1820 ])

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

2022

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

6971 attrs = [Attribute "x" IntAtomType]

7072 expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)

7173 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+