6d4bf99 · project-m36 · git.iko.soy

ProjectM36/AtomFunction.hs−17

@@ -4,7 +4,6 @@ import ProjectM36.Base

44import ProjectM36.Error

55import qualified ProjectM36.Attribute as A

66import qualified Data.HashSet as HS

7−import qualified Data.Vector as V

87

98foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

109foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

@@ -17,21 +16,5 @@ atomFunctionForName funcName funcSet = if HS.null foundFunc then

1716 where

1817 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet

1918

20−--determine if two types are equal or compatible

21−atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

22−atomTypeVerify AnyAtomType x = Right x

23−atomTypeVerify x AnyAtomType = Right x

24−atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

25− _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1

26− name2 = A.attributeName attr2 in

27− if notElem "_" [name1, name2] && name1 /= name2 then

28− Left $ AtomTypeMismatchError x y

29− else

30− atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

31− return x

32−atomTypeVerify x y = if x == y then

33− Right x

34− else

35− Left $ AtomTypeMismatchError x y

3619

3720

ProjectM36/AtomFunctions/Basic.hs+6−1

@@ -3,9 +3,14 @@

33module ProjectM36.AtomFunctions.Basic where

44import ProjectM36.Base

55import ProjectM36.DataTypes.Day

6+import ProjectM36.DataTypes.Either

7+import ProjectM36.DataTypes.Maybe

68import ProjectM36.AtomFunctions.Primitive

79import qualified Data.HashSet as HS

810

911basicAtomFunctions :: AtomFunctions

10−basicAtomFunctions = primitiveAtomFunctions `HS.union` dayFunctions

12+basicAtomFunctions = HS.unions [primitiveAtomFunctions,

13+ dayAtomFunctions,

14+ eitherAtomFunctions,

15+ maybeAtomFunctions]

1116

ProjectM36/AtomType.hs+32−3

@@ -5,11 +5,12 @@ import qualified ProjectM36.TypeConstructorDef as TCD

55import qualified ProjectM36.TypeConstructor as TC

66import qualified ProjectM36.DataConstructorDef as DCD

77import ProjectM36.Error

8−import ProjectM36.Attribute

8+import qualified ProjectM36.Attribute as A

99import qualified Data.Vector as V

1010import qualified Data.Set as S

1111import qualified Data.List as L

1212import Data.Maybe (isJust)

13+import Data.Either (rights)

1314import Control.Monad.Writer

1415import qualified Data.Map as M

1516--import Debug.Trace

@@ -205,7 +206,7 @@ resolveTypeInAtom _ atom = Right atom

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

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

207208resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

208− newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map atomType (V.toList resolvedAttrs)))

209+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map A.atomType (V.toList resolvedAttrs)))

209210 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

210211

211212-- | Validate that the type is provided with complete type variables for type constructors.

@@ -225,4 +226,32 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do

225226validateAtomType _ _ = Right ()

226227

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

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

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

230+

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

232+atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

233+atomTypeVerify AnyAtomType x = Right x

234+atomTypeVerify x AnyAtomType = Right x

235+atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) =

236+ if tConsNameA /= tConsNameB then

237+ Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

238+ else if not (typeVarMapsVerify tVarMapA tVarMapB) then

239+ Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB)

240+ else

241+ Right x

242+atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

243+ _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1

244+ name2 = A.attributeName attr2 in

245+ if notElem "_" [name1, name2] && name1 /= name2 then

246+ Left $ AtomTypeMismatchError x y

247+ else

248+ atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

249+ return x

250+atomTypeVerify x y = if x == y then

251+ Right x

252+ else

253+ Left $ AtomTypeMismatchError x y

254+

255+-- | Determine if two typeVar

256+typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool

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

ProjectM36/DataTypes/Basic.hs+10−8

@@ -2,17 +2,19 @@

22-- wraps up primitives plus other basic data types

33module ProjectM36.DataTypes.Basic where

44import ProjectM36.DataTypes.Primitive

5+import ProjectM36.DataTypes.Day

6+import ProjectM36.DataTypes.Either

7+import ProjectM36.DataTypes.Maybe

58import ProjectM36.Base

69

710basicTypeConstructorMapping :: TypeConstructorMapping

8−basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ moreTypes

9− where

10− moreTypes = [(ADTypeConstructorDef "Day" [],

11− [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]]),

12− (ADTypeConstructorDef "Maybe" ["a"],

13− [DataConstructorDef "Nothing" [],

14− DataConstructorDef "Just" [DataConstructorDefTypeVarNameArg "a"]])

15− ]

11+basicTypeConstructorMapping = (primitiveTypeConstructorMapping ++

12+ maybeTypeConstructorMapping ++

13+ eitherTypeConstructorMapping ++

14+ dayTypeConstructorMapping)

15+

16+

17+

1618

1719

1820

ProjectM36/DataTypes/Day.hs+6−2

@@ -10,8 +10,8 @@ import qualified Data.Map as M

1010dayAtomType :: AtomType

1111dayAtomType = ConstructedAtomType "Day" M.empty

1212

13−dayFunctions :: AtomFunctions

14−dayFunctions = HS.fromList [

13+dayAtomFunctions :: AtomFunctions

14+dayAtomFunctions = HS.fromList [

1515 AtomFunction { atomFuncName = "fromGregorian",

1616 atomFuncType = [intAtomType, intAtomType, intAtomType, dayAtomType],

1717 atomFunc = \(year:month:day:_) -> ConstructedAtom "Day" dayAtomType [Atom (fromGregorian (fromIntegral (unsafeCast year::Int)) (unsafeCast month) (unsafeCast day))]

@@ -21,3 +21,7 @@ dayFunctions = HS.fromList [

2121 atomFunc = \((ConstructedAtom _ _ (dayA:_)):(ConstructedAtom _ _ (dayB:_)):_) -> Atom (unsafeCast dayA < (unsafeCast dayB :: Day))

2222 }

2323 ]

24+

25+dayTypeConstructorMapping :: TypeConstructorMapping

26+dayTypeConstructorMapping = [(ADTypeConstructorDef "Day" [],

27+ [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]])]

ProjectM36/DataTypes/Either.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.DataTypes.Either where

3+import ProjectM36.Base

4+import ProjectM36.DataTypes.Primitive

5+import qualified Data.HashSet as HS

6+import qualified Data.Map as M

7+

8+eitherAtomType :: AtomType -> AtomType -> AtomType

9+eitherAtomType tA tB = ConstructedAtomType "Either" (M.fromList [("a", tA), ("b", tB)])

10+

11+eitherTypeConstructorMapping :: TypeConstructorMapping

12+eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],

13+ [DataConstructorDef "Left" [DataConstructorDefTypeVarNameArg "a"],

14+ DataConstructorDef "Right" [DataConstructorDefTypeVarNameArg "b"]])]

15+

16+eitherAtomFunctions :: AtomFunctions

17+eitherAtomFunctions = HS.fromList [

18+ AtomFunction { atomFuncName = "isLeft",

19+ atomFuncType = [eitherAtomType AnyAtomType AnyAtomType, boolAtomType],

20+ atomFunc = \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Left")

21+ }

22+ ]

ProjectM36/DataTypes/Maybe.hsnew file+24

@@ -0,0 +1,24 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.DataTypes.Maybe where

3+import ProjectM36.Base

4+import ProjectM36.DataTypes.Primitive

5+import qualified Data.HashSet as HS

6+import qualified Data.Map as M

7+

8+maybeAtomType :: AtomType -> AtomType

9+maybeAtomType arg = ConstructedAtomType "Maybe" (M.singleton "a" arg)

10+

11+maybeTypeConstructorMapping :: TypeConstructorMapping

12+maybeTypeConstructorMapping = [(ADTypeConstructorDef "Maybe" ["a"],

13+ [DataConstructorDef "Nothing" [],

14+ DataConstructorDef "Just" [DataConstructorDefTypeVarNameArg "a"]])

15+ ]

16+

17+maybeAtomFunctions :: AtomFunctions

18+maybeAtomFunctions = HS.fromList [

19+ AtomFunction {

20+ atomFuncName ="isJust",

21+ atomFuncType = [maybeAtomType AnyAtomType, boolAtomType],

22+ atomFunc = \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Nothing")

23+ }

24+ ]

ProjectM36/Error.hs+1

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

4242 | DataConstructorUsesUndeclaredTypeVariable TypeVarName

4343 | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)

4444 | TypeConstructorTypeVarMissing TypeVarName

45+ | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap

4546 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

4647 | AtomTypeNameInUseError AtomTypeName

4748 | IncompletelyDefinedAtomTypeWithConstructorError

test/TutorialD/Interpreter.hs+7−1

@@ -8,6 +8,7 @@ import ProjectM36.Tuple

88import ProjectM36.TupleSet

99import ProjectM36.Error

1010import ProjectM36.DatabaseContext

11+import ProjectM36.DataTypes.Either

1112import ProjectM36.DataTypes.Primitive

1213import ProjectM36.DateExamples

1314import ProjectM36.Base hiding (Finite)

@@ -25,6 +26,7 @@ import Data.Text.Encoding as TE

2526import Control.Concurrent.STM

2627import Control.Concurrent

2728import qualified STMContainers.Map as STMMap

29+import qualified Data.Set as S

2830

2931main :: IO ()

3032main = do

@@ -73,6 +75,7 @@ main = do

7375 maybeIntAtomType = ConstructedAtomType "Maybe" (M.singleton "a" intAtomType)

7476 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]

7577 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntAtomType]

78+ simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType intAtomType textAtomType)]

7679 simpleProjectionAttributes = A.attributesFromList [Attribute "c" intAtomType]

7780 nestedRelationAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" intAtomType])]

7881 extendTestAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

@@ -111,7 +114,10 @@ main = do

111114 --test Maybe Text

112115 ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [textAtom "spam"]]]),

113116 --test Maybe Int

114− ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [intAtom 3]]])

117+ ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [intAtom 3]]]),

118+ --test Either Int Text

119+ ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type

120+ ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType intAtomType textAtomType) [intAtom 3]]])

115121 ]

116122

117123assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion