a77fba2 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

add prettyprinter and test

a77fba2Yu-Ming Liao6 years ago

.gitignore+2−1

compare with master

unifiedsplit

@@ -18,4 +18,5 @@ persistence-notes

18jupyter/itutd.egg-info

19jupyter/build

20juyter/dist

21−.ipynb_checkpoints

21+.ipynb_checkpoints

22+project-m36.nix

project-m36.cabal+11−2

@@ -34,7 +34,7 @@ Flag haskell-scripting

34 Default: True

36Library

37− Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3

37+ Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, prettyprinter

38 if flag(haskell-scripting)

39 Build-Depends: ghc >= 8.2 && < 8.11

40 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -121,7 +121,8 @@ Library

121 ProjectM36.GraphRefRelationalExpr,

122 ProjectM36.NormalizeExpr,

123 ProjectM36.TransactionInfo,

124− ProjectM36.WithNameExpr

124+ ProjectM36.WithNameExpr,

125+ ProjectM36.PrettyPrinter

125 GHC-Options: -Wall -rdynamic

126 GHC-Options: -Wall -rdynamic

126 if os(windows)

127 if os(windows)

127 Build-Depends: Win32 >= 2.5.4.1

128 Build-Depends: Win32 >= 2.5.4.1

@@ -357,6 +358,14 @@ Test-Suite test-transactiongraph-merge

357 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36

358 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36

358 GHC-Options: -Wall -threaded

359 GHC-Options: -Wall -threaded

359

360

361+Test-Suite test-prettyprinter

362+ Default-Language: Haskell2010

363+ Default-Extensions: OverloadedStrings

364+ type: exitcode-stdio-1.0

365+ main-is: test/PrettyPrinter.hs

366+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36

367+ GHC-Options: -Wall -threaded

368+

360benchmark bench

369benchmark bench

361 Default-Language: Haskell2010

370 Default-Language: Haskell2010

362 Default-Extensions: OverloadedStrings

371 Default-Extensions: OverloadedStrings

src/lib/ProjectM36/InclusionDependency.hs+5−3

@@ -5,6 +5,8 @@ import ProjectM36.Error

5import ProjectM36.Relation

6import qualified Data.Map as M

7import qualified Data.Text as T

8+import ProjectM36.PrettyPrinter

9+import Data.Text.Prettyprint.Doc

9inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation

11inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation

10inclusionDependenciesAsRelation incDeps =

12inclusionDependenciesAsRelation incDeps =

@@ -15,6 +17,6 @@ inclusionDependenciesAsRelation incDeps =

15 Attribute "super" TextAtomType

17 Attribute "super" TextAtomType

16 ]

18 ]

17 incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,

19 incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,

18− TextAtom (T.pack (show exprA)),

20+ TextAtom (T.pack (show (pretty exprA))),

19− TextAtom (T.pack (show exprB))]

21+ TextAtom (T.pack (show (pretty exprB)))]

20−

22+

src/lib/ProjectM36/PrettyPrinter.hsnew file+127

@@ -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+

test/PrettyPrinter.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Test.HUnit

3+import ProjectM36.Base

4+import ProjectM36.PrettyPrinter

5+import qualified Data.Vector as V

6+import System.Exit

7+import Data.Text

8+import ProjectM36.Relation

9+import Data.Text.Prettyprint.Doc

10+testList :: Test

11+testList = TestList [

12+ testPretty "true" (ExistingRelation (Relation V.empty (RelationTupleSet [RelationTuple V.empty V.empty]))),

13+ testPretty "false" (ExistingRelation (Relation V.empty (RelationTupleSet []))),

14+ testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntAtom 1))) (ExistingRelation relationTrue)))]

15+

16+main :: IO ()

17+main = do

18+ tcounts <- runTestTT testList

19+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

20+

21+testPretty :: String -> RelationalExpr -> Test

22+testPretty relExprText relExprADT = TestCase $ assertEqual relExprText (show (pretty relExprADT)) (show (pretty relExprText))