0c481e8 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP- polymorphic data types parsing

-compilation checkpoint

commit0c481e8d77582ffca6d1021703fee2f3a83cdf27 authorAgentM <agentm@themactionfaction.com> dateFri 26 Feb 2016, 22:55 (11 years ago) parent1d7b6e3

19 files changed+300−126

compare with master

unifiedsplit

ProjectM36/Atom.hs+2−1 ProjectM36/AtomConstructor.hs−7 ProjectM36/AtomType.hs+107−33 ProjectM36/Base.hs+30−14 ProjectM36/Client.hs+1−1 ProjectM36/DataConstructor.hs+15 ProjectM36/DataTypes/Basic.hs+6−5 ProjectM36/DataTypes/Day.hs+1−1 ProjectM36/DataTypes/Primitive.hs+3−4 ProjectM36/DatabaseContext.hs+2−2 ProjectM36/Error.hs+7 ProjectM36/RelationalExpression.hs+24−28 ProjectM36/StaticOptimizer.hs+2−2 ProjectM36/Transaction/Persist.hs+10−10 ProjectM36/TypeConstructor.hs+18 TutorialD/Interpreter/Base.hs+17 TutorialD/Interpreter/DatabaseExpr.hs+10−16 TutorialD/Interpreter/RelationalExpr.hs+11−2 TutorialD/Interpreter/Types.hs+34

ProjectM36/Atom.hs+2−1

@@ -61,4 +61,5 @@ basicAtomTypes = M.union primitiveAtomTypes moreTypes

6161-}

6262atomToText :: Atom -> T.Text

6363atomToText (Atom atom) = toText atom

64−atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

64+atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

65+

ProjectM36/AtomConstructor.hsdeleted−7

@@ -1,7 +0,0 @@

1−module ProjectM36.AtomConstructor where

2−import ProjectM36.Base

3−import qualified Data.Map as M

4−

5−emptyAtomConstructor :: AtomConstructor

6−emptyAtomConstructor = AtomConstructor M.empty

7−

ProjectM36/AtomType.hs+107−33

@@ -3,27 +3,34 @@ module ProjectM36.AtomType where

33import ProjectM36.Base

44import ProjectM36.Relation

55import ProjectM36.DataTypes.Primitive

6+import qualified ProjectM36.TypeConstructor as TC

7+import qualified ProjectM36.DataConstructor as DC

68import qualified Data.Text as T

79import ProjectM36.Error

810import ProjectM36.Attribute

911import ProjectM36.Atom

10−import qualified Data.Map as M

1112import qualified Data.Vector as V

12−import Data.Either (isRight)

13−import Data.Maybe

13+import qualified Data.Set as S

14+import qualified Data.List as L

15+import Data.Maybe (isJust, catMaybes)

16+import Control.Monad.Writer

1417

15−typesAsRelation :: AtomTypes -> Either RelationalError Relation

16−typesAsRelation aTypes = mkRelationFromTuples attrs tuples

18+typesAsRelation :: TypeConstructors -> Either RelationalError Relation

19+typesAsRelation types = mkRelationFromTuples attrs tuples

1720 where

1821 attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,

1922 Attribute "DataConstructors" dConsType]

2023 subAttrs = attributesFromList [Attribute "DataConstructor" textAtomType]

2124 dConsType = RelationAtomType subAttrs

22− tuples = map mkTypeConsDescription (M.toList aTypes)

23− mkTypeConsDescription (tConsName, (_, AtomConstructor dConsMap)) = RelationTuple attrs (V.fromList [textAtom tConsName, mkDataConsRelation dConsMap])

24− mkDataConsRelation dConsMap = case mkRelationFromTuples subAttrs $ map (\(dConsName, dConsTypeNames) -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " (dConsName:dConsTypeNames))) (M.toList dConsMap) of

25+ tuples = map mkTypeConsDescription types

26+

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

28+

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

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

2631 Right rel -> Atom rel

32+

33+

2734{-

2835-- | Scan all type constructors for the proper data constructor

2936dataConstructorTypeNamesForName :: DataConstructorName -> AtomTypes -> Either RelationalError [AtomTypeName]

@@ -38,33 +45,100 @@ dataConstructorTypeNamesForName dConsName aTypes = M.foldrWithKey typeFolder def

3845 Just aTypeNames -> Right (dConsName, aTypeNames)

3946-}

4047-- fix mostly-duplicated fold code

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

42−atomAndArgsTypesForDataConstructorName :: DataConstructorName -> AtomTypes -> Either RelationalError (AtomType, [AtomType])

43−atomAndArgsTypesForDataConstructorName dConsName aTypes = M.foldrWithKey typeFolder defaultErr aTypes

48+

49+

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

51+findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

4452 where

45− defaultErr = Left (NoSuchDataConstructorError dConsName)

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

47− accum

48− else

49− case M.lookup dConsName dConsMap of

50− Nothing -> accum

51− Just aArgsTypeNames -> do --convert aTypeNames into AtomTypes

52− aArgsTypes <- mapM (\tName -> atomTypeForTypeConstructor tName aTypes) aArgsTypeNames

53− Right (aType, aArgsTypes)

53+ tConsFolder (tCons, dConsList) accum = if isJust accum then

54+ accum

55+ else

56+ case findDCons dConsList of

57+ Just dCons -> Just (tCons, dCons)

58+ Nothing -> Nothing

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

60+ [] -> Nothing

61+ [dCons] -> Just dCons

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

63+

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

65+-- Used in typeFromAtomExpr to validate argument types.

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

67+-- search for the data constructor and resolve the types' names

68+atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do

69+ case findDataConstructor dConsName tConsList of

70+ Nothing -> Left (NoSuchDataConstructorError dConsName)

71+ 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)

78+

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

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

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

82+

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

86+

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

5489

55−atomTypeForTypeConstructor :: TypeConstructorName -> AtomTypes -> Either RelationalError AtomType

56−atomTypeForTypeConstructor tConsName aTypes = case M.lookup tConsName aTypes of

57− Nothing -> Left (NoSuchTypeConstructorError tConsName)

58− Just (aType, _) -> Right aType

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

5991

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

95+ --lookup the data constructor

96+ case findDataConstructor dConsName tConss of

97+ Nothing -> Left (NoSuchDataConstructorError dConsName)

98+ 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)

103+

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

105+-- 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))

109+ 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)

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

114+ pure ()

115+

116+--returns duplicates of a pre-sorted list

117+dupes :: Eq a => [a] -> [a]

118+dupes [] = []

119+dupes (_:[]) = []

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

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

122+

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

132+

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

134+atomTypeForTypeConstructorArg (TypeConstructorPolymorphicArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError

135+atomTypeForTypeConstructorArg (TypeConstructorArg tCons) tConsList = atomTypeForTypeConstructor tCons tConsList

60136

61−-- | Validate that the arguments to the data constructors in the atom constructor are valid type names.

62−validateAtomConstructor :: AtomConstructor -> AtomTypes -> Maybe RelationalError

63−validateAtomConstructor (AtomConstructor aConsMap) validAtomTypes = mapM validateDataConstructor (M.elems aConsMap) >>= listToMaybe

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

138+findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

64139 where

65− validateDataConstructor :: [AtomTypeName] -> Maybe RelationalError

66− validateDataConstructor dConsTypeNames = mapM validateTypeConstructor dConsTypeNames >>= listToMaybe

67− validateTypeConstructor :: AtomTypeName -> Maybe RelationalError

68− validateTypeConstructor dConsTypeName = case atomTypeForTypeConstructor dConsTypeName validAtomTypes of

69− Right _ -> Nothing

70− Left err -> Just err

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

141+ Just (tCons, dConsList)

142+ else

143+ accum

144+

ProjectM36/Base.hs+30−14

@@ -82,7 +82,7 @@ instance Binary Atom where

8282 --http://stackoverflow.com/questions/8101067/binary-instance-for-an-existential

8383 case atomtype of

8484 AnyAtomType -> error "unsupported serialization AnyAtomType"

85− caType@(ConstructedAtomType _) -> ConstructedAtom <$> (get :: Get DataConstructorName) <*> pure caType <*> (get :: Get [Atom]) --we really should verify the type with the atoms

85+ caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> (get :: Get DataConstructorName) <*> pure caType <*> (get :: Get [Atom]) --we really should verify the type with the atoms

8686 (RelationAtomType _) -> Atom <$> (get :: Get Relation)

8787 (AtomType cTypeRep) -> if unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then

8888 Atom <$> (get :: Get Int)

@@ -131,8 +131,9 @@ 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 |

135− AnyAtomType --wildcard used in Atom Functions

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

135+ AnyAtomType

136+ --wildcard used in Atom Functions

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

137138

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

@@ -275,7 +276,28 @@ data Notification = Notification {

275276 }

276277 deriving (Show, Eq, Binary, Generic)

277278

278−type AtomTypes = M.Map TypeConstructorName (AtomType, AtomConstructor)

279+type TypeConstructorPolymorphicName = StringType

280+

281+data TypeConstructorArg = TypeConstructorPolymorphicArg TypeConstructorPolymorphicName |

282+ TypeConstructorArg TypeConstructor

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

284+

285+data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |

286+ PrimitiveTypeConstructor TypeConstructorName AtomType

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

288+

289+-- Either a b

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

291+

292+type TypeConstructorName = StringType

293+type TypeConstructorArgName = StringType

294+type DataConstructorName = StringType

295+type AtomTypeName = StringType

296+

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

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

299+

300+type DataConstructors = [DataConstructor]

279301

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

281303data DatabaseContext = DatabaseContext {

@@ -283,7 +305,7 @@ data DatabaseContext = DatabaseContext {

283305 relationVariables :: M.Map RelVarName Relation,

284306 atomFunctions :: AtomFunctions,

285307 notifications :: Notifications,

286− atomTypes :: AtomTypes

308+ typeConstructors :: TypeConstructors

287309 } deriving (Show, Generic)

288310

289311type IncDepName = StringType

@@ -308,9 +330,8 @@ data DatabaseExpr where

308330 AddNotification :: NotificationName -> RelationalExpr -> RelationalExpr -> DatabaseExpr

309331 RemoveNotification :: NotificationName -> DatabaseExpr

310332

311− -- this may be generalized to AddAtomFunction in the future

312− AddAtomConstructor :: TypeConstructorName -> AtomConstructor -> DatabaseExpr

313− RemoveAtomConstructor :: TypeConstructorName -> DatabaseExpr

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

334+ RemoveTypeConstructor :: TypeConstructorName -> DatabaseExpr

314335

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

316337 --AddAtomFunction :: AtomFunction -> DatabaseExpr

@@ -319,11 +340,6 @@ data DatabaseExpr where

319340 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

320341 deriving (Show, Eq, Binary, Generic)

321342

322−type TypeConstructorName = StringType

323−type DataConstructorName = StringType

324−type AtomTypeName = StringType

325−

326−data AtomConstructor = AtomConstructor (M.Map DataConstructorName [AtomTypeName]) deriving (Eq, Show, Binary, Generic)

327343

328344type DatabaseState a = State DatabaseContext a

329345

@@ -437,7 +453,7 @@ data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory

437453 CrashSafePersistence FilePath -- ^ full fsync to disk (flushes kernel and physical drive buffers to ensure that the transaction is on non-volatile storage)

438454 deriving (Show, Read)

439455

440−data AttributeExpr = AttributeAndTypeNameExpr AttributeName TypeConstructorName

456+data AttributeExpr = AttributeAndTypeNameExpr AttributeName TypeConstructor

441457 deriving (Eq, Show, Generic, Binary)

442458

443459data TupleExpr = TupleExpr (M.Map AttributeName AtomExpr)

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 (atomTypes context) of

517+ case typesAsRelation (typeConstructors context) of

518518 Left err -> pure (Left err)

519519 Right rel -> pure (Right rel)

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

ProjectM36/DataConstructor.hsnew file+15

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

1+module ProjectM36.DataConstructor where

2+import ProjectM36.Base

3+import qualified ProjectM36.TypeConstructor as TC

5+emptyDataConstructor :: DataConstructorName -> DataConstructor

6+emptyDataConstructor name' = DataConstructor name' []

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/DataTypes/Basic.hs+6−5

@@ -2,13 +2,14 @@

22-- wraps up primitives plus other basic data types

33module ProjectM36.DataTypes.Basic where

44import ProjectM36.DataTypes.Primitive

5−import qualified Data.Map as M

65import ProjectM36.Base

8−basicAtomTypes :: AtomTypes

9−basicAtomTypes = M.union primitiveAtomTypes moreTypes

7+basicTypeConstructors :: TypeConstructors

8+basicTypeConstructors = primitiveTypeConstructors ++ moreTypes

109 where

11− moreTypes = M.fromList [("Day", (ConstructedAtomType "Day",

12− AtomConstructor (M.singleton "Day" ["Int"])))]

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

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

12+

13+

1314

1415

ProjectM36/DataTypes/Day.hs+1−1

@@ -7,7 +7,7 @@ import qualified Data.HashSet as HS

77import Data.Time.Calendar

99dayAtomType :: AtomType

10−dayAtomType = ConstructedAtomType "Day"

10+dayAtomType = ConstructedAtomType "Day" [intAtomType]

1111

1212dayFunctions :: AtomFunctions

1313dayFunctions = HS.fromList [

ProjectM36/DataTypes/Primitive.hs+3−4

@@ -3,9 +3,7 @@ module ProjectM36.DataTypes.Primitive where

33import ProjectM36.Base

44import Data.Proxy

55import Data.Typeable

6−import ProjectM36.AtomConstructor

76import ProjectM36.ConcreteTypeRep

8−import qualified Data.Map as M

97import qualified Data.Text as T

108import qualified Data.ByteString as BS

119

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

2725byteStringAtomType :: AtomType

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

2927

30−primitiveAtomTypes :: AtomTypes

31−primitiveAtomTypes = M.fromList $ map (\(typeName,typ) -> (typeName, (typ, emptyAtomConstructor))) prims

28+primitiveTypeConstructors :: TypeConstructors

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

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

3231 where

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

3433 ("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− atomTypes = M.empty }

15+ typeConstructors = [] }

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− atomTypes = basicAtomTypes

32+ typeConstructors = basicTypeConstructors

3333 }

ProjectM36/Error.hs+7

@@ -33,8 +33,14 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3333 | SessionIdInUseError U.UUID

3434 | NoSuchSessionError U.UUID

3535 | NoSuchTupleExprFunctionError AtomFunctionName

36+ | NoSuchTypeConstructorName TypeConstructorName

3637 | AtomTypeMismatchError AtomType AtomType

38+ | TypeConstructorNameMismatch TypeConstructorName TypeConstructorName

39+ | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructor

40+ | DataConstructorNameInUseError DataConstructorName

41+ | DataConstructorUsesUndeclaredTypeVariable TypeConstructorPolymorphicName

3742 | AtomTypeNameInUseError AtomTypeName

43+ | IncompletelyDefinedAtomTypeWithConstructorError

3844 | AtomTypeNameNotInUseError AtomTypeName

3945 | NoSuchDataConstructorError DataConstructorName

4046 | NoSuchTypeConstructorError TypeConstructorName

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

4955 | NotificationNameNotInUseError NotificationName

5056 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

5157 | ExportError T.Text

58+ | MultipleErrors [RelationalError]

5259 deriving (Show,Eq,Generic,Binary,Typeable)

5360

5461instance NFData RelationalError where rnf = genericRnf

ProjectM36/RelationalExpression.hs+24−28

@@ -17,6 +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

2021--import Debug.Trace

2122

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

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

5859

5960evalRelationalExpr (MakeEmptyRelation attrExprs) = do

6061 currentContext <- get

61− let eAttrs = map (evalAttrExpr (atomTypes currentContext)) attrExprs

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

6263 case lefts eAttrs of

6364 err:_ -> pure (Left err)

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

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

140141 relationVariables = M.empty,

141142 atomFunctions = HS.empty,

142143 notifications = M.empty,

143− atomTypes = M.empty

144+ typeConstructors = []

144145 }

145146

146147

@@ -168,8 +169,8 @@ deleteRelVar relVarName = do

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

169170evalContextExpr (Define relVarName attrExprs) = do

170171 relvars <- liftM relationVariables get

171− aTypes <- liftM atomTypes get

172− let eAttrs = map (evalAttrExpr aTypes) attrExprs

172+ tConss <- liftM typeConstructors get

173+ let eAttrs = map (evalAttrExpr tConss) attrExprs

173174 case lefts eAttrs of

174175 err:_ -> pure (Just err)

175176 [] -> case M.member relVarName relvars of

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

275276

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

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

278−evalContextExpr (AddAtomConstructor tConsName atomCons) = do

279+evalContextExpr (AddTypeConstructor tCons dConsList) = do

279280 currentContext <- get

280− let oldAtomTypes = atomTypes currentContext

281+ let oldTypes = typeConstructors currentContext

282+ tConsName = TC.name tCons

281283 -- validate that the constructor's types exist

282− case validateAtomConstructor atomCons oldAtomTypes of

283− Just err -> pure $ Just err

284− Nothing -> do

284+ case validateTypeConstructor tCons dConsList of

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

286+ [] -> do

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

286288 pure $ Just (InvalidAtomTypeName tConsName)

287− else if M.member tConsName oldAtomTypes then

289+ else if isRight (atomTypeForTypeConstructor tCons oldTypes) then

288290 pure $ Just (AtomTypeNameInUseError tConsName)

289291 else do

290− let newAtomTypes = M.insert tConsName newType oldAtomTypes

291− newType = (ConstructedAtomType tConsName, atomCons)

292− put $ currentContext { atomTypes = newAtomTypes }

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

293+ put $ currentContext { typeConstructors = newTypes }

293294 pure Nothing

294295

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

296−evalContextExpr (RemoveAtomConstructor tConsName) = do

297+evalContextExpr (RemoveTypeConstructor tConsName) = do

297298 currentContext <- get

298− let oldAtomTypes = atomTypes currentContext

299− if M.notMember tConsName oldAtomTypes then

299+ let oldTypes = typeConstructors currentContext

300+ if findTypeConstructor tConsName oldTypes == Nothing then

300301 pure $ Just (AtomTypeNameNotInUseError tConsName)

301302 else do

302− let newAtomTypes = M.delete tConsName oldAtomTypes

303− put $ currentContext { atomTypes = newAtomTypes }

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

304+ put $ currentContext { typeConstructors = newTypes }

304305 pure Nothing

305306

306307evalContextExpr (MultipleExpr exprs) = do

@@ -461,13 +462,8 @@ typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do

461462 return $ RelationAtomType (attributes relType)

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

463464typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do

464− (tConsType, dConsArgTypes) <- atomAndArgsTypesForDataConstructorName dConsName (atomTypes context)

465− argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs

466− --validate that the argument types match

467− if argsTypes /= dConsArgTypes then

468− Left $ AtomTypeMismatchError intAtomType intAtomType --fix error message

469− else

470− pure tConsType

465+ argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs

466+ atomTypeWithDataConstructor (typeConstructors context) dConsName argsTypes

471467

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

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

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

498494

499495

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

501−evalAttrExpr :: AtomTypes -> AttributeExpr -> Either RelationalError Attribute

502−evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tConsName) = do

503− aType <- atomTypeForTypeConstructor tConsName aTypes

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

498+evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do

499+ aType <- atomTypeForTypeConstructor tCons aTypes

504500 Right (Attribute attrName aType)

505501

506502evalTupleExpr :: DatabaseContext -> TupleExpr -> Either RelationalError RelationTuple

ProjectM36/StaticOptimizer.hs+2−2

@@ -137,8 +137,8 @@ applyStaticDatabaseOptimization (AddNotification name triggerExpr resultExpr) =

137137

138138applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif)

139139

140−applyStaticDatabaseOptimization c@(AddAtomConstructor _ _) = pure (Right c)

141−applyStaticDatabaseOptimization c@(RemoveAtomConstructor _) = pure (Right c)

140+applyStaticDatabaseOptimization c@(AddTypeConstructor _ _) = pure (Right c)

141+applyStaticDatabaseOptimization c@(RemoveTypeConstructor _) = pure (Right c)

142142

143143--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

144144

ProjectM36/Transaction/Persist.hs+10−10

@@ -36,8 +36,8 @@ incDepsDir transdir = transdir </> "incdeps"

3636atomFuncsDir :: FilePath -> FilePath

3737atomFuncsDir transdir = transdir </> "atomfuncs"

3838

39−atomTypesPath :: FilePath -> FilePath

40−atomTypesPath transdir = transdir </> "atomtypes"

39+typeConsPath :: FilePath -> FilePath

40+typeConsPath transdir = transdir </> "typecons"

4141

4242readTransaction :: FilePath -> U.UUID -> IO (Either PersistenceError Transaction)

4343readTransaction dbdir transUUID = do

@@ -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− atomtypes <- readAtomTypes transDir

52+ typeCons <- readTypeConstructors 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− atomTypes = atomtypes,

57+ typeConstructors = 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− writeAtomTypes sync tempTransDir (atomTypes context)

75+ writeTypeConstructors sync tempTransDir (typeConstructors 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−writeAtomTypes :: DiskSync -> FilePath -> AtomTypes -> IO ()

142−writeAtomTypes sync path aTypes = writeBSFileSync sync path $ B.encode aTypes

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

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

143143

144−readAtomTypes :: FilePath -> IO (AtomTypes)

145−readAtomTypes path = do

146− let atPath = atomTypesPath path

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

145+readTypeConstructors path = do

146+ let atPath = typeConsPath path

147147 liftM B.decode (BS.readFile atPath)

ProjectM36/TypeConstructor.hsnew file+18

@@ -0,0 +1,18 @@

1+module ProjectM36.TypeConstructor where

2+import ProjectM36.Base

4+name :: TypeConstructor -> TypeConstructorName

5+name (ADTypeConstructor nam _) = nam

6+name (PrimitiveTypeConstructor nam _) = nam

8+arguments :: TypeConstructor -> [TypeConstructorArg]

9+arguments (PrimitiveTypeConstructor _ _) = []

10+arguments (ADTypeConstructor _ tConsArgs) = tConsArgs

11+

12+polymorphicVariables :: TypeConstructor -> [TypeConstructorPolymorphicName]

13+polymorphicVariables (PrimitiveTypeConstructor _ _) = []

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

15+

16+polymorphicVariablesInArg :: TypeConstructorArg -> [TypeConstructorPolymorphicName]

17+polymorphicVariablesInArg (TypeConstructorPolymorphicArg nam) = [nam]

18+polymorphicVariablesInArg (TypeConstructorArg tCons) = polymorphicVariables tCons

TutorialD/Interpreter/Base.hs+17

@@ -36,6 +36,9 @@ braces = Token.braces lexer

3636identifier :: Parser String

3737identifier = Token.identifier lexer

3838

39+symbol :: String -> Parser String

40+symbol = Token.symbol lexer

41+

3942comma :: Parser String

4043comma = Token.comma lexer

4144

@@ -54,6 +57,20 @@ integer = Token.integer lexer

5457float :: Parser Double

5558float = Token.float lexer

5659

60+capitalizedIdentifier :: Parser String

61+capitalizedIdentifier = do

62+ fletter <- upper

63+ rest <- option "" identifier

64+ spaces

65+ pure $ fletter:rest

66+

67+uncapitalizedIdentifier :: Parser String

68+uncapitalizedIdentifier = do

69+ fletter <- lower

70+ rest <- option "" identifier

71+ spaces

72+ pure (fletter:rest)

73+

5774atomTypeToTutDType :: AtomType -> Maybe T.Text

5875atomTypeToTutDType atomType = case atomType of

5976 aType@(AtomType _) -> lookup aType [(textAtomType, "char"),

TutorialD/Interpreter/DatabaseExpr.hs+10−16

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

66import TutorialD.Interpreter.Base

77import qualified Data.Text as T

88import TutorialD.Interpreter.RelationalExpr

9+import TutorialD.Interpreter.Types

910import qualified Data.Map as M

1011import Control.Monad.State

1112import ProjectM36.StaticOptimizer

@@ -26,8 +27,8 @@ databaseExprP = insertP

2627 <|> assignP

2728 <|> addNotificationP

2829 <|> removeNotificationP

29− <|> addAtomConstructorP

30− <|> removeAtomConstructorP

30+ <|> addTypeConstructorP

31+ <|> removeTypeConstructorP

3132

3233assignP :: Parser DatabaseExpr

3334assignP = do

@@ -127,25 +128,18 @@ removeNotificationP = do

127128 return $ RemoveNotification (T.pack notName)

128129

129130-- | data Hair = Bald | Color Text

130−addAtomConstructorP :: Parser DatabaseExpr

131−addAtomConstructorP = do

131+addTypeConstructorP :: Parser DatabaseExpr

132+addTypeConstructorP = do

132133 reserved "data"

133− typeConstructorName <- identifier

134+ typeConstructor <- typeConstructorP

134135 reservedOp "="

135136 dataConstructors <- sepBy1 dataConstructorP pipe

136− let aCons = AtomConstructor (M.fromList dataConstructors)

137− pure (AddAtomConstructor (T.pack typeConstructorName) aCons)

137+ pure (AddTypeConstructor typeConstructor dataConstructors)

138138

139−dataConstructorP :: Parser (DataConstructorName, [AtomTypeName])

140−dataConstructorP = do

141− dConsName <- identifier

142− atomTypeNames <- sepBy (liftM T.pack identifier) spaces

143− pure (T.pack dConsName, atomTypeNames)

144−

145−removeAtomConstructorP :: Parser DatabaseExpr

146−removeAtomConstructorP = do

139+removeTypeConstructorP :: Parser DatabaseExpr

140+removeTypeConstructorP = do

147141 reserved "undata"

148− RemoveAtomConstructor <$> liftM T.pack identifier

142+ RemoveTypeConstructor <$> liftM T.pack identifier

149143

150144databaseExprOpP :: Parser DatabaseExpr

151145databaseExprOpP = multipleDatabaseExprP

TutorialD/Interpreter/RelationalExpr.hs+11−2

@@ -4,6 +4,7 @@ import Text.Parsec.Expr

44import ProjectM36.Base

55import Text.Parsec.String

66import TutorialD.Interpreter.Base

7+import TutorialD.Interpreter.Types

78import qualified Data.Text as T

89import qualified Data.Set as S

910import qualified Data.Map as M

@@ -40,8 +41,16 @@ attributeAndTypeNameP :: Parser AttributeExpr

4041attributeAndTypeNameP = do

4142 attrName <- identifier

4243 --convert type name into type

43− atomType <- identifier

44− return $ AttributeAndTypeNameExpr (T.pack attrName) (T.pack atomType)

44+ typeCons <- typeConstructorP

45+ return $ AttributeAndTypeNameExpr (T.pack attrName) typeCons

46+

47+--abstract data type parser- in this context, the type constructor must not include any type arguments

48+--Either Text Int

49+adTypeConstructorP :: Parser TypeConstructor

50+adTypeConstructorP = do

51+ tConsName <- capitalizedIdentifier

52+ tConsArgs <- many typeConstructorArgP

53+ pure $ ADTypeConstructor (T.pack tConsName) tConsArgs

4554

4655tupleExprP :: Parser TupleExpr

4756tupleExprP = do

TutorialD/Interpreter/Types.hsnew file+34

@@ -0,0 +1,34 @@

1+--parse type and data constructors

2+module TutorialD.Interpreter.Types where

3+import ProjectM36.Base

4+import Text.Parsec.String

5+import Text.Parsec

6+import TutorialD.Interpreter.Base

7+import ProjectM36.DataTypes.Primitive

8+import Control.Monad (liftM)

9+import qualified Data.Text as T

10+

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

18+

19+dataConstructorP :: Parser DataConstructor

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

21+

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)

29+

30+primitiveTypeConstructorArgP :: Parser TypeConstructorArg

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

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

33+ pure $ TypeConstructorArg (PrimitiveTypeConstructor tName typ))

34+ primitiveTypeConstructors)