b5477e2 · project-m36 · git.iko.soy

git.iko.soy/project-m36

implement relation variable type safety

commitb5477e23fdf506455b02174f3b8a3cb31a276d85 authorAgentM <agentm@themactionfaction.com> dateSun 16 Nov 2014, 12:14 (12 years ago) parentb605de7

3 files changed+111−10

compare with master

unifiedsplit

RelationExpr.hs+44−7 RelationalError.hs+2 TutorialDInterpreter.hs+65−3

RelationExpr.hs+44−7

@@ -22,12 +22,19 @@ data RelationalExpr where

2222 Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr

2323 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr

2424 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr

25− Assign :: String -> RelationalExpr -> RelationalExpr

2625 MultipleExpr :: [RelationalExpr] -> RelationalExpr

2726 Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr

2827 Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr

2928 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr

30− --Restrict :: RExpr.RestrictionExpr -> RelationalExpr -> RelationalExpr

29+ --Restrict :: RExpr.RestrictionExpr -> RelationalExpr -> RelationalExpr

30+

31+ --nominal relational expressions- the following operations could also be deemed non-relational, but I allow them to return relational expressions regardless- maybe this doesn't make sense since they should only be allowed as top-level commands

32+ Define :: String -> Attributes -> RelationalExpr

33+ Assign :: String -> RelationalExpr -> RelationalExpr

34+ Insert :: String -> RelationalExpr -> RelationalExpr

35+ Delete :: String -> RelationalExpr -- needs restriction support

36+ Update :: String -> M.Map String Atom -> RelationalExpr -- needs restriction support

37+

3138{- maybe break this into multiple steps:

32391. check relational types for match (attribute counts) (typechecking step

33402. create an execution plan (another system of nodes, another GADT)

@@ -37,14 +44,38 @@ data RelationalExpr where

3744

3845type RelVarState a = State RelVarContext a

3946

47+--helper function to process relation variable creation/assignment

48+setRelVar :: String -> Relation -> RelVarState (Either RelationalError Relation)

49+setRelVar relVarName rel = do

50+ relVars <- get

51+ put $ M.insert relVarName rel relVars

52+ return $ Right rel

53+

4054eval :: RelationalExpr -> RelVarState (Either RelationalError Relation)

55+

56+--define a relvar by creating an empty-tupled relation

57+eval (Define relVarName attributes) = do

58+ relvars <- get

59+ case M.member relVarName relvars of

60+ True -> return (Left (RelvarAlreadyDefined relVarName))

61+ False -> setRelVar relVarName emptyRelation

62+ where

63+ emptyRelation = Relation attributes HS.empty

64+

4165eval (Assign relVarName expr) = do

42− relvarTable <- get

43− value <- eval expr

66+ relVarTable <- get

67+ -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it

68+ let existingRelVar = M.lookup relVarName relVarTable

69+ value <- eval expr

4470 case value of

45− Right rel -> (put $ M.insert relVarName rel relvarTable) >>

46− (return $ Right rel)

4771 Left err -> return $ Left err

72+ Right rel -> case existingRelVar of

73+ Nothing -> setRelVar relVarName rel

74+ Just existingRel -> if attributes existingRel == attributes rel then

75+ setRelVar relVarName rel

76+ else

77+ return $ Left RelvarAssignmentTypeMismatch

78+

4879

4980eval (RelationVariable name) = do

5081 relvarTable <- get

@@ -102,7 +133,13 @@ eval (Ungroup attrName relExpr) = do

102133 case evald of

103134 Right rel -> return $ ungroup attrName rel

104135 Left err -> return $ Left err

105−

136+

137+eval (Insert relVarName relExpr) = do

138+ evald <- eval $ Assign relVarName (Union relExpr (RelationVariable relVarName))

139+ case evald of

140+ Right rel -> return $ evald

141+ Left err -> return $ Left err

142+

106143emptyRelVarContext :: RelVarContext

107144emptyRelVarContext = M.empty

108145

RelationalError.hs+2

@@ -10,6 +10,8 @@ data RelationalError = NoSuchAttributeNameError String

1010 | AttributeNameInUseError AttributeName

1111 | AttributeIsNotRelationValuedError AttributeName

1212 | RelvarNotDefinedError String

13+ | RelvarAlreadyDefined String

14+ | RelvarAssignmentTypeMismatch

1315 | ParseError String

1416 deriving (Show,Eq)

1517

TutorialDInterpreter.hs+65−3

@@ -1,4 +1,6 @@

1+{-# LANGUAGE GADTs #-}

12module TutorialDInterpreter where

3+import Relation

24import RelationType

35import RelationalError

46import RelationExpr

@@ -11,6 +13,7 @@ import qualified Text.Parsec.Token as Token

1113import qualified Data.Set as S

1214import qualified Data.HashSet as HS

1315import qualified Data.Map as M

16+import qualified Data.List as L

1417import Control.Applicative (liftA)

1518import Control.Monad.State

1619import System.Console.Readline

@@ -65,11 +68,19 @@ tutDTypeToAtomType tutDType = case tutDType of

6568 "int" -> Just IntAtomType

6669 _ -> Nothing

6770

71+atomTypeToTutDType :: AtomType -> Maybe String

72+atomTypeToTutDType atomType = case atomType of

73+ StringAtomType -> Just "char"

74+ IntAtomType -> Just "int"

75+ --RelationAtomType rel ->

76+ _ -> Nothing

77+

6878relVarP :: Parser RelationalExpr

6979relVarP = liftA RelationVariable identifier

7080

7181relTerm = parens relExpr

7282 <|> makeRelation

83+ <|> (try defineP)

7384 <|> relVarP

7485

7586projectOp = do

@@ -111,14 +122,29 @@ ungroupP = do

111122 reservedOp "ungroup"

112123 rvaAttrName <- identifier

113124 return $ Ungroup rvaAttrName

114−

115−

125+

126+insertP :: Parser (RelationalExpr -> RelationalExpr)

127+insertP = do

128+ reservedOp "insert"

129+ relvar <- identifier

130+ return $ Insert relvar

131+

132+defineP :: Parser RelationalExpr

133+defineP = do

134+ relVarName <- identifier

135+ reservedOp "::"

136+ attributes <- makeAttributes

137+ return $ Define relVarName attributes

138+

116139relOperators = [

117140 [Postfix projectOp],

118141 [Postfix renameP],

119142 [Postfix groupP],

143+ [Postfix ungroupP],

120144 [Infix (reservedOp "join" >> return Join) AssocLeft],

121145 [Infix (reservedOp "union" >> return Union) AssocLeft],

146+ [Prefix insertP],

147+

122148 [Prefix (try assignP)]

123149 ]

124150

@@ -134,6 +160,29 @@ parseString :: String -> Either RelationalError RelationalExpr

134160parseString str = case parse multipleRelExpr "" str of

135161 Left err -> Left $ ParseError (show err)

136162 Right r -> Right r

163+

164+data TutorialDOperator where

165+ ShowRelationVariableType :: String -> TutorialDOperator

166+

167+interpreterOps :: Parser TutorialDOperator

168+interpreterOps = do

169+ reservedOp ":t"

170+ relVarName <- identifier

171+ return $ ShowRelationVariableType relVarName

172+

173+showRelationAttributes :: Relation -> String

174+showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"

175+ where

176+ showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of

177+ Just t -> show t

178+ Nothing -> "unknown"

179+ attrs = values (attributes rel)

180+ values m = map snd (M.toAscList m)

181+

182+evalTutorialDOp :: RelVarContext -> TutorialDOperator -> String

183+evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName context of

184+ Just rel -> showRelationAttributes rel

185+ Nothing -> relVarName ++ " not defined"

137186

138187example1 = "relA {a,b, c}"

139188example2 = "relA join relB"

@@ -149,7 +198,13 @@ interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVar

149198interpret context tutdstring = case parseString tutdstring of

150199 Left err -> (Left err, context)

151200 Right parsed -> runState (eval parsed) context

152−

201+

202+-- for interpreter-specific operations

203+interpretOps :: RelVarContext -> String -> Maybe String

204+interpretOps context instring = case parse interpreterOps "" instring of

205+ Left err -> Nothing

206+ Right ops -> Just $ evalTutorialDOp context ops

207+

153208reprLoop :: RelVarContext -> IO ()

154209reprLoop context = do

155210 maybeLine <- readline "TutorialD: "

@@ -157,6 +212,13 @@ reprLoop context = do

157212 Nothing -> return ()

158213 Just line -> do

159214 addHistory line

215+

216+ case interpretOps context line of

217+ Just out -> do

218+ putStrLn out

219+ reprLoop context

220+ Nothing -> return ()

221+

160222 let (value, contextup) = interpret context line

161223 case value of

162224 (Right rel) -> do