@@ -1,4 +1,4 @@
1−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE GADTs,OverloadedStrings #-}
22module TutorialD.Interpreter where
33import ProjectM36.Base
44import ProjectM36.Relation
@@ -29,6 +29,8 @@ import System.Directory (getHomeDirectory)
2929import qualified Data.UUID as U
3030import Data.UUID.V4 (nextRandom)
3131import qualified Data.Vector as V
32+import qualified Data.Text as T
33+import qualified Data.Text.IO as TIO
3234
3335{-
3436List of Tutorial D operators:
@@ -70,7 +72,9 @@ uuidP = do
7072
7173--used in projection
7274attributeList :: Parser [AttributeName]
73−attributeList = sepBy identifier comma
75+attributeList = do
76+ attrs <- sepBy identifier comma
77+ return $ map T.pack attrs
7478
7579makeRelation :: Parser RelationalExpr
7680makeRelation = do
@@ -94,7 +98,7 @@ attributeAndType = do
9498 attrTypeName <- identifier
9599 --convert type name into type
96100 case tutDTypeToAtomType attrTypeName of
97− Just t -> return $ Attribute attrName t
101+ Just t -> return $ Attribute (T.pack attrName) t
98102 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
99103
100104tupleP :: Parser RelationTuple
@@ -113,7 +117,7 @@ tupleAtomP = do
113117 case tutDTypeToAtomType attrType of
114118 Nothing -> fail (attrType ++ " is not a valid type name.")
115119 Just typeA -> if typeA == atomTypeForAtom atom then
116− return $ (attributeName, atom)
120+ return $ (T.pack attributeName, atom)
117121 else
118122 fail "type mismatch in tuple generation"
119123
@@ -132,7 +136,7 @@ atomTypeToTutDType atomType = case atomType of
132136 _ -> Nothing
133137
134138relVarP :: Parser RelationalExpr
135−relVarP = liftA RelationVariable identifier
139+relVarP = liftA (RelationVariable . T.pack) identifier
136140
137141relTerm = parens relExpr
138142 <|> makeRelation
@@ -149,7 +153,7 @@ assignP = do
149153 reservedOp ":="
150154 return relVarName
151155 expr <- relExpr
152− return $ Assign relVarName expr
156+ return $ Assign (T.pack relVarName) expr
153157
154158renameClause = do
155159 oldAttr <- identifier
@@ -161,7 +165,7 @@ renameP :: Parser (RelationalExpr -> RelationalExpr)
161165renameP = do
162166 reservedOp "rename"
163167 (oldAttr, newAttr) <- braces renameClause
164− return $ Rename oldAttr newAttr
168+ return $ Rename (T.pack oldAttr) (T.pack newAttr)
165169
166170whereClauseP = do
167171 reservedOp "where"
@@ -178,14 +182,14 @@ groupP :: Parser (RelationalExpr -> RelationalExpr)
178182groupP = do
179183 reservedOp "group"
180184 (groupAttrList, groupAttrName) <- parens groupClause
181− return $ Group (S.fromList groupAttrList) groupAttrName
185+ return $ Group (S.fromList groupAttrList) (T.pack groupAttrName)
182186
183187--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.
184188ungroupP :: Parser (RelationalExpr -> RelationalExpr)
185189ungroupP = do
186190 reservedOp "ungroup"
187191 rvaAttrName <- identifier
188− return $ Ungroup rvaAttrName
192+ return $ Ungroup (T.pack rvaAttrName)
189193
190194relOperators = [
191195 [Postfix projectOp],
@@ -220,7 +224,7 @@ insertP = do
220224 reservedOp "insert"
221225 relvar <- identifier
222226 expr <- relExpr
223− return $ Insert relvar expr
227+ return $ Insert (T.pack relvar) expr
224228
225229defineP :: Parser DatabaseExpr
226230defineP = do
@@ -229,20 +233,20 @@ defineP = do
229233 reservedOp "::"
230234 return relVarName
231235 attributeSet <- makeAttributes
232− return $ Define relVarName attributeSet
236+ return $ Define (T.pack relVarName) attributeSet
233237
234238undefineP :: Parser DatabaseExpr
235239undefineP = do
236240 reservedOp "undefine"
237241 relVarName <- identifier
238− return $ Undefine relVarName
242+ return $ Undefine (T.pack relVarName)
239243
240244deleteP :: Parser DatabaseExpr
241245deleteP = do
242246 reservedOp "delete"
243247 relVarName <- identifier
244248 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
245− return $ Delete relVarName predicate
249+ return $ Delete (T.pack relVarName) predicate
246250
247251updateP :: Parser DatabaseExpr
248252updateP = do
@@ -250,7 +254,7 @@ updateP = do
250254 relVarName <- identifier
251255 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
252256 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
253− return $ Update relVarName attributeAssignments predicate
257+ return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
254258
255259constraintP :: Parser DatabaseExpr
256260constraintP = do
@@ -259,7 +263,7 @@ constraintP = do
259263 subset <- relExpr
260264 reservedOp "in"
261265 superset <- relExpr
262− return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
266+ return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)
263267
264268attributeAssignment :: Parser (String, Atom)
265269attributeAssignment = do
@@ -270,21 +274,21 @@ attributeAssignment = do
270274
271275parseString :: String -> Either RelationalError DatabaseExpr
272276parseString str = case parse (multipleDatabaseExpr <* eof) "" str of
273− Left err -> Left $ ParseError (show err)
277+ Left err -> Left $ ParseError (T.pack (show err))
274278 Right r -> Right r
275279
276280--operators which only rely on database context reading
277281data ContextOperator where
278282 ShowRelation :: RelationalExpr -> ContextOperator
279283 ShowRelationType :: RelationalExpr -> ContextOperator
280− ShowConstraint :: String -> ContextOperator
284+ ShowConstraint :: StringType -> ContextOperator
281285 ShowPlan :: DatabaseExpr -> ContextOperator
282286 Quit :: ContextOperator
283287 deriving (Show)
284288
285289--operators which manipulate a transaction graph
286290data GraphOperator where
287− JumpToHead :: String -> GraphOperator
291+ JumpToHead :: HeadName -> GraphOperator
288292 JumpToTransaction :: U.UUID -> GraphOperator
289293 Branch :: HeadName -> GraphOperator
290294 Commit :: GraphOperator
@@ -318,13 +322,13 @@ showConstraintsP :: Parser ContextOperator
318322showConstraintsP = do
319323 reservedOp ":constraints"
320324 constraintName <- option "" identifier
321− return $ ShowConstraint constraintName
325+ return $ ShowConstraint (T.pack constraintName)
322326
323327jumpToHeadP :: Parser GraphOperator
324328jumpToHeadP = do
325329 reservedOp ":jumphead"
326330 headid <- identifier
327− return $ JumpToHead headid
331+ return $ JumpToHead (T.pack headid)
328332
329333jumpToTransactionP :: Parser GraphOperator
330334jumpToTransactionP = do
@@ -336,7 +340,7 @@ branchTransactionP :: Parser GraphOperator
336340branchTransactionP = do
337341 reservedOp ":branch"
338342 branchName <- identifier
339− return $ Branch branchName
343+ return $ Branch (T.pack branchName)
340344
341345commitTransactionP :: Parser GraphOperator
342346commitTransactionP = do
@@ -372,32 +376,32 @@ contextOps = typeP
372376interpreterOps :: Parser (Either ContextOperator GraphOperator)
373377interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps
374378
375−showRelationAttributes :: Relation -> String
376−showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
379+showRelationAttributes :: Relation -> T.Text
380+showRelationAttributes rel = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrs) `T.append` "}"
377381 where
378− showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
379− Just t -> show t
380− Nothing -> "unknown"
382+ showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of
383+ Just t -> T.pack (show t)
384+ Nothing -> T.pack "unknown"
381385 attrs = V.toList $ attributes rel
382386
383387data TutorialDOperatorResult = QuitResult |
384− DisplayResult String |
385− DisplayErrorResult String |
388+ DisplayResult StringType |
389+ DisplayErrorResult StringType |
386390 QuietSuccessResult |
387391 NoActionResult --refactor to make this dead- there should be only one parser
388392
389393evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult
390394evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
391395 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
392− (Left err, _) -> DisplayErrorResult $ show err
396+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)
393397
394398evalContextOp context (ShowRelation expr) = do
395399 case runState (evalRelationalExpr expr) context of
396− (Left err, _) -> DisplayErrorResult $ show err
400+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)
397401 (Right rel, _) -> DisplayResult $ showRelation rel
398402
399403evalContextOp context (ShowConstraint name) = do
400− DisplayResult $ show filteredDeps
404+ DisplayResult $ T.pack (show filteredDeps)
401405 where
402406 deps = inclusionDependencies context
403407 filteredDeps = case name of
@@ -405,7 +409,7 @@ evalContextOp context (ShowConstraint name) = do
405409 name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps
406410
407411evalContextOp context (ShowPlan dbExpr) = do
408− DisplayResult $ show plan
412+ DisplayResult $ T.pack (show plan)
409413 where
410414 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
411415
@@ -500,20 +504,20 @@ interpretNO context tutdstring = case parseString tutdstring of
500504-- for interpreter-specific operations
501505interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
502506interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
503− Left err -> (trans, transGraph, NoActionResult)
507+ Left _ -> (trans, transGraph, NoActionResult)
504508 Right ops -> case ops of
505509 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
506510 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
507− Left err -> (trans, transGraph, DisplayErrorResult $ show err)
511+ Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
508512 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
509513
510−promptText :: DisconnectedTransaction -> TransactionGraph -> String
511−promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
514+promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
515+promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
512516 where
513517 transInfo = case transactionForUUID parentUUID graph of
514518 Left _ -> "unknown"
515519 Right parentTrans -> case headNameForTransaction parentTrans graph of
516− Nothing -> show $ transactionUUID parentTrans
520+ Nothing -> T.pack (show $ transactionUUID parentTrans)
517521 Just headName -> headName
518522
519523reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
@@ -521,7 +525,7 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo
521525 homeDirectory <- getHomeDirectory
522526 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
523527
524− maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)
528+ maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))
525529
526530 let roloop = reprLoop currentTransaction graph
527531 case maybeLine of
@@ -530,12 +534,12 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo
530534 newUUID <- nextRandom
531535 case interpretOps newUUID currentTransaction graph line of
532536 (_, _, QuitResult) -> return ()
533− (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop
537+ (_, _, DisplayErrorResult err) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
534538 (updatedTrans, updatedGraph, DisplayResult out) -> do
535− putStrLn out
539+ TIO.putStrLn out
536540 reprLoop updatedTrans updatedGraph
537541 (updatedTrans, updatedGraph, QuietSuccessResult) -> do
538− putStrLn "Done."
542+ TIO.putStrLn "Done."
539543 reprLoop updatedTrans updatedGraph
540544 (_, _, NoActionResult) -> do
541545 let (value, contextup) = interpret currentContext line
@@ -543,7 +547,7 @@ reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentCo
543547 case value of
544548 Nothing -> reprLoop updatedTransaction graph
545549 Just err -> do
546− hPutStrLn stderr ("ERR:" ++ show err)
550+ TIO.hPutStrLn stderr ("ERR:" `T.append` T.pack (show err))
547551 reprLoop currentTransaction graph
548552
549553restrictionPredicateP :: Parser RestrictionPredicateExpr
@@ -569,18 +573,19 @@ restrictionAttributeEqualityP = do
569573 attributeName <- identifier
570574 reservedOp "="
571575 atom <- stringAtomP <|> intAtomP
572− return $ AttributeEqualityPredicate attributeName atom
576+ return $ AttributeEqualityPredicate (T.pack attributeName) atom
573577
574578quotedChar = noneOf "\""
575579 <|> try (string "\"\"" >> return '"')
576580
577−stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
581+stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")
578582
579583intAtomP = do
580584 intstr <- many digit
581585 return $ IntAtom (read intstr)
582586
583587--used by :dumpGraph
588+{-
584589displayTransactionGraph :: TransactionGraph -> String
585590displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
586−
591+-}