module ProjectM36.Relation.Show.Term where
import ProjectM36.Base
import ProjectM36.Atom
import ProjectM36.AtomType
import ProjectM36.Tuple
import ProjectM36.Relation
import ProjectM36.Attribute hiding (null)
import qualified Data.List as L
import qualified Data.Text as T
import Control.Arrow hiding (left)
import Data.ByteString.Base64 as B64
import qualified Data.Text.Encoding as TE
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import ProjectM36.WCWidth
boxV :: StringType
boxV :: StringType
boxV = StringType
"│"
boxH :: StringType
boxH :: StringType
boxH = StringType
"─"
boxTL :: StringType
boxTL :: StringType
boxTL = StringType
"┌"
boxTR :: StringType
boxTR :: StringType
boxTR = StringType
"┐"
boxBL :: StringType
boxBL :: StringType
boxBL = StringType
"└"
boxBR :: StringType
boxBR :: StringType
boxBR = StringType
"┘"
boxLB :: StringType
boxLB :: StringType
boxLB = StringType
"├"
boxRB :: StringType
boxRB :: StringType
boxRB = StringType
"┤"
boxTB :: StringType
boxTB :: StringType
boxTB = StringType
"┬"
boxBB :: StringType
boxBB :: StringType
boxBB = StringType
"┴"
boxC :: StringType
boxC :: StringType
boxC = StringType
"┼"
type Cell = StringType
type Table = ([Cell], [[Cell]])
addRow :: [Cell] -> Table -> Table
addRow :: [StringType] -> Table -> Table
addRow [StringType]
cells ([StringType]
header,[[StringType]]
body) = ([StringType]
header, [[StringType]]
body [[StringType]] -> [[StringType]] -> [[StringType]]
forall a. [a] -> [a] -> [a]
++ [[StringType]
cells])
cellLocations :: Table -> ([Int],[Int])
cellLocations :: Table -> ([Int], [Int])
cellLocations tab :: Table
tab@([StringType]
header, [[StringType]]
_) = ([Int]
maxWidths, [Int]
maxHeights)
where
cellSizeMatrix :: [([Int], [Int])]
cellSizeMatrix = Table -> [([Int], [Int])]
cellSizes Table
tab
maxWidths :: [Int]
maxWidths = ([Int] -> [Int] -> [Int]) -> [Int] -> [[Int]] -> [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Int] -> [Int] -> [Int]
mergeMax (Int -> [Int]
forall a. Num a => Int -> [a]
baseSize ([StringType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StringType]
header)) ((([Int], [Int]) -> [Int]) -> [([Int], [Int])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst [([Int], [Int])]
cellSizeMatrix)
baseSize :: Int -> [a]
baseSize Int
num = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
num a
0
rowHeights :: [[Int]]
rowHeights = (([Int], [Int]) -> [Int]) -> [([Int], [Int])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd [([Int], [Int])]
cellSizeMatrix
maxHeights :: [Int]
maxHeights = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\[Int]
l -> if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
l then Int
0 else [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.maximum [Int]
l) [[Int]]
rowHeights
mergeMax :: [Int] -> [Int] -> [Int]
mergeMax = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
max
breakLines :: StringType -> [StringType]
breakLines :: StringType -> [StringType]
breakLines StringType
"" = [StringType
""]
breakLines StringType
x = StringType -> [StringType]
T.lines StringType
x
cellSizes :: Table -> [([Int], [Int])]
cellSizes :: Table -> [([Int], [Int])]
cellSizes ([StringType]
header, [[StringType]]
body) = ([StringType] -> ([Int], [Int]))
-> [[StringType]] -> [([Int], [Int])]
forall a b. (a -> b) -> [a] -> [b]
map ((StringType -> Int) -> [StringType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map StringType -> Int
maxRowWidth ([StringType] -> [Int])
-> ([StringType] -> [Int]) -> [StringType] -> ([Int], [Int])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (StringType -> Int) -> [StringType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([StringType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([StringType] -> Int)
-> (StringType -> [StringType]) -> StringType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringType -> [StringType]
breakLines)) [[StringType]]
allRows
where
maxRowWidth :: StringType -> Int
maxRowWidth StringType
row = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (StringType -> [Int]
lengths StringType
row) then
Int
0
else
[Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.maximum (StringType -> [Int]
lengths StringType
row)
lengths :: StringType -> [Int]
lengths StringType
row = (StringType -> Int) -> [StringType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map StringType -> Int
stringDisplayLength (StringType -> [StringType]
breakLines StringType
row)
allRows :: [[StringType]]
allRows = [StringType]
header [StringType] -> [[StringType]] -> [[StringType]]
forall a. a -> [a] -> [a]
: [[StringType]]
body
relationAsTable :: Relation -> Table
relationAsTable :: Relation -> Table
relationAsTable rel :: Relation
rel@(Relation Attributes
_ RelationTupleSet
tupleSet) = ([StringType]
header, [[StringType]]
body)
where
oAttrs :: [Attribute]
oAttrs = Attributes -> [Attribute]
orderedAttributes (Relation -> Attributes
attributes Relation
rel)
oAttrNames :: [StringType]
oAttrNames = Attributes -> [StringType]
orderedAttributeNames (Relation -> Attributes
attributes Relation
rel)
header :: [StringType]
header = (Attribute -> StringType) -> [Attribute] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> StringType
prettyAttribute [Attribute]
oAttrs
body :: [[Cell]]
body :: [[StringType]]
body = (RelationTuple -> [[StringType]] -> [[StringType]])
-> [[StringType]] -> [RelationTuple] -> [[StringType]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr RelationTuple -> [[StringType]] -> [[StringType]]
tupleFolder [] (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet)
tupleFolder :: RelationTuple -> [[StringType]] -> [[StringType]]
tupleFolder RelationTuple
tuple [[StringType]]
acc = (StringType -> StringType) -> [StringType] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (\StringType
attrName -> case StringType -> RelationTuple -> Either RelationalError Atom
atomForAttributeName StringType
attrName RelationTuple
tuple of
Left RelationalError
_ -> StringType
"?"
Right Atom
atom -> Int -> Atom -> StringType
showAtom Int
0 Atom
atom
) [StringType]
oAttrNames [StringType] -> [[StringType]] -> [[StringType]]
forall a. a -> [a] -> [a]
: [[StringType]]
acc
showParens :: Bool -> StringType -> StringType
showParens :: Bool -> StringType -> StringType
showParens Bool
predicate StringType
f = if Bool
predicate then
StringType
"(" StringType -> StringType -> StringType
`T.append` StringType
f StringType -> StringType -> StringType
`T.append` StringType
")"
else
StringType
f
showAtom :: Int -> Atom -> StringType
showAtom :: Int -> Atom -> StringType
showAtom Int
_ (RelationAtom Relation
rel) = Table -> StringType
renderTable (Table -> StringType) -> Table -> StringType
forall a b. (a -> b) -> a -> b
$ Relation -> Table
relationAsTable Relation
rel
showAtom Int
level (ConstructedAtom StringType
dConsName AtomType
_ [Atom]
atoms) = Bool -> StringType -> StringType
showParens (Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Atom] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Atom]
atoms)) (StringType -> StringType) -> StringType -> StringType
forall a b. (a -> b) -> a -> b
$ [StringType] -> StringType
T.concat (StringType -> [StringType] -> [StringType]
forall a. a -> [a] -> [a]
L.intersperse StringType
" " (StringType
dConsName StringType -> [StringType] -> [StringType]
forall a. a -> [a] -> [a]
: (Atom -> StringType) -> [Atom] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Atom -> StringType
showAtom Int
1) [Atom]
atoms))
showAtom Int
_ (TextAtom StringType
t) = StringType
"\"" StringType -> StringType -> StringType
forall a. Semigroup a => a -> a -> a
<> StringType
t StringType -> StringType -> StringType
forall a. Semigroup a => a -> a -> a
<> StringType
"\""
showAtom Int
_ (ByteStringAtom ByteString
bs) = ByteString -> StringType
TE.decodeUtf8 (ByteString -> ByteString
B64.encode ByteString
bs)
showAtom Int
_ Atom
atom = Atom -> StringType
atomToText Atom
atom
renderTable :: Table -> StringType
renderTable :: Table -> StringType
renderTable Table
table = Table -> [Int] -> StringType
renderHeader Table
table (([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst ([Int], [Int])
cellLocs) StringType -> StringType -> StringType
`T.append` [[StringType]] -> ([Int], [Int]) -> StringType
renderBody (Table -> [[StringType]]
forall a b. (a, b) -> b
snd Table
table) ([Int], [Int])
cellLocs
where
cellLocs :: ([Int], [Int])
cellLocs = Table -> ([Int], [Int])
cellLocations Table
table
renderHeader :: Table -> [Int] -> StringType
([StringType]
header, [[StringType]]
body) [Int]
columnLocations = StringType
renderTopBar StringType -> StringType -> StringType
`T.append` StringType
renderHeaderNames StringType -> StringType -> StringType
`T.append` StringType
renderBottomBar
where
renderTopBar :: StringType
renderTopBar = StringType
boxTL StringType -> StringType -> StringType
`T.append` [StringType] -> StringType
T.concat (StringType -> [StringType] -> [StringType]
forall a. a -> [a] -> [a]
L.intersperse StringType
boxTB ((Int -> StringType) -> [Int] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> StringType -> StringType
`repeatString` StringType
boxH) [Int]
columnLocations)) StringType -> StringType -> StringType
`T.append` StringType
boxTR StringType -> StringType -> StringType
`T.append` StringType
"\n"
renderHeaderNames :: StringType
renderHeaderNames = [StringType] -> [Int] -> Int -> StringType -> StringType
renderRow [StringType]
header [Int]
columnLocations Int
1 StringType
boxV
renderBottomBar :: StringType
renderBottomBar = if [[StringType]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[StringType]]
body then StringType
""
else StringType -> StringType -> StringType -> [Int] -> StringType
renderHBar StringType
boxLB StringType
boxC StringType
boxRB [Int]
columnLocations StringType -> StringType -> StringType
`T.append` StringType
"\n"
renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType
renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType
renderHBar StringType
left StringType
middle StringType
end [Int]
columnLocations = StringType
left StringType -> StringType -> StringType
`T.append` [StringType] -> StringType
T.concat (StringType -> [StringType] -> [StringType]
forall a. a -> [a] -> [a]
L.intersperse StringType
middle ((Int -> StringType) -> [Int] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> StringType -> StringType
`repeatString` StringType
boxH) [Int]
columnLocations)) StringType -> StringType -> StringType
`T.append` StringType
end
leftPaddedString :: Int -> Int -> StringType -> StringType
leftPaddedString :: Int -> Int -> StringType -> StringType
leftPaddedString Int
lineNum Int
size StringType
str = if Int
lineNum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [StringType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StringType]
paddedLines Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 then
Int -> StringType -> StringType
repeatString Int
size StringType
" "
else
[StringType]
paddedLines [StringType] -> Int -> StringType
forall a. [a] -> Int -> a
!! Int
lineNum
where
paddedLines :: [StringType]
paddedLines = (StringType -> StringType) -> [StringType] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (\StringType
line -> StringType
line StringType -> StringType -> StringType
`T.append` Int -> StringType -> StringType
repeatString (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- StringType -> Int
stringDisplayLength StringType
line) StringType
" ") (StringType -> [StringType]
breakLines StringType
str)
renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType
renderRow :: [StringType] -> [Int] -> Int -> StringType -> StringType
renderRow [StringType]
cells [Int]
columnLocations Int
rowHeight StringType
interspersed = [StringType] -> StringType
T.unlines ([StringType] -> StringType) -> [StringType] -> StringType
forall a b. (a -> b) -> a -> b
$ (Int -> StringType) -> [Int] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map Int -> StringType
renderOneLine [Int
0..Int
rowHeightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
where
renderOneLine :: Int -> StringType
renderOneLine Int
lineNum = StringType
boxV StringType -> StringType -> StringType
`T.append` [StringType] -> StringType
T.concat (StringType -> [StringType] -> [StringType]
forall a. a -> [a] -> [a]
L.intersperse StringType
interspersed ((Int -> StringType -> StringType)
-> [Int] -> [StringType] -> [StringType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> StringType -> StringType
leftPaddedString Int
lineNum) [Int]
columnLocations [StringType]
cells)) StringType -> StringType -> StringType
`T.append` StringType
boxV
renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType
renderBody :: [[StringType]] -> ([Int], [Int]) -> StringType
renderBody [[StringType]]
cellMatrix ([Int], [Int])
cellLocs = StringType
renderRows StringType -> StringType -> StringType
`T.append` StringType
renderBottomBar
where
columnLocations :: [Int]
columnLocations = ([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst ([Int], [Int])
cellLocs
rowLocations :: [Int]
rowLocations = ([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd ([Int], [Int])
cellLocs
renderRows :: StringType
renderRows = [StringType] -> StringType
T.concat ((([StringType], Int) -> StringType)
-> [([StringType], Int)] -> [StringType]
forall a b. (a -> b) -> [a] -> [b]
map (\([StringType]
row, Int
rowHeight)-> [StringType] -> [Int] -> Int -> StringType -> StringType
renderRow [StringType]
row [Int]
columnLocations Int
rowHeight StringType
boxV) [([StringType], Int)]
rowHeightMatrix)
rowHeightMatrix :: [([StringType], Int)]
rowHeightMatrix = [[StringType]] -> [Int] -> [([StringType], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[StringType]]
cellMatrix ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
rowLocations)
renderBottomBar :: StringType
renderBottomBar = StringType -> StringType -> StringType -> [Int] -> StringType
renderHBar StringType
boxBL StringType
boxBB StringType
boxBR [Int]
columnLocations
repeatString :: Int -> StringType -> StringType
repeatString :: Int -> StringType -> StringType
repeatString Int
c StringType
s = [StringType] -> StringType
T.concat (Int -> StringType -> [StringType]
forall a. Int -> a -> [a]
replicate Int
c StringType
s)
showRelation :: Relation -> StringType
showRelation :: Relation -> StringType
showRelation Relation
rel = Table -> StringType
renderTable (Relation -> Table
relationAsTable Relation
rel)
stringDisplayLength :: StringType -> Int
stringDisplayLength :: StringType -> Int
stringDisplayLength = (Char -> Int -> Int) -> Int -> StringType -> Int
forall a. (Char -> a -> a) -> a -> StringType -> a
T.foldr Char -> Int -> Int
charSize Int
0
where
charSize :: Char -> Int -> Int
charSize Char
char Int
accum = let w :: Int
w = Char -> Int
wcwidth Char
char in
Int
accum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then
Int
1
else
Int
w