70 lines
2.8 KiB
Haskell
70 lines
2.8 KiB
Haskell
module Handler.Utils.Table.Pagination.CsvColumnExplanations
|
||
( CsvColumnsExplained(..)
|
||
, genericCsvColumnsExplanations
|
||
) where
|
||
|
||
import Import
|
||
|
||
import qualified Data.Csv as Csv
|
||
import GHC.Generics
|
||
import qualified GHC.Generics as Generics
|
||
|
||
import Language.Haskell.TH
|
||
-- import Language.Haskell.TH.Datatype
|
||
-- import Language.Haskell.TH.Lib
|
||
|
||
import qualified Data.Map as Map
|
||
import qualified Data.ByteString.Char8 as B8
|
||
|
||
|
||
class CsvColumnsExplained csv where
|
||
csvColumnsExplanations :: forall p. p csv -> Map Csv.Name Widget
|
||
csvColumnsExplanations _ = Map.empty
|
||
|
||
genericCsvColumnsExplanations :: forall msg p csv.
|
||
( Generic csv
|
||
, GCsvColumnsExplained (Rep csv)
|
||
, RenderMessage UniWorX msg
|
||
)
|
||
=> Csv.Options
|
||
-> Map Name msg
|
||
-> p csv
|
||
-> Map Csv.Name Widget
|
||
genericCsvColumnsExplanations opts msgMap' _ = Map.mapMaybe (fmap (toWidget <=< ap getMessageRender . pure) . flip Map.lookup msgMap) headerNames
|
||
where
|
||
msgMap :: Map String msg
|
||
msgMap = Map.mapKeys nameBase msgMap'
|
||
headerNames :: Map Csv.Name String
|
||
headerNames = gCsvColumnsExplanations opts $ Generics.from (error "proxy" :: csv)
|
||
|
||
class GCsvColumnsExplained a where
|
||
gCsvColumnsExplanations :: Csv.Options -> a p -> Map Csv.Name String
|
||
|
||
instance GCsvColumnsExplained U1 where
|
||
gCsvColumnsExplanations _ _ = Map.empty
|
||
|
||
instance (GCsvColumnsExplained a, GCsvColumnsExplained b) => GCsvColumnsExplained (a :*: b) where
|
||
gCsvColumnsExplanations opts _ = Map.unionWithKey (\h f1 f2 -> error $ "Column header ‘" ++ B8.unpack h ++ "’ is produced by both ‘" ++ f1 ++ "’ and ‘" ++ f2 ++ "’")
|
||
(gCsvColumnsExplanations opts (error "proxy" :: a p))
|
||
(gCsvColumnsExplanations opts (error "proxy" :: b p))
|
||
|
||
|
||
instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 D c a) where
|
||
gCsvColumnsExplanations opts _ = gCsvColumnsExplanations opts (error "proxy" :: a p)
|
||
|
||
instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 C c a) where
|
||
gCsvColumnsExplanations opts _ = gCsvColumnsExplanations opts (error "proxy" :: a p)
|
||
|
||
-- | Instance to ensure that you cannot derive DefaultOrdered for
|
||
-- constructors without selectors.
|
||
instance GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
|
||
where
|
||
gCsvColumnsExplanations _ _ =
|
||
error "You cannot derive CsvColumnsExplanations for constructors without selectors."
|
||
|
||
instance Selector s => GCsvColumnsExplained (M1 S s a) where
|
||
gCsvColumnsExplanations (Csv.fieldLabelModifier -> f) m
|
||
| null name = error "Cannot derive CsvColumnsExplanations for constructors without selectors"
|
||
| otherwise = Map.singleton (B8.pack $ f name) name
|
||
where name = selName m
|