path: root/test/Tests/Writers/AnnotatedTable.hs

{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Tests.Writers.AnnotatedTable
   Copyright   : 2020 Christian Despres
   License     : GNU GPL, version 2 or above

   Maintainer  : Christian Despres <christian.j.j.despres@gmail.com>
   Stability   : alpha
   Portability : portable

Tests for the table helper functions.
-}
module Tests.Writers.AnnotatedTable
  ( tests
  )
where

import           Prelude
import qualified Data.Foldable                 as F
import qualified Data.List.NonEmpty            as NonEmpty
import           Test.Tasty
import           Test.Tasty.HUnit               ( testCase
                                                , (@?=)
                                                )
import           Test.Tasty.QuickCheck          ( QuickCheckTests(..)
                                                , Property
                                                , Testable
                                                , conjoin
                                                , forAll
                                                , testProperty
                                                , (===)
                                                , vectorOf
                                                , choose
                                                , arbitrary
                                                , elements
                                                )
import           Text.Pandoc.Arbitrary          ( )
import           Text.Pandoc.Builder
import qualified Text.Pandoc.Writers.AnnotatedTable
                                               as Ann

tests :: [TestTree]
tests = [testGroup "toTable" $ testAnnTable <> annTableProps]

getSpec :: Ann.Cell -> [ColSpec]
getSpec (Ann.Cell colspec _ _) = F.toList colspec

catHeaderSpec :: Ann.HeaderRow -> [ColSpec]
catHeaderSpec (Ann.HeaderRow _ _ x) = concatMap getSpec x

catBodySpec :: Ann.BodyRow -> [ColSpec]
catBodySpec (Ann.BodyRow _ _ x y) = concatMap getSpec x <> concatMap getSpec y

-- Test if the first list can be obtained from the second by deleting
-- elements from it.
isSubsetOf :: Eq a => [a] -> [a] -> Bool
isSubsetOf (x : xs) (y : ys) | x == y    = isSubsetOf xs ys
                             | otherwise = isSubsetOf (x : xs) ys
isSubsetOf [] _  = True
isSubsetOf _  [] = False

testAnnTable :: [TestTree]
testAnnTable =
  [testCase "annotates a sample table properly" $ generated @?= expected]
 where
  spec1 = (AlignRight, ColWidthDefault)
  spec2 = (AlignLeft, ColWidthDefault)
  spec3 = (AlignCenter, ColWidthDefault)
  spec  = [spec1, spec2, spec3]

  cl a h w = Cell (a, [], []) AlignDefault h w []
  rws = map $ Row nullAttr
  th  = TableHead nullAttr . rws
  tb n x y = TableBody nullAttr n (rws x) (rws y)
  tf           = TableFoot nullAttr . rws
  initialHeads = [[cl "a" 1 1, cl "b" 3 2], [cl "c" 2 2, cl "d" 1 1]]
  initialTB1   = tb 1
                    [[], [cl "e" 5 1, cl "f" (-7) 0]]
                    [[cl "g" 4 3, cl "h" 4 3], [], [emptyCell]]
  initialTB2 = tb 2 [] [[cl "i" 4 3, cl "j" 4 3]]
  generated  = Ann.toTable nullAttr
                           emptyCaption
                           spec
                           (th initialHeads)
                           [initialTB1, initialTB2]
                           (tf initialHeads)

  acl al n a h w =
    Ann.Cell (NonEmpty.fromList al) n $ Cell (a, [], []) AlignDefault h w []
  emptyAnnCell al n = acl al n "" 1 1
  ahrw    = Ann.HeaderRow nullAttr
  abrw    = Ann.BodyRow nullAttr
  ath     = Ann.TableHead nullAttr
  atb     = Ann.TableBody nullAttr
  atf     = Ann.TableFoot nullAttr

  finalTH = ath
    [ ahrw 0 [acl [spec1] 0 "a" 1 1, acl [spec2, spec3] 1 "b" 2 2]
    , ahrw 1 [acl [spec1] 0 "c" 1 1]
    ]
  finalTB1 = atb
    1
    [ ahrw
      2
      [emptyAnnCell [spec1] 0, emptyAnnCell [spec2] 1, emptyAnnCell [spec3] 2]
    , ahrw
      3
      [acl [spec1] 0 "e" 1 1, acl [spec2] 1 "f" 1 1, emptyAnnCell [spec3] 2]
    ]
    [ abrw 4 [acl [spec1] 0 "g" 3 1] [acl [spec2, spec3] 1 "h" 3 2]
    , abrw 5 []                      []
    , abrw 6 []                      []
    ]
  finalTB2 =
    atb 2 [] [abrw 7 [acl [spec1, spec2] 0 "i" 1 2] [acl [spec3] 2 "j" 1 1]]
  finalTF = atf
    [ ahrw 8 [acl [spec1] 0 "a" 1 1, acl [spec2, spec3] 1 "b" 2 2]
    , ahrw 9 [acl [spec1] 0 "c" 1 1]
    ]
  expected =
    Ann.Table nullAttr emptyCaption spec finalTH [finalTB1, finalTB2] finalTF

withColSpec :: Testable prop => ([ColSpec] -> prop) -> Property
withColSpec = forAll arbColSpec
 where
  arbColSpec = do
    cs <- choose (1 :: Int, 6)
    vectorOf
      cs
      ((,) <$> arbitrary <*> elements
        [ColWidthDefault, ColWidth (1 / 3), ColWidth 0.25]
      )

annTableProps :: [TestTree]
annTableProps =
  localOption (QuickCheckTests 50)
    <$> [ testProperty "normalizes like the table builder"  propBuilderAnnTable
        , testProperty "has valid final cell columns"       propColNumber
        , testProperty "has valid first row column data"    propFirstRowCols
        , testProperty "has valid all row column data"      propColSubsets
        , testProperty "has valid cell column data lengths" propCellColLengths
        ]

-- The property that Ann.toTable will normalize a table identically to
-- the table builder. This should mean that Ann.toTable is at least as
-- rigorous as Builder.table in that respect without repeating those
-- tests here (see the pandoc-types Table tests for examples).
propBuilderAnnTable :: TableHead -> [TableBody] -> TableFoot -> Property
propBuilderAnnTable th tbs tf = withColSpec $ \cs ->
  convertTable (table emptyCaption cs th tbs tf)
    === convertAnnTable (Ann.toTable nullAttr emptyCaption cs th tbs tf)
 where
  convertTable blks = case toList blks of
    [Table _ _ colspec a b c] -> Right (colspec, a, b, c)
    x                         -> Left x
  convertAnnTable x = case Ann.fromTable x of
    (_, _, colspec, a, b, c) -> Right (colspec, a, b, c)

-- The property of Ann.toTable that if the last cell in the first row
-- of a table section has ColSpan w and ColNumber n, then w + n is the
-- width of the table.
propColNumber :: TableHead -> [TableBody] -> TableFoot -> Property
propColNumber th tbs tf = withColSpec $ \cs ->
  let twidth = length cs
      Ann.Table _ _ _ ath atbs atf =
          Ann.toTable nullAttr emptyCaption cs th tbs tf
  in  conjoin
        $  [colNumTH twidth ath]
        <> (colNumTB twidth <$> atbs)
        <> [colNumTF twidth atf]
 where
  colNumTH n (Ann.TableHead _ rs) = firstly (isHeaderValid n) rs
  colNumTB n (Ann.TableBody _ _ rs ts) =
    firstly (isHeaderValid n) rs && firstly (isBodyValid n) ts
  colNumTF n (Ann.TableFoot _ rs) = firstly (isHeaderValid n) rs

  isHeaderValid n (Ann.HeaderRow _ _ x) = isSegmentValid n x
  isBodyValid n (Ann.BodyRow _ _ _ x) = isSegmentValid n x

  firstly f (x : _) = f x
  firstly _ []      = True
  lastly f [x     ] = f x
  lastly f (_ : xs) = lastly f xs
  lastly _ []       = True

  isSegmentValid twidth cs =
    flip lastly cs
      $ \(Ann.Cell _ (Ann.ColNumber n) (Cell _ _ _ (ColSpan w) _)) ->
          n + w == twidth

-- The property of an Ann.Table from Ann.toTable that if the NonEmpty
-- ColSpec data of the cells in the first row of a table section are
-- concatenated, the result should equal the [ColSpec] of the entire
-- table.
propFirstRowCols :: TableHead -> [TableBody] -> TableFoot -> Property
propFirstRowCols th tbs tf = withColSpec $ \cs ->
  let Ann.Table _ _ _ ath atbs atf =
          Ann.toTable nullAttr emptyCaption cs th tbs tf
  in  conjoin
        $  [firstRowTH cs ath]
        <> (firstRowTB cs <$> atbs)
        <> [firstRowTF cs atf]
 where
  firstly f (x : _) = f x
  firstly _ []      = True

  firstHeaderValid cs = firstly $ \r -> cs == catHeaderSpec r
  firstBodyValid cs = firstly $ \r -> cs == catBodySpec r

  firstRowTH cs (Ann.TableHead _ rs) = firstHeaderValid cs rs
  firstRowTB cs (Ann.TableBody _ _ rs ts) =
    firstHeaderValid cs rs && firstBodyValid cs ts
  firstRowTF cs (Ann.TableFoot _ rs) = firstHeaderValid cs rs

-- The property that in any row in an Ann.Table from Ann.toTable, the
-- NonEmpty ColSpec annotations on cells, when concatenated, form a
-- subset (really sublist) of the [ColSpec] of the entire table.
propColSubsets :: TableHead -> [TableBody] -> TableFoot -> Property
propColSubsets th tbs tf = withColSpec $ \cs ->
  let Ann.Table _ _ _ ath atbs atf =
          Ann.toTable nullAttr emptyCaption cs th tbs tf
  in  conjoin
        $  subsetTH cs ath
        <> concatMap (subsetTB cs) atbs
        <> subsetTF cs atf
 where
  subsetTH cs (Ann.TableHead _ rs) = map (subsetHeader cs) rs
  subsetTB cs (Ann.TableBody _ _ rs ts) =
    map (subsetHeader cs) rs <> map (subsetBody cs) ts
  subsetTF cs (Ann.TableFoot _ rs) = map (subsetHeader cs) rs

  subsetHeader cs r = catHeaderSpec r `isSubsetOf` cs
  subsetBody cs r = catBodySpec r `isSubsetOf` cs

-- The property that in any cell in an Ann.Table from Ann.toTable, the
-- NonEmpty ColSpec annotation on a cell is equal in length to its
-- ColSpan.
propCellColLengths :: TableHead -> [TableBody] -> TableFoot -> Property
propCellColLengths th tbs tf = withColSpec $ \cs ->
  let Ann.Table _ _ _ ath atbs atf =
          Ann.toTable nullAttr emptyCaption cs th tbs tf
  in  conjoin $ cellColTH ath <> concatMap cellColTB atbs <> cellColTF atf
 where
  cellColTH (Ann.TableHead _ rs) = concatMap cellColHeader rs
  cellColTB (Ann.TableBody _ _ rs ts) =
    concatMap cellColHeader rs <> concatMap cellColBody ts
  cellColTF (Ann.TableFoot _ rs) = concatMap cellColHeader rs

  cellColHeader (Ann.HeaderRow _ _ x) = fmap validLength x
  cellColBody (Ann.BodyRow _ _ x y) = fmap validLength x <> fmap validLength y

  validLength (Ann.Cell colspec _ (Cell _ _ _ (ColSpan w) _)) =
    length colspec == w