@@ -0,0 +1,127 @@
1+{-# LANGUAGE TypeSynonymInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+module ProjectM36.PrettyPrinter where
6+import ProjectM36.Base
7+import ProjectM36.Atomable
8+import ProjectM36.Attribute
9+import Data.Text.Prettyprint.Doc
10+import qualified Data.Set as S hiding (fromList)
11+import qualified Data.Text as T
12+import qualified Data.Vector as V
13+import qualified Data.Map.Strict as M
14+import Data.Foldable as F
15+
16+instance Pretty Atom where
17+ pretty (IntegerAtom x) = pretty x
18+ pretty (IntAtom x) = pretty x
19+ pretty (DoubleAtom x) = pretty x
20+ pretty (TextAtom x) = pretty x
21+ pretty (DayAtom x) = pretty $ show x
22+ pretty (DateTimeAtom x) = pretty $ show x
23+ pretty (ByteStringAtom x) = pretty $ show x
24+ pretty (BoolAtom x) = pretty x
25+ pretty (RelationAtom x) = pretty x
26+ pretty (ConstructedAtom n ty as) = pretty n <+> prettyList as
27+
28+instance Pretty AtomExpr where
29+ pretty (AttributeAtomExpr attrName) = pretty attrName
30+ pretty (NakedAtomExpr atom) = pretty atom
31+ pretty (FunctionAtomExpr atomFuncName atomExprs _) = pretty atomFuncName <> prettyAtomExprsAsArguments atomExprs
32+ pretty (RelationAtomExpr relExpr) = pretty relExpr
33+ pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> prettyList atomExprs
34+
35+prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann
36+prettyAtomExprsAsArguments = align . parensList . map addAt
37+ where addAt (atomExpr :: AtomExpr) = case atomExpr of
38+ AttributeAtomExpr attrName -> "@" <> pretty attrName
39+ otherwise -> pretty atomExpr
40+
41+instance Pretty TupleExpr where
42+ pretty (TupleExpr map) = "tuple" <> bracesList (Prelude.map (\(attrName,atom)-> pretty attrName <+> pretty atom) (M.toList map))
43+
44+instance Pretty RelationTuple where
45+ pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))
46+
47+instance Pretty Relation where
48+ pretty (Relation attrs tupSet) | attrs == V.empty && (asList tupSet) == [] = "false"
49+ pretty (Relation attrs tupSet) | attrs == V.empty && (asList tupSet) == [RelationTuple V.empty (V.empty)] = "true"
50+ pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)
51+
52+instance Pretty Attribute where
53+ pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround
54+
55+instance Pretty RelationalExpr where
56+ pretty (RelationVariable n _) = pretty n
57+ pretty (ExistingRelation r) = pretty r
58+ pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b
59+ pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b
60+ pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns
61+ pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"
62+ pretty (MakeRelationFromExprs (Just attrExprs) tupExprs) = "relation" <> (prettyBracesList attrExprs) <> prettyBracesList (F.toList tupExprs)
63+ pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)
64+ pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b
65+ pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b
66+ pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)
67+ pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b
68+ pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens ((pretty attrNames) <+> "as" <+> pretty attrName)
69+ pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName
70+ pretty (Restrict resPreExpr relExpr) = parens $ pretty' relExpr <+> "where" <+> pretty resPreExpr
71+ pretty (With pairs a) = "with" <+> parensList (map (\(name,expr)-> pretty name <+> "as" <+> pretty expr) pairs) <+> pretty' a
72+
73+-- relvar:{a:=?}:{b:=?}:... in ADTs => relvar:{a:=?, b:=?, ...} in Doc ann
74+collectExtends :: RelationalExpr -> Doc ann
75+collectExtends (Extend ext r) = (collectExtends r) <> (pretty ext) <> ", "
76+collectExtends r = pretty r <> ":{"
77+
78+--relvar{a,b,c,...}{a,b,...}..{a} => relvar{a}
79+ignoreProjects :: RelationalExpr -> RelationalExpr
80+ignoreProjects (Project ns r) = ignoreProjects r
81+ignoreProjects r = r
82+
83+pretty' :: RelationalExpr -> Doc n
84+pretty' (RelationVariable n _) = pretty n
85+pretty' r = parens (pretty r)
86+
87+instance Pretty AttributeNames where
88+ pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames)
89+ pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> (concatWith (surround ", ") (map pretty (S.toList attrNames)))
90+ pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr
91+ pretty a = error $ show a ++ " is not implemented yet."
92+-- YuMing L.: I guess these two are used in evaluating relational expressions. So we won't be using them in pretty printer.
93+-- pretty (UnionAttributeNames aAttrNames bAttrNames) = prettyBracesList (S.toList (aAttrNames `union` bAttrNames))
94+-- pretty (IntersectAttributeNames aAttrNames bAttrNames) = prettyBracesList (S.toList (aAttrNames `intersection` bAttrNames))
95+
96+instance Pretty AttributeExpr where
97+ pretty (NakedAttributeExpr attr) = pretty attr
98+ pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty (show typeCons) -- workaround
99+
100+instance Pretty ExtendTupleExpr where
101+ pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr
102+
103+
104+instance Pretty RestrictionPredicateExpr where
105+ pretty TruePredicate = "true"
106+ pretty (AndPredicate a b) = pretty a <+> "and" <+> pretty b
107+ pretty (OrPredicate a b) = pretty a <+> "or" <+> pretty b
108+ pretty (NotPredicate a) = "not" <+> pretty a
109+ pretty (RelationalExprPredicate relExpr) = pretty relExpr
110+ pretty (AtomExprPredicate atomExpr) = pretty atomExpr
111+ pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr
112+
113+instance Pretty WithNameExpr where
114+ pretty (WithNameExpr name _) = pretty name
115+
116+bracesList :: [Doc ann] -> Doc ann
117+bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", "
118+
119+prettyBracesList :: Pretty a => [a] -> Doc ann
120+prettyBracesList = align . bracesList . map pretty
121+
122+parensList :: [Doc ann] -> Doc ann
123+parensList = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") ", "
124+
125+prettyParensList :: Pretty a => [a] -> Doc ann
126+prettyParensList = align . parensList . map pretty
127+