git.iko.soy/project-m36
on master help sign in
clear separation between type and data constructor definition and instantiation
5f34a12AgentM
ProjectM36/AtomType.hs+89−64
compare with master
unifiedsplit
@@ -3,8 +3,9 @@ module ProjectM36.AtomType where
3import ProjectM36.Base
3import ProjectM36.Base
4import ProjectM36.Relation
4import ProjectM36.Relation
5import ProjectM36.DataTypes.Primitive
5import ProjectM36.DataTypes.Primitive
6+import qualified ProjectM36.TypeConstructorDef as TCD
6import qualified ProjectM36.TypeConstructor as TC
7import qualified ProjectM36.TypeConstructor as TC
7−import qualified ProjectM36.DataConstructor as DC
8+import qualified ProjectM36.DataConstructorDef as DCD
8import qualified Data.Text as T
9import qualified Data.Text as T
9import ProjectM36.Error
10import ProjectM36.Error
10import ProjectM36.Attribute
11import ProjectM36.Attribute
@@ -12,10 +13,12 @@ import ProjectM36.Atom
12import qualified Data.Vector as V
13import qualified Data.Vector as V
13import qualified Data.Set as S
14import qualified Data.Set as S
14import qualified Data.List as L
15import qualified Data.List as L
15−import Data.Maybe (isJust, catMaybes)
16+import Data.Maybe (isJust)
16import Control.Monad.Writer
17import Control.Monad.Writer
18+import qualified Data.Map as M
19+--import Debug.Trace
17
20
18−typesAsRelation :: TypeConstructors -> Either RelationalError Relation
21+typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
19typesAsRelation types = mkRelationFromTuples attrs tuples
22typesAsRelation types = mkRelationFromTuples attrs tuples
20 where
23 where
21 attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,
24 attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,
@@ -24,30 +27,13 @@ typesAsRelation types = mkRelationFromTuples attrs tuples
24 dConsType = RelationAtomType subAttrs
27 dConsType = RelationAtomType subAttrs
25 tuples = map mkTypeConsDescription types
28 tuples = map mkTypeConsDescription types
26
29
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])
28
31
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
30 Left err -> error ("mkRelationFromTuples pooped " ++ show err)
33 Left err -> error ("mkRelationFromTuples pooped " ++ show err)
31 Right rel -> Atom rel
34 Right rel -> Atom rel
32
35
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)
51findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList
37findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList
52 where
38 where
53 tConsFolder (tCons, dConsList) accum = if isJust accum then
39 tConsFolder (tCons, dConsList) accum = if isJust accum then
@@ -56,60 +42,98 @@ findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList
56 case findDCons dConsList of
42 case findDCons dConsList of
57 Just dCons -> Just (tCons, dCons)
43 Just dCons -> Just (tCons, dCons)
58 Nothing -> Nothing
44 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
60 [] -> Nothing
46 [] -> Nothing
61 [dCons] -> Just dCons
47 [dCons] -> Just dCons
62 _ -> error "More than one data constructor with the same name found"
48 _ -> error "More than one data constructor with the same name found"
63
49
64-- | Scan the atom types and return the resultant ConstructedAtomType or error.
50-- | Scan the atom types and return the resultant ConstructedAtomType or error.
65-- Used in typeFromAtomExpr to validate argument types.
51-- Used in typeFromAtomExpr to validate argument types.
66−atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructors -> Either RelationalError AtomType
52+atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType
67-- search for the data constructor and resolve the types' names
53-- search for the data constructor and resolve the types' names
68atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do
54atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do
69 case findDataConstructor dConsName tConsList of
55 case findDataConstructor dConsName tConsList of
70 Nothing -> Left (NoSuchDataConstructorError dConsName)
56 Nothing -> Left (NoSuchDataConstructorError dConsName)
71 Just (tCons, dCons) -> do
57 Just (tCons, dCons) -> do
72− let validation = map (\(aTypeIn, tConsArgIn) -> validAtomTypeWithTypeConstructorArg aTypeIn tConsArgIn tConsList) (zip atomTypesIn (DC.fields dCons))
58+ typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList
73− errors = catMaybes validation
74− if length errors /= 0 then
75− Left (head errors)
76− else
77− Right (ConstructedAtomType (TC.name tCons) atomTypesIn)
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
78
68
79−validAtomTypeWithTypeConstructorArg :: AtomType -> TypeConstructorArg -> TypeConstructors -> Maybe RelationalError
69+isValidAtomTypeForTypeConstructorArg :: AtomType -> TypeConstructorArg -> TypeConstructorMapping -> Maybe RelationalError
80−validAtomTypeWithTypeConstructorArg aType (TypeConstructorArg tCons) tConsList = validAtomTypeWithTypeConstructor aType tCons tConsList
70+isValidAtomTypeForTypeConstructorArg aType (TypeConstructorArg tCons) tConsList = isValidAtomTypeForTypeConstructor aType tCons tConsList
81−validAtomTypeWithTypeConstructorArg _ (TypeConstructorPolymorphicArg _) _ = Just IncompletelyDefinedAtomTypeWithConstructorError
71+isValidAtomTypeForTypeConstructorArg _ (TypeConstructorTypeVarArg _) _ = Nothing
82
72
83--reconcile the atom-in types with the type constructors
73--reconcile the atom-in types with the type constructors
84−validAtomTypeWithTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructors -> Maybe RelationalError
74+isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError
85−validAtomTypeWithTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing
75+isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing
86
76
87--lookup constructor name and check if the incoming atom types are valid
77--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
89
79
90−validAtomTypeWithTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType tCons)
80+isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))
91
81
92-- | Used to determine if the atom arguments can be used with the data constructor.
82-- | Used to determine if the atom arguments can be used with the data constructor.
83+-- | This is the entry point for type-checking from RelationalExpression.hs.
93−atomTypeWithDataConstructor :: TypeConstructors -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType
84+atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType
94−atomTypeWithDataConstructor tConss dConsName atomArgTypes = do
85+atomTypeForDataConstructor tConss dConsName atomArgTypes = do
95 --lookup the data constructor
86 --lookup the data constructor
96 case findDataConstructor dConsName tConss of
87 case findDataConstructor dConsName tConss of
97 Nothing -> Left (NoSuchDataConstructorError dConsName)
88 Nothing -> Left (NoSuchDataConstructorError dConsName)
98 Just (tCons, dCons) -> do
89 Just (tCons, dCons) -> do
99− --match the data constructor arguments to the atom args
90+ --validate that the type constructor arguments are fulfilled in the data constructor
100− let validator (tConsArg', aType) = maybe (Right ()) Left (validAtomTypeWithTypeConstructorArg aType tConsArg' tConss)
91+ typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss
101− mapM_ validator (zip (DC.fields dCons) atomArgTypes)
102− pure (ConstructedAtomType (TC.name tCons) atomArgTypes)
92+ pure (ConstructedAtomType (TCD.name tCons) typeVars)
103
93
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+
104−-- check that polymorphic vars on the right also appear on the left
128+-- check that type vars on the right also appear on the left
105-- check that the data constructor names are unique
129-- check that the data constructor names are unique
106−validateTypeConstructor :: TypeConstructor -> [DataConstructor] -> [RelationalError]
130+validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]
107−validateTypeConstructor tCons dConsList = execWriter $ do
131+validateTypeConstructorDef tConsDef dConsList = execWriter $ do
108− let duplicateDConsNames = dupes (L.sort (map DC.name dConsList))
132+ let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))
109 mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]
133 mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]
110− let leftSideVars = TC.polymorphicVariables tCons
134+ let leftSideVars = S.fromList (TCD.typeVars tConsDef)
111− rightSideVars = concatMap DC.polymorphicVariables dConsList
135+ rightSideVars = S.unions (map DCD.typeVars dConsList)
112− varsDiff = S.difference (S.fromList leftSideVars) (S.fromList rightSideVars)
136+ varsDiff = S.difference leftSideVars rightSideVars
113 mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]
137 mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]
114 pure ()
138 pure ()
115
139
@@ -120,24 +144,25 @@ dupes (_:[]) = []
120dupes (x:y:[]) = if x == y then [x] else []
144dupes (x:y:[]) = if x == y then [x] else []
121dupes (x:y:xs) = dupes(x:[y]) ++ dupes(xs)
145dupes (x:y:xs) = dupes(x:[y]) ++ dupes(xs)
122
146
147+-- | Create an atom type iff all type variables are provided.
148+-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}
123−atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructors -> Either RelationalError AtomType
149+atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType
124−atomTypeForTypeConstructor tCons tConsList = foldr tConsFolder defaultErr (map fst tConsList)
150+atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of
125− where
151+ Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))
126− tConsFolder tCons' accum = if TC.name tCons == TC.name tCons' then do
152+ Just (tConsDef, _) -> do
127− tConsArgTypes <- mapM ((flip atomTypeForTypeConstructorArg) tConsList) (TC.arguments tCons')
153+ tConsArgTypes <- mapM ((flip atomTypeForTypeConstructorArg) tConss) (TC.arguments tCons)
154+ let pVarNames = TCD.typeVars tConsDef
155+ tConsArgs = M.fromList (zip pVarNames tConsArgTypes)
128− Right (ConstructedAtomType (TC.name tCons') tConsArgTypes)
156+ Right (ConstructedAtomType (TC.name tCons) tConsArgs)
129− else
130− accum
131− defaultErr = Left (NoSuchTypeConstructorName (TC.name tCons))
132
157
133−atomTypeForTypeConstructorArg :: TypeConstructorArg -> TypeConstructors -> Either RelationalError AtomType
158+atomTypeForTypeConstructorArg :: TypeConstructorArg -> TypeConstructorMapping -> Either RelationalError AtomType
134−atomTypeForTypeConstructorArg (TypeConstructorPolymorphicArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError
159+atomTypeForTypeConstructorArg (TypeConstructorTypeVarArg _) _ = Left IncompletelyDefinedAtomTypeWithConstructorError
135atomTypeForTypeConstructorArg (TypeConstructorArg tCons) tConsList = atomTypeForTypeConstructor tCons tConsList
160atomTypeForTypeConstructorArg (TypeConstructorArg tCons) tConsList = atomTypeForTypeConstructor tCons tConsList
136
161
137−findTypeConstructor :: TypeConstructorName -> TypeConstructors -> Maybe (TypeConstructor, [DataConstructor])
162+findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])
138findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList
163findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList
139 where
164 where
140− tConsFolder (tCons, dConsList) accum = if TC.name tCons == name then
165+ tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then
141 Just (tCons, dConsList)
166 Just (tCons, dConsList)
142 else
167 else
143 accum
168 accum
ProjectM36/Base.hs+25−14
@@ -131,11 +131,13 @@ instance Binary Day where
131-- | The AtomType must uniquely identify the type of a atom.
131-- | The AtomType must uniquely identify the type of a atom.
132data AtomType = AtomType ConcreteTypeRep |
132data AtomType = AtomType ConcreteTypeRep |
133 RelationAtomType Attributes |
133 RelationAtomType Attributes |
134− ConstructedAtomType TypeConstructorName [AtomType] | --list of polymorphic argument types- we can't have a complete type without them
134+ ConstructedAtomType TypeConstructorName TypeVarMap |
135 AnyAtomType
135 AnyAtomType
136 --wildcard used in Atom Functions
136 --wildcard used in Atom Functions
137 deriving (Eq,NFData,Generic,Binary,Show)
137 deriving (Eq,NFData,Generic,Binary,Show)
138
138
139+type TypeVarMap = M.Map TypeVarName AtomType
140+
139-- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation.
141-- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation.
140isRelationAtomType :: AtomType -> Bool
142isRelationAtomType :: AtomType -> Bool
141isRelationAtomType (RelationAtomType _) = True
143isRelationAtomType (RelationAtomType _) = True
@@ -276,36 +278,45 @@ data Notification = Notification {
276 }
278 }
277 deriving (Show, Eq, Binary, Generic)
279 deriving (Show, Eq, Binary, Generic)
278
280
279−type TypeConstructorPolymorphicName = StringType
281+type TypeVarName = StringType
280
282
281−data TypeConstructorArg = TypeConstructorPolymorphicArg TypeConstructorPolymorphicName |
283+-- | "data Either a b"
282− TypeConstructorArg TypeConstructor
284+data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |
285+ PrimitiveTypeConstructorDef TypeConstructorName AtomType
283− deriving (Show, Generic, Binary, Eq, NFData)
286+ deriving (Show, Generic, Binary, Eq, NFData)
284−
287+
288+-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int
285data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |
289data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructorArg] |
286 PrimitiveTypeConstructor TypeConstructorName AtomType
290 PrimitiveTypeConstructor TypeConstructorName AtomType
287 deriving (Show, Generic, Binary, Eq, NFData)
291 deriving (Show, Generic, Binary, Eq, NFData)
288−
292+
289−-- Either a b
293+data TypeConstructorArg = TypeConstructorArg TypeConstructor |
290−type TypeConstructors = [(TypeConstructor, DataConstructors)]
294+ TypeConstructorTypeVarArg TypeVarName
295+ deriving (Show, Generic, Binary, Eq, NFData)
296+
297+type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]
291
298
292type TypeConstructorName = StringType
299type TypeConstructorName = StringType
293type TypeConstructorArgName = StringType
300type TypeConstructorArgName = StringType
294type DataConstructorName = StringType
301type DataConstructorName = StringType
295type AtomTypeName = StringType
302type AtomTypeName = StringType
296
303
297−--data Hair = Color (Either Int String)
304+-- | Used to define a data constructor in a type constructor context. (Left a | Right b)
298−data DataConstructor = DataConstructor DataConstructorName [TypeConstructorArg] deriving (Eq, Show, Binary, Generic)
305+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic)
299
306
300−type DataConstructors = [DataConstructor]
307+type DataConstructorDefs = [DataConstructorDef]
301
308
309+data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |
310+ DataConstructorDefTypeVarNameArg TypeVarName
311+ deriving (Show, Generic, Binary, Eq, NFData)
312+
302-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.
313-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.
303data DatabaseContext = DatabaseContext {
314data DatabaseContext = DatabaseContext {
304 inclusionDependencies :: M.Map IncDepName InclusionDependency,
315 inclusionDependencies :: M.Map IncDepName InclusionDependency,
305 relationVariables :: M.Map RelVarName Relation,
316 relationVariables :: M.Map RelVarName Relation,
306 atomFunctions :: AtomFunctions,
317 atomFunctions :: AtomFunctions,
307 notifications :: Notifications,
318 notifications :: Notifications,
308− typeConstructors :: TypeConstructors
319+ typeConstructorMapping :: TypeConstructorMapping
309 } deriving (Show, Generic)
320 } deriving (Show, Generic)
310
321
311type IncDepName = StringType
322type IncDepName = StringType
@@ -330,7 +341,7 @@ data DatabaseExpr where
330 AddNotification :: NotificationName -> RelationalExpr -> RelationalExpr -> DatabaseExpr
341 AddNotification :: NotificationName -> RelationalExpr -> RelationalExpr -> DatabaseExpr
331 RemoveNotification :: NotificationName -> DatabaseExpr
342 RemoveNotification :: NotificationName -> DatabaseExpr
332
343
333− AddTypeConstructor :: TypeConstructor -> [DataConstructor] -> DatabaseExpr
344+ AddTypeConstructor :: TypeConstructorDef -> [DataConstructorDef] -> DatabaseExpr
334 RemoveTypeConstructor :: TypeConstructorName -> DatabaseExpr
345 RemoveTypeConstructor :: TypeConstructorName -> DatabaseExpr
335
346
336 -- to implement this, I likely need to implement a DSL for constructing arbitrary functions to operate on atoms at runtime
347 -- 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
514 case eSession of
514 case eSession of
515 Left err -> pure (Left err)
515 Left err -> pure (Left err)
516 Right (Session (DisconnectedTransaction _ context)) -> do
516 Right (Session (DisconnectedTransaction _ context)) -> do
517− case typesAsRelation (typeConstructors context) of
517+ case typesAsRelation (typeConstructorMapping context) of
518 Left err -> pure (Left err)
518 Left err -> pure (Left err)
519 Right rel -> pure (Right rel)
519 Right rel -> pure (Right rel)
520atomTypesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)
520atomTypesAsRelation 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
5+
6+emptyDataConstructor :: DataConstructorName -> DataConstructorDef
7+emptyDataConstructor name' = DataConstructorDef name' []
8+
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
4import ProjectM36.DataTypes.Primitive
4import ProjectM36.DataTypes.Primitive
5import ProjectM36.Base
5import ProjectM36.Base
6
6
7−basicTypeConstructors :: TypeConstructors
7+basicTypeConstructorMapping :: TypeConstructorMapping
8−basicTypeConstructors = primitiveTypeConstructors ++ moreTypes
8+basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ moreTypes
9 where
9 where
10− moreTypes = [(ADTypeConstructor "Day" [],
10+ moreTypes = [(ADTypeConstructorDef "Day" ["a"],
11− [DataConstructor "Day" [TypeConstructorArg $ PrimitiveTypeConstructor "Int" intAtomType]])]
11+ [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]])]
12
12
13
13
14
14
ProjectM36/DataTypes/Day.hs+2−1
@@ -5,9 +5,10 @@ import ProjectM36.DataTypes.Primitive
5import ProjectM36.AtomFunctions.Primitive
5import ProjectM36.AtomFunctions.Primitive
6import qualified Data.HashSet as HS
6import qualified Data.HashSet as HS
7import Data.Time.Calendar
7import Data.Time.Calendar
8+import qualified Data.Map as M
8
9
9dayAtomType :: AtomType
10dayAtomType :: AtomType
10−dayAtomType = ConstructedAtomType "Day" [intAtomType]
11+dayAtomType = ConstructedAtomType "Day" (M.singleton "a" intAtomType)
11
12
12dayFunctions :: AtomFunctions
13dayFunctions :: AtomFunctions
13dayFunctions = HS.fromList [
14dayFunctions = HS.fromList [
ProjectM36/DataTypes/Primitive.hs+3−3
@@ -25,9 +25,9 @@ doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)
25byteStringAtomType :: AtomType
25byteStringAtomType :: AtomType
26byteStringAtomType = atomTypeForProxy (Proxy :: Proxy BS.ByteString)
26byteStringAtomType = atomTypeForProxy (Proxy :: Proxy BS.ByteString)
27
27
28−primitiveTypeConstructors :: TypeConstructors
28+primitiveTypeConstructorMapping :: TypeConstructorMapping
29−primitiveTypeConstructors = map (\(name, aType) ->
29+primitiveTypeConstructorMapping = map (\(name, aType) ->
30− (PrimitiveTypeConstructor name aType, [])) prims
30+ (PrimitiveTypeConstructorDef name aType, [])) prims
31 where
31 where
32 prims = [("Int", intAtomType),
32 prims = [("Int", intAtomType),
33 ("Text", textAtomType),
33 ("Text", textAtomType),
ProjectM36/DatabaseContext.hs+2−2
@@ -12,7 +12,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,
12 relationVariables = M.empty,
12 relationVariables = M.empty,
13 notifications = M.empty,
13 notifications = M.empty,
14 atomFunctions = HS.empty,
14 atomFunctions = HS.empty,
15− typeConstructors = [] }
15+ typeConstructorMapping = [] }
16
16
17-- | convert an existing database context into its constituent expression.
17-- | convert an existing database context into its constituent expression.
18databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseExpr
18databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseExpr
@@ -29,5 +29,5 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
29 ("false", relationFalse)],
29 ("false", relationFalse)],
30 atomFunctions = basicAtomFunctions,
30 atomFunctions = basicAtomFunctions,
31 notifications = M.empty,
31 notifications = M.empty,
32− typeConstructors = basicTypeConstructors
32+ typeConstructorMapping = basicTypeConstructorMapping
33 }
33 }
ProjectM36/Error.hs+4−2
@@ -34,11 +34,13 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)
34 | NoSuchSessionError U.UUID
34 | NoSuchSessionError U.UUID
35 | NoSuchTupleExprFunctionError AtomFunctionName
35 | NoSuchTupleExprFunctionError AtomFunctionName
36 | NoSuchTypeConstructorName TypeConstructorName
36 | NoSuchTypeConstructorName TypeConstructorName
37+ | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType
37 | AtomTypeMismatchError AtomType AtomType
38 | AtomTypeMismatchError AtomType AtomType
38 | TypeConstructorNameMismatch TypeConstructorName TypeConstructorName
39 | TypeConstructorNameMismatch TypeConstructorName TypeConstructorName
39− | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructor
40+ | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructorName
40 | DataConstructorNameInUseError DataConstructorName
41 | DataConstructorNameInUseError DataConstructorName
41− | DataConstructorUsesUndeclaredTypeVariable TypeConstructorPolymorphicName
42+ | DataConstructorUsesUndeclaredTypeVariable TypeVarName
43+ | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)
42 | AtomTypeNameInUseError AtomTypeName
44 | AtomTypeNameInUseError AtomTypeName
43 | IncompletelyDefinedAtomTypeWithConstructorError
45 | IncompletelyDefinedAtomTypeWithConstructorError
44 | AtomTypeNameNotInUseError AtomTypeName
46 | AtomTypeNameNotInUseError AtomTypeName
ProjectM36/RelationalExpression.hs+18−17
@@ -17,7 +17,7 @@ import Data.Either
17import Data.Char (isUpper)
17import Data.Char (isUpper)
18import qualified Data.Text as T
18import qualified Data.Text as T
19import qualified Data.Vector as V
19import qualified Data.Vector as V
20−import qualified ProjectM36.TypeConstructor as TC
20+import qualified ProjectM36.TypeConstructorDef as TCD
21--import Debug.Trace
21--import Debug.Trace
22
22
23--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
23--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
59
59
60evalRelationalExpr (MakeEmptyRelation attrExprs) = do
60evalRelationalExpr (MakeEmptyRelation attrExprs) = do
61 currentContext <- get
61 currentContext <- get
62− let eAttrs = map (evalAttrExpr (typeConstructors currentContext)) attrExprs
62+ let eAttrs = map (evalAttrExpr (typeConstructorMapping currentContext)) attrExprs
63 case lefts eAttrs of
63 case lefts eAttrs of
64 err:_ -> pure (Left err)
64 err:_ -> pure (Left err)
65 [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet
65 [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet
@@ -141,7 +141,7 @@ emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
141 relationVariables = M.empty,
141 relationVariables = M.empty,
142 atomFunctions = HS.empty,
142 atomFunctions = HS.empty,
143 notifications = M.empty,
143 notifications = M.empty,
144− typeConstructors = []
144+ typeConstructorMapping = []
145 }
145 }
146
146
147
147
@@ -169,7 +169,7 @@ deleteRelVar relVarName = do
169evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
169evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
170evalContextExpr (Define relVarName attrExprs) = do
170evalContextExpr (Define relVarName attrExprs) = do
171 relvars <- liftM relationVariables get
171 relvars <- liftM relationVariables get
172− tConss <- liftM typeConstructors get
172+ tConss <- liftM typeConstructorMapping get
173 let eAttrs = map (evalAttrExpr tConss) attrExprs
173 let eAttrs = map (evalAttrExpr tConss) attrExprs
174 case lefts eAttrs of
174 case lefts eAttrs of
175 err:_ -> pure (Just err)
175 err:_ -> pure (Just err)
@@ -276,32 +276,32 @@ evalContextExpr (RemoveNotification notName) = do
276
276
277-- | Adds type and data constructors to the database context.
277-- | Adds type and data constructors to the database context.
278-- validate that the type *and* constructor names are unique! not yet implemented!
278-- validate that the type *and* constructor names are unique! not yet implemented!
279−evalContextExpr (AddTypeConstructor tCons dConsList) = do
279+evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
280 currentContext <- get
280 currentContext <- get
281− let oldTypes = typeConstructors currentContext
281+ let oldTypes = typeConstructorMapping currentContext
282− tConsName = TC.name tCons
282+ tConsName = TCD.name tConsDef
283 -- validate that the constructor's types exist
283 -- validate that the constructor's types exist
284− case validateTypeConstructor tCons dConsList of
284+ case validateTypeConstructorDef tConsDef dConsDefList of
285 errs@(_:_) -> pure $ Just (MultipleErrors errs)
285 errs@(_:_) -> pure $ Just (MultipleErrors errs)
286 [] -> do
286 [] -> do
287 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
287 if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
288 pure $ Just (InvalidAtomTypeName tConsName)
288 pure $ Just (InvalidAtomTypeName tConsName)
289− else if isRight (atomTypeForTypeConstructor tCons oldTypes) then
289+ else if isJust (findTypeConstructor tConsName oldTypes) then
290 pure $ Just (AtomTypeNameInUseError tConsName)
290 pure $ Just (AtomTypeNameInUseError tConsName)
291 else do
291 else do
292− let newTypes = oldTypes ++ [(tCons, dConsList)]
292+ let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
293− put $ currentContext { typeConstructors = newTypes }
293+ put $ currentContext { typeConstructorMapping = newTypes }
294 pure Nothing
294 pure Nothing
295
295
296-- | 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-- | 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.
297evalContextExpr (RemoveTypeConstructor tConsName) = do
297evalContextExpr (RemoveTypeConstructor tConsName) = do
298 currentContext <- get
298 currentContext <- get
299− let oldTypes = typeConstructors currentContext
299+ let oldTypes = typeConstructorMapping currentContext
300 if findTypeConstructor tConsName oldTypes == Nothing then
300 if findTypeConstructor tConsName oldTypes == Nothing then
301 pure $ Just (AtomTypeNameNotInUseError tConsName)
301 pure $ Just (AtomTypeNameNotInUseError tConsName)
302 else do
302 else do
303− let newTypes = filter (\(tCons, _) -> TC.name tCons /= tConsName) oldTypes
303+ let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
304− put $ currentContext { typeConstructors = newTypes }
304+ put $ currentContext { typeConstructorMapping = newTypes }
305 pure Nothing
305 pure Nothing
306
306
307evalContextExpr (MultipleExpr exprs) = do
307evalContextExpr (MultipleExpr exprs) = do
@@ -460,10 +460,11 @@ typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do
460typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do
460typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do
461 relType <- evalState (typeForRelationalExpr relExpr) context
461 relType <- evalState (typeForRelationalExpr relExpr) context
462 return $ RelationAtomType (attributes relType)
462 return $ RelationAtomType (attributes relType)
463+
463−-- grab the type of the data constructor, then validate that the args match the expected types
464+-- grab the type of the data constructor, then validate that the args match the expected types
464typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do
465typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do
465 argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs
466 argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs
466− atomTypeWithDataConstructor (typeConstructors context) dConsName argsTypes
467+ atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes
467
468
468-- | Validate that the type of the AtomExpr matches the expected type.
469-- | Validate that the type of the AtomExpr matches the expected type.
469verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType
470verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType
@@ -494,7 +495,7 @@ verifyAtomExprTypes rel context cons@(ConstructedAtomExpr _ _) expectedType = do
494
495
495
496
496-- | Look up the type's name and create a new attribute.
497-- | 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
498evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do
499evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons) = do
499 aType <- atomTypeForTypeConstructor tCons aTypes
500 aType <- atomTypeForTypeConstructor tCons aTypes
500 Right (Attribute attrName aType)
501 Right (Attribute attrName aType)
ProjectM36/Transaction/Persist.hs+7−7
@@ -49,12 +49,12 @@ readTransaction dbdir transUUID = do
49 relvars <- readRelVars transDir
49 relvars <- readRelVars transDir
50 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)
50 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)
51 incDeps <- readIncDeps transDir
51 incDeps <- readIncDeps transDir
52− typeCons <- readTypeConstructors transDir
52+ typeCons <- readTypeConstructorMapping transDir
53 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet
53 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet
54 let atomFuncs = basicAtomFunctions
54 let atomFuncs = basicAtomFunctions
55 let newContext = DatabaseContext { inclusionDependencies = incDeps,
55 let newContext = DatabaseContext { inclusionDependencies = incDeps,
56 relationVariables = relvars,
56 relationVariables = relvars,
57− typeConstructors = typeCons,
57+ typeConstructorMapping = typeCons,
58 notifications = M.empty,
58 notifications = M.empty,
59 atomFunctions = atomFuncs }
59 atomFunctions = atomFuncs }
60
60
@@ -72,7 +72,7 @@ writeTransaction sync dbdir trans = do
72 writeRelVars sync tempTransDir (relationVariables context)
72 writeRelVars sync tempTransDir (relationVariables context)
73 writeIncDeps sync tempTransDir (inclusionDependencies context)
73 writeIncDeps sync tempTransDir (inclusionDependencies context)
74 writeAtomFuncs sync tempTransDir (atomFunctions context)
74 writeAtomFuncs sync tempTransDir (atomFunctions context)
75− writeTypeConstructors sync tempTransDir (typeConstructors context)
75+ writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)
76 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)
76 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)
77 --move the temp directory to final location
77 --move the temp directory to final location
78 renameSync sync tempTransDir finalTransDir
78 renameSync sync tempTransDir finalTransDir
@@ -138,10 +138,10 @@ readIncDeps transDir = do
138 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)
138 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)
139 return $ M.fromList incDeps
139 return $ M.fromList incDeps
140
140
141−writeTypeConstructors :: DiskSync -> FilePath -> TypeConstructors -> IO ()
141+writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()
142−writeTypeConstructors sync path types = writeBSFileSync sync path $ B.encode types
142+writeTypeConstructorMapping sync path types = writeBSFileSync sync path $ B.encode types
143
143
144−readTypeConstructors :: FilePath -> IO (TypeConstructors)
144+readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping)
145−readTypeConstructors path = do
145+readTypeConstructorMapping path = do
146 let atPath = typeConsPath path
146 let atPath = typeConsPath path
147 liftM B.decode (BS.readFile atPath)
147 liftM B.decode (BS.readFile atPath)
ProjectM36/TypeConstructor.hs+10−9
@@ -1,18 +1,19 @@
1module ProjectM36.TypeConstructor where
1module ProjectM36.TypeConstructor where
2import ProjectM36.Base
2import ProjectM36.Base
3+import qualified Data.Set as S
3
4
4name :: TypeConstructor -> TypeConstructorName
5name :: TypeConstructor -> TypeConstructorName
5−name (ADTypeConstructor nam _) = nam
6+name (ADTypeConstructor name' _) = name'
6−name (PrimitiveTypeConstructor nam _) = nam
7+name (PrimitiveTypeConstructor name' _) = name'
7
8
8arguments :: TypeConstructor -> [TypeConstructorArg]
9arguments :: TypeConstructor -> [TypeConstructorArg]
10+arguments (ADTypeConstructor _ args) = args
9arguments (PrimitiveTypeConstructor _ _) = []
11arguments (PrimitiveTypeConstructor _ _) = []
10−arguments (ADTypeConstructor _ tConsArgs) = tConsArgs
11
12
12−polymorphicVariables :: TypeConstructor -> [TypeConstructorPolymorphicName]
13+typeVars :: TypeConstructor -> S.Set TypeVarName
13−polymorphicVariables (PrimitiveTypeConstructor _ _) = []
14+typeVars (PrimitiveTypeConstructor _ _) = S.empty
14−polymorphicVariables (ADTypeConstructor _ tConsArgs) = concatMap polymorphicVariablesInArg tConsArgs
15+typeVars (ADTypeConstructor _ args) = S.unions (map typeVarsForArg args)
15
16
16−polymorphicVariablesInArg :: TypeConstructorArg -> [TypeConstructorPolymorphicName]
17+typeVarsForArg :: TypeConstructorArg -> S.Set TypeVarName
17−polymorphicVariablesInArg (TypeConstructorPolymorphicArg nam) = [nam]
18+typeVarsForArg (TypeConstructorArg arg) = typeVars arg
18−polymorphicVariablesInArg (TypeConstructorArg tCons) = polymorphicVariables tCons
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
4+
5+name :: TypeConstructorDef -> TypeConstructorName
6+name (ADTypeConstructorDef nam _) = nam
7+name (PrimitiveTypeConstructorDef nam _) = nam
8+
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
131addTypeConstructorP :: Parser DatabaseExpr
131addTypeConstructorP :: Parser DatabaseExpr
132addTypeConstructorP = do
132addTypeConstructorP = do
133 reserved "data"
133 reserved "data"
134− typeConstructor <- typeConstructorP
134+ typeConstructorDef <- typeConstructorDefP
135 reservedOp "="
135 reservedOp "="
136− dataConstructors <- sepBy1 dataConstructorP pipe
136+ dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
137− pure (AddTypeConstructor typeConstructor dataConstructors)
137+ pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
138
138
139removeTypeConstructorP :: Parser DatabaseExpr
139removeTypeConstructorP :: Parser DatabaseExpr
140removeTypeConstructorP = do
140removeTypeConstructorP = do
TutorialD/Interpreter/RelationalExpr.hs+3−30
@@ -9,11 +9,7 @@ import qualified Data.Text as T
9import qualified Data.Set as S
9import qualified Data.Set as S
10import qualified Data.Map as M
10import qualified Data.Map as M
11import Data.Functor.Identity (Identity)
11import Data.Functor.Identity (Identity)
12−import Data.Time.Format
13import Control.Applicative (liftA)
12import Control.Applicative (liftA)
14−import Data.ByteString.Base64 as B64
15−import Data.Text.Encoding as TE
16−import Data.Time.Calendar (Day)
17
13
18--used in projection
14--used in projection
19attributeListP :: Parser AttributeNames
15attributeListP :: Parser AttributeNames
@@ -202,9 +198,9 @@ nakedAtomExprP = NakedAtomExpr <$> atomP
202constructedAtomExprP :: Parser AtomExpr
198constructedAtomExprP :: Parser AtomExpr
203constructedAtomExprP = do
199constructedAtomExprP = do
204 dConsName <- identifier
200 dConsName <- identifier
205− _ <- char '['
201+ --_ <- char '['
206− dConsArgs <- sepBy atomExprP comma
202+ dConsArgs <- sepBy atomExprP spaces
207− _ <- char ']'
203+ --_ <- char ']'
208 pure $ ConstructedAtomExpr (T.pack dConsName) dConsArgs
204 pure $ ConstructedAtomExpr (T.pack dConsName) dConsArgs
209
205
210-- used only for primitive type parsing ?
206-- used only for primitive type parsing ?
@@ -240,17 +236,6 @@ maybeIntAtomP = do
240 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"
236 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"
241 return $ Atom (maybeInt :: Maybe Int)
237 return $ Atom (maybeInt :: Maybe Int)
242
238
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−
254doubleAtomP :: Parser Atom
239doubleAtomP :: Parser Atom
255doubleAtomP = Atom <$> (try float)
240doubleAtomP = Atom <$> (try float)
256
241
@@ -266,15 +251,3 @@ boolAtomP = do
266
251
267relationAtomExprP :: Parser AtomExpr
252relationAtomExprP :: Parser AtomExpr
268relationAtomExprP = RelationAtomExpr <$> makeRelationP
253relationAtomExprP = 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)
9import qualified Data.Text as T
9import qualified Data.Text as T
10
10
11-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.
11-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.
12−-- Either a b
12+-- data *Either a b* = Left a | Right b
13−typeConstructorP :: Parser TypeConstructor
13+typeConstructorDefP :: Parser TypeConstructorDef
14−typeConstructorP = ADTypeConstructor <$> liftM T.pack capitalizedIdentifier <*> many typeConstructorArgP
14+typeConstructorDefP = ADTypeConstructorDef <$> liftM T.pack capitalizedIdentifier <*> typeVarNamesP
15−
16−typeConstructorArgP :: Parser TypeConstructorArg
17−typeConstructorArgP = TypeConstructorPolymorphicArg <$> liftM T.pack uncapitalizedIdentifier
18
15
19−dataConstructorP :: Parser DataConstructor
16+typeVarNamesP :: Parser [TypeVarName]
20−dataConstructorP = DataConstructor <$> liftM T.pack identifier <*> many dataConstructorArgP
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
21
24
22−--Either Int Text
23−--Either a Int
25+-- data *Either a b* = Left *a* | Right *b*
24−--Either (Either a b) Int
26+dataConstructorDefArgP :: Parser DataConstructorDefArg
25−dataConstructorArgP :: Parser TypeConstructorArg
27+dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeConstructorP) <|>
26−dataConstructorArgP = primitiveTypeConstructorArgP <|>
27− TypeConstructorPolymorphicArg <$> liftM T.pack uncapitalizedIdentifier <|>
28+ DataConstructorDefTypeVarNameArg <$> liftM T.pack uncapitalizedIdentifier
28− parens (TypeConstructorArg <$> typeConstructorP)
29
29
30−primitiveTypeConstructorArgP :: Parser TypeConstructorArg
30+--built-in, nullary type constructors
31−primitiveTypeConstructorArgP = choice (map (\(PrimitiveTypeConstructor name typ, _) -> do
31+-- Int, Text, etc.
32+primitiveTypeConstructorP :: Parser TypeConstructor
33+primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do
32 tName <- liftM T.pack (symbol (T.unpack name))
34 tName <- liftM T.pack (symbol (T.unpack name))
33− pure $ TypeConstructorArg (PrimitiveTypeConstructor tName typ))
35+ pure $ PrimitiveTypeConstructor tName typ)
34− primitiveTypeConstructors)
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+