{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
module Hcompta.CLI.Lib.Leijen.Table where

import           Data.Bool
import           Data.Char (Char)
import           Data.Foldable (Foldable(..))
import           Data.Foldable (any)
import qualified Data.List
import           Data.List (map, replicate)
import           Data.Maybe (Maybe(..), maybe)
import           Data.Maybe (fromMaybe)
import           Data.Ord (Ord(..))
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import           Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)

import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))

-- * Type 'Table'

type Table = [Column]

-- ** Class 'Table_of'

class Table_of context x where
	table_of :: context -> x -> Table

-- * Type 'Column'

data Column
 =   Column
 { column_title :: Text
 , column_width :: Int
 , column_align :: Align
 , column_rows  :: [Cell]
 }
instance ToDoc () [Column] where
	toDoc _m cols = do
		let rows = Data.List.transpose $ map column_rows cols
		let has_title = any (not . Text.null . column_title) cols
		let titles =
			W.intercalate (W.bold $ W.dullblack $ W.char '|')
			 (\col@Column{column_title} -> do
				let cell_width = Text.length column_title
				let under = W.bold $ W.dullblack $ W.char '_'
				let cell_content = W.enclose under under $
					W.hcat $ map
					 (\c -> case c of { ' ' -> under; _ -> W.char c })
					 (Text.unpack column_title)
				let pad len = W.bold $ W.dullblack $
					W.text $ TL.pack $ replicate len '_'
				align (Just pad) col
				 Cell{cell_width, cell_content, cell_align=Just Align_Center}
			 ) cols
		W.vsep (
			(if has_title then (:) titles else id) $
			map
			 ( W.intercalate (W.space <> do W.bold $ W.dullblack $ W.char '|') id
			 . map (W.space <>)
			 . zipWith toDoc cols
			 ) rows
		 ) <> do
		(case cols of { [] -> W.empty; _ -> W.line })
column :: Text -> Align -> [Cell] -> Column
column column_title column_align column_rows =
	Column
	 { column_title
	 , column_width = max (Text.length column_title) $
	                  foldr (max . cell_width) 0 column_rows
	 , column_align
	 , column_rows
	 }

-- ** Class 'Column_of'

class Column_of context x where
	column_of :: context -> x -> Column

-- ** Type 'Align'

data Align
 = Align_Left
 | Align_Center
 | Align_Right
align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
align filling
 Column{column_width, column_align}
 Cell{cell_width, cell_content, cell_align} =
	let pad = column_width - cell_width in
	let fill = fromMaybe (`W.fill` W.empty) filling in
	case fromMaybe column_align cell_align of
	 Align_Left   -> cell_content <> fill pad
	 Align_Center ->
		let half = fromInteger $ quot (toInteger pad) 2 in
		fill half <> cell_content <> fill (pad - half)
	 Align_Right  -> fill pad <> cell_content
align _filling
 Column{column_width}
 (Cell_Line {cell_pad}) =
	W.bold $ W.dullblack $ W.text $
	TL.replicate (fromIntegral column_width) $
	TL.singleton cell_pad

-- * Type 'Cell'

data Cell
 = Cell
	 { cell_align   :: Maybe Align
	 , cell_width   :: Int
	 , cell_content :: W.Doc
	 }
 | Cell_Line
	 { cell_pad     :: Char
	 , cell_width   :: Int
	 }
cell :: Cell
cell =
	Cell
	 { cell_width   = 0
	 , cell_content = W.empty
	 , cell_align   = Nothing
	 }
instance ToDoc Column Cell where
	toDoc = align Nothing

-- ** Class 'Cell_of'

class Cell_of context x where
	cell_of :: context -> x -> Cell

instance Cell_of context x => Cell_of context (Maybe x) where
	cell_of ctx = maybe cell (cell_of ctx)

-- ** Class 'Cell_of_forall_param'

-- | A class useful when using a context of kind '*' is not wanted
--   for example in a class instance constraint
--   to keep the instance decidable (i.e. avoid UndecidableInstances).
class Cell_of_forall_param f x where
	cell_of_forall_param :: forall m. f m -> x -> Cell
-- instance Cell_of_forall_param f x => Cell_of (f m) x where
-- 	cell_of = cell_of_forall_param
instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
	cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)