src/Literate/Invoice/HTML.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2 {-# LANGUAGE PolyKinds #-}
   3 -- For QuantFact
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# OPTIONS_GHC -Wno-orphans #-}
   6
   7 module Literate.Invoice.HTML where
   8
   9 import Data.Time.Format.ISO8601 qualified as Time
  10 import Data.Time.LocalTime qualified as Time
  11 import Literate.Accounting.Math
  12 import Literate.Document qualified as Doc
  13 import Literate.Document.HTML
  14 import Literate.Document.Type (Block (BlockPara))
  15 import Literate.Invoice.Invoice
  16 import Literate.Prelude
  17 import Paths_literate_invoice qualified as Self
  18 import System.FilePath.Posix ((</>))
  19 import System.FilePath.Posix qualified as File
  20 import Text.Blaze.Html5.Attributes qualified as HA
  21 import Text.Printf qualified as Printf
  22 import Prelude qualified
  23
  24 -- import Text.Blaze.Html5 qualified as H
  25 class HTMLIOable a where
  26   htmlIO :: a -> IO Html
  27
  28 instance ToMarkup Address where
  29   toMarkup Address{..} = do
  30     div ! classes ["address"] $ do
  31       forM_ addressText \t ->
  32         div $ t & toHtml
  33       div ! classes ["address-bottom"] $ do
  34         div $ addressZipCode & toHtml
  35         div $ addressCity & toHtml
  36         div $ addressCountry & toHtml
  37 instance ToMarkup (String, Entity) where
  38   toMarkup (pos, Entity{..}) = do
  39     div ! classes ["entity"] $ do
  40       div ! classes ["key-value", "entity-name"] $ do
  41         div ! classes ["key"] $ do
  42           pos & toHtml
  43           ("\x202F:" :: String) & toHtml
  44         div ! classes ["value"] $ do
  45           entityName & toHtml
  46       div ! classes ["entity-address"] $ do
  47         entityAddress & toHtml
  48       case entitySIREN of
  49         Nothing -> return ()
  50         Just siren -> do
  51           div ! classes ["key-value", "entity-siren"] $ do
  52             div ! classes ["key"] $ do
  53               ("SIREN\x202F:" :: String) & toHtml
  54             div ! classes ["value"] $ do
  55               siren & toHtml
  56       case entityEmail of
  57         Nothing -> return ()
  58         Just email -> do
  59           div ! classes ["key-value", "entity-email"] $ do
  60             div ! classes ["key"] $ do
  61               ("Email\x202F:" :: String) & toHtml
  62             div ! classes ["value"] $ do
  63               a ! HA.href ("mailto:" <> toValue email) $ do
  64                 email & toHtml
  65
  66 instance (ToMarkup (Quantity qf), UnitShowS unit) => ToMarkup (Amount qf unit) where
  67   toMarkup Amount{..} =
  68     (amountQuantity & toMarkup)
  69       <> (if null unit then "" else "\x202F" <> (unit & toHtml))
  70     where
  71       unit = unitShow @unit
  72 instance (Doc.ToInlines (Quantity qf), UnitShowS unit) => Doc.ToInlines (Amount qf unit) where
  73   toInlines Amount{..} =
  74     (amountQuantity & Doc.toInlines)
  75       <> (if null unit then "" else "\x202F" <> (unit & Doc.toInlines))
  76     where
  77       unit = unitShow @unit
  78 instance (Doc.ToBlock (Quantity qf), QuantFact qf, UnitShowS unit) => Doc.ToBlock (Amount qf unit) where
  79   toBlock x = Doc.BlockPara $ x & Doc.toInlines
  80
  81 instance QuantFact qf => ToMarkup (Quantity qf) where
  82   toMarkup qty = do
  83     toHtml $
  84       qty
  85         & quantityToRatio @qf
  86         & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double)
  87         & ( `Printf.formatArg`
  88               Printf.FieldFormat
  89                 { fmtAdjust = Nothing
  90                 , fmtAlternate = False
  91                 , fmtChar = 'f'
  92                 , fmtModifiers = ""
  93                 , fmtPrecision =
  94                     Just $
  95                       quantisationFactor @qf
  96                         & (Prelude.fromIntegral :: _ -> Double)
  97                         & Prelude.logBase 10
  98                         & Prelude.floor
  99                 , fmtSign = Nothing
 100                 , fmtWidth = Nothing
 101                 }
 102           )
 103         & ($ "")
 104 instance QuantFact qf => Doc.ToInlines (Quantity qf) where
 105   toInlines qty = do
 106     Doc.toInlines $
 107       qty
 108         & quantityToRatio @qf
 109         & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double)
 110         & ( `Printf.formatArg`
 111               Printf.FieldFormat
 112                 { fmtAdjust = Nothing
 113                 , fmtAlternate = False
 114                 , fmtChar = 'f'
 115                 , fmtModifiers = ""
 116                 , fmtPrecision =
 117                     Just $
 118                       quantisationFactor @qf
 119                         & (Prelude.fromIntegral :: _ -> Double)
 120                         & Prelude.logBase 10
 121                         & Prelude.floor
 122                 , fmtSign = Nothing
 123                 , fmtWidth = Nothing
 124                 }
 125           )
 126         & ($ "")
 127 instance QuantFact qf => Doc.ToBlock (Quantity qf) where
 128   toBlock x = Doc.BlockPara $ x & Doc.toInlines
 129
 130 instance HTMLIOable (InvoiceId, Invoice) where
 131   htmlIO (invoiceId, invoice@Invoice{..}) = do
 132     -- FIXME: this absolute path is not portable out of my system
 133     dataPath <- Self.getDataDir <&> File.normalise
 134     -- paperCSS <- dataPath </> "styles" </> "Paper.css" & BS.readFile <&> Text.decodeUtf8
 135     -- invoiceCSS <- dataPath </> "styles" </> "Invoice.css" & BS.readFile <&> Text.decodeUtf8
 136     return $ do
 137       docTypeHtml do
 138         head do
 139           title $ "invoice"
 140           forM_
 141             ( [ "styles/Document.css"
 142               , "styles/Paper.css"
 143               , "styles/Table.css"
 144               , "styles/Invoice.css"
 145               ]
 146                 & list
 147             )
 148             \cssFile ->
 149               link
 150                 ! HA.rel "stylesheet"
 151                 ! HA.type_ "text/css"
 152                 ! HA.href (dataPath </> cssFile & toValue)
 153         -- styleCSS $ cssPrintPage pageOrientation pageSize
 154         -- styleCSS $ pagesDifficulties & difficultyCSS
 155         body do
 156           section
 157             ! classes ["A4", "portrait", "sheet"]
 158             ! styles ["size" := "A4 portrait"]
 159             $ do
 160               div ! classes ["invoice"] $ do
 161                 div ! classes ["key-value", "invoice-id"] $ do
 162                   div ! classes ["key"] $ do
 163                     ("Invoice#\x202F:" :: String) & toHtml
 164                   div ! classes ["value"] $ do
 165                     invoiceId & toHtml
 166                 div ! classes ["key-value", "invoice-creation"] $ do
 167                   div ! classes ["key"] $ do
 168                     ("Date\x202F:" :: String) & toHtml
 169                   div ! classes ["value"] $ do
 170                     invoiceCreation & Time.localDay & Time.iso8601Show & toHtml
 171                 div ! classes ["invoice-from-to"] $ do
 172                   div ! classes ["invoice-issuer"] $ do
 173                     toHtml $ ("Seller" :: String) := invoiceIssuer
 174                   div ! classes ["invoice-recipient"] $ do
 175                     toHtml $ ("Buyer" :: String) := invoiceCustomer
 176                 toHtml $
 177                   Doc.BlockFlex
 178                     Doc.flex
 179                       { Doc.flexDirection = Doc.FlexDirectionColumn
 180                       , Doc.flexGap = 0.5 & Doc.cm
 181                       , Doc.flexItems =
 182                           [ Doc.flexItem
 183                               { Doc.flexItemContent =
 184                                   [ Doc.BlockTable
 185                                       Doc.table
 186                                         { Doc.tableTemplate =
 187                                             [ Doc.LengthRelative $ Doc.LengthRelativeMaxContent
 188                                             , Doc.LengthRelative $ 5 & Doc.fr
 189                                             , Doc.LengthRelative $ 1 & Doc.fr
 190                                             , Doc.LengthRelative $ 1 & Doc.fr
 191                                             , Doc.LengthRelative $ 1 & Doc.fr
 192                                             ]
 193                                         , Doc.tableRowsEvenOdd = True
 194                                         , Doc.tableHeads =
 195                                             Doc.Head
 196                                               { Doc.tableHeadColumns =
 197                                                   [ Doc.tableCell{Doc.tableCellContent = "#"}
 198                                                   , Doc.tableCell{Doc.tableCellContent = "Description"}
 199                                                   , Doc.tableCell{Doc.tableCellContent = "Rate (excl.\xA0taxes.)"}
 200                                                   , Doc.tableCell{Doc.tableCellContent = "Quantity"}
 201                                                   , Doc.tableCell{Doc.tableCellContent = "Total (excl.\xA0taxes.)"}
 202                                                   ]
 203                                               }
 204                                               & Just
 205                                         , Doc.tableRows =
 206                                             [ Doc.TableRow
 207                                               { tableRowColumns =
 208                                                   [ Doc.tableCell
 209                                                       { Doc.tableCellContent = itemCount & Doc.toBlock
 210                                                       , Doc.tableCellJustify = Doc.JustificationEnd
 211                                                       }
 212                                                   , Doc.tableCell
 213                                                       { Doc.tableCellContent = invoiceItem & invoiceItemDescription & Doc.toBlock
 214                                                       , Doc.tableCellJustify = Doc.JustificationLeft
 215                                                       }
 216                                                   , Doc.tableCell
 217                                                       { Doc.tableCellContent = invoiceItem & invoiceItemRate & Doc.toBlock
 218                                                       , Doc.tableCellJustify = Doc.JustificationEnd
 219                                                       }
 220                                                   , Doc.tableCell
 221                                                       { Doc.tableCellContent = invoiceItem & invoiceItemQuantity & Doc.toBlock
 222                                                       , Doc.tableCellJustify = Doc.JustificationEnd
 223                                                       }
 224                                                   , Doc.tableCell
 225                                                       { Doc.tableCellContent = invoiceItem & invoiceItemTotal & Doc.toBlock
 226                                                       , Doc.tableCellJustify = Doc.JustificationEnd
 227                                                       }
 228                                                   ]
 229                                               }
 230                                             | (itemCount, invoiceItem) <- invoiceItems & ol1
 231                                             ]
 232                                         }
 233                                   ]
 234                               }
 235                           , Doc.flexItem
 236                               { Doc.flexItemContent =
 237                                   [ Doc.BlockTable
 238                                       Doc.table
 239                                         { Doc.tableHeads =
 240                                             Just
 241                                               Doc.Head
 242                                                 { tableHeadColumns =
 243                                                     [ Doc.tableCell{Doc.tableCellContent = "Total quantity"}
 244                                                     , Doc.tableCell{Doc.tableCellContent = "Total (excl. taxes)"}
 245                                                     ]
 246                                                 }
 247                                         , Doc.tableRows =
 248                                             [ Doc.tableRow
 249                                                 { Doc.tableRowColumns =
 250                                                     [ Doc.tableCell
 251                                                         { Doc.tableCellJustify = Doc.JustificationCenter
 252                                                         , Doc.tableCellContent =
 253                                                             sumAmounts
 254                                                               [ itm & invoiceItemQuantity
 255                                                               | itm <- invoiceItems
 256                                                               ]
 257                                                               & fromMaybe 0
 258                                                               & Doc.toBlock
 259                                                         }
 260                                                     , Doc.tableCell
 261                                                         { Doc.tableCellJustify = Doc.JustificationCenter
 262                                                         , Doc.tableCellContent =
 263                                                             sumAmounts
 264                                                               [ itm & invoiceItemTotal
 265                                                               | itm <- invoiceItems
 266                                                               ]
 267                                                               & fromMaybe 0
 268                                                               & Doc.toBlock
 269                                                         }
 270                                                     ]
 271                                                 }
 272                                             ]
 273                                         }
 274                                   ]
 275                               }
 276                           ]
 277                       }