{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Ordering (
    testLayouts
  ) where

import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Map as Map (Map, (!), fromList, insert)
import Distribution.TestSuite (Progress(..), Result(..), Test, testGroup)
import Log (fatal)
import Mock.Layout (array, column, row, sameStructure)
import Mock.Page (Page, TextBlock, pagesGeometry)
import Mock.Resource (TestStack, simpleTest)
import Text.Printf (printf)
import Text.XML.Light.ALTO.Block (defaultHorizontalBody, glueColumns)
import Text.XML.Light.ALTO.Geometry (Axis(..))
import Text.XML.Light.ALTO.Layout (Layout(..), arrange, tree)
import qualified Text.XML.Light.ALTO.Layout as Layout (array)

testGlueColumns :: Int -> Test
testGlueColumns n = simpleTest testName [] $ do
  actual <- fmap fst . Layout.array V <$> glueColumns a b
  Finished <$>
    if sameStructure actual (array V expected)
    then return Pass
    else
      liftIO $ putStr (tree actual) >> return (Fail "Wrong output layouts")
  where
    testName = printf "glue columns — #%d" n
    ((a, b), expected) = strips !! n

testLayout :: Eq a =>
  ([TextBlock] -> TestStack (Layout (Int, a))) -> (Map Page (Layout Int)) -> String -> Page -> Test
testLayout f expected description coord@(t, p) = simpleTest testName [] $
  ((fmap fst <$> f (pagesGeometry ! coord)) >>= checkStructure)
  where
    testName = printf "%s — t%d p%d" description t p
    checkStructure actual
      | sameStructure actual (expected ! coord) = return $ Finished Pass
      | otherwise = liftIO $ putStr (tree actual) >> return (Finished $ Fail "Bad layout")

testArrange :: Page -> Test
testArrange = testLayout arrange arranged "1st step arrange"

testHorizontallyRearranged :: Page -> Test
testHorizontallyRearranged =
  testLayout (arrange >=> reArrangeBody) horizontallyRearranged "2nd step 2 columns"
  where
    reArrangeBody (Simple _) = fatal "Bad Simple Layout"
    reArrangeBody a@(Array {layouts}) =
      let (peritexts, body) = splitAt 1 layouts in
      (\b -> a {layouts = peritexts ++ b}) <$> defaultHorizontalBody body

testLayouts :: Test
testLayouts = testGroup "layouts" [
        testGroup "arrange" $ testArrange <$> pages
      , testGroup "glue" $ testGlueColumns <$> [0..(length strips - 1)]
      , testGroup "horizontally re-arranged" $ testHorizontallyRearranged <$> pages
    ]
  where
    tome k = ((,) k <$>)
    pages =
        tome 1 [37, 39, 58, 60, 72, 74, 79, 82, 157, 231, 1248]
      ++ tome 7 [106]

strips :: [((Layout TextBlock, [Layout TextBlock]), [Layout Int])]
strips =
  let t1p74 = (pagesGeometry ! (1, 74))
      t1p39 = (pagesGeometry ! (1, 39)) in [
        ((Simple (t1p74 !! 4), [Layout.array H (Simple . (t1p74 !!) <$> [5, 6])])
          , [Simple 4, row [5, 6]])
      , ((Simple (t1p39 !! 2), [Layout.array H (Simple . (t1p39 !!) <$> [3, 7])])
                , [Simple 2, row [3, 7]])
    ]

arranged :: Map (Int, Int) (Layout Int)
arranged = Map.fromList [
      ((1, 37), array V [
            row [1, 0]
          , row [2, 3]
          , row [4, 5]
          , row [6, 7]
        ])
    , ((1, 39), array V [
            row [0, 1]
          , Simple 2
          , array H [array V [Simple 3, row [4..6]], Simple 7]
        ])
    , ((1, 58), array V [
            row [0, 1]
          , array H [column [2..6], column [7..11]]
        ])
    , ((1, 60), array V [
            Simple 0
          , array H [column [1..3], column [7,8]]
          , array H [column [4..6], Simple 9]
        ])
    , ((1, 72), array V [
            row [0, 1]
          , row [2, 4]
          , Simple 6
          , row [3, 5]
        ])
    , ((1, 74), array V [
            row [0, 1]
          , row [2, 3]
          , Simple 4
          , row [5, 6]
        ])
    , ((1, 79), array V [
            Simple 0
          , row [1, 2]
          , Simple 3
          , row [4, 5]
        ])
    , ((1, 82), array V [
            row [0, 1]
          , array H [column [2..4], Simple 5]
        ])
    , ((1, 157), array V [
            row [0, 1]
          , array H [column [2, 3], column [5..8]]
          , array H [Simple 4, column [9..11]]
        ])
    , ((1, 231), array V [
            row [0, 1]
          , array H [Simple 2, Simple 3, Simple 4, column [5,6]]
          , row [7, 8]
          , Simple 9
          , Simple 10
        ])
    , ((1, 1248), array V [
            row [6, 7]
          , row [8, 9]
          , Simple 0
          , Simple 1
          , row [2, 3]
          , Simple 4
          , Simple 5
        ])
    , ((7, 106), array V [
            row [0, 1]
          , array H [Simple 2, column [6, 7], column [3, 4]]
          , Simple 5
        ])
  ]

horizontallyRearranged :: Map (Int, Int) (Layout Int)
horizontallyRearranged =
    Map.insert (1, 60) (array V [
          Simple 0
        , array H [
                array V $ Simple <$> [1..6]
              , array V $ Simple <$> [7..9]
            ]
      ])
  . Map.insert (1, 157) (array V [
          row [0, 1]
        , array H [
                column [2..4]
              , column [5..11]
            ]
      ])
  . Map.insert (7, 106) (array V [
          row [0, 1]
        , array H [
                Simple 2
              , column [6,7]
              , column [3..5]
            ]
      ])
  $ arranged