5f34a12 · project-m36 · git.iko.soy

git.iko.soy/project-m36

clear separation between type and data constructor definition and instantiation

-compilation checkpoint

commit5f34a1288c6f18d61a844564a8c47636ebbb407d authorAgentM <agentm@themactionfaction.com> dateMon 29 Feb 2016, 23:43 (11 years ago) parent0c481e8

17 files changed+236−191

compare with master

unifiedsplit

ProjectM36/AtomType.hs+89−64 ProjectM36/Base.hs+25−14 ProjectM36/Client.hs+1−1 ProjectM36/DataConstructor.hs−15 ProjectM36/DataConstructorDef.hs+20 ProjectM36/DataTypes/Basic.hs+4−4 ProjectM36/DataTypes/Day.hs+2−1 ProjectM36/DataTypes/Primitive.hs+3−3 ProjectM36/DatabaseContext.hs+2−2 ProjectM36/Error.hs+4−2 ProjectM36/RelationalExpression.hs+18−17 ProjectM36/Transaction/Persist.hs+7−7 ProjectM36/TypeConstructor.hs+10−9 ProjectM36/TypeConstructorDef.hs+12 TutorialD/Interpreter/DatabaseExpr.hs+3−3 TutorialD/Interpreter/RelationalExpr.hs+3−30 TutorialD/Interpreter/Types.hs+33−19

ProjectM36/AtomType.hs+89−64

@@ -3,8 +3,9 @@ module ProjectM36.AtomType where

33import ProjectM36.Base

44import ProjectM36.Relation

55import ProjectM36.DataTypes.Primitive

6+import qualified ProjectM36.TypeConstructorDef as TCD

67import qualified ProjectM36.TypeConstructor as TC

7−import qualified ProjectM36.DataConstructor as DC

8+import qualified ProjectM36.DataConstructorDef as DCD

89import qualified Data.Text as T

910import ProjectM36.Error

1011import ProjectM36.Attribute

@@ -12,10 +13,12 @@ import ProjectM36.Atom

1213import qualified Data.Vector as V

1314import qualified Data.Set as S

1415import qualified Data.List as L

15−import Data.Maybe (isJust, catMaybes)

16+import Data.Maybe (isJust)

1617import Control.Monad.Writer

18+import qualified Data.Map as M

19+--import Debug.Trace

1720

18−typesAsRelation :: TypeConstructors -> Either RelationalError Relation

21+typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation

1922typesAsRelation types = mkRelationFromTuples attrs tuples

2023 where

2124 attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,

@@ -24,30 +27,13 @@ typesAsRelation types = mkRelationFromTuples attrs tuples

2427 dConsType = RelationAtomType subAttrs

2528 tuples = map mkTypeConsDescription types

2629

27− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TC.name tCons), mkDataConsRelation dConsList])

30+ mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TCD.name tCons), mkDataConsRelation dConsList])

2831

29− mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DC.name dCons):(map (T.pack . show) (DC.fields dCons))))) dConsList of

32+ mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

3033 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

3134 Right rel -> Atom rel

3235

33−

34−{-

35−-- | Scan all type constructors for the proper data constructor

36−dataConstructorTypeNamesForName :: DataConstructorName -> AtomTypes -> Either RelationalError [AtomTypeName]

37−dataConstructorTypeNamesForName dConsName aTypes = M.foldrWithKey typeFolder defaultErr aTypes

38− where

39− defaultErr = Left (NoSuchDataConstructorError dConsName)

40− typeFolder _ (_, AtomConstructor dConsMap) accum = if isRight accum then

41− accum

42− else

43− case M.lookup dConsName dConsMap of

44− Nothing -> accum

45− Just aTypeNames -> Right (dConsName, aTypeNames)

46−-}

47−-- fix mostly-duplicated fold code

48−

49−

50−findDataConstructor :: DataConstructorName -> TypeConstructors -> Maybe (TypeConstructor, DataConstructor)

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

5137findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

5238 where

5339 tConsFolder (tCons, dConsList) accum = if isJust accum then

@@ -56,60 +42,98 @@ findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

5642 case findDCons dConsList of

5743 Just dCons -> Just (tCons, dCons)

5844 Nothing -> Nothing

59− findDCons dConsList = case filter (\dCons -> DC.name dCons == dName) dConsList of

45+ findDCons dConsList = case filter (\dCons -> DCD.name dCons == dName) dConsList of

6046 [] -> Nothing

6147 [dCons] -> Just dCons

6248 _ -> error "More than one data constructor with the same name found"

6349

6450-- | Scan the atom types and return the resultant ConstructedAtomType or error.

6551-- Used in typeFromAtomExpr to validate argument types.

66−atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructors -> Either RelationalError AtomType

52+atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType

6753-- search for the data constructor and resolve the types' names

6854atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do

6955 case findDataConstructor dConsName tConsList of

7056 Nothing -> Left (NoSuchDataConstructorError dConsName)

7157 Just (tCons, dCons) -> do

72− let validation = map (\(aTypeIn, tConsArgIn) -> validAtomTypeWithTypeConstructorArg aTypeIn tConsArgIn tConsList) (zip atomTypesIn (DC.fields dCons))

73− errors = catMaybes validation

74− if length errors /= 0 then

75− Left (head errors)

76− else

77− Right (ConstructedAtomType (TC.name tCons) atomTypesIn)

58+ typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList

59+ pure (ConstructedAtomType (TCD.name tCons) typeVars)

60+

61+atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType

62+atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =

63+ case isValidAtomTypeForTypeConstructor aType tCons tConss of

64+ Just err -> Left err

65+ Nothing -> Right aType

66+

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

7868

79−validAtomTypeWithTypeConstructorArg :: AtomType -> TypeConstructorArg -> TypeConstructors -> Maybe RelationalError

80−validAtomTypeWithTypeConstructorArg aType (TypeConstructorArg tCons) tConsList = validAtomTypeWithTypeConstructor aType tCons tConsList

81−validAtomTypeWithTypeConstructorArg _ (TypeConstructorPolymorphicArg _) _ = Just IncompletelyDefinedAtomTypeWithConstructorError

69+isValidAtomTypeForTypeConstructorArg :: AtomType -> TypeConstructorArg -> TypeConstructorMapping -> Maybe RelationalError

70+isValidAtomTypeForTypeConstructorArg aType (TypeConstructorArg tCons) tConsList = isValidAtomTypeForTypeConstructor aType tCons tConsList

71+isValidAtomTypeForTypeConstructorArg _ (TypeConstructorTypeVarArg _) _ = Nothing

8272

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

84−validAtomTypeWithTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructors -> Maybe RelationalError

85−validAtomTypeWithTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing

74+isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError

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

8676

8777--lookup constructor name and check if the incoming atom types are valid

88−validAtomTypeWithTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing

78+isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing

8979

90−validAtomTypeWithTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType tCons)

80+isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))

9181

9282-- | Used to determine if the atom arguments can be used with the data constructor.

93−atomTypeWithDataConstructor :: TypeConstructors -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType

94−atomTypeWithDataConstructor tConss dConsName atomArgTypes = do

83+-- | This is the entry point for type-checking from RelationalExpression.hs.

84+atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType

85+atomTypeForDataConstructor tConss dConsName atomArgTypes = do

9586 --lookup the data constructor

9687 case findDataConstructor dConsName tConss of

9788 Nothing -> Left (NoSuchDataConstructorError dConsName)

9889 Just (tCons, dCons) -> do

99− --match the data constructor arguments to the atom args

100− let validator (tConsArg', aType) = maybe (Right ()) Left (validAtomTypeWithTypeConstructorArg aType tConsArg' tConss)

101− mapM_ validator (zip (DC.fields dCons) atomArgTypes)

102− pure (ConstructedAtomType (TC.name tCons) atomArgTypes)

90+ --validate that the type constructor arguments are fulfilled in the data constructor

91+ typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

92+ pure (ConstructedAtomType (TCD.name tCons) typeVars)

10393

104−-- check that polymorphic vars on the right also appear on the left

94+-- | Walks the data and type constructors to extract the type variable map.

95+resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

96+resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

97+ maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

98+ --if any two maps have the same key and different values- bail!

99+ pure (M.unions maps)

100+

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

102+resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

103+resolveDataConstructorArgTypeVars (DataConstructorDefTypeConstructorArg tCons) aType tConss = resolveTypeConstructorTypeVars tCons aType tConss

104+

105+resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)

106+

107+resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

108+resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType tConss =

109+ if aType /= pType then

110+ Left (AtomTypeMismatchError pType aType)

111+ else

112+ Right M.empty

113+

114+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName tConsArgs) (ConstructedAtomType tConsName' pVarMap') tConss =

115+ if tConsName /= tConsName' then

116+ Left (TypeConstructorNameMismatch tConsName tConsName')

117+ else

118+ case findTypeConstructor tConsName tConss of

119+ Nothing -> Left (NoSuchTypeConstructorName tConsName)

120+ Just (tConsDef, _) -> let expectedPVars = S.fromList (TCD.typeVars tConsDef)

121+ actualPVars = M.keysSet pVarMap' in

122+ if expectedPVars /= actualPVars then

123+ Left (TypeConstructorTypeVarsMismatch expectedPVars actualPVars)

124+ else

125+ Right (pVarMap')

126+resolveTypeConstructorTypeVars _ _ _ = error "Unhandled type vars"

127+

128+-- check that type vars on the right also appear on the left

105129-- check that the data constructor names are unique

106−validateTypeConstructor :: TypeConstructor -> [DataConstructor] -> [RelationalError]

107−validateTypeConstructor tCons dConsList = execWriter $ do

108− let duplicateDConsNames = dupes (L.sort (map DC.name dConsList))

130+validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]

131+validateTypeConstructorDef tConsDef dConsList = execWriter $ do

132+ let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))

109133 mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]

110− let leftSideVars = TC.polymorphicVariables tCons

111− rightSideVars = concatMap DC.polymorphicVariables dConsList

112− varsDiff = S.difference (S.fromList leftSideVars) (S.fromList rightSideVars)

134+ let leftSideVars = S.fromList (TCD.typeVars tConsDef)

135+ rightSideVars = S.unions (map DCD.typeVars dConsList)

136+ varsDiff = S.difference leftSideVars rightSideVars

113137 mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]

114138 pure ()

115139

@@ -120,24 +144,25 @@ dupes (_:[]) = []

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

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

122146

123−atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructors -> Either RelationalError AtomType

124−atomTypeForTypeConstructor tCons tConsList = foldr tConsFolder defaultErr (map fst tConsList)

125− where

126− tConsFolder tCons' accum = if TC.name tCons == TC.name tCons' then do

127− tConsArgTypes <- mapM ((flip atomTypeForTypeConstructorArg) tConsList) (TC.arguments tCons')

128− Right (ConstructedAtomType (TC.name tCons') tConsArgTypes)

129− else

130− accum

131− defaultErr = Left (NoSuchTypeConstructorName (TC.name tCons))

147+-- | Create an atom type iff all type variables are provided.

148+-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

149+atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType

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

151+ Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

152+ Just (tConsDef, _) -> do

153+ tConsArgTypes <- mapM ((flip atomTypeForTypeConstructorArg) tConss) (TC.arguments tCons)

154+ let pVarNames = TCD.typeVars tConsDef

155+ tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

156+ Right (ConstructedAtomType (TC.name tCons) tConsArgs)

132157

133−atomTypeForTypeConstructorArg :: TypeConstructorArg -> TypeConstructors -> Either RelationalError AtomType

134−atomTypeForTypeConstructorArg (TypeConstructorPolymorphicArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError

158+atomTypeForTypeConstructorArg :: TypeConstructorArg -> TypeConstructorMapping -> Either RelationalError AtomType

159+atomTypeForTypeConstructorArg (TypeConstructorTypeVarArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError

135160atomTypeForTypeConstructorArg (TypeConstructorArg tCons) tConsList = atomTypeForTypeConstructor tCons tConsList

136161

137−findTypeConstructor :: TypeConstructorName -> TypeConstructors -> Maybe (TypeConstructor, [DataConstructor])

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

138163findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

139164 where

140− tConsFolder (tCons, dConsList) accum = if TC.name tCons == name then

165+ tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then

141166 Just (tCons, dConsList)

142167 else

143168 accum

ProjectM36/Base.hs+25−14

@@ -131,11 +131,13 @@ instance Binary Day where

131131-- | The AtomType must uniquely identify the type of a atom.

132132data AtomType = AtomType ConcreteTypeRep |

133133 RelationAtomType Attributes |

134− ConstructedAtomType TypeConstructorName [AtomType] | --list of polymorphic argument types- we can't have a complete type without them

134+ ConstructedAtomType TypeConstructorName TypeVarMap |

135135 AnyAtomType

136136 --wildcard used in Atom Functions

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

138138

139+type TypeVarMap = M.Map TypeVarName AtomType

140+

139141-- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation.

140142isRelationAtomType :: AtomType -> Bool

141143isRelationAtomType (RelationAtomType _) = True

@@ -276,36 +278,45 @@ data Notification = Notification {

276278 }

277279 deriving (Show, Eq, Binary, Generic)

278280

279−type TypeConstructorPolymorphicName = StringType

281+type TypeVarName = StringType

280282

281−data TypeConstructorArg = TypeConstructorPolymorphicArg TypeConstructorPolymorphicName |

282− TypeConstructorArg TypeConstructor

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

284−

283+-- | "data Either a b"

284+data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |

285+ PrimitiveTypeConstructorDef TypeConstructorName AtomType

286+ deriving (Show, Generic, Binary, Eq, NFData)

287+

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

285289data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |

286290 PrimitiveTypeConstructor TypeConstructorName AtomType

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

288−

289−-- Either a b

290−type TypeConstructors = [(TypeConstructor, DataConstructors)]

292+

293+data TypeConstructorArg = TypeConstructorArg TypeConstructor |

294+ TypeConstructorTypeVarArg TypeVarName

295+ deriving (Show, Generic, Binary, Eq, NFData)

296+

297+type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

291298

292299type TypeConstructorName = StringType

293300type TypeConstructorArgName = StringType

294301type DataConstructorName = StringType

295302type AtomTypeName = StringType

296303

297−--data Hair = Color (Either Int String)

298−data DataConstructor = DataConstructor DataConstructorName [TypeConstructorArg] deriving (Eq, Show, Binary, Generic)

304+-- | Used to define a data constructor in a type constructor context. (Left a | Right b)

305+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic)

299306

300−type DataConstructors = [DataConstructor]

307+type DataConstructorDefs = [DataConstructorDef]

301308

309+data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |

310+ DataConstructorDefTypeVarNameArg TypeVarName

311+ deriving (Show, Generic, Binary, Eq, NFData)

312+

302313-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.

303314data DatabaseContext = DatabaseContext {

304315 inclusionDependencies :: M.Map IncDepName InclusionDependency,

305316 relationVariables :: M.Map RelVarName Relation,

306317 atomFunctions :: AtomFunctions,

307318 notifications :: Notifications,

308− typeConstructors :: TypeConstructors

319+ typeConstructorMapping :: TypeConstructorMapping

309320 } deriving (Show, Generic)

310321

311322type IncDepName = StringType

@@ -330,7 +341,7 @@ data DatabaseExpr where

330341 AddNotification :: NotificationName -> RelationalExpr -> RelationalExpr -> DatabaseExpr

331342 RemoveNotification :: NotificationName -> DatabaseExpr

332343

333− AddTypeConstructor :: TypeConstructor -> [DataConstructor] -> DatabaseExpr

344+ AddTypeConstructor :: TypeConstructorDef -> [DataConstructorDef] -> DatabaseExpr

334345 RemoveTypeConstructor :: TypeConstructorName -> DatabaseExpr

335346

336347 -- to implement this, I likely need to implement a DSL for constructing arbitrary functions to operate on atoms at runtime

ProjectM36/Client.hs+1−1

@@ -514,7 +514,7 @@ atomTypesAsRelation sessionId (InProcessConnection _ _ sessions _) = do

514514 case eSession of

515515 Left err -> pure (Left err)

516516 Right (Session (DisconnectedTransaction _ context)) -> do

517− case typesAsRelation (typeConstructors context) of

517+ case typesAsRelation (typeConstructorMapping context) of

518518 Left err -> pure (Left err)

519519 Right rel -> pure (Right rel)

520520atomTypesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

ProjectM36/DataConstructor.hsdeleted−15

@@ -1,15 +0,0 @@

1−module ProjectM36.DataConstructor where

2−import ProjectM36.Base

3−import qualified ProjectM36.TypeConstructor as TC

4−

5−emptyDataConstructor :: DataConstructorName -> DataConstructor

6−emptyDataConstructor name' = DataConstructor name' []

7−

8−name :: DataConstructor -> DataConstructorName

9−name (DataConstructor name' _) = name'

10−

11−fields :: DataConstructor -> [TypeConstructorArg]

12−fields (DataConstructor _ types) = types

13−

14−polymorphicVariables :: DataConstructor -> [TypeConstructorPolymorphicName]

15−polymorphicVariables (DataConstructor _ tConsArgs) = concatMap TC.polymorphicVariablesInArg tConsArgs

ProjectM36/DataConstructorDef.hsnew file+20

@@ -0,0 +1,20 @@

1+module ProjectM36.DataConstructorDef where

2+import ProjectM36.Base

3+import qualified ProjectM36.TypeConstructor as TC

4+import qualified Data.Set as S

6+emptyDataConstructor :: DataConstructorName -> DataConstructorDef

7+emptyDataConstructor name' = DataConstructorDef name' []

9+name :: DataConstructorDef -> DataConstructorName

10+name (DataConstructorDef name' _) = name'

11+

12+fields :: DataConstructorDef -> [DataConstructorDefArg]

13+fields (DataConstructorDef _ args) = args

14+

15+typeVars :: DataConstructorDef -> S.Set TypeVarName

16+typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs

17+

18+typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName

19+typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons

20+typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName

ProjectM36/DataTypes/Basic.hs+4−4

@@ -4,11 +4,11 @@ module ProjectM36.DataTypes.Basic where

44import ProjectM36.DataTypes.Primitive

55import ProjectM36.Base

7−basicTypeConstructors :: TypeConstructors

8−basicTypeConstructors = primitiveTypeConstructors ++ moreTypes

7+basicTypeConstructorMapping :: TypeConstructorMapping

8+basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ moreTypes

99 where

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

11− [DataConstructor "Day" [TypeConstructorArg $ PrimitiveTypeConstructor "Int" intAtomType]])]

10+ moreTypes = [(ADTypeConstructorDef "Day" ["a"],

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

1212

1313

1414

ProjectM36/DataTypes/Day.hs+2−1

@@ -5,9 +5,10 @@ import ProjectM36.DataTypes.Primitive

55import ProjectM36.AtomFunctions.Primitive

66import qualified Data.HashSet as HS

77import Data.Time.Calendar

8+import qualified Data.Map as M

910dayAtomType :: AtomType

10−dayAtomType = ConstructedAtomType "Day" [intAtomType]

11+dayAtomType = ConstructedAtomType "Day" (M.singleton "a" intAtomType)

1112

1213dayFunctions :: AtomFunctions

1314dayFunctions = HS.fromList [

ProjectM36/DataTypes/Primitive.hs+3−3

@@ -25,9 +25,9 @@ doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)

2525byteStringAtomType :: AtomType

2626byteStringAtomType = atomTypeForProxy (Proxy :: Proxy BS.ByteString)

2727

28−primitiveTypeConstructors :: TypeConstructors

29−primitiveTypeConstructors = map (\(name, aType) ->

30− (PrimitiveTypeConstructor name aType, [])) prims

28+primitiveTypeConstructorMapping :: TypeConstructorMapping

29+primitiveTypeConstructorMapping = map (\(name, aType) ->

30+ (PrimitiveTypeConstructorDef name aType, [])) prims

3131 where

3232 prims = [("Int", intAtomType),

3333 ("Text", textAtomType),

ProjectM36/DatabaseContext.hs+2−2

@@ -12,7 +12,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

1212 relationVariables = M.empty,

1313 notifications = M.empty,

1414 atomFunctions = HS.empty,

15− typeConstructors = [] }

15+ typeConstructorMapping = [] }

1616

1717-- | convert an existing database context into its constituent expression.

1818databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseExpr

@@ -29,5 +29,5 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

2929 ("false", relationFalse)],

3030 atomFunctions = basicAtomFunctions,

3131 notifications = M.empty,

32− typeConstructors = basicTypeConstructors

32+ typeConstructorMapping = basicTypeConstructorMapping

3333 }

ProjectM36/Error.hs+4−2

@@ -34,11 +34,13 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3434 | NoSuchSessionError U.UUID

3535 | NoSuchTupleExprFunctionError AtomFunctionName

3636 | NoSuchTypeConstructorName TypeConstructorName

37+ | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType

3738 | AtomTypeMismatchError AtomType AtomType

3839 | TypeConstructorNameMismatch TypeConstructorName TypeConstructorName

39− | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructor

40+ | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructorName

4041 | DataConstructorNameInUseError DataConstructorName

41− | DataConstructorUsesUndeclaredTypeVariable TypeConstructorPolymorphicName

42+ | DataConstructorUsesUndeclaredTypeVariable TypeVarName

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

4244 | AtomTypeNameInUseError AtomTypeName

4345 | IncompletelyDefinedAtomTypeWithConstructorError

4446 | AtomTypeNameNotInUseError AtomTypeName

ProjectM36/RelationalExpression.hs+18−17

@@ -17,7 +17,7 @@ import Data.Either

1717import Data.Char (isUpper)

1818import qualified Data.Text as T

1919import qualified Data.Vector as V

20−import qualified ProjectM36.TypeConstructor as TC

20+import qualified ProjectM36.TypeConstructorDef as TCD

2121--import Debug.Trace

2222

2323--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

@@ -59,7 +59,7 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

5959

6060evalRelationalExpr (MakeEmptyRelation attrExprs) = do

6161 currentContext <- get

62− let eAttrs = map (evalAttrExpr (typeConstructors currentContext)) attrExprs

62+ let eAttrs = map (evalAttrExpr (typeConstructorMapping currentContext)) attrExprs

6363 case lefts eAttrs of

6464 err:_ -> pure (Left err)

6565 [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet

@@ -141,7 +141,7 @@ emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

141141 relationVariables = M.empty,

142142 atomFunctions = HS.empty,

143143 notifications = M.empty,

144− typeConstructors = []

144+ typeConstructorMapping = []

145145 }

146146

147147

@@ -169,7 +169,7 @@ deleteRelVar relVarName = do

169169evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

170170evalContextExpr (Define relVarName attrExprs) = do

171171 relvars <- liftM relationVariables get

172− tConss <- liftM typeConstructors get

172+ tConss <- liftM typeConstructorMapping get

173173 let eAttrs = map (evalAttrExpr tConss) attrExprs

174174 case lefts eAttrs of

175175 err:_ -> pure (Just err)

@@ -276,32 +276,32 @@ evalContextExpr (RemoveNotification notName) = do

276276

277277-- | Adds type and data constructors to the database context.

278278-- validate that the type *and* constructor names are unique! not yet implemented!

279−evalContextExpr (AddTypeConstructor tCons dConsList) = do

279+evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

280280 currentContext <- get

281− let oldTypes = typeConstructors currentContext

282− tConsName = TC.name tCons

281+ let oldTypes = typeConstructorMapping currentContext

282+ tConsName = TCD.name tConsDef

283283 -- validate that the constructor's types exist

284− case validateTypeConstructor tCons dConsList of

284+ case validateTypeConstructorDef tConsDef dConsDefList of

285285 errs@(_:_) -> pure $ Just (MultipleErrors errs)

286286 [] -> do

287287 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then

288288 pure $ Just (InvalidAtomTypeName tConsName)

289− else if isRight (atomTypeForTypeConstructor tCons oldTypes) then

289+ else if isJust (findTypeConstructor tConsName oldTypes) then

290290 pure $ Just (AtomTypeNameInUseError tConsName)

291291 else do

292− let newTypes = oldTypes ++ [(tCons, dConsList)]

293− put $ currentContext { typeConstructors = newTypes }

292+ let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

293+ put $ currentContext { typeConstructorMapping = newTypes }

294294 pure Nothing

295295

296296-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.

297297evalContextExpr (RemoveTypeConstructor tConsName) = do

298298 currentContext <- get

299− let oldTypes = typeConstructors currentContext

299+ let oldTypes = typeConstructorMapping currentContext

300300 if findTypeConstructor tConsName oldTypes == Nothing then

301301 pure $ Just (AtomTypeNameNotInUseError tConsName)

302302 else do

303− let newTypes = filter (\(tCons, _) -> TC.name tCons /= tConsName) oldTypes

304− put $ currentContext { typeConstructors = newTypes }

303+ let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

304+ put $ currentContext { typeConstructorMapping = newTypes }

305305 pure Nothing

306306

307307evalContextExpr (MultipleExpr exprs) = do

@@ -460,10 +460,11 @@ typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

460460typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do

461461 relType <- evalState (typeForRelationalExpr relExpr) context

462462 return $ RelationAtomType (attributes relType)

463−-- grab the type of the data constructor, then validate that the args match the expected types

463+

464+-- grab the type of the data constructor, then validate that the args match the expected types

464465typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do

465466 argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs

466− atomTypeWithDataConstructor (typeConstructors context) dConsName argsTypes

467+ atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes

467468

468469-- | Validate that the type of the AtomExpr matches the expected type.

469470verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType

@@ -494,7 +495,7 @@ verifyAtomExprTypes rel context cons@(ConstructedAtomExpr _ _) expectedType = do

494495

495496

496497-- | Look up the type's name and create a new attribute.

497−evalAttrExpr :: TypeConstructors -> AttributeExpr -> Either RelationalError Attribute

498+evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute

498499evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do

499500 aType <- atomTypeForTypeConstructor tCons aTypes

500501 Right (Attribute attrName aType)

ProjectM36/Transaction/Persist.hs+7−7

@@ -49,12 +49,12 @@ readTransaction dbdir transUUID = do

4949 relvars <- readRelVars transDir

5050 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

5151 incDeps <- readIncDeps transDir

52− typeCons <- readTypeConstructors transDir

52+ typeCons <- readTypeConstructorMapping transDir

5353 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

5454 let atomFuncs = basicAtomFunctions

5555 let newContext = DatabaseContext { inclusionDependencies = incDeps,

5656 relationVariables = relvars,

57− typeConstructors = typeCons,

57+ typeConstructorMapping = typeCons,

5858 notifications = M.empty,

5959 atomFunctions = atomFuncs }

6060

@@ -72,7 +72,7 @@ writeTransaction sync dbdir trans = do

7272 writeRelVars sync tempTransDir (relationVariables context)

7373 writeIncDeps sync tempTransDir (inclusionDependencies context)

7474 writeAtomFuncs sync tempTransDir (atomFunctions context)

75− writeTypeConstructors sync tempTransDir (typeConstructors context)

75+ writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)

7676 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)

7777 --move the temp directory to final location

7878 renameSync sync tempTransDir finalTransDir

@@ -138,10 +138,10 @@ readIncDeps transDir = do

138138 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

139139 return $ M.fromList incDeps

140140

141−writeTypeConstructors :: DiskSync -> FilePath -> TypeConstructors -> IO ()

142−writeTypeConstructors sync path types = writeBSFileSync sync path $ B.encode types

141+writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()

142+writeTypeConstructorMapping sync path types = writeBSFileSync sync path $ B.encode types

143143

144−readTypeConstructors :: FilePath -> IO (TypeConstructors)

145−readTypeConstructors path = do

144+readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping)

145+readTypeConstructorMapping path = do

146146 let atPath = typeConsPath path

147147 liftM B.decode (BS.readFile atPath)

ProjectM36/TypeConstructor.hs+10−9

@@ -1,18 +1,19 @@

11module ProjectM36.TypeConstructor where

22import ProjectM36.Base

3+import qualified Data.Set as S

45name :: TypeConstructor -> TypeConstructorName

5−name (ADTypeConstructor nam _) = nam

6−name (PrimitiveTypeConstructor nam _) = nam

6+name (ADTypeConstructor name' _) = name'

7+name (PrimitiveTypeConstructor name' _) = name'

89arguments :: TypeConstructor -> [TypeConstructorArg]

10+arguments (ADTypeConstructor _ args) = args

911arguments (PrimitiveTypeConstructor _ _) = []

10−arguments (ADTypeConstructor _ tConsArgs) = tConsArgs

1112

12−polymorphicVariables :: TypeConstructor -> [TypeConstructorPolymorphicName]

13−polymorphicVariables (PrimitiveTypeConstructor _ _) = []

14−polymorphicVariables (ADTypeConstructor _ tConsArgs) = concatMap polymorphicVariablesInArg tConsArgs

13+typeVars :: TypeConstructor -> S.Set TypeVarName

14+typeVars (PrimitiveTypeConstructor _ _) = S.empty

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

1516

16−polymorphicVariablesInArg :: TypeConstructorArg -> [TypeConstructorPolymorphicName]

17−polymorphicVariablesInArg (TypeConstructorPolymorphicArg nam) = [nam]

18−polymorphicVariablesInArg (TypeConstructorArg tCons) = polymorphicVariables tCons

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

18+typeVarsForArg (TypeConstructorArg arg) = typeVars arg

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

ProjectM36/TypeConstructorDef.hsnew file+12

@@ -0,0 +1,12 @@

1+module ProjectM36.TypeConstructorDef where

2+import ProjectM36.Base

3+import qualified Data.Set as S

5+name :: TypeConstructorDef -> TypeConstructorName

6+name (ADTypeConstructorDef nam _) = nam

7+name (PrimitiveTypeConstructorDef nam _) = nam

9+typeVars :: TypeConstructorDef -> [TypeVarName]

10+typeVars (PrimitiveTypeConstructorDef _ _) = []

11+typeVars (ADTypeConstructorDef _ args) = args

12+

TutorialD/Interpreter/DatabaseExpr.hs+3−3

@@ -131,10 +131,10 @@ removeNotificationP = do

131131addTypeConstructorP :: Parser DatabaseExpr

132132addTypeConstructorP = do

133133 reserved "data"

134− typeConstructor <- typeConstructorP

134+ typeConstructorDef <- typeConstructorDefP

135135 reservedOp "="

136− dataConstructors <- sepBy1 dataConstructorP pipe

137− pure (AddTypeConstructor typeConstructor dataConstructors)

136+ dataConstructorDefs <- sepBy1 dataConstructorDefP pipe

137+ pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)

138138

139139removeTypeConstructorP :: Parser DatabaseExpr

140140removeTypeConstructorP = do

TutorialD/Interpreter/RelationalExpr.hs+3−30

@@ -9,11 +9,7 @@ import qualified Data.Text as T

99import qualified Data.Set as S

1010import qualified Data.Map as M

1111import Data.Functor.Identity (Identity)

12−import Data.Time.Format

1312import Control.Applicative (liftA)

14−import Data.ByteString.Base64 as B64

15−import Data.Text.Encoding as TE

16−import Data.Time.Calendar (Day)

1713

1814--used in projection

1915attributeListP :: Parser AttributeNames

@@ -202,9 +198,9 @@ nakedAtomExprP = NakedAtomExpr <$> atomP

202198constructedAtomExprP :: Parser AtomExpr

203199constructedAtomExprP = do

204200 dConsName <- identifier

205− _ <- char '['

206− dConsArgs <- sepBy atomExprP comma

207− _ <- char ']'

201+ --_ <- char '['

202+ dConsArgs <- sepBy atomExprP spaces

203+ --_ <- char ']'

208204 pure $ ConstructedAtomExpr (T.pack dConsName) dConsArgs

209205

210206-- used only for primitive type parsing ?

@@ -240,17 +236,6 @@ maybeIntAtomP = do

240236 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"

241237 return $ Atom (maybeInt :: Maybe Int)

242238

243−--refactor to use constructors

244−dateAtomP :: Parser Atom

245−dateAtomP = do

246− dateString' <- try $ do

247− dateString <- quotedString

248− reserved "::date"

249− return dateString

250− case parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString' of

251− Just todaytime -> return $ Atom (todaytime :: Day)

252− Nothing -> fail "Failed to parse date"

253−

254239doubleAtomP :: Parser Atom

255240doubleAtomP = Atom <$> (try float)

256241

@@ -266,15 +251,3 @@ boolAtomP = do

266251

267252relationAtomExprP :: Parser AtomExpr

268253relationAtomExprP = RelationAtomExpr <$> makeRelationP

269−

270−-- deprecated for removal- use constructors

271−byteStringAtomP :: Parser Atom

272−byteStringAtomP = do

273− byteString' <- try $ do

274− byteString <- quotedString

275− reserved "::bytestring"

276− return byteString

277− case B64.decode $ TE.encodeUtf8 (T.pack byteString') of

278− Left err -> fail err

279− Right bsVal -> return $ Atom bsVal

280−

TutorialD/Interpreter/Types.hs+33−19

@@ -9,26 +9,40 @@ import Control.Monad (liftM)

99import qualified Data.Text as T

1010

1111-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.

12−-- Either a b

13−typeConstructorP :: Parser TypeConstructor

14−typeConstructorP = ADTypeConstructor <$> liftM T.pack capitalizedIdentifier <*> many typeConstructorArgP

15−

16−typeConstructorArgP :: Parser TypeConstructorArg

17−typeConstructorArgP = TypeConstructorPolymorphicArg <$> liftM T.pack uncapitalizedIdentifier

12+-- data *Either a b* = Left a | Right b

13+typeConstructorDefP :: Parser TypeConstructorDef

14+typeConstructorDefP = ADTypeConstructorDef <$> liftM T.pack capitalizedIdentifier <*> typeVarNamesP

1815

19−dataConstructorP :: Parser DataConstructor

20−dataConstructorP = DataConstructor <$> liftM T.pack identifier <*> many dataConstructorArgP

16+typeVarNamesP :: Parser [TypeVarName]

17+typeVarNamesP = do

18+ vars <- many uncapitalizedIdentifier

19+ pure (map T.pack vars)

20+

21+-- data Either a b = *Left a* | *Right b*

22+dataConstructorDefP :: Parser DataConstructorDef

23+dataConstructorDefP = DataConstructorDef <$> liftM T.pack identifier <*> many dataConstructorDefArgP

2124

22−--Either Int Text

23−--Either a Int

24−--Either (Either a b) Int

25−dataConstructorArgP :: Parser TypeConstructorArg

26−dataConstructorArgP = primitiveTypeConstructorArgP <|>

27− TypeConstructorPolymorphicArg <$> liftM T.pack uncapitalizedIdentifier <|>

28− parens (TypeConstructorArg <$> typeConstructorP)

25+-- data *Either a b* = Left *a* | Right *b*

26+dataConstructorDefArgP :: Parser DataConstructorDefArg

27+dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeConstructorP) <|>

28+ DataConstructorDefTypeVarNameArg <$> liftM T.pack uncapitalizedIdentifier

2929

30−primitiveTypeConstructorArgP :: Parser TypeConstructorArg

31−primitiveTypeConstructorArgP = choice (map (\(PrimitiveTypeConstructor name typ, _) -> do

30+--built-in, nullary type constructors

31+-- Int, Text, etc.

32+primitiveTypeConstructorP :: Parser TypeConstructor

33+primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do

3234 tName <- liftM T.pack (symbol (T.unpack name))

33− pure $ TypeConstructorArg (PrimitiveTypeConstructor tName typ))

34− primitiveTypeConstructors)

35+ pure $ PrimitiveTypeConstructor tName typ)

36+ primitiveTypeConstructorMapping)

37+

38+-- *Either Int Text*, *Int*

39+typeConstructorP :: Parser TypeConstructor

40+typeConstructorP = primitiveTypeConstructorP <|>

41+ ADTypeConstructor <$> liftM T.pack identifier <*> many typeConstructorArgP

42+

43+typeConstructorArgP :: Parser TypeConstructorArg

44+typeConstructorArgP = TypeConstructorArg <$> typeConstructorP <|>

45+ TypeConstructorTypeVarArg <$> liftM T.pack uncapitalizedIdentifier

46+

47+

48+