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

ProjectM36/AtomFunction.hs−17

compare with master

unifiedsplit

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

4import ProjectM36.Error

5import qualified ProjectM36.Attribute as A

6import qualified Data.HashSet as HS

7−import qualified Data.Vector as V

8

7

9foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

8foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

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

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

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

17 where

16 where

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

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

19

18

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

36

19

37

20

ProjectM36/AtomFunctions/Basic.hs+6−1

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

3module ProjectM36.AtomFunctions.Basic where

4import ProjectM36.Base

5import ProjectM36.DataTypes.Day

6+import ProjectM36.DataTypes.Either

7+import ProjectM36.DataTypes.Maybe

6import ProjectM36.AtomFunctions.Primitive

8import ProjectM36.AtomFunctions.Primitive

7import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

8

10

9basicAtomFunctions :: AtomFunctions

11basicAtomFunctions :: AtomFunctions

10−basicAtomFunctions = primitiveAtomFunctions `HS.union` dayFunctions

12+basicAtomFunctions = HS.unions [primitiveAtomFunctions,

13+ dayAtomFunctions,

14+ eitherAtomFunctions,

15+ maybeAtomFunctions]

11

16

ProjectM36/AtomType.hs+32−3

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

5import qualified ProjectM36.TypeConstructor as TC

6import qualified ProjectM36.DataConstructorDef as DCD

7import ProjectM36.Error

8−import ProjectM36.Attribute

8+import qualified ProjectM36.Attribute as A

9import qualified Data.Vector as V

10import qualified Data.Set as S

11import qualified Data.List as L

12import Data.Maybe (isJust)

13+import Data.Either (rights)

13import Control.Monad.Writer

14import Control.Monad.Writer

14import qualified Data.Map as M

15import qualified Data.Map as M

15--import Debug.Trace

16--import Debug.Trace

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

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

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

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

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

207resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

208resolveTypesInTuple 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)))

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

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

210

211

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

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

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

225validateAtomType _ _ = Right ()

226validateAtomType _ _ = Right ()

226

227

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

228validateTuple :: 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 @@

2-- wraps up primitives plus other basic data types

3module ProjectM36.DataTypes.Basic where

4import ProjectM36.DataTypes.Primitive

5+import ProjectM36.DataTypes.Day

6+import ProjectM36.DataTypes.Either

7+import ProjectM36.DataTypes.Maybe

5import ProjectM36.Base

8import ProjectM36.Base

6

9

7basicTypeConstructorMapping :: TypeConstructorMapping

10basicTypeConstructorMapping :: TypeConstructorMapping

8−basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ moreTypes

11+basicTypeConstructorMapping = (primitiveTypeConstructorMapping ++

9− where

12+ maybeTypeConstructorMapping ++

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

13+ eitherTypeConstructorMapping ++

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

14+ dayTypeConstructorMapping)

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

15+

13− [DataConstructorDef "Nothing" [],

16+

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

17+

15− ]

16

18

17

19

18

20

ProjectM36/DataTypes/Day.hs+6−2

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

10dayAtomType :: AtomType

11dayAtomType = ConstructedAtomType "Day" M.empty

12

13−dayFunctions :: AtomFunctions

13+dayAtomFunctions :: AtomFunctions

14−dayFunctions = HS.fromList [

14+dayAtomFunctions = HS.fromList [

15 AtomFunction { atomFuncName = "fromGregorian",

16 atomFuncType = [intAtomType, intAtomType, intAtomType, dayAtomType],

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

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

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

22 }

23 ]

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)

42 | DataConstructorUsesUndeclaredTypeVariable TypeVarName

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

44 | TypeConstructorTypeVarMissing TypeVarName

45+ | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap

45 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

46 | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap

46 | AtomTypeNameInUseError AtomTypeName

47 | AtomTypeNameInUseError AtomTypeName

47 | IncompletelyDefinedAtomTypeWithConstructorError

48 | IncompletelyDefinedAtomTypeWithConstructorError

test/TutorialD/Interpreter.hs+7−1

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

8import ProjectM36.TupleSet

9import ProjectM36.Error

10import ProjectM36.DatabaseContext

11+import ProjectM36.DataTypes.Either

11import ProjectM36.DataTypes.Primitive

12import ProjectM36.DataTypes.Primitive

12import ProjectM36.DateExamples

13import ProjectM36.DateExamples

13import ProjectM36.Base hiding (Finite)

14import ProjectM36.Base hiding (Finite)

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

25import Control.Concurrent.STM

26import Control.Concurrent.STM

26import Control.Concurrent

27import Control.Concurrent

27import qualified STMContainers.Map as STMMap

28import qualified STMContainers.Map as STMMap

29+import qualified Data.Set as S

28

30

29main :: IO ()

31main :: IO ()

30main = do

32main = do

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

111 --test Maybe Text

114 --test Maybe Text

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

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

113 --test Maybe Int

116 --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]]])

115 ]

121 ]

116

122

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

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