{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}

{-
TODO: Can this be rewritten to be less reliant on Data.Typeable? Should be
possible to just use it for getting the field type names, and not for parsing
the entire type.

TODO: Check that nothing is missing from the export list; only HaskRel's
dependencies are known to be covered.

TODO: New functions that did a tiny bit more than the last ones have been added
haphazardly, clean up this and the users of this.
-}
{-|
Module      : HFWTabulation
Description : Presentation of HList values in a two-dimensional fixed-width font
              form.
Copyright   : © Thor Michael Støre, 2015
License     : GPL v2 without "any later version" clause
Maintainer  : thormichael át gmail døt com
Stability   : experimental

HList fixed-width tabular presentation. Presentation of HList values in a
two-dimensional, tabular fixed-width font form with a header consisting of
labels and optionally types. Only records are supported by this module, see
`TIPFWTabulation` for support for TIPs.
-}
module Database.HaskRel.HFWTabulation (
  HFWPresent ( hfwPrint, hfwPrintTyped, hfwPrintTypedTS ),
  FWPresent ( fwPresent, fwPresentTyped ),
  FWPresent' ( fwPresent', fwPresentTyped' ),
  printHRecSetTab, printHRecSetTabTyped, printHRecSetTabTypedTS,
  showHRecSetTab,
  showTR, showTRTS, showHTypeTS, showHListSetType,
  HFWTIPSet, HFWTIP, HFWRec, HFWString, HFWOther,
  HListTypeSynonym ( hRecTS, hRecSetTS, hTIPTS, hTIPSetTS ), FWPPred,
  HPresentRecAttr(HPresentRecAttr), HPresentTypedRecAttr(HPresentTypedRecAttr)
  ) where

import Data.HList.CommonMain

import Data.Typeable

import Data.Set ( Set, toList )
import Data.List ( intercalate )

import Database.HaskRel.FWTabulation


-- Presentation of table heading

-- data HFWTIPList -- <- TODO. Use ↑ to distinguish them from sets? Not really appropriate, it's not known to be ordered. [] in some fashion?
data HFWTIPSet
data HFWTIP
-- data HFWRecList -- <- TODO
data HFWRecSet
data HFWRec
data HFWString
data HFWOther

type family FWPPred a where
--    FWPPred [ Record a ] = HFWRecList
    FWPPred ( Set ( Record a ) ) = HFWRecSet
    FWPPred ( Record a )         = HFWRec
--    FWPPred [ ( TIP a ) ]    = HFWTIPList
    FWPPred ( Set ( TIP a ) )    = HFWTIPSet
    FWPPred ( TIP a )            = HFWTIP
    FWPPred String               = HFWString
    FWPPred a                    = HFWOther


-- As having no type synonyms in effect
data EmptyTS = EmptyTS

-- | Type synoyms used when building the table header with type names
class HListTypeSynonym s where
  hRecTS :: s -> String
  hRecSetTS :: s -> String
  hTIPTS :: s -> String
  hTIPSetTS :: s -> String

{- TODO: This only supports showing a single type synonym, it doesn't support
showing "Set ( TIP '[Foo] )", for instance. This is sufficient for HaskRel,
which only uses full type synonyms, for instance "Relation '[Foo]".
-}
instance HListTypeSynonym EmptyTS where
  hRecTS _ = "Record"
  hRecSetTS _ = "Set-Record"
  hTIPTS _ = "TIP"
  hTIPSetTS _ = "Set-TIP"


-- | Show a TypeRep
showTR :: TypeRep -> String
showTR = showTRTS EmptyTS

{- TODO: Record presentation is copy'n'paste of TIP presentation, which gives
the unfortunate 'Record '["foo"]'
-}
-- | Show a TypeRep, using the given type synonyms
showTRTS :: HListTypeSynonym ts => ts -> TypeRep -> String
showTRTS ts t
  | t == stringType   = "String"
  | tyCon == recTyCon = hRecTS ts ++ showHListType app
  | tyCon == tipTyCon = hTIPTS ts ++ showHListType app
  | tyCon == setTyCon && typeRepTyCon ( head app ) == recTyCon =
      hRecSetTS ts ++ showHListType ( typeRepArgs $ head app )
  | tyCon == setTyCon && typeRepTyCon ( head app ) == tipTyCon =
      hTIPSetTS ts ++ showHListType ( typeRepArgs $ head app )
  | otherwise         = show t
  where
    ( tyCon, app ) = splitTyConApp t
    stringType = typeRep ( Proxy :: Proxy String )
    -- The argument to Set could be anything that is an instance of Typeable
    setTyCon = typeRepTyCon $ typeRep ( Proxy :: Proxy ( Set Int ) )
    -- listTyCon = ...
    recTyCon = typeRepTyCon $ typeRep ( Proxy :: Proxy ( Record '[] ) )
    tipTyCon = typeRepTyCon $ typeRep ( Proxy :: Proxy ( TIP '[] ) )

showHListSetType :: forall a (r :: [*] -> *) .
    ( Typeable r, Typeable a ) =>
    Set (r a) -> String
showHListSetType = showHListType . typeRepArgs . head . typeRepArgs . typeOf

showHListType :: [TypeRep] -> String
showHListType = (++) " '" . show . hListTypeToTRList

hListTypeToTRList :: [TypeRep] -> [TypeRep]
hListTypeToTRList = parseHListType . typeRepArgs . head

parseHListType :: [TypeRep] -> [TypeRep]
parseHListType [] = []
parseHListType [_] = error "Not a valid TIP/Record type" -- Always come in pairs. Will also fail here if it's not tagged
parseHListType (tr:trx) = head ( typeRepArgs tr ) : parseHListType ( typeRepArgs $ head trx )


-- Meta information

tagFName :: TypeRep -> String
tagFName = tail . init . show . head . typeRepArgs

{-|
>>> hRecFNames $ sno .=. "S1" .*. status .=. 10 .*. emptyRecord
["sno","status"]
-}
hRecFNames :: Typeable a => a -> [String]
hRecFNames = map tagFName . flatHRec

tagQFName :: TypeRep -> String
tagQFName = tagQFNameTS EmptyTS

tagQFNameTS :: HListTypeSynonym ts => ts -> TypeRep -> String
tagQFNameTS ts a = tagFName a ++ " :: " ++ showHTypeTS ts a

{-|
>>> hRecQFNames $ sno .=. "S1" .*. status .=. 10 .*. emptyRecord
["sno :: String","status :: Integer"]
-}
hRecQFNames :: Typeable a => a -> [String]
hRecQFNames = map tagQFName . flatHRec

hRecQFNamesTS :: ( HListTypeSynonym ts, Typeable a ) => ts -> a -> [String]
hRecQFNamesTS ts = map ( tagQFNameTS ts ) . flatHRec

showHTypeTS :: HListTypeSynonym ts => ts -> TypeRep -> String
showHTypeTS ts = showTRTS ts . head . tail . typeRepArgs


{-
>>> typeOf $ sno .=. "S1" .*. status .=. 10 .*. emptyRecord
Record (: * (Tagged Symbol "sno" [Char]) (: * (Tagged Symbol "status" Integer) []))
>>> flatHRec $ sno .=. "S1" .*. status .=. 10 .*. emptyRecord
[Tagged Symbol "sno" [Char],Tagged Symbol "status" Integer]
-}
-- I did this before noticing hEnd, would that in the right location work just as well?
-- TODO: Rewrite to use typeRep and Proxy. (This probably goes for other places too.)
flatHRec :: Typeable a => a -> [TypeRep]
flatHRec = flatHRec' . typeRepArgs . head . typeRepArgs . typeOf

flatHRec' :: [TypeRep] -> [TypeRep]
flatHRec' [] = []
flatHRec' [m] = [m]
flatHRec' (m:mx) = m : flatHRec' ( typeRepArgs $ head mx )


-- Presentation

class HFWPresent r where
    hfwPrint :: r -> IO ()
    hfwPrintTyped :: r -> IO ()
    hfwPrintTyped = hfwPrintTypedTS EmptyTS
    hfwPrintTypedTS :: HListTypeSynonym ts => ts -> r -> IO ()

class Show a => FWPresent a where
    fwPresent      :: a -> [String]
    fwPresentTyped :: a -> [String]

class Show a => FWPresent' flag a where
    fwPresent'      :: flag -> a -> [String]
    fwPresentTyped' :: flag -> a -> [String]


-- Presentation of a non-HList value

instance (FWPPred a ~ flag, FWPresent' flag a) => FWPresent a where
    fwPresent      = fwPresent' ( undefined :: flag )
    fwPresentTyped = fwPresentTyped' ( undefined :: flag )

instance Show a => FWPresent' HFWOther a where
    fwPresent' _ x      = [show x]
    fwPresentTyped' _ x = [show x]

instance FWPresent' HFWString String where
    fwPresent' _ x      = [x]
    fwPresentTyped' _ x = [x]


-- Presentation of a single record

buildHRec
  :: (Typeable r, RecordValues r,
      HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR r) [[String]]) =>
     Record r -> [String]
buildHRec rrTup = present1LineValue ( listPresentRec rrTup ) ( hRecFNames rrTup )

buildHRecTyped
  :: (Typeable r, RecordValues r,
      HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR r) [[String]]) =>
     Record r -> [String]
buildHRecTyped rrTup = present1LineValue ( listPresentTypedRec rrTup ) ( hRecQFNames rrTup )

buildHRecTypedTS
  :: (HListTypeSynonym ts, Typeable r, RecordValues r,
      HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR r) [[String]]) =>
     ts -> Record r -> [String]
buildHRecTypedTS ts rrTup = present1LineValue ( listPresentTypedRec rrTup ) ( hRecQFNamesTS ts rrTup )

listPresentRec :: (RecordValues r,
      HFoldr (Mapcar HPresentRecAttr) [e] (RecordValuesR r) [e]) =>
     Record r -> [e]
listPresentRec = hMapOut HPresentRecAttr . recordValues

listPresentTypedRec :: (RecordValues r,
      HFoldr (Mapcar HPresentTypedRecAttr) [e] (RecordValuesR r) [e]) =>
     Record r -> [e]
listPresentTypedRec = hMapOut HPresentTypedRecAttr . recordValues


data HPresentRecAttr = HPresentRecAttr
instance ([String] ~ stringL, FWPresent' (FWPPred a) a) => 
        ApplyAB HPresentRecAttr a stringL
    where
        applyAB _ = fwPresent

data HPresentTypedRecAttr = HPresentTypedRecAttr
instance ([String] ~ stringL, FWPresent' (FWPPred a) a) => 
        ApplyAB HPresentTypedRecAttr a stringL
    where
        applyAB _ = fwPresentTyped


instance (HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR r) [[String]],
          HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR r) [[String]],
          Typeable r, RecordValues r
          ) =>
         HFWPresent ( Record r )
    where
        hfwPrint = putStrLn . intercalate "\n" . buildHRec
        hfwPrintTyped = putStrLn . intercalate "\n" . buildHRecTyped
        hfwPrintTypedTS ts = putStrLn . intercalate "\n" . buildHRecTypedTS ts


instance ( HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR r) [[String]],
           HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR r) [[String]],
           Typeable r, RecordValues r, ShowComponents r
         ) =>
        FWPresent' HFWRec ( Record r )
  where
    fwPresent' _      = buildHRec
    fwPresentTyped' _ = buildHRecTyped

-- Presentation of a set of records

showHRecSetTab ::
     (Typeable a, RecordValues a,
      HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR a) [[String]]) =>
     Set (Record a) -> String
showHRecSetTab = intercalate "\n" . buildHRecSet

{-
showHRecSetTabTyped = intercalate "\n" . buildHRecSetTyped
showHRecSetTabTypedTS = intercalate "\n" . buildHRecSetTypedTS
-}

-- | Prints a set of HList records in a table format
printHRecSetTab a = putStrLn $ intercalate "\n" $ buildHRecSet a
-- | Prints a set of HList records in a table format, with types in the header
printHRecSetTabTyped a = putStrLn $ intercalate "\n" $ buildHRecSetTyped a
-- | Prints a set of HList records in a table format, with types that use the given type synonyms in the header
printHRecSetTabTypedTS ts a = putStrLn $ intercalate "\n" $ buildHRecSetTypedTS ts a

instance (Typeable a, RecordValues a,
          HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR a) [[String]],
          HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR a) [[String]]) =>
      HFWPresent ( Set ( Record a ) ) where
      hfwPrint = printHRecSetTab
      hfwPrintTyped = printHRecSetTabTyped
      hfwPrintTypedTS = printHRecSetTabTypedTS

instance (Typeable a, RecordValues a, ShowComponents a,
          HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR a) [[String]],
          HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR a) [[String]]) =>
        FWPresent' HFWRecSet ( Set ( Record a ) )
  where
    fwPresent' _      = buildHRecSet
    fwPresentTyped' _ = buildHRecSetTyped

unwrap :: x (Record a) -> Record a
unwrap = undefined

buildHRecSet ::
     (Typeable a, RecordValues a,
      HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR a) [[String]]) =>
     Set (Record a) -> [String]
buildHRecSet rs =
  presentNLineValue ( map listPresentRec $ toList rs ) ( hRecFNames $ unwrap rs )

buildHRecSetTyped ::
     (Typeable a, RecordValues a,
      HFoldr (Mapcar HPresentTypedRecAttr) [[String]] (RecordValuesR a) [[String]]) =>
     Set (Record a) -> [String]
buildHRecSetTyped rs =
  presentNLineValue ( map listPresentTypedRec $ toList rs ) ( hRecQFNames $ unwrap rs )

buildHRecSetTypedTS
  :: (Typeable a, RecordValues a,
      HFoldr
        (Mapcar HPresentTypedRecAttr)
        [[String]]
        (RecordValuesR a)
        [[String]],
      HListTypeSynonym ts) =>
     ts -> Set (Record a) -> [String]
buildHRecSetTypedTS ts rs =
  presentNLineValue ( map listPresentTypedRec $ toList rs ) ( hRecQFNamesTS ts $ unwrap rs )