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

git.iko.soy/project-m36

first pass at working sub relation attributes

manual test seems to work

commit38151c03da3cf64aa6db542d6210e0106067b121 authorAgentM <agentm@themactionfaction.com> dateWed 23 May 2018, 23:43 (8 years ago) parent14a9d9a

7 files changed+44−25

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/RelationalExpr.hs−6 src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+2−1 src/bin/TutorialD/Interpreter/Types.hs+11−4 src/lib/ProjectM36/AtomType.hs+16−7 src/lib/ProjectM36/AttributeExpr.hs+7 src/lib/ProjectM36/Base.hs+7−6 src/lib/ProjectM36/Client.hs+1−1

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

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

1111import Data.List (sort)

1212import ProjectM36.MiscUtils

1313

14−class RelationalMarkerExpr a where

15− parseMarkerP :: Parser a

16−

17−instance RelationalMarkerExpr () where

18− parseMarkerP = pure ()

19−

2014--used in projection

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

2216attributeListP =

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

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

33module TutorialD.Interpreter.TransGraphRelationalOperator where

44import ProjectM36.TransGraphRelationalExpression

55import ProjectM36.TransactionGraph

6+import TutorialD.Interpreter.Types

67import qualified ProjectM36.Client as C

89import TutorialD.Interpreter.Base

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

1516

1617instance RelationalMarkerExpr TransactionIdLookup where

1718 parseMarkerP = string "@" *> transactionIdLookupP

18−

19+

1920newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

2021 deriving Show

2122

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

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

77import ProjectM36.DataTypes.Primitive

88import qualified Data.Text as T

10+class RelationalMarkerExpr a where

11+ parseMarkerP :: Parser a

12+

13+instance RelationalMarkerExpr () where

14+ parseMarkerP = pure ()

15+

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

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

1218typeConstructorDefP :: Parser TypeConstructorDef

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

2834--built-in, nullary type constructors

2935-- Int, Text, etc.

3036primitiveTypeConstructorP :: Parser TypeConstructor

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

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

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

3339 pure $ PrimitiveTypeConstructor tName typ)

3440 primitiveTypeConstructorMapping)

3541

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

37−relationTypeP :: Parser TypeConstructor

38−relationTypeP = do

43+relationTypeConstructorP :: Parser TypeConstructor

44+relationTypeConstructorP = do

3945 reserved "relation"

40− RelationAtomTypeConstructor <$> braces makeAttributeExprsP

46+ RelationAtomTypeConstructor <$> makeAttributeExprsP

4147

4248--used in relation creation

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

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

5056-- *Either Int Text*, *Int*

5157typeConstructorP :: Parser TypeConstructor

5258typeConstructorP = primitiveTypeConstructorP <|>

59+ relationTypeConstructorP <|>

5360 TypeVariable <$> uncapitalizedIdentifier <|>

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

5562 monoTypeConstructorP)

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

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

66import ProjectM36.MiscUtils

77import ProjectM36.Error

88import ProjectM36.DataTypes.Primitive

9+import ProjectM36.AttributeExpr as AE

910import qualified ProjectM36.Attribute as A

1011import qualified Data.Vector as V

1112import qualified Data.Set as S

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

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

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

5758

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

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

5961

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

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

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

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

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

119−resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExpr) typ tConsMap =

121+resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =

120122 case typ of

121123 RelationAtomType attrs -> do

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

123− error "poop"

124+ --resolve any typevars in the attrExprs

125+ error "poop4"

126+ otherType -> error "poop5"

124127

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

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

127−resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = do

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

129−

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

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

131132

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

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

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

150151 Nothing -> Right (TypeVariableType tvname)

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

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

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

154159 Just (tConsDef, _) -> do

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

156161 let pVarNames = TCD.typeVars tConsDef

157162 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

158163 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

159168

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

161170findTypeConstructor name = foldr tConsFolder Nothing

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

228237 else

229238 Right ()

230239 _ -> Right ()

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

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

232241validateAtomType _ _ = Right ()

233242

234243validateTuple :: 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]

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

239239

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

241−data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

242− PrimitiveTypeConstructor TypeConstructorName AtomType |

243− RelationAtomTypeConstructor AttributeExpr |

244− TypeVariable TypeVarName

241+type TypeConstructor = TypeConstructorBase ()

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

243+ PrimitiveTypeConstructor TypeConstructorName AtomType |

244+ RelationAtomTypeConstructor [AttributeExprBase a] |

245+ TypeVariable TypeVarName

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

246247

247248type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

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

548549typeVars (PrimitiveTypeConstructor _ _) = S.empty

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

550551typeVars (TypeVariable v) = S.singleton v

551−typeVars (RelationAtomTypeConstructor attrExpr) = attrExprTypeVars attrExpr

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

552553

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

554555attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons

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

566567atomTypeVars (IntervalAtomType aType) = atomTypeVars aType

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

568569atomTypeVars (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

7878 databaseContextExprForForeignKey,

7979 createScriptedAtomFunction,

8080 AttributeExprBase(..),

81− TypeConstructor(..),

81+ TypeConstructorBase(..),

8282 TypeConstructorDef(..),

8383 DataConstructorDef(..),

8484 AttributeNamesBase(..),