--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 :: Text
boxV = Text
"│"
boxH :: StringType
boxH :: Text
boxH = Text
"─"

boxTL :: StringType
boxTL :: Text
boxTL = Text
"┌"
boxTR :: StringType
boxTR :: Text
boxTR = Text
"┐"
boxBL :: StringType
boxBL :: Text
boxBL = Text
"└"
boxBR :: StringType
boxBR :: Text
boxBR = Text
"┘"

boxLB :: StringType
boxLB :: Text
boxLB = Text
"├"
boxRB :: StringType
boxRB :: Text
boxRB = Text
"┤"
boxTB :: StringType
boxTB :: Text
boxTB = Text
"┬"
boxBB :: StringType
boxBB :: Text
boxBB = Text
"┴"

boxC :: StringType
boxC :: Text
boxC = Text
"┼"

--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 :: [Text] -> Table -> Table
addRow [Text]
cells ([Text]
header,[[Text]]
body) = ([Text]
header, [[Text]]
body forall a. [a] -> [a] -> [a]
++ [[Text]
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@([Text]
header, [[Text]]
_) = ([Int]
maxWidths, [Int]
maxHeights)
  where
    cellSizeMatrix :: [([Int], [Int])]
cellSizeMatrix = Table -> [([Int], [Int])]
cellSizes Table
tab
    maxWidths :: [Int]
maxWidths = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Int] -> [Int] -> [Int]
mergeMax (forall {a}. Num a => Int -> [a]
baseSize (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
header)) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Int], [Int])]
cellSizeMatrix)
    baseSize :: Int -> [a]
baseSize Int
num = forall a. Int -> a -> [a]
replicate Int
num a
0
    rowHeights :: [[Int]]
rowHeights = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Int], [Int])]
cellSizeMatrix
    maxHeights :: [Int]
maxHeights = forall a b. (a -> b) -> [a] -> [b]
map (\[Int]
l -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
l then Int
0 else forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.maximum [Int]
l) [[Int]]
rowHeights
    mergeMax :: [Int] -> [Int] -> [Int]
mergeMax = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 :: Text -> [Text]
breakLines Text
"" = [Text
""]
breakLines Text
x = Text -> [Text]
T.lines Text
x

cellSizes :: Table -> [([Int], [Int])]
cellSizes :: Table -> [([Int], [Int])]
cellSizes ([Text]
header, [[Text]]
body) = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
maxRowWidth forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
breakLines)) [[Text]]
allRows
  where
    maxRowWidth :: Text -> Int
maxRowWidth Text
row = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Text -> [Int]
lengths Text
row) then
                         Int
0
                      else
                        forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.maximum (Text -> [Int]
lengths Text
row)
    lengths :: Text -> [Int]
lengths Text
row = forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
stringDisplayLength (Text -> [Text]
breakLines Text
row)
    allRows :: [[Text]]
allRows = [Text]
header forall a. a -> [a] -> [a]
: [[Text]]
body
    
relationAsTable :: Relation -> Table
relationAsTable :: Relation -> Table
relationAsTable rel :: Relation
rel@(Relation Attributes
_ RelationTupleSet
tupleSet) = ([Text]
header, [[Text]]
body)
  where
    oAttrs :: [Attribute]
oAttrs = Attributes -> [Attribute]
orderedAttributes (Relation -> Attributes
attributes Relation
rel)
    oAttrNames :: [Text]
oAttrNames = Attributes -> [Text]
orderedAttributeNames (Relation -> Attributes
attributes Relation
rel)
    header :: [Text]
header = forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Text
prettyAttribute [Attribute]
oAttrs
    body :: [[Cell]]
    body :: [[Text]]
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr RelationTuple -> [[Text]] -> [[Text]]
tupleFolder [] (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet)
    tupleFolder :: RelationTuple -> [[Text]] -> [[Text]]
tupleFolder RelationTuple
tuple [[Text]]
acc = forall a b. (a -> b) -> [a] -> [b]
map (\Text
attrName -> case Text -> RelationTuple -> Either RelationalError Atom
atomForAttributeName Text
attrName RelationTuple
tuple of
                                            Left RelationalError
_ -> Text
"?"
                                            Right Atom
atom -> Int -> Atom -> Text
showAtom Int
0 Atom
atom
                                            ) [Text]
oAttrNames forall a. a -> [a] -> [a]
: [[Text]]
acc

showParens :: Bool -> StringType -> StringType
showParens :: Bool -> Text -> Text
showParens Bool
predicate Text
f = if Bool
predicate then
                      Text
"(" Text -> Text -> Text
`T.append` Text
f Text -> Text -> Text
`T.append` Text
")"
                    else
                      Text
f

showAtom :: Int -> Atom -> StringType
showAtom :: Int -> Atom -> Text
showAtom Int
_ (RelationAtom Relation
rel) = Table -> Text
renderTable forall a b. (a -> b) -> a -> b
$ Relation -> Table
relationAsTable Relation
rel
showAtom Int
level (ConstructedAtom Text
dConsName AtomType
_ [Atom]
atoms) = Bool -> Text -> Text
showParens (Int
level forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Atom]
atoms)) forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat (forall a. a -> [a] -> [a]
L.intersperse Text
" " (Text
dConsName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> Atom -> Text
showAtom Int
1) [Atom]
atoms))
showAtom Int
_ (TextAtom Text
t) = Text
"\"" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"\""
showAtom Int
_ (ByteStringAtom ByteString
bs) = ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B64.encode ByteString
bs)
showAtom Int
_ Atom
atom = Atom -> Text
atomToText Atom
atom

renderTable :: Table -> StringType
renderTable :: Table -> Text
renderTable Table
table = Table -> [Int] -> Text
renderHeader Table
table (forall a b. (a, b) -> a
fst ([Int], [Int])
cellLocs) Text -> Text -> Text
`T.append` [[Text]] -> ([Int], [Int]) -> Text
renderBody (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] -> Text
renderHeader ([Text]
header, [[Text]]
body) [Int]
columnLocations = Text
renderTopBar Text -> Text -> Text
`T.append` Text
renderHeaderNames Text -> Text -> Text
`T.append` Text
renderBottomBar
  where
    renderTopBar :: Text
renderTopBar = Text
boxTL Text -> Text -> Text
`T.append` [Text] -> Text
T.concat (forall a. a -> [a] -> [a]
L.intersperse Text
boxTB (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
`repeatString` Text
boxH) [Int]
columnLocations)) Text -> Text -> Text
`T.append` Text
boxTR Text -> Text -> Text
`T.append` Text
"\n"
    renderHeaderNames :: Text
renderHeaderNames = [Text] -> [Int] -> Int -> Text -> Text
renderRow [Text]
header [Int]
columnLocations Int
1 Text
boxV
    renderBottomBar :: Text
renderBottomBar = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
body then Text
""
                      else Text -> Text -> Text -> [Int] -> Text
renderHBar Text
boxLB Text
boxC Text
boxRB [Int]
columnLocations Text -> Text -> Text
`T.append` Text
"\n"

renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType
renderHBar :: Text -> Text -> Text -> [Int] -> Text
renderHBar Text
left Text
middle Text
end [Int]
columnLocations = Text
left Text -> Text -> Text
`T.append` [Text] -> Text
T.concat (forall a. a -> [a] -> [a]
L.intersperse Text
middle (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
`repeatString` Text
boxH) [Int]
columnLocations)) Text -> Text -> Text
`T.append` Text
end

--pad a block of potentially multi-lined text
leftPaddedString :: Int -> Int -> StringType -> StringType
leftPaddedString :: Int -> Int -> Text -> Text
leftPaddedString Int
lineNum Int
size Text
str = if Int
lineNum forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
paddedLines forall a. Num a => a -> a -> a
-Int
1 then
                                      Int -> Text -> Text
repeatString Int
size Text
" "
                                    else
                                      [Text]
paddedLines forall a. [a] -> Int -> a
!! Int
lineNum
  where
    paddedLines :: [Text]
paddedLines = forall a b. (a -> b) -> [a] -> [b]
map (\Text
line -> Text
line Text -> Text -> Text
`T.append` Int -> Text -> Text
repeatString (Int
size forall a. Num a => a -> a -> a
- Text -> Int
stringDisplayLength Text
line) Text
" ") (Text -> [Text]
breakLines Text
str)

renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType
renderRow :: [Text] -> [Int] -> Int -> Text -> Text
renderRow [Text]
cells [Int]
columnLocations Int
rowHeight Text
interspersed = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
renderOneLine [Int
0..Int
rowHeightforall a. Num a => a -> a -> a
-Int
1]
  where
    renderOneLine :: Int -> Text
renderOneLine Int
lineNum = Text
boxV Text -> Text -> Text
`T.append` [Text] -> Text
T.concat (forall a. a -> [a] -> [a]
L.intersperse Text
interspersed (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> Text -> Text
leftPaddedString Int
lineNum) [Int]
columnLocations [Text]
cells)) Text -> Text -> Text
`T.append` Text
boxV

renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType
renderBody :: [[Text]] -> ([Int], [Int]) -> Text
renderBody [[Text]]
cellMatrix ([Int], [Int])
cellLocs = Text
renderRows Text -> Text -> Text
`T.append` Text
renderBottomBar
  where
    columnLocations :: [Int]
columnLocations = forall a b. (a, b) -> a
fst ([Int], [Int])
cellLocs
    rowLocations :: [Int]
rowLocations = case forall a b. (a, b) -> b
snd ([Int], [Int])
cellLocs of
      [] -> []
      Int
_ : [Int]
xs -> [Int]
xs
    renderRows :: Text
renderRows = [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map (\([Text]
row, Int
rowHeight) -> [Text] -> [Int] -> Int -> Text -> Text
renderRow [Text]
row [Int]
columnLocations Int
rowHeight Text
boxV) [([Text], Int)]
rowHeightMatrix)
    rowHeightMatrix :: [([Text], Int)]
rowHeightMatrix = forall a b. [a] -> [b] -> [(a, b)]
zip [[Text]]
cellMatrix [Int]
rowLocations
    renderBottomBar :: Text
renderBottomBar = Text -> Text -> Text -> [Int] -> Text
renderHBar Text
boxBL Text
boxBB Text
boxBR [Int]
columnLocations

repeatString :: Int -> StringType -> StringType
repeatString :: Int -> Text -> Text
repeatString Int
c Text
s = [Text] -> Text
T.concat (forall a. Int -> a -> [a]
replicate Int
c Text
s)

showRelation :: Relation -> StringType
showRelation :: Relation -> Text
showRelation Relation
rel = Table -> Text
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 :: Text -> Int
stringDisplayLength = forall a. (Char -> a -> a) -> a -> Text -> 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 forall a. Num a => a -> a -> a
+ if Int
w forall a. Ord a => a -> a -> Bool
< Int
0 then
        Int
1 
      else
        Int
w