--writes Relation to a String suitable for terminal output
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 --guess the width that the character will appear as in the terminal

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
"┼"

--represent a relation as a table similar to those drawn by Date
type Cell = StringType
type Table = ([Cell], [[Cell]]) --header, body

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])

--calculate maximum per-row and per-column sizes

cellLocations :: Table -> ([Int],[Int]) --column size, row size
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

--the normal "lines" function returns an empty list for an empty string which is not what we want
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
renderHeader :: Table -> [Int] -> StringType
renderHeader ([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

--pad a block of potentially multi-lined text
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)

--use wcwidth to guess the string width in the terminal- many CJK characters can take multiple columns in a fixed width font
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