{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PolyKinds #-} -- For QuantFact {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-operator-whitespace-ext-conflict #-} {-# OPTIONS_GHC -Wno-orphans #-} module Literate.Invoice.HTML where import Data.Time.Format.ISO8601 qualified as Time import Data.Time.LocalTime qualified as Time import Literate.Accounting.Math import Literate.Document qualified as Doc import Literate.Document.HTML import Literate.Document.Type (Block (BlockPara)) import Literate.Invoice.Invoice import Literate.Prelude import Paths_literate_invoice qualified as Self import System.FilePath.Posix (()) import System.FilePath.Posix qualified as File import Text.Blaze.Html5.Attributes qualified as HA import Text.Printf qualified as Printf import Prelude qualified -- import Text.Blaze.Html5 qualified as H class HTMLIOable a where htmlIO :: a -> IO Html instance Doc.ToBlock Address where toBlock addr = do Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["address"] , Doc.blockDivBlock = Doc.Blocks $ fromList [ t & Doc.toBlock | t <- addr & addressText ] <> [ Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["address-bottom"] , Doc.blockDivBlock = [ addr & addressZipCode & Doc.toBlock , addr & addressCity & Doc.toBlock , addr & addressCountry & Doc.toBlock ] } ] } instance Doc.ToBlock Time.LocalTime where toBlock t = t & Time.localDay & Time.iso8601Show & fromString {- instance ToMarkup Address where toMarkup Address{..} = do div ! classes ["address"] $ do forM_ addressText \t -> div $ t & toHtml div ! classes ["address-bottom"] $ do div $ addressZipCode & toHtml div $ addressCity & toHtml div $ addressCountry & toHtml instance ToMarkup (String, Entity) where toMarkup (pos, Entity{..}) = do div ! classes ["entity"] $ do div ! classes ["key-value", "entity-name"] $ do div ! classes ["key"] $ do pos & toHtml ("\x202F:" :: String) & toHtml div ! classes ["value"] $ do entityName & toHtml div ! classes ["entity-address"] $ do entityAddress & toHtml case entitySIREN of Nothing -> return () Just siren -> do div ! classes ["key-value", "entity-siren"] $ do div ! classes ["key"] $ do ("SIREN\x202F:" :: String) & toHtml div ! classes ["value"] $ do siren & toHtml case entityEmail of Nothing -> return () Just email -> do div ! classes ["key-value", "entity-email"] $ do div ! classes ["key"] $ do ("Email\x202F:" :: String) & toHtml div ! classes ["value"] $ do a ! HA.href ("mailto:" <> toValue email) $ do email & toHtml -} instance Doc.ToBlock (String, Entity) where toBlock (pos, ent) = Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["entity"] , Doc.blockDivBlock = [ Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["entity-name"] , Doc.blockDivBlock = [ Doc.BlockDict $ Doc.Dict [ pos & Doc.toInline := ent & entityName & Doc.toBlock ] , Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["entity-address"] , Doc.blockDivBlock = [ent & entityAddress & Doc.toBlock] } ] } , Doc.BlockDict $ Doc.Dict $ mconcat $ [ [ "SIREN" := siren & Doc.toBlock | siren <- ent & entitySIREN & maybeToList ] , -- FixMe: a ! HA.href ("mailto:" <> toValue email) [ "Email" := Doc.InlineLink { Doc.inlineLinkText = email & Doc.toInline , Doc.inlineLinkTarget = Doc.Target $ "mailto:" <> email } & Doc.toBlock | email <- ent & entityEmail & maybeToList ] ] ] } instance (ToMarkup (Quantity qf), UnitShowS unit) => ToMarkup (Amount qf unit) where toMarkup Amount{..} = (amountQuantity & toMarkup) <> (if null unit then "" else "\x202F" <> (unit & toHtml)) where unit = unitShow @unit instance (Doc.ToInline (Quantity qf), UnitShowS unit) => Doc.ToInline (Amount qf unit) where toInline Amount{..} = (amountQuantity & Doc.toInline) <> (if null unit then "" else "\x202F" <> (unit & Doc.toInline)) where unit = unitShow @unit instance (Doc.ToBlock (Quantity qf), QuantFact qf, UnitShowS unit) => Doc.ToBlock (Amount qf unit) where toBlock x = Doc.BlockPara $ x & Doc.toInline instance QuantFact qf => ToMarkup (Quantity qf) where toMarkup qty = do toHtml $ qty & quantityToRatio @qf & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double) & ( `Printf.formatArg` Printf.FieldFormat { fmtAdjust = Nothing , fmtAlternate = False , fmtChar = 'f' , fmtModifiers = "" , fmtPrecision = Just $ quantisationFactor @qf & (Prelude.fromIntegral :: _ -> Double) & Prelude.logBase 10 & Prelude.floor , fmtSign = Nothing , fmtWidth = Nothing } ) & ($ "") instance QuantFact qf => Doc.ToInline (Quantity qf) where toInline qty = Doc.toInline do qty & quantityToRatio @qf & (Prelude.toRational >>> Prelude.fromRational :: Ratio Natural -> Double) & ( `Printf.formatArg` Printf.FieldFormat { fmtAdjust = Nothing , fmtAlternate = False , fmtChar = 'f' , fmtModifiers = "" , fmtPrecision = Just $ quantisationFactor @qf & (Prelude.fromIntegral :: _ -> Double) & Prelude.logBase 10 & Prelude.floor , fmtSign = Nothing , fmtWidth = Nothing } ) & ($ "") instance QuantFact qf => Doc.ToBlock (Quantity qf) where toBlock x = Doc.BlockPara $ x & Doc.toInline instance HTMLIOable (InvoiceId, Invoice) where htmlIO (invId, inv) = do -- FIXME: this absolute path is not portable out of my system dataPath <- Self.getDataDir <&> File.normalise -- paperCSS <- dataPath "styles" "Paper.css" & BS.readFile <&> Text.decodeUtf8 -- invoiceCSS <- dataPath "styles" "Invoice.css" & BS.readFile <&> Text.decodeUtf8 return $ do docTypeHtml do head do title $ "invoice" forM_ ( [ "styles/Document.css" , "styles/Invoice.css" , "styles/List.css" , "styles/Paper.css" , "styles/Table.css" ] & list ) \cssFile -> link ! HA.rel "stylesheet" ! HA.type_ "text/css" ! HA.href (dataPath cssFile & toValue) -- styleCSS $ cssPrintPage pageOrientation pageSize -- styleCSS $ pagesDifficulties & difficultyCSS body do section ! classes ["A4", "portrait", "sheet"] ! styles ["size" := "A4 portrait"] $ toHtml do Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["invoice"] , Doc.blockDivBlock = [ Doc.BlockFlex Doc.flex { Doc.flexDirection = Doc.FlexDirectionColumn , Doc.flexGap = 0.5 & Doc.cm , Doc.flexItems = [ Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = [] , Doc.blockDivBlock = [ Doc.BlockDict $ Doc.Dict [ "Invoice" := invId & Doc.toInline & Doc.BlockPara , "Date" := inv & invoiceCreation & Doc.toBlock ] ] } , Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["invoice-from-to"] , Doc.blockDivBlock = [ Doc.toBlock $ ("Seller" :: String) := inv & invoiceIssuer , Doc.toBlock $ ("Buyer" :: String) := inv & invoiceCustomer ] } , Doc.BlockDiv { Doc.blockDivAnchor = Nothing , Doc.blockDivClasses = ["invoice-details"] , Doc.blockDivBlock = [ Doc.BlockTable Doc.table { Doc.tableTemplate = [ Doc.LengthRelative $ Doc.LengthRelativeMaxContent , Doc.LengthRelative $ 2 & Doc.fr , Doc.LengthRelative $ 1 & Doc.fr , Doc.LengthRelative $ 1 & Doc.fr , Doc.LengthRelative $ 1 & Doc.fr , Doc.LengthRelative $ 1 & Doc.fr , Doc.LengthRelative $ 1 & Doc.fr ] , Doc.tableRowsEvenOdd = True , Doc.tableHeads = Doc.Head { Doc.tableHeadColumns = [ Doc.tableCell{Doc.tableCellContent = "#"} , Doc.tableCell{Doc.tableCellContent = "Description"} , Doc.tableCell{Doc.tableCellContent = "Begin"} , Doc.tableCell{Doc.tableCellContent = "End"} , Doc.tableCell{Doc.tableCellContent = "Rate (excl.\xA0taxes.)"} , Doc.tableCell{Doc.tableCellContent = "Quantity"} , Doc.tableCell{Doc.tableCellContent = "Total (excl.\xA0taxes.)"} ] } & Just , Doc.tableRows = [ Doc.TableRow { tableRowColumns = [ Doc.tableCell { Doc.tableCellContent = itemCount & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationEnd } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemDescription , Doc.tableCellJustify = Doc.JustificationLeft } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemPeriod & periodBegin & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationLeft } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemPeriod & periodEnd & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationLeft } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemRate & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationEnd } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemQuantity & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationEnd } , Doc.tableCell { Doc.tableCellContent = invoiceItem & invoiceItemTotal & Doc.toBlock , Doc.tableCellJustify = Doc.JustificationEnd } ] } | (itemCount, invoiceItem) <- inv & invoiceItems & ol1 ] } ] } , Doc.BlockTable Doc.table { Doc.tableHeads = Just Doc.Head { tableHeadColumns = [ Doc.tableCell{Doc.tableCellContent = "Total quantity"} , Doc.tableCell{Doc.tableCellContent = "Total (excl. taxes)"} ] } , Doc.tableRows = [ Doc.tableRow { Doc.tableRowColumns = [ Doc.tableCell { Doc.tableCellJustify = Doc.JustificationCenter , Doc.tableCellContent = sumAmounts [ itm & invoiceItemQuantity | itm <- inv & invoiceItems ] & fromMaybe 0 & Doc.toBlock } , Doc.tableCell { Doc.tableCellJustify = Doc.JustificationCenter , Doc.tableCellContent = sumAmounts [ itm & invoiceItemTotal | itm <- inv & invoiceItems ] & fromMaybe 0 & Doc.toBlock } ] } ] } , Doc.BlockList $ Doc.List [ case mention of InvoiceMentionTVANonApplicable -> "—" := "TVA non applicable, art. 293 B du code général des impôts" | mention <- inv & invoiceMentions ] ] <&> \blk -> (Doc.flexItem{Doc.flexItemContent = [blk]}) } ] }