src/Literate/Invoice/HTML.hs

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