38151c0 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

first pass at working sub relation attributes

38151c0AgentM8 years ago

src/bin/TutorialD/Interpreter/RelationalExpr.hs−6

compare with master

unifiedsplit

@@ -11,12 +11,6 @@ import qualified Data.Map as M

11import Data.List (sort)

12import ProjectM36.MiscUtils

14−class RelationalMarkerExpr a where

15− parseMarkerP :: Parser a

16−

17−instance RelationalMarkerExpr () where

18− parseMarkerP = pure ()

19−

20--used in projection

14--used in projection

21attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)

15attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)

22attributeListP =

16attributeListP =

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+2−1

@@ -3,6 +3,7 @@

3module TutorialD.Interpreter.TransGraphRelationalOperator where

4import ProjectM36.TransGraphRelationalExpression

5import ProjectM36.TransactionGraph

6+import TutorialD.Interpreter.Types

6import qualified ProjectM36.Client as C

7import qualified ProjectM36.Client as C

8import TutorialD.Interpreter.Base

9import TutorialD.Interpreter.Base

@@ -15,7 +16,7 @@ import qualified Data.Text as T

16instance RelationalMarkerExpr TransactionIdLookup where

17instance RelationalMarkerExpr TransactionIdLookup where

17 parseMarkerP = string "@" *> transactionIdLookupP

18 parseMarkerP = string "@" *> transactionIdLookupP

18−

19+

19newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

20newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

20 deriving Show

21 deriving Show

src/bin/TutorialD/Interpreter/Types.hs+11−4

@@ -7,6 +7,12 @@ import TutorialD.Interpreter.Base

7import ProjectM36.DataTypes.Primitive

8import qualified Data.Text as T

10+class RelationalMarkerExpr a where

11+ parseMarkerP :: Parser a

12+

13+instance RelationalMarkerExpr () where

14+ parseMarkerP = pure ()

15+

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

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

11-- data *Either a b* = Left a | Right b

17-- data *Either a b* = Left a | Right b

12typeConstructorDefP :: Parser TypeConstructorDef

18typeConstructorDefP :: Parser TypeConstructorDef

@@ -28,16 +34,16 @@ dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeCo

28--built-in, nullary type constructors

34--built-in, nullary type constructors

29-- Int, Text, etc.

35-- Int, Text, etc.

30primitiveTypeConstructorP :: Parser TypeConstructor

36primitiveTypeConstructorP :: Parser TypeConstructor

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

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

32 tName <- try $ symbol (T.unpack name)

38 tName <- try $ symbol (T.unpack name)

33 pure $ PrimitiveTypeConstructor tName typ)

39 pure $ PrimitiveTypeConstructor tName typ)

34 primitiveTypeConstructorMapping)

40 primitiveTypeConstructorMapping)

36-- relation{a Int} in type construction (no tuples parsed)

42-- relation{a Int} in type construction (no tuples parsed)

37−relationTypeP :: Parser TypeConstructor

43+relationTypeConstructorP :: Parser TypeConstructor

38−relationTypeP = do

44+relationTypeConstructorP = do

39 reserved "relation"

45 reserved "relation"

40− RelationAtomTypeConstructor <$> braces makeAttributeExprsP

46+ RelationAtomTypeConstructor <$> makeAttributeExprsP

42--used in relation creation

48--used in relation creation

43makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

49makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

@@ -50,6 +56,7 @@ attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstruc

50-- *Either Int Text*, *Int*

56-- *Either Int Text*, *Int*

51typeConstructorP :: Parser TypeConstructor

57typeConstructorP :: Parser TypeConstructor

52typeConstructorP = primitiveTypeConstructorP <|>

58typeConstructorP = primitiveTypeConstructorP <|>

59+ relationTypeConstructorP <|>

53 TypeVariable <$> uncapitalizedIdentifier <|>

60 TypeVariable <$> uncapitalizedIdentifier <|>

54 ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>

61 ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>

55 monoTypeConstructorP)

62 monoTypeConstructorP)

src/lib/ProjectM36/AtomType.hs+16−7

@@ -6,6 +6,7 @@ import qualified ProjectM36.DataConstructorDef as DCD

6import ProjectM36.MiscUtils

7import ProjectM36.Error

8import ProjectM36.DataTypes.Primitive

9+import ProjectM36.AttributeExpr as AE

9import qualified ProjectM36.Attribute as A

10import qualified ProjectM36.Attribute as A

10import qualified Data.Vector as V

11import qualified Data.Vector as V

11import qualified Data.Set as S

12import qualified Data.Set as S

@@ -55,6 +56,7 @@ isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedATyp

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

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

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

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

59+isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) _ = error "poopla"

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

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

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

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

@@ -116,17 +118,16 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

116 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

118 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

117resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

119resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

118resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)

120resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)

119−resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExpr) typ tConsMap =

121+resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =

120 case typ of

122 case typ of

121 RelationAtomType attrs -> do

123 RelationAtomType attrs -> do

122− resolvedAttrs <- mapM (\atomtype' -> resolveAttributeExprTypeVars attrExpr atomtype' tConsMap) (map A.atomType (V.toList attrs))

124+ --resolve any typevars in the attrExprs

123− error "poop"

125+ error "poop4"

126+ otherType -> error "poop5"

124

127

125--used when recursing down sub-relation type definition

128--used when recursing down sub-relation type definition

126resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

129resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

127−resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = do

130+resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = error "poop2"

128− resolvedType <- resolveAtomType (A.atomType attr) aType

129−

130resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap

131resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap

131

132

132-- check that type vars on the right also appear on the left

133-- check that type vars on the right also appear on the left

@@ -149,6 +150,10 @@ atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ _ = Right aType

149atomTypeForTypeConstructor (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of

150atomTypeForTypeConstructor (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of

150 Nothing -> Right (TypeVariableType tvname)

151 Nothing -> Right (TypeVariableType tvname)

151 Just typ -> Right typ

152 Just typ -> Right typ

153+atomTypeForTypeConstructor (RelationAtomTypeConstructor attrExprs) tConsMap tvMap = do

154+ resolvedAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap tvMap) attrExprs

155+ let attrs = map (uncurry Attribute) (zip (map AE.attributeName attrExprs) resolvedAtomTypes)

156+ pure (RelationAtomType (A.attributesFromList attrs))

152atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of

157atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of

153 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

158 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

154 Just (tConsDef, _) -> do

159 Just (tConsDef, _) -> do

@@ -156,6 +161,10 @@ atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.nam

156 let pVarNames = TCD.typeVars tConsDef

161 let pVarNames = TCD.typeVars tConsDef

157 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

162 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

158 Right (ConstructedAtomType (TC.name tCons) tConsArgs)

163 Right (ConstructedAtomType (TC.name tCons) tConsArgs)

164+

165+atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

166+atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)

167+atomTypeForAttributeExpr (AttributeAndTypeNameExpr _ tCons _) tConsMap tvMap = atomTypeForTypeConstructor tCons tConsMap tvMap

159

168

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

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

161findTypeConstructor name = foldr tConsFolder Nothing

170findTypeConstructor name = foldr tConsFolder Nothing

@@ -228,7 +237,7 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

228 else

237 else

229 Right ()

238 Right ()

230 _ -> Right ()

239 _ -> Right ()

231−validateAtomType (RelationAtomType attrs) = error "poop"

240+validateAtomType (RelationAtomType attrs) _ = error "poop"

232validateAtomType _ _ = Right ()

241validateAtomType _ _ = Right ()

233

242

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

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

src/lib/ProjectM36/AttributeExpr.hsnew file+7

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

1+module ProjectM36.AttributeExpr where

2+import ProjectM36.Base

3+import ProjectM36.Attribute as A

5+attributeName :: AttributeExprBase a -> AttributeName

6+attributeName (AttributeAndTypeNameExpr nam _ _) = nam

7+attributeName (NakedAttributeExpr attr) = A.attributeName attr

src/lib/ProjectM36/Base.hs+7−6

@@ -238,10 +238,11 @@ data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName]

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

239

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

241+type TypeConstructor = TypeConstructorBase ()

241−data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

242+data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] |

242− PrimitiveTypeConstructor TypeConstructorName AtomType |

243+ PrimitiveTypeConstructor TypeConstructorName AtomType |

243− RelationAtomTypeConstructor AttributeExpr |

244+ RelationAtomTypeConstructor [AttributeExprBase a] |

244− TypeVariable TypeVarName

245+ TypeVariable TypeVarName

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

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

246

247

247type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

248type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

@@ -548,7 +549,7 @@ typeVars :: TypeConstructor -> S.Set TypeVarName

548typeVars (PrimitiveTypeConstructor _ _) = S.empty

549typeVars (PrimitiveTypeConstructor _ _) = S.empty

549typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

550typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

550typeVars (TypeVariable v) = S.singleton v

551typeVars (TypeVariable v) = S.singleton v

551−typeVars (RelationAtomTypeConstructor attrExpr) = attrExprTypeVars attrExpr

552+typeVars (RelationAtomTypeConstructor attrExprs) = S.unions (map attrExprTypeVars attrExprs)

552

553

553attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName

554attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName

554attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons

555attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons

@@ -566,4 +567,4 @@ atomTypeVars BoolAtomType = S.empty

566atomTypeVars (IntervalAtomType aType) = atomTypeVars aType

567atomTypeVars (IntervalAtomType aType) = atomTypeVars aType

567atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

568atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

568atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

569atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

569−atomTypeVars (TypeVariableType nam) = S.singleton nam

570+atomTypeVars (TypeVariableType nam) = S.singleton nam

src/lib/ProjectM36/Client.hs+1−1

@@ -78,7 +78,7 @@ module ProjectM36.Client

78 databaseContextExprForForeignKey,

79 createScriptedAtomFunction,

80 AttributeExprBase(..),

81− TypeConstructor(..),

81+ TypeConstructorBase(..),

82 TypeConstructorDef(..),

83 DataConstructorDef(..),

84 AttributeNamesBase(..),