git.iko.soy/project-m36
on e5bb4e5 help sign in
project-m36/src/bin/TutorialD/Printer.hs
165 lines 8.3 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeApplications #-}
6module TutorialD.Printer where
7import ProjectM36.Base
8import ProjectM36.Attribute hiding (null)
9import Data.Text.Prettyprint.Doc
10import qualified Data.Set as S hiding (fromList)
11import qualified Data.Vector as V
12import qualified Data.Map.Strict as M
13import Data.Time.Calendar
14import Data.Time.Clock.POSIX
15import qualified Data.ByteString.Base64 as B64
16import qualified Data.Text.Encoding as TE
18instance Pretty Atom where
19 pretty (IntegerAtom x) = pretty x
20 pretty (IntAtom x) = "int" <> parensList [pretty x]
21 pretty (DoubleAtom x) = pretty x
22 pretty (TextAtom x) = dquotes (pretty x)
23 pretty (DayAtom x) = "fromGregorian" <> parensList [pretty a, pretty b, pretty c]
24 where
25 (a,b,c) = toGregorian x
26 pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))]
27 pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))]
28 pretty (BoolAtom x) = if x then "t" else "f"
29 pretty (RelationAtom x) = pretty x
30 pretty (RelationalExprAtom re) = pretty re
31 pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as
33instance Pretty AtomExpr where
34 pretty (AttributeAtomExpr attrName) = pretty attrName
35 pretty (NakedAtomExpr atom) = pretty atom
36 pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs
37 pretty (RelationAtomExpr relExpr) = pretty relExpr
38 pretty (ConstructedAtomExpr dName [] _) = pretty dName
39 pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> hsep (map prettyAtomExpr atomExprs)
41prettyAtomExpr :: AtomExpr -> Doc ann
42prettyAtomExpr atomExpr =
43 case atomExpr of
44 AttributeAtomExpr attrName -> "@" <> pretty attrName
45 ConstructedAtomExpr dConsName [] () -> pretty dConsName
46 ConstructedAtomExpr dConsName atomExprs () -> parens (pretty dConsName <+> hsep (map prettyAtomExpr atomExprs))
47 _ -> pretty atomExpr
49prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann
50prettyAtomExprsAsArguments = align . parensList . map addAt
51 where addAt (atomExpr :: AtomExpr) =
52 case atomExpr of
53 AttributeAtomExpr attrName -> "@" <> pretty attrName
54 _ -> pretty atomExpr
56instance Pretty TupleExpr where
57 pretty (TupleExpr map') = "tuple" <> bracesList (Prelude.map (\(attrName,atom)-> pretty attrName <+> pretty atom) (M.toList map'))
59instance Pretty RelationTuple where
60 pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))
62instance Pretty Relation where
63 pretty (Relation attrs tupSet) | attrs == V.empty && null (asList tupSet) = "false"
64 pretty (Relation attrs tupSet) | attrs == V.empty && asList tupSet == [RelationTuple V.empty V.empty] = "true"
65 pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)
67instance Pretty Attribute where
68 pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround
70instance Pretty RelationalExpr where
71 pretty (RelationVariable n _) = pretty n
72 pretty (ExistingRelation r) = pretty r
73 pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b
74 pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b
75 pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns
76 pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"
77 pretty (MakeRelationFromExprs Nothing (TupleExprs () tupExprs)) = "relation" <> prettyBracesList tupExprs
78 pretty (MakeRelationFromExprs (Just attrExprs) (TupleExprs () tupExprs)) = "relation" <> prettyBracesList attrExprs <> prettyBracesList tupExprs
79 pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)
80 pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b
81 pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b
82 pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)
83 pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b
84 pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens (pretty attrNames <+> "as" <+> pretty attrName)
85 pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName
86 pretty (Restrict resPreExpr relExpr) = parens $ pretty' relExpr <+> "where" <+> pretty resPreExpr
87 pretty (With pairs a) = "with" <+> parensList (map (\(name,expr)-> pretty name <+> "as" <+> pretty expr) pairs) <+> pretty' a
89-- relvar:{a:=?}:{b:=?}:... in ADTs => relvar:{a:=?, b:=?, ...} in Doc ann
90collectExtends :: RelationalExpr -> Doc ann
91collectExtends (Extend ext r) = collectExtends r <> pretty ext <> ", "
92collectExtends r = pretty r <> ":{"
94--relvar{a,b,c,...}{a,b,...}..{a} => relvar{a}
95ignoreProjects :: RelationalExpr -> RelationalExpr
96ignoreProjects (Project _ r) = ignoreProjects r
97ignoreProjects r = r
99prettyRelationalExpr :: RelationalExpr -> Doc n
100prettyRelationalExpr (RelationVariable n _) = pretty n
101prettyRelationalExpr r = parens (pretty r)
103pretty' :: RelationalExpr -> Doc n
104pretty' = prettyRelationalExpr
106instance Pretty AttributeNames where
107 pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames)
108 pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map pretty (S.toList attrNames))
109 pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr
110 pretty (UnionAttributeNames aAttrNames bAttrNames) = braces ("union of" <+> pretty aAttrNames <+> pretty bAttrNames)
111 pretty (IntersectAttributeNames aAttrNames bAttrNames) = braces ("intersection of" <+> pretty aAttrNames <+> pretty bAttrNames)
113instance Pretty AttributeExpr where
114 pretty (NakedAttributeExpr attr) = pretty attr
115 pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty typeCons
117instance Pretty TypeConstructor where
118 pretty (ADTypeConstructor tcName []) = pretty tcName
119 pretty (ADTypeConstructor tcName tConsArgs) = pretty tcName <+> hsep (map pretty tConsArgs)
120 pretty (PrimitiveTypeConstructor tcName atomType') = pretty tcName <+> pretty atomType'
121 pretty (RelationAtomTypeConstructor attrExprs) = "relation" <> prettyBracesList attrExprs
122 pretty (TypeVariable x) = pretty x
124instance Pretty AtomType where
125 pretty IntAtomType = "Int"
126 pretty IntegerAtomType = "Integer"
127 pretty DoubleAtomType = "Double"
128 pretty TextAtomType = "Text"
129 pretty DayAtomType = "Day"
130 pretty DateTimeAtomType = "DateTime"
131 pretty ByteStringAtomType = "ByteString"
132 pretty BoolAtomType = "Bool"
133 pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (V.toList attrs)
134 pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters
135 pretty RelationalExprAtomType = "RelationalExpr"
136 pretty (TypeVariableType x) = pretty x
138instance Pretty ExtendTupleExpr where
139 pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr
142instance Pretty RestrictionPredicateExpr where
143 pretty TruePredicate = "true"
144 pretty (AndPredicate a b) = pretty a <+> "and" <+> pretty b
145 pretty (OrPredicate a b) = pretty a <+> "or" <+> pretty b
146 pretty (NotPredicate a) = "not" <+> pretty a
147 pretty (RelationalExprPredicate relExpr) = pretty relExpr
148 pretty (AtomExprPredicate atomExpr) = pretty atomExpr
149 pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr
151instance Pretty WithNameExpr where
152 pretty (WithNameExpr name _) = pretty name
154bracesList :: [Doc ann] -> Doc ann
155bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", "
157prettyBracesList :: Pretty a => [a] -> Doc ann
158prettyBracesList = align . bracesList . map pretty
160parensList :: [Doc ann] -> Doc ann
161parensList = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") ", "
163prettyParensList :: Pretty a => [a] -> Doc ann
164prettyParensList = align . parensList . map pretty