module Hcompta.LCC.Write.Table where

import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (any, foldr)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Tuple (curry)
import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
import Text.Show (Show)
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL

import Hcompta.LCC.Write.Compta
import qualified Language.Symantic.Document as D

-- * Type 'TablePlain'
type TablePlain d = [ColumnPlain d]

instance (D.Doc_Text d, D.Doc_Color d) => Writeable d (TablePlain d) where
	write cols' =
		let cols        = refreshWidthCol <$> cols' in
		let rows        = L.transpose $ columnPlain_rows <$> cols in
		let has_title   = any (not . T.null . columnPlain_title) cols in
		let titles :: d = D.catH $ L.intersperse (d_sep '|') $ d_title <$> cols in
		D.catV (
			(if has_title then (:) titles else id) $
			(<$> rows) $ \row ->
				D.catH $
				L.intersperse (D.space <> d_sep '|') $
				((D.space <>) <$>) $
				zipWith (curry $ alignCellPlain Nothing) cols row
		 ) <>
		(case cols of { [] -> D.empty; _ -> D.eol })
		where
		refreshWidthCol col@ColumnPlain{columnPlain_width=w} =
			if w == 0
			then col{columnPlain_width = widthCol col}
			else col
			where
			widthCol :: ColumnPlain d -> Int
			widthCol ColumnPlain
			 { columnPlain_title
			 , columnPlain_rows } =
				max (T.length columnPlain_title) $
				foldr (max . cellPlain_width) 0 columnPlain_rows
		d_title :: ColumnPlain d -> d
		d_title col@ColumnPlain{columnPlain_title} = do
			let pad len = D.blacker $ D.text $ T.pack $ L.replicate len '_'
			alignCellPlain (Just pad) (col, CellPlain
			 { cellPlain_width   = T.length columnPlain_title
			 , cellPlain_content = d_under <> d_underline columnPlain_title <> d_under
			 , cellPlain_align   = Just AlignPlainC
			 })
		d_sep = D.blacker . D.charH
		d_under = d_sep '_'
		d_underline t =
			D.catH $ (<$> T.unpack t) $ \case
			 ' ' -> d_under
			 c -> D.charH c
		
		alignCellPlain ::
		 D.Doc_Text d =>
		 D.Doc_Color d =>
		 Maybe (Int -> d) ->
		 (ColumnPlain d, CellPlain d) -> d
		alignCellPlain may_padding
		 ( ColumnPlain{columnPlain_align, columnPlain_width}
		 , CellPlain{cellPlain_width, cellPlain_content, cellPlain_align} ) =
			let pad = columnPlain_width - cellPlain_width in
			case columnPlain_align `fromMaybe` cellPlain_align of
			 AlignPlainL -> cellPlain_content <> padding pad
			 AlignPlainC -> padding half <> cellPlain_content <> padding (pad - half)
				where half = fromInteger $ quot (toInteger pad) 2
			 AlignPlainR -> padding pad <> cellPlain_content
			where padding = D.spaces `fromMaybe` may_padding
		alignCellPlain _filling
		 ( ColumnPlain{columnPlain_width}
		 , CellPlain_Line{cellPlain_pad} ) =
			D.blacker $ D.ltextH $
			TL.replicate (fromIntegral columnPlain_width) $
			TL.singleton cellPlain_pad

-- ** Class 'TablePlainOf'
class TablePlainOf a d where
	tablePlainOf :: a -> TablePlain d

-- * Type 'ColumnPlain'
data ColumnPlain d
 =   ColumnPlain
 {   columnPlain_title :: Text
 ,   columnPlain_align :: AlignPlain
 ,   columnPlain_width :: Int
 ,   columnPlain_rows  :: [CellPlain d]
 } deriving (Eq, Show)

columnPlain :: Text -> AlignPlain -> [CellPlain d] -> ColumnPlain d
columnPlain t a r =
	ColumnPlain
	 { columnPlain_title = t
	 , columnPlain_align = a
	 , columnPlain_width = 0
	 , columnPlain_rows  = r
	 }

-- ** Type 'AlignPlain'
data AlignPlain
 =   AlignPlainL
 |   AlignPlainC
 |   AlignPlainR
 deriving (Eq, Show)

-- ** Class 'columnPlainOf'
class ColumnPlainOf a d where
	columnPlainOf :: a -> ColumnPlain d

-- * Type 'CellPlain'
data CellPlain d
 =   CellPlain { cellPlain_align   :: Maybe AlignPlain
               , cellPlain_width   :: Int
               , cellPlain_content :: d
               }
 |   CellPlain_Line { cellPlain_pad     :: Char
                    , cellPlain_width   :: Int
                    }
 deriving (Eq, Show)

-- ** Class 'CellPlainOf'
class CellPlainOf a d where
	cellPlainOf :: a -> CellPlain d
	default cellPlainOf ::
	 Writeable D.Dim a =>
	 Writeable d a =>
	 a -> CellPlain d
	cellPlainOf = cellPlain

instance D.Doc_Text d => CellPlainOf () d where
	cellPlainOf () = CellPlain
	 { cellPlain_width   = 0
	 , cellPlain_align   = Nothing
	 , cellPlain_content = D.empty
	 }

cellPlain ::
 Writeable D.Dim a =>
 Writeable d a =>
 a -> CellPlain d
cellPlain a =
	CellPlain
	 { cellPlain_width   = D.width $ D.dim $ write a
	 , cellPlain_align   = Nothing
	 , cellPlain_content = write a
	 }






{-
instance ToDoc ColumnPlain CellPlain where
	toDoc = alignCellPlain Nothing

-- ** Class 'CellOf'
class CellOf context x where
	cellOf :: context -> x -> CellPlain

instance CellOf context x => CellOf context (Maybe x) where
	cellOf ctx = maybe cellPlain (cellOf 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
	cellPlain_of_forall_param :: forall m. f m -> x -> CellPlain
-- instance Cell_of_forall_param f x => CellOf (f m) x where
-- 	cellOf = cellPlain_of_forall_param
instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
	cellPlain_of_forall_param ctx = maybe cellPlain (cellPlain_of_forall_param ctx)
-}