{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
-- Remove this
{-# LANGUAGE DeriveDataTypeable #-}
-- Remove this
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | Module implements the default methods for Tabulate
 All examples listed in the document need the following language pragmas
 and following modules imported

 @
 {#- LANGUAGE MultiParamTypeClasses}
 {#- LANGUAGE DeriveGeneric}
 {#- LANGUAGE DeriveDataTypeable}

 import qualified GHC.Generics as G
 import Data.Data
 @
-}
module Literate.Table where

--import Data.Generics.Aliases

import Data.Bool (Bool)
import Data.Data
import Data.Foldable (foldMap)
import Data.Function (($), (.))
import Data.Functor (Functor, fmap, (<$>))
import Data.Int (Int)
import Data.List ((++))
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe
import Data.String (IsString (..), String)
import Data.Tree
import Data.Typeable
import GHC.Err (undefined)
import GHC.Float (Float)
import GHC.Generics as G
import GHC.Num (Integer, (+), (-))
import GHC.Show
import Literate.Box (Alignment (AlignTopLeft))
import Literate.Box qualified as B
import System.IO (IO)
import Text.Printf
import Prelude (Double, error)

-- | * Class 'GRecordMeta'
class GRecordMeta f where
  toTree :: f a -> [Tree String]

instance GRecordMeta U1 where
  toTree U1 = []
instance (GRecordMeta a, GRecordMeta b) => GRecordMeta (a :*: b) where
  toTree (x :*: y) = toTree x ++ toTree y
instance (GRecordMeta a, GRecordMeta b) => GRecordMeta (a :+: b) where
  toTree (G.L1 x) = toTree x
  toTree (G.R1 x) = toTree x
instance (GRecordMeta a, Selector s) => GRecordMeta (M1 S s a) where
  toTree a = [Node (selName a) $ toTree (unM1 a)]
instance (GRecordMeta a, Constructor c) => GRecordMeta (M1 C c a) where
  -- we don't want to build node for constructor
  toTree a = [Node (conName a) $ toTree (unM1 a)]

--toTree a = toTree (unM1 a)
instance (GRecordMeta a) => GRecordMeta (M1 D c a) where
  toTree (M1 x) = toTree x
instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where
  --toTree x = [Node (show (unK1 x)) (toTree' $ unK1 x)]
  toTree x = toTree' $ unK1 x

{- | Use this flag to expand a Record Type as a table when
 nested inside another record.
-}
data ExpandWhenNested

{- | Use this flag to not expand a Record type as a table when
 nested inside another record. The 'Show' instance of the nested record
 is used by default without expanding. This means that the fields of the
 nested record are not displayed as separate headers.
-}
data DoNotExpandWhenNested

{- | Class instance that needs to be instantiated for each
 record that needs to be printed using printTable

 @

 data Stock = Stock {price:: Double, name:: String} derive (Show, G.Generic, Data)
 instance Tabulate S 'ExpandWhenNested'
 @

 If 'S' is embedded inside another `Record` type and should be
 displayed in regular Record Syntax, then

 @

 instance Tabulate S 'DoNotExpandWhenNested'
 @
-}
class Tabulate a flag | a -> flag

--instance TypeCast flag HFalse => Tabulate a flag
instance {-# OVERLAPPABLE #-} (flag ~ DoNotExpandWhenNested) => Tabulate a flag

class RecordMeta a where
  toTree' :: a -> [Tree String]
instance (Tabulate a flag, RecordMeta' flag a) => RecordMeta a where
  toTree' = toTree'' (undefined :: proxy flag)

class RecordMeta' flag a where
  toTree'' :: proxy flag -> a -> [Tree String]
instance (G.Generic a, GRecordMeta (Rep a)) => RecordMeta' ExpandWhenNested a where
  toTree'' _ a = toTree (G.from a)
instance (CellValueFormatter a) => RecordMeta' DoNotExpandWhenNested a where
  toTree'' _ a = [Node (ppFormatter a) []]

{- |  Class that implements formatting using printf.
    Default instances for String, Char, Int, Integer, Double and Float
    are provided. For types that are not an instance of this class
    `show` is used.
-}
class CellValueFormatter a where
  -- Function that can be implemented by each instance
  ppFormatter :: a -> String
  -- Future support for this signature will be added
  --ppFormatterWithStyle :: TablizeValueFormat -> a -> String

  -- Default instance of function for types that do
  -- do not have their own instance
  default ppFormatter :: (Show a) => a -> String
  ppFormatter x = show x

instance CellValueFormatter Integer where
  ppFormatter x = printf "%d" x
instance CellValueFormatter Int where
  ppFormatter x = printf "%d" x
instance CellValueFormatter Float where
  ppFormatter x = printf "%g" x
instance CellValueFormatter String where
  ppFormatter x = printf "%s" x
instance CellValueFormatter Double where
  ppFormatter x = printf "%g" x
instance CellValueFormatter Bool
instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a)

gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box
gen_renderTableWithFlds flds recs = results
  where
    col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter . f) recs) flds
    vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ fmap (fmap fromString) col_wise_values
    results = B.hsep 5 B.AlignTopLeft vertical_boxes

class Boxable b where
  printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO ()

  --printTableWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> IO ()

  renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box
  printTableWithFlds :: [DisplayFld t] -> b t -> IO ()
  renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box

-- | Instance methods to render or print a list of records in a tabular format.
instance Boxable [] where
  printTable m = B.printBox $ ppRecords m

  renderTable m = ppRecords m
  printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
  renderTableWithFlds = gen_renderTableWithFlds

{-
instance Boxable V.Vector where
  -- | Prints a "Vector" as a table. Called by "printTable".
  -- | Need not be called directly
  printTable m = B.printBox $ renderTable m  --TODO: switch this to Vector
  renderTable m = ppRecords $ V.toList m

  -- | Print a "Vector" of records as a table with the selected fields.
  -- Called by "printTableWithFlds".
  printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds $ V.toList recs
  renderTableWithFlds flds recs = gen_renderTableWithFlds flds $ V.toList recs
-}

instance (CellValueFormatter k) => Boxable (Map.Map k) where
  printTable m = B.printBox $ renderTable m
  renderTable m = ppRecordsWithIndex m
  printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs

  renderTableWithFlds flds recs = results
    where
      data_cols = renderTableWithFlds flds $ Map.elems recs
      index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs
      vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
      results = vertical_cols

-- Pretty Print the records as a table. Handles both records inside
-- Lists and Vectors
ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box
ppRecords recs = B.punctuateH AlignTopLeft "|" $ createHeaderDataBoxes recs

-- Pretty Print the records as a table. Handles records contained in a Map.
-- Functions also prints the keys as the index of the table.
ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => Map.Map k a -> B.Box
ppRecordsWithIndex recs = B.punctuateH AlignTopLeft "|" $ index_box : data_boxes
  where
    data_boxes = createHeaderDataBoxes $ Map.elems recs
    index_box = createIndexBoxes recs

-- What follows are helper functions to build the B.Box structure to print as table.

-- Internal helper functions for building the Tree.

-- Build the list of paths from the root to every leaf.
-- >>> constructPath $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])kk
-- [["","root","R00","r00Int","42"],["","root","R00","r00String","foo"]]
constructPath :: Tree a -> [[a]]
constructPath (Node r []) = [[r]]
constructPath (Node r f) = [r : x | x <- List.concatMap constructPath f]

-- Fill paths with a "-" so that all paths have the
-- same length.
-- >>> fillPath ([["1", "2", "3", "4"], ["5"]]::[[String]])
-- [["2","3","4"],["-","-","-"]]
fillPath :: IsString a => [[a]] -> [[a]]
fillPath paths = [xs | x : xs <- new_paths]
  where
    depth = List.maximum $ List.length <$> paths
    diff = (\p -> depth - List.length p) <$> paths
    new_paths = (\(p, d) -> p ++ List.replicate d "-") <$> List.zip paths diff

-- Count the number of fields in the passed structure.
-- The no of leaves is the sum of all fields across all nested
-- records in the passed structure.
countLeaves :: Tree a -> Tree (Int, a)
countLeaves (Node r f) = case f of
  [] -> Node (1, r) []
  x -> countLeaves' x
    where
      countLeaves' x =
        let count_leaves = fmap countLeaves x
            level_count = List.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves
         in Node (level_count, r) count_leaves

-- Trims the tree of records and return just the
-- leaves of the record
-- >>> error $ drawTree $ trimTree $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])

{- |
 `- root
    |
    `- R00
       |
       +- r00Int
       |
       `- r00String
-}
trimTree :: Tree t -> Tree t
trimTree (Node r f) = trimLeaves r f

-- Helper function called by trimTree.
trimLeaves :: t -> [Tree t] -> Tree t
trimLeaves r f = Node r (go f)
  where
    go f =
      let result = goo <$> f
            where
              goo (Node r' f') =
                case f' of
                  [] -> Nothing
                  _ -> Just $ trimLeaves r' f'
       in catMaybes result

-- Get all the leaves from the record.
-- Returns all leaves across the record structure.
getLeaves :: (CellValueFormatter a) => Tree a -> [String]
getLeaves (Node r f) = case f of
  [] -> [ppFormatter r]
  _ -> foldMap getLeaves f

{- | >>> y recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
 root
 NOW |
 NOW `- R00
 NOW    |
 NOW    +- r00Int
 NOW    |  |
 NOW    |  `- 42
 NOW    |
 NOW    `- r00String
 NOW       |
 NOW       `- foo
 |
 +- r00Int
 |  |
 |  `- 42
 |
 `- r00String
    |
    `- foo
-}
recsToTrees :: (Functor f, GRecordMeta (Rep a), Generic a) => f a -> f (Tree String)
recsToTrees = fmap (\a -> Node "root" $ toTree $ G.from a)

getHeaderDepth :: IsString a => [Tree a] -> Int
getHeaderDepth = List.length . List.head . fillPath . constructPath . trimTree . List.head

--createIndexBoxes :: Map.Map a a -> B.Box
createIndexBoxes :: (GRecordMeta (Rep a), Generic a, CellValueFormatter k) => Map.Map k a -> B.Box
createIndexBoxes recs = index_box
  where
    rec_trees = recsToTrees $ Map.elems recs
    header_depth = getHeaderDepth rec_trees
    index_col = List.replicate header_depth "-" ++ List.map ppFormatter (Map.keys recs)
    index_box = B.vsep 0 B.AlignTopLeft $ List.map fromString index_col

createHeaderDataBoxes :: (GRecordMeta (Rep a), Generic a) => [a] -> [B.Box]
createHeaderDataBoxes recs = vertical_boxes
  where
    rec_trees = recsToTrees recs
    header_boxes = createHeaderCols rec_trees
    data_boxes = createDataBoxes rec_trees
    vertical_boxes = (\(a, b) -> B.vsep 0 B.AlignTopLeft [a, b]) <$> List.zip header_boxes data_boxes

-- >>> error $ B.render $ B.hcat AlignTopLeft $ createHeaderCols $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
-- R00   R00
-- r00Intr00String
createHeaderCols :: [Tree String] -> [B.Box]
createHeaderCols rec_trees =
  createBoxedHeaders $
    fillPath $
      constructPath $
        trimTree $
          List.head rec_trees

createBoxedHeaders :: [[String]] -> [B.Box]
createBoxedHeaders paths = B.vsep 0 B.AlignTopLeft . (fromString <$>) <$> paths

-- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
-- 42foo
-- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([getR01]::[R01])
-- Jack-Jack100.101021Just 10.101
createDataBoxes :: CellValueFormatter a => [Tree a] -> [B.Box]
createDataBoxes rec_trees = vertical_boxes
  where
    horizontal_boxes = (fromString <$>) <$> (getLeaves <$> rec_trees)
    vertical_boxes = B.vsep 0 B.AlignTopLeft <$> List.transpose horizontal_boxes

-- testing

data T = C1 {aInt :: Double, aString :: String} deriving (Data, Typeable, Show, G.Generic)
data T1 = C2 {t1 :: T, bInt :: Double, bString :: String} deriving (Data, Typeable, Show, G.Generic)

c1 = C1 1000 "record_c1fdsafaf"
c2 = C2 c1 100.12121 "record_c2"
c3 = C2 c1 1001.12111 "record_c2fdsafdsafsafdsafasfa"
c4 = C2 c1 22222.12121 "r"

instance Tabulate T ExpandWhenNested
instance Tabulate T1 ExpandWhenNested
instance CellValueFormatter T

data R2 = R2 {a :: Maybe Integer} deriving (G.Generic, Show)
data R3 = R3 {r31 :: Maybe Integer, r32 :: String} deriving (G.Generic, Show)
tr = Node "root" (toTree . G.from $ c2)
r2 = Node "root" (toTree . G.from $ (R2 (Just 10)))
r3 = Node "root" (toTree . G.from $ (R3 (Just 10) "r3_string"))

-- | Used with 'printTableWithFlds'
data DisplayFld a = forall s. CellValueFormatter s => DFld (a -> s)

-- printTableWithFlds2 :: [DisplayFld t] -> V.Vector t -> IO ()
-- printTableWithFlds2 flds recs = B.printBox $ printTableWithFlds flds $ V.toList recs

-- printTableWithFlds3 :: (CellValueFormatter k) => [DisplayFld t] -> Map.Map k t -> String
-- printTableWithFlds3 flds recs = results
--  where
--   data_cols = renderTableWithFlds flds $ Map.elems recs
--   index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs
--   vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
--   results = B.render vertical_cols

data R00
  = R00
      { r00Int :: Int
      , r00String :: String
      }
  | R00_
      { r00_Int :: Int
      , r00_String :: String
      }
  deriving (Show, Generic, Data)
instance CellValueFormatter R00

-- R0 has to derive from Data, since
-- it will be nested
data R01 = R01
  { test_string :: String
  , test_integer :: Integer
  , test_float :: Float
  , test_DOUBLE :: Maybe Double
  }
  deriving (Data, Show, G.Generic)
instance CellValueFormatter R01

data R02 = R02 {r2_r00 :: R00, r2_r01 :: R01}
  deriving (Show, G.Generic, Data)
instance CellValueFormatter R02

data R03 = R03 {r3_id :: Int, r3_r02 :: R02}
  deriving (Show, G.Generic, Data)

instance Tabulate R01 ExpandWhenNested
instance Tabulate R02 ExpandWhenNested
instance Tabulate R03 ExpandWhenNested

getR01 =
  R01
    { test_string = "Jack-Jack"
    , test_integer = 10
    , test_DOUBLE = Just 10.101
    , test_float = 0.101021
    }

getR02 = R02{r2_r00 = R00_ 100 "foo", r2_r01 = getR01}

getR03 = R03{r3_id = 200, r3_r02 = getR02}

recordsList = List.replicate 2 $ getR03

-- >>> recordsList
-- [R03 {r3_id = 20, nested_r02 = R02 {r2_id = 10, nested_r = R01 {test_string = "Jack-Jack", test_integer = 10, test_float = 0.101021, test_double = 10.101}}}
-- ,R03 {r3_id = 20, nested_r02 = R02 {r2_id = 10, nested_r = R01 {test_string = "Jack-Jack", test_integer = 10, test_float = 0.101021, test_double = 10.101}}}]
--
-- >>> B.rows $ renderTable recordsList
-- 5
--
-- >>> B.cols $ renderTable recordsList
-- 91

-- >>> error $ B.render $ ppRecords recordsList
-- R03  |R03                                     |R03        |R03         |R03       |R03
-- r3_id r3_r02                                   r3_r02      r3_r02       r3_r02     r3_r02
-- -     R02                                      R02         R02          R02        R02
-- -     r2_r00                                   r2_r01      r2_r01       r2_r01     r2_r01
-- -     -                                        R01         R01          R01        R01
-- -     -                                        test_string test_integer test_float test_DOUBLE
-- 200   R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack   10           0.101021   Just 10.101
-- 200   R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack   10           0.101021   Just 10.101

recordsMap =
  Map.fromList
    [ ("key1", getR03)
    , ("key2", getR03)
    , ("key3", getR03{r3_id = 32})
    ]

-- >>> B.rows $ renderTable recordsMap
-- 5

-- >>> B.cols $ renderTable recordsMap
-- 100

-- >>> error $ B.render $ ppRecordsWithIndex recordsMap
-- -        R03       R03                                          R03             R03              R03            R03
-- -        r3_id     r3_r02                                       r3_r02          r3_r02           r3_r02         r3_r02
-- -        -         R02                                          R02             R02              R02            R02
-- -        -         r2_r00                                       r2_r01          r2_r01           r2_r01         r2_r01
-- -        -         -                                            R01             R01              R01            R01
-- -        -         -                                            test_string     test_integer     test_float     test_DOUBLE
-- key1     200       R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101
-- key2     200       R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101
-- key3     32        R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101