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.Invoice.Invoice
  15 import Literate.Prelude
  16 import Paths_literate_invoice qualified as Self
  17 import System.FilePath.Posix ((</>))
  18 import System.FilePath.Posix qualified as File
  19 import Text.Blaze.Html5.Attributes qualified as HA
  20 import Text.Printf qualified as Printf
  21 import Prelude qualified
  22
  23 -- import Text.Blaze.Html5 qualified as H
  24 class HTMLIOable a where
  25   htmlIO :: a -> IO Html
  26
  27 instance Doc.ToBlock Address where
  28   toBlock addr = do
  29     Doc.classes
  30       ["address"]
  31       $ Doc.Blocks
  32       $ fromList
  33         [ t & Doc.toBlock
  34         | t <- addr & addressText
  35         ]
  36         <> [ Doc.classes
  37                ["address-bottom"]
  38                [ addr & addressZipCode & Doc.toBlock
  39                , addr & addressCity & Doc.toBlock
  40                , addr & addressCountry & Doc.toBlock
  41                ]
  42            ]
  43
  44 instance Doc.ToBlock Time.LocalTime where
  45   toBlock t = t & Time.localDay & Time.iso8601Show & fromString
  46
  47 {-
  48 instance ToMarkup Address where
  49   toMarkup Address{..} = do
  50     div ! classes ["address"] $ do
  51       forM_ addressText \t ->
  52         div $ t & toHtml
  53       div ! classes ["address-bottom"] $ do
  54         div $ addressZipCode & toHtml
  55         div $ addressCity & toHtml
  56         div $ addressCountry & toHtml
  57 instance ToMarkup (String, Entity) where
  58   toMarkup (pos, Entity{..}) = do
  59     div ! classes ["entity"] $ do
  60       div ! classes ["key-value", "entity-name"] $ do
  61         div ! classes ["key"] $ do
  62           pos & toHtml
  63           ("\x202F:" :: String) & toHtml
  64         div ! classes ["value"] $ do
  65           entityName & toHtml
  66       div ! classes ["entity-address"] $ do
  67         entityAddress & toHtml
  68       case entitySIREN of
  69         Nothing -> return ()
  70         Just siren -> do
  71           div ! classes ["key-value", "entity-siren"] $ do
  72             div ! classes ["key"] $ do
  73               ("SIREN\x202F:" :: String) & toHtml
  74             div ! classes ["value"] $ do
  75               siren & toHtml
  76       case entityEmail of
  77         Nothing -> return ()
  78         Just email -> do
  79           div ! classes ["key-value", "entity-email"] $ do
  80             div ! classes ["key"] $ do
  81               ("Email\x202F:" :: String) & toHtml
  82             div ! classes ["value"] $ do
  83               a ! HA.href ("mailto:" <> toValue email) $ do
  84                 email & toHtml
  85 -}
  86 instance Doc.ToBlock (String, Entity) where
  87   toBlock (pos, ent) =
  88     Doc.classes
  89       ["entity"]
  90       [ Doc.div
  91           { Doc.divClasses = ["entity-name"]
  92           , Doc.divBlock =
  93               [ Doc.Dict
  94                   [ pos & Doc.toInline := ent & entityName & Doc.toBlock
  95                   ]
  96                   & Doc.toBlock
  97               , Doc.div
  98                   { Doc.divClasses = ["entity-address"]
  99                   , Doc.divBlock = [ent & entityAddress & Doc.toBlock]
 100                   }
 101                   & Doc.toBlock
 102               ]
 103           }
 104           & Doc.toBlock
 105       , Doc.Dict
 106           ( mconcat $
 107               [ [ "SIREN" := siren & Doc.toBlock
 108                 | siren <- ent & entitySIREN & maybeToList
 109                 ]
 110               , -- FixMe: a ! HA.href ("mailto:" <> toValue email)
 111                 [ "Email" :=
 112                     Doc.InlineLink
 113                       { Doc.inlineLinkText = email & Doc.toInline
 114                       , Doc.inlineLinkTarget = Doc.Target $ "mailto:" <> email
 115                       }
 116                       & Doc.toBlock
 117                 | email <- ent & entityEmail & maybeToList
 118                 ]
 119               ]
 120           )
 121           & Doc.toBlock
 122       ]
 123
 124 instance (ToMarkup (Quantity qf), UnitShowS unit) => ToMarkup (Amount qf unit) where
 125   toMarkup Amount{..} =
 126     (amountQuantity & toMarkup)
 127       <> (if null unit then "" else "\x202F" <> (unit & toHtml))
 128     where
 129       unit = unitShow @unit
 130 instance (Doc.ToInline (Quantity qf), UnitShowS unit) => Doc.ToInline (Amount qf unit) where
 131   toInline Amount{..} =
 132     (amountQuantity & Doc.toInline)
 133       <> (if null unit then "" else "\x202F" <> (unit & Doc.toInline))
 134     where
 135       unit = unitShow @unit
 136 instance (Doc.ToBlock (Quantity qf), QuantFact qf, UnitShowS unit) => Doc.ToBlock (Amount qf unit) where
 137   toBlock x = Doc.BlockPara $ x & Doc.toInline
 138
 139 instance QuantFact qf => ToMarkup (Quantity qf) where
 140   toMarkup qty = do
 141     toHtml $
 142       qty
 143         & quantityToRatio @qf
 144         & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double)
 145         & ( `Printf.formatArg`
 146               Printf.FieldFormat
 147                 { fmtAdjust = Nothing
 148                 , fmtAlternate = False
 149                 , fmtChar = 'f'
 150                 , fmtModifiers = ""
 151                 , fmtPrecision =
 152                     Just $
 153                       quantisationFactor @qf
 154                         & (Prelude.fromIntegral :: _ -> Double)
 155                         & Prelude.logBase 10
 156                         & Prelude.floor
 157                 , fmtSign = Nothing
 158                 , fmtWidth = Nothing
 159                 }
 160           )
 161         & ($ "")
 162 instance QuantFact qf => Doc.ToInline (Quantity qf) where
 163   toInline qty = Doc.toInline do
 164     qty
 165       & quantityToRatio @qf
 166       & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double)
 167       & ( `Printf.formatArg`
 168             Printf.FieldFormat
 169               { fmtAdjust = Nothing
 170               , fmtAlternate = False
 171               , fmtChar = 'f'
 172               , fmtModifiers = ""
 173               , fmtPrecision =
 174                   Just $
 175                     quantisationFactor @qf
 176                       & (Prelude.fromIntegral :: _ -> Double)
 177                       & Prelude.logBase 10
 178                       & Prelude.floor
 179               , fmtSign = Nothing
 180               , fmtWidth = Nothing
 181               }
 182         )
 183       & ($ "")
 184 instance QuantFact qf => Doc.ToBlock (Quantity qf) where
 185   toBlock x = Doc.BlockPara $ x & Doc.toInline
 186
 187 instance HTMLIOable (InvoiceId, Invoice) where
 188   htmlIO (invId, inv) = do
 189     -- FIXME: this absolute path is not portable out of my system
 190     dataPath <- Self.getDataDir <&> File.normalise
 191     -- paperCSS <- dataPath </> "styles" </> "Paper.css" & BS.readFile <&> Text.decodeUtf8
 192     -- invoiceCSS <- dataPath </> "styles" </> "Invoice.css" & BS.readFile <&> Text.decodeUtf8
 193     return $ do
 194       docTypeHtml do
 195         head do
 196           title $ "invoice"
 197           forM_
 198             ( [ "styles/Document.css"
 199               , "styles/Invoice.css"
 200               , "styles/List.css"
 201               , "styles/Paper.css"
 202               , "styles/Table.css"
 203               ]
 204                 & list
 205             )
 206             \cssFile ->
 207               link
 208                 ! HA.rel "stylesheet"
 209                 ! HA.type_ "text/css"
 210                 ! HA.href (dataPath </> cssFile & toValue)
 211         -- styleCSS $ cssPrintPage pageOrientation pageSize
 212         -- styleCSS $ pagesDifficulties & difficultyCSS
 213         body do
 214           section
 215             ! classes ["A4", "portrait", "sheet"]
 216             ! styles ["size" := "A4 portrait"]
 217             $ toHtml do
 218               Doc.classes
 219                 ["invoice"]
 220                 [ Doc.flex
 221                     { Doc.flexDirection = Doc.FlexDirectionColumn
 222                     , Doc.flexGap = 0.5 & Doc.cm
 223                     , Doc.flexItems =
 224                         [ Doc.Dict
 225                             [ "Invoice" := invId & Doc.toInline & Doc.BlockPara
 226                             , "IssueDate" := inv & invoiceCreation & Doc.toBlock
 227                             ]
 228                             & Doc.toBlock
 229                         , Doc.classes
 230                             ["invoice-from-to"]
 231                             [ Doc.toBlock $ ("Seller" :: String) := inv & invoiceIssuer
 232                             , Doc.toBlock $ ("Buyer" :: String) := inv & invoiceCustomer
 233                             ]
 234                         , Doc.classes
 235                             ["invoice-details"]
 236                             [ Doc.table
 237                                 { Doc.tableTemplate =
 238                                     [ Doc.LengthRelative $ Doc.LengthRelativeMaxContent
 239                                     , Doc.LengthRelative $ 2 & Doc.fr
 240                                     , Doc.LengthRelative $ 1 & Doc.fr
 241                                     , Doc.LengthRelative $ 1 & Doc.fr
 242                                     , Doc.LengthRelative $ 1 & Doc.fr
 243                                     , Doc.LengthRelative $ 1 & Doc.fr
 244                                     , Doc.LengthRelative $ 1 & Doc.fr
 245                                     ]
 246                                 , Doc.tableRowsEvenOdd = True
 247                                 , Doc.tableHeads =
 248                                     Just
 249                                       [ Doc.tableCell{Doc.tableCellContent = "#"}
 250                                       , Doc.tableCell{Doc.tableCellContent = "Description"}
 251                                       , Doc.tableCell{Doc.tableCellContent = "Begin"}
 252                                       , Doc.tableCell{Doc.tableCellContent = "End"}
 253                                       , Doc.tableCell{Doc.tableCellContent = "Rate (excl.\xA0taxes.)"}
 254                                       , Doc.tableCell{Doc.tableCellContent = "Quantity"}
 255                                       , Doc.tableCell{Doc.tableCellContent = "Total (excl.\xA0taxes.)"}
 256                                       ]
 257                                 , Doc.tableRows =
 258                                     [ [ Doc.tableCell
 259                                           { Doc.tableCellContent = itemCount & Doc.toBlock
 260                                           , Doc.tableCellJustify = Doc.JustificationEnd
 261                                           }
 262                                       , Doc.tableCell
 263                                           { Doc.tableCellContent = invoiceItem & invoiceItemDescription
 264                                           , Doc.tableCellJustify = Doc.JustificationLeft
 265                                           }
 266                                       , Doc.tableCell
 267                                           { Doc.tableCellContent = invoiceItem & invoiceItemPeriod & periodBegin & Doc.toBlock
 268                                           , Doc.tableCellJustify = Doc.JustificationLeft
 269                                           }
 270                                       , Doc.tableCell
 271                                           { Doc.tableCellContent = invoiceItem & invoiceItemPeriod & periodEnd & Doc.toBlock
 272                                           , Doc.tableCellJustify = Doc.JustificationLeft
 273                                           }
 274                                       , Doc.tableCell
 275                                           { Doc.tableCellContent = invoiceItem & invoiceItemRate & Doc.toBlock
 276                                           , Doc.tableCellJustify = Doc.JustificationEnd
 277                                           }
 278                                       , Doc.tableCell
 279                                           { Doc.tableCellContent = invoiceItem & invoiceItemQuantity & Doc.toBlock
 280                                           , Doc.tableCellJustify = Doc.JustificationEnd
 281                                           }
 282                                       , Doc.tableCell
 283                                           { Doc.tableCellContent = invoiceItem & invoiceItemTotal & Doc.toBlock
 284                                           , Doc.tableCellJustify = Doc.JustificationEnd
 285                                           }
 286                                       ]
 287                                     | (itemCount, invoiceItem) <- inv & invoiceItems & ol1
 288                                     ]
 289                                 }
 290                                 & Doc.toBlock
 291                             ]
 292                         , Doc.table
 293                             { Doc.tableHeads =
 294                                 Just
 295                                   [ Doc.tableCell{Doc.tableCellContent = "Total quantity"}
 296                                   , Doc.tableCell{Doc.tableCellContent = "Total (excl. taxes)"}
 297                                   ]
 298                             , Doc.tableRows =
 299                                 [
 300                                   [ Doc.tableCell
 301                                       { Doc.tableCellJustify = Doc.JustificationCenter
 302                                       , Doc.tableCellContent =
 303                                           sumAmounts
 304                                             [ itm & invoiceItemQuantity
 305                                             | itm <- inv & invoiceItems
 306                                             ]
 307                                             & fromMaybe 0
 308                                             & Doc.toBlock
 309                                       }
 310                                   , Doc.tableCell
 311                                       { Doc.tableCellJustify = Doc.JustificationCenter
 312                                       , Doc.tableCellContent =
 313                                           sumAmounts
 314                                             [ itm & invoiceItemTotal
 315                                             | itm <- inv & invoiceItems
 316                                             ]
 317                                             & fromMaybe 0
 318                                             & Doc.toBlock
 319                                       }
 320                                   ]
 321                                 ]
 322                             }
 323                             & Doc.toBlock
 324                         , Doc.List
 325                             [ case mention of
 326                                 InvoiceMentionTVANonApplicable ->
 327                                   "—" := "TVA non applicable, art. 293 B du code général des impôts"
 328                             | mention <- inv & invoiceMentions
 329                             ]
 330                             & Doc.toBlock
 331                         ]
 332                           <&> \blk -> (Doc.flexItem{Doc.flexItemContent = [blk]})
 333                     }
 334                     & Doc.toBlock
 335                 ]