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

import           Data.Bool
import           Data.Char (Char)
import qualified Data.Foldable as Foldable
import qualified Data.List
import           Data.List (map, replicate)
import           Data.Maybe (Maybe(..), fromMaybe, maybe)
import           Data.Monoid ((<>))
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           Text.WalderLeijen.ANSI.Text (ToDoc(..))
import qualified Text.WalderLeijen.ANSI.Text as W

-- * 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 =
		let rows = Data.List.transpose $ map column_rows cols in
		let has_title = Foldable.any (not . Text.null . column_title) cols in
		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 in
		W.vsep (
			(if has_title then (:) titles else id) $
			map
			 ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
			 . map (W.space <>)
			 . zipWith toDoc cols
			 ) rows
		 ) <>
		(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) $
	                  Foldable.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)