From 883542787701e6f6feaa8817fd0c9529affb292e Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 30 Nov 2025 08:32:48 +0100 Subject: [PATCH] WIP --- data/styles/Document.css | 3 + data/styles/Invoice.css | 207 +++++++++++++ data/styles/Paper.css | 44 +++ data/styles/Table.css | 45 +++ flake.lock | 87 ++++++ flake.nix | 14 +- literate-invoice.cabal | 143 +++++++++ src/Literate/Accounting/Math.hs | 485 ++++++++++++++++++++++++++++++ src/Literate/Document.hs | 8 + src/Literate/Document/HTML.hs | 197 ++++++++++++ src/Literate/Document/Table.hs | 41 +++ src/Literate/Document/Type.hs | 170 +++++++++++ src/Literate/Invoice/HTML.hs | 277 +++++++++++++++++ src/Literate/Invoice/Invoice.hs | 74 +++++ src/Literate/Prelude.hs | 381 +++++++++++++++++++++++ src/Literate/Rebindable.hs | 146 +++++++++ src/Literate/Time.hs | 85 ++++++ tests/Tests.hs | 15 + tests/Tests/Entity.hs | 42 +++ tests/Tests/Invoice.hs | 68 +++++ tests/Tests/Invoice/ent2inv1.html | 2 + tests/Tests/Utils/Tests.hs | 26 ++ 22 files changed, 2553 insertions(+), 7 deletions(-) create mode 100644 data/styles/Document.css create mode 100644 data/styles/Invoice.css create mode 100644 data/styles/Paper.css create mode 100644 data/styles/Table.css create mode 100644 flake.lock create mode 100644 literate-invoice.cabal create mode 100644 src/Literate/Accounting/Math.hs create mode 100644 src/Literate/Document.hs create mode 100644 src/Literate/Document/HTML.hs create mode 100644 src/Literate/Document/Table.hs create mode 100644 src/Literate/Document/Type.hs create mode 100644 src/Literate/Invoice/HTML.hs create mode 100644 src/Literate/Invoice/Invoice.hs create mode 100644 src/Literate/Prelude.hs create mode 100644 src/Literate/Rebindable.hs create mode 100644 src/Literate/Time.hs create mode 100644 tests/Tests.hs create mode 100644 tests/Tests/Entity.hs create mode 100644 tests/Tests/Invoice.hs create mode 100644 tests/Tests/Invoice/ent2inv1.html create mode 100644 tests/Tests/Utils/Tests.hs diff --git a/data/styles/Document.css b/data/styles/Document.css new file mode 100644 index 0000000..48e116e --- /dev/null +++ b/data/styles/Document.css @@ -0,0 +1,3 @@ +p { + margin:0 0; +} diff --git a/data/styles/Invoice.css b/data/styles/Invoice.css new file mode 100644 index 0000000..fe3309b --- /dev/null +++ b/data/styles/Invoice.css @@ -0,0 +1,207 @@ +.invoice { + margin:4em 4em; +} +.invoice-from-to { + display:grid; + gap:5ex; + grid-template-columns:1fr 1fr; + margin-top:2ex; +} +.invoice-issuer { + display:grid; +} +.invoice-recipient { + display:grid; +} +.entity { + border:1px solid black; + padding:0.5ex 1ex; + gap:1px; + display:flex; + flex-direction:column; + justify-spacing:begin; +} +.entity > div { + padding:0.5ex 0; +} +.entity-name { +} +.entity-address { + border-top:1px solid black; +} +.entity .key-value:first-child { + border-top:0; +} +.entity .key-value { + border-top:1px solid black; +} + +.address { + //display:grid; + display:grid; + grid-template-columns:1fr; + //grid-template-rows:1fr 5fr; + //grid-template-columns:subgrid; + //grid-template-rows:subgrid; + align-items:end; + justify-items:end; +} +.address > div { + //grid-column:1 / span 3; + //align-items:center; + //justify-items:center; +} +.address .address-bottom { + display:flex; + flex-direction:row; + //grid-template-columns:1fr 1fr 1fr; + justify-items:spacing-around; + align-items:center; + //grid-template-columns:subgrid; + //grid-template-rows:subgrid; + gap:1ex; + //grid-column-start:1; + //grid-column-end:4; +} +.key-value { + display:flex; + flex-direction:row; + justify-items:space-between; + align-items:baseline; + //grid-template-columns:1fr 3fr; + gap:1ex; + //border-top:1px solid black; +} +.key-value .key { + //justify-self:end; + font-weight:bold; +} +.key-value .value { + //justify-self:begin; +} + + + +.invoice-items { + display:grid; + grid-template-columns:max-content 5fr 1fr 1fr 1fr; + margin-top:2ex; + background:black; + gap:2px 2px; +} +.invoice-items-head { + display:grid; + font-weight:bold; + grid-template-columns:subgrid; + grid-template-rows:subgrid; + grid-column-start:1; + grid-column-end:-1; + //background-color:white; + //gap:0; +} +.invoice-items-head .invoice-items-item { + //background:#ccc; + //background-color:#eeee00; + background-color:#F6CD93; + //background-color:#57ADC3; + //background-clip:text; + //border-top:1px solid black; + //border-left:1px solid black; + //border-right:1px solid black; + //border-top-left-radius:2ex; + //border-top-right-radius:2ex; + + padding-left:2ex; + padding-right:2ex; + padding-top:1ex; + padding-bottom:0.5ex; +} +//.invoice-items-head .invoice-items-item:after { +// position:absolute; +// display:block; +// content:''; +// right:0; +// bottom:0; +// height:50%; +// box-sizing:border-box; +// width:100%; +// border-bottom:1px solid black; +//} + +.invoice-items-body { + display:grid; + grid-template-columns:subgrid; + grid-template-rows:subgrid; + grid-column-start:1; + grid-column-end:-1; +} +.invoice-items-body.odd .invoice-items-item { + //background:#DBE7D4; +} +.invoice-items-body.even .invoice-items-item { + background:#E9F1E7; +} +.invoice-items-tail { + display:grid; + grid-template-columns:subgrid; + grid-template-rows:subgrid; + grid-column-start:1; + grid-column-end:-1; + background-color:white; + gap:0; +} +.invoice-items-item { + justify-self:stretch; + align-self:stretch; + background:white; + padding:1ex 1ex; +} +.invoice-items-head .invoice-items-item { + //align-self:end; + text-align:center; + display:grid; +} +.invoice-items-head .invoice-items-item > div { + align-self:center; +} +.invoice-items-body .invoice-items-item { + display:grid; +} +.invoice-items-body .invoice-items-item.invoice-items-item-Name > div { + justify-self:stretch; +} +.invoice-items-body .invoice-items-item > div { + align-self:center; + justify-self:end; +} +.invoice-items-body .invoice-items-item-Name { + text-align:left; +} +.invoice-items-tail .invoice-items-item { + text-align:right; + background-color:#ccc; + border-bottom-left-radius:2ex; + border-bottom-right-radius:2ex; +} +.invoice-items-item-Name { + text-align:justify; +} +.invoice-items-tail .invoice-items-item-Totals { + font-weight:bold; + grid-column:span 3; + background-color:white; +} + +.invoice-items-item { +} +.invoice-items-tail .invoice-items-item-Sum { + background-color:black; + color:white; + font-weight:bold; + //border:1ex solid white; + //border-radius:1ex; + //margin:0.5ex 0.4ex 0.7ex; + //padding:0.5ex 0.6ex 0.3ex; +} + + diff --git a/data/styles/Paper.css b/data/styles/Paper.css new file mode 100644 index 0000000..059c0a9 --- /dev/null +++ b/data/styles/Paper.css @@ -0,0 +1,44 @@ +body { margin:0; } +@page { margin:0; } +.sheet { + overflow:hidden; + position:relative; + box-sizing:border-box; + page-break-after:always; +} + +/** Paper sizes **/ +.sheet.A3 { width: 297mm; height: 419mm } +.sheet.A3.landscape { width: 420mm; height: 296mm } +.sheet.A4 { width: 210mm; height: 296mm } +.sheet.A4.landscape { width: 297mm; height: 209mm } +.sheet.A4plus { width: 240mm; height: 320mm } +.sheet.A4plus.landscape { width: 320mm; height: 240mm } +.sheet.A5 { width: 148mm; height: 209mm } +.sheet.A5.landscape { width: 210mm; height: 147mm } +.sheet.letter { width: 216mm; height: 279mm } +.sheet.letter.landscape { width: 280mm; height: 215mm } +.sheet.legal { width: 216mm; height: 356mm } +.sheet.legal.landscape { width: 357mm; height: 215mm } + +/** For screen preview **/ +@media screen { + body { background:#e0e0e0 } + .sheet { + background:white; + box-shadow:0 .5mm 2mm rgba(0,0,0,.3); + margin:5mm auto !important; + } +} + +/** Fix for Chrome issue #273306 +@media print { + body.A3.landscape { width: 420mm } + body.A3, body.A4.landscape { width: 297mm } + body.A4, body.A5.landscape { width: 210mm } + body.A5 { width: 148mm } + body.letter, body.legal { width: 216mm } + body.letter.landscape { width: 280mm } + body.legal.landscape { width: 357mm } +} +**/ diff --git a/data/styles/Table.css b/data/styles/Table.css new file mode 100644 index 0000000..0f68c21 --- /dev/null +++ b/data/styles/Table.css @@ -0,0 +1,45 @@ +.table { + display:grid; + background-color:white; + background:black; + gap:2px 2px; +} +.table-head { + display:grid; + font-weight:bold; + grid-template-columns:subgrid; + grid-template-rows:subgrid; + grid-column-start:1; + grid-column-end:-1; + //gap:0; +} +.table-body { + display:grid; + grid-template-columns:subgrid; + grid-template-rows:subgrid; + grid-column-start:1; + grid-column-end:-1; +} +.table-head .table-cell { +} +.table-cell { + display:grid; + align-self:stretch; + background-color:white; + justify-self:stretch; + padding:1ex 1ex; +} +.table-cell > div { + align-self:center; + justify-self:center; + //text-align:center; +} +.table-head .table-cell { + background-color:#F6CD93; +} +.table-body.odd .table-cell { + //background:#DBE7D4; +} +.table-body.even .table-cell { + background:#E9F1E7; +} diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..3add11e --- /dev/null +++ b/flake.lock @@ -0,0 +1,87 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1761588595, + "narHash": "sha256-XKUZz9zewJNUj46b4AJdiRZJAvSZ0Dqj2BNfXvFlJC4=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "f387cd2afec9419c8ee37694406ca490c3f34ee5", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "git-hooks": { + "inputs": { + "flake-compat": "flake-compat", + "gitignore": "gitignore", + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1763988335, + "narHash": "sha256-QlcnByMc8KBjpU37rbq5iP7Cp97HvjRP0ucfdh+M4Qc=", + "owner": "cachix", + "repo": "git-hooks.nix", + "rev": "50b9238891e388c9fdc6a5c49e49c42533a1b5ce", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "git-hooks.nix", + "type": "github" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "git-hooks", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1709087332, + "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1755704039, + "narHash": "sha256-gKlP0LbyJ3qX0KObfIWcp5nbuHSb5EHwIvU6UcNBg2A=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "9cb344e96d5b6918e94e1bca2d9f3ea1e9615545", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "9cb344e96d5b6918e94e1bca2d9f3ea1e9615545", + "type": "github" + } + }, + "root": { + "inputs": { + "git-hooks": "git-hooks", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix index 83d48dd..194d892 100644 --- a/flake.nix +++ b/flake.nix @@ -6,10 +6,10 @@ nixpkgs.url = "github:NixOS/nixpkgs/9cb344e96d5b6918e94e1bca2d9f3ea1e9615545"; git-hooks.url = "github:cachix/git-hooks.nix"; git-hooks.inputs.nixpkgs.follows = "nixpkgs"; - really-safe-money = { - url = "github:NorfairKing/really-safe-money"; - flake = false; - }; + # really-safe-money = { + # url = "github:NorfairKing/really-safe-money"; + # flake = false; + # }; }; outputs = inputs: @@ -59,9 +59,9 @@ with finalPkgs.haskell.lib; finalHaskellPkgs: previousHaskellPkgs: { ${pkg} = buildFromSdist (finalHaskellPkgs.callCabal2nix pkg fileInputs { }); - really-safe-money = - finalHaskellPkgs.callCabal2nix "really-safe-money" "${inputs.really-safe-money}/really-safe-money" - { }; + # really-safe-money = + # finalHaskellPkgs.callCabal2nix "really-safe-money" "${inputs.really-safe-money}/really-safe-money" + # { }; } ); }) diff --git a/literate-invoice.cabal b/literate-invoice.cabal new file mode 100644 index 0000000..d8d640e --- /dev/null +++ b/literate-invoice.cabal @@ -0,0 +1,143 @@ +cabal-version: 3.0 +name: literate-invoice +maintainer: Julien Moutinho +bug-reports: + https://radicle.sourcephile.fr/nodes/radicle-mermet.sourcephile.fr/rad:XXXXXXXXXXXXXXXXXXXXXXXXXXXXX/issues + +homepage: + https://radicle.sourcephile.fr/nodes/radicle-mermet.sourcephile.fr/rad:XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +author: Julien Moutinho +copyright: Julien Moutinho + +-- PVP: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.0.0.20251129 +stability: experimental +category: Literate Invoice +synopsis: Literate Invoice +description: Literate Invoice +build-type: Simple +tested-with: GHC ==9.6.6 +extra-doc-files: +extra-tmp-files: +data-dir: data + +source-repository head + type: git + location: + https://radicle-mermet.sourcephile.fr/XXXXXXXXXXXXXXXXXXXXXXXXXXXXX.git + +source-repository head + type: rad + location: rad://XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +common haskell + default-language: Haskell2010 + default-extensions: + BangPatterns + BlockArguments + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + RecordWildCards + RoleAnnotations + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + RebindableSyntax + + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wno-partial-fields -fprint-potential-instances + -Wno-missing-signatures -Wno-unused-do-bind + -Wno-partial-type-signatures + +common library-deps + import: + build-depends: + , base >=4.10 && <5 + , blaze-builder + , blaze-html + , blaze-markup + , bytestring + , containers + , filepath + , pretty-simple + , text >=2.1 + , text-short + , time + , transformers + , validity + , monad-classes + +library + import: haskell, library-deps + hs-source-dirs: src + autogen-modules: Paths_literate_invoice + exposed-modules: + Literate.Accounting.Math + Literate.Invoice.Invoice + Literate.Document + Literate.Document.Type + Literate.Document.Table + Literate.Document.HTML + Literate.Invoice.HTML + Literate.Time + Literate.Prelude + Literate.Rebindable + + other-modules: Paths_literate_invoice + build-depends: base >=4.10 && <5 + +test-suite literate-invoice-tests + import: haskell, library-deps + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + + -- ExplanationNote: manual listing gives more control + -- especially to quickly comment-out some tests. + -- build-tool-depends: sydtest-discover:sydtest-discover + ghc-options: -threaded -rtsopts -with-rtsopts=-N + autogen-modules: Paths_literate_invoice + other-modules: + Paths_literate_invoice + Tests.Entity + Tests.Invoice + Tests.Utils.Tests + + build-depends: + , filepath + , genvalidity + , genvalidity-containers + , genvalidity-sydtest + , genvalidity-text + , genvalidity-time + , pretty-simple + , relude + , sydtest >=0.19 + , validity + , validity-containers + , validity-text + , literate-invoice + diff --git a/src/Literate/Accounting/Math.hs b/src/Literate/Accounting/Math.hs new file mode 100644 index 0000000..7533006 --- /dev/null +++ b/src/Literate/Accounting/Math.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} + +module Literate.Accounting.Math where + +import Control.Applicative (Applicative (..)) +import Control.Exception (Exception, throw) +import Control.Monad.Classes qualified as MC +import Control.Monad.Classes.Run qualified as MC +import Control.Monad.Trans.Except as MT +import Control.Monad.Trans.Reader as MT +import Data.Bool +import Data.Data (Data) +import Data.Either (Either (..), either) +import Data.Eq (Eq (..)) +import Data.Foldable (Foldable, foldl') +import Data.Function (flip, id, ($), (.)) +import Data.Functor ((<$>)) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (Maybe (..)) +import Data.Monoid (Endo (..)) +import Data.Ord (Ord (..), Ordering (..)) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Rational) +import Data.String (String) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Word +import GHC.Generics (Generic) +import GHC.Real (FractionalExponentBase (Base10), Ratio ((:%)), (%)) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, Nat, Symbol, natVal, type (<=)) +import Literate.Prelude +import Numeric.Natural +import Text.Read (Read) +import Text.Show (Show (..), ShowS, showParen, showString, showsPrec) +import Prelude (Integer, Integral, error, fromIntegral, maxBound) +import Prelude qualified + +-- import Data.Decimal (Decimal, DecimalRaw (..), roundTo) +-- import Data.Validity qualified as Validity +-- import Data.Reflection (Reifies(..), reify) +-- import Data.Modular +-- import Literate.Accounting.Rebindable (fromInteger, FromRational(..)) + +errorWithStack :: HasCallStack => String -> a +errorWithStack = error -- (msg <> "\n" <> prettyCallStack callStack) + +-- * Class 'Zeroable' +class Zeroable a where + zero :: a + isZero :: a -> Bool + default isZero :: Zeroable a => Eq a => a -> Bool + isZero = (== zero) +instance Zeroable String where + zero = "" + isZero = null +instance Zeroable Word32 where + zero = (0 :: Int) & fromIntegral +instance Zeroable Word64 where + zero = (0 :: Int) & fromIntegral + +-- instance Zeroable Decimal where +-- zero = 0 +instance Zeroable (Map.Map k a) where + zero = Map.empty + isZero = Map.null + +{- +instance Zeroable Decimal where + zero = 0 +instance Zeroable (Map k a) where + zero = Map.empty +-} + +-- * Class 'Signable' +class Signable a where + sign :: a -> Ordering + default sign :: Zeroable a => Ord a => a -> Ordering + sign a = + case () of + _ | isZero a -> EQ + _ | a < zero -> LT + _ -> GT + +-- instance Signable Decimal + +-- * Class 'Addable' + +-- | Can be added. +class Addable a where + (+) :: HasCallStack => a -> a -> a + infixl 6 + + default (+) :: Prelude.Num a => HasCallStack => a -> a -> a + (+) = (Prelude.+) + +-- | For @'Addable' ('Map' k ())@. +instance Addable () where + (+) () () = () + +instance (Ord k, Addable a) => Addable (Map k a) where + (+) = Map.unionWith (flip (+)) +instance Addable a => Addable (Maybe a) where + Nothing + Nothing = Nothing + Just x + Nothing = Just x + Nothing + Just y = Just y + Just x + Just y = Just (x + y) + +{- +instance Addable Decimal where + (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny)) + where + (e, nx, ny) = roundMinDecimal x y + +-- | Round the two 'DecimalRaw' values to the smallest exponent. +roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i) +roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2) + where + e = min e1 e2 + Decimal _ n1 = roundTo e d1 + Decimal _ n2 = roundTo e d2 +-} + +-- * Class 'Negable' +class Negable a where + negate :: a -> a + default negate :: Prelude.Num a => a -> a + negate = Prelude.negate + +-- | For @'Negable' ('Map' k ())@. +instance Negable () where + negate () = () + +instance Negable Int +instance Negable Integer + +-- instance Negable Decimal +instance Negable a => Negable (Map k a) where + negate = Map.map negate +instance Negable a => Negable (Endo a) where + negate (Endo f) = Endo (f . negate) +instance Negable a => Negable [a] where + negate = (negate <$>) + +-- * Class 'Substractable' +class Substractable a where + (-) :: a -> a -> a + infixl 6 - + default (-) :: Prelude.Num a => a -> a -> a + (-) = (Prelude.-) + +-- | For @'Substractable' ('Map' k ())@. +instance Substractable () where + (-) () () = () + +instance Substractable Int +instance Substractable Integer + +-- instance Substractable Decimal +instance (Ord k, Addable a, Negable a) => Substractable (Map k a) where + (-) x y = Map.unionWith (flip (+)) x (negate y) + +-- * Constraint 'MinQty' +type QuantFact n = (KnownNat n, 1 <= n, n <= 4294967295 {-Word32-}) +quantisationFactor :: forall qf. QuantFact qf => Word32 +quantisationFactor = Prelude.fromIntegral (natVal (Proxy @qf)) + +data Unit + = UnitName Symbol + | (:*:) Unit Unit + | (:/:) Unit Unit + +class UnitShowS (u :: Unit) where + unitShowS :: Int -> ShowS +instance KnownSymbol u => UnitShowS (UnitName u) where + unitShowS _prec = showString (symbolVal (Proxy @u)) +instance (UnitShowS x, UnitShowS y) => UnitShowS (x :*: y) where + unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F*\x202F" . unitShowS @y 7 +instance (UnitShowS x, UnitShowS y) => UnitShowS (x :/: y) where + unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F/\x202F" . unitShowS @y 7 + +unitShow :: forall u. UnitShowS u => String +unitShow = unitShowS @u 0 "" + +-- * Type 'Amount' +newtype Amount (qf :: Nat) (unit :: Unit) = Amount + { amountQuantity :: Quantity qf + } + deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) +instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Amount qf unit)) where + fromInteger i = fromRational (i :% 1) + +-- * Type 'Quantity' +newtype Quantity qf = Quantity + { unQuantity :: Word64 + } + deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) + +instance Zeroable (Quantity qf) where + zero = Quantity 0 + isZero (Quantity q) = q == 0 + +-- instance Validity Quantity +-- instance NFData Quantity +instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Quantity qf)) where + fromInteger n = fromRational (n :% 1) +instance QuantFact qf => FromInteger (Quantity qf) where + fromInteger n = fromRational (n :% 1) +instance QuantFact qf => FromInteger (Amount qf unit) where + fromInteger = fromInteger >>> Amount + +instance Integral a => Addable (Ratio a) where + x + y = x Prelude.+ y +instance Addable (Maybe (Quantity qf)) where + (+) mx my = do + Quantity x <- mx + Quantity y <- my + let res = fromIntegral x Prelude.+ fromIntegral y + if res > fromIntegral @Word64 maxBound + then Nothing + else Just (Quantity (Prelude.fromInteger res)) +instance Addable (Quantity qf) where + (+) x y = do + let res = fromIntegral (unQuantity x) Prelude.+ fromIntegral (unQuantity y) + if res > fromIntegral (maxBound @Word64) + then errorWithStack "Quantity overflow" + else Quantity (Prelude.fromInteger res) +instance Addable (Amount qf unit) where + Amount x + Amount y = Amount (x + y) + +{- +sum :: forall f. Foldable f => f Amount -> Maybe Amount +sum l = + let maxBoundI :: Integer + maxBoundI = fromIntegral (maxBound :: Word64) + r :: Integer + r = foldl' (\acc a -> (toInteger :: Word64 -> Integer) (amountQuantity a) + acc) 0 l + in if r > maxBoundI + then Nothing + else Just (Amount ((fromInteger :: Integer -> Word64) r)) +-} + +instance Substractable (Maybe (Quantity qf)) where + (-) mx my = do + Quantity x <- mx + Quantity y <- my + let res = fromIntegral x - fromIntegral y + if res < 0 + then Nothing + else Just (Quantity (Prelude.fromInteger res)) + +sumAmounts :: forall qf unit f. Functor f => Foldable f => f (Amount qf unit) -> Maybe (Amount qf unit) +sumAmounts l = l <&> amountQuantity & sumQuantities <&> Amount + +sumQuantities :: forall qf f. Foldable f => f (Quantity qf) -> Maybe (Quantity qf) +sumQuantities l = + let res = foldl' (\acc a -> Prelude.toInteger (unQuantity a) Prelude.+ acc) 0 l + in if res > fromIntegral (maxBound @Word64) + then Nothing + else Just (Quantity (Prelude.fromInteger res)) + +multiply :: Word32 -> Quantity qf -> Maybe (Quantity qf) +multiply c (Quantity qty) = + let + res :: Integer + res = Prelude.fromIntegral c Prelude.* Prelude.fromIntegral qty + in + if res > fromIntegral (maxBound @Word64) + then Nothing + else Just (Quantity (Prelude.fromInteger res)) + +-- * Type 'CurrencyEnv' +newtype CurrencyEnv = CurrencyEnv + { currencyDefault :: Text + } + +-- newtype CurrencyT repr a = CurrencyT { unCurrencyT :: MT.ReaderT CurrencyEnv repr a } + +-- * Class 'CurrencyUSD' +class CurrencyUSD repr where + usd :: repr a -> repr a +instance CurrencyUSD (MT.ReaderT CurrencyEnv repr) where + usd = MT.local (\c -> c{currencyDefault = "$"}) + +-- * Type 'ErrorQuantity' +data ErrorQuantity + = ErrorQuantityNaN + | ErrorQuantityInfinite + | ErrorQuantityNotNormalised + | ErrorQuantityOverflow Natural + | ErrorQuantityNegative + | ErrorQuantityNotMultipleOfMinimalQuantity (Rational) (Word32) Natural Natural + deriving (Eq, Show) +instance Exception ErrorQuantity + +newtype MinimalQuantity = MinimalQuantity Word32 + +{- +quantityFromRational :: + forall qf m. + MC.MonadExcept ErrorQuantity m => + MC.MonadReader MinimalQuantity m => + --Reifies qf MinimalQuantity => + Rational -> + m (Quantity qf) +-} + +instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Quantity qf)) where + fromRational r@(rn :% rd) + -- ToDo: replace with isValid + | rd == 0 = MC.throw $ if rn == 0 then ErrorQuantityNaN else ErrorQuantityInfinite + | gcd < 0 || Prelude.quot rn gcd :% Prelude.quot rd gcd /= rn :% rd = + MC.throw ErrorQuantityNotNormalised + | r < 0 = MC.throw ErrorQuantityNegative + | (fromIntegral :: Word64 -> Natural) (maxBound :: Word64) < ceiled = MC.throw $ ErrorQuantityOverflow ceiled + | floored == ceiled = pure $ Quantity $ fromIntegral floored + | otherwise = MC.throw $ ErrorQuantityNotMultipleOfMinimalQuantity r minQty floored ceiled + where + gcd = Prelude.gcd rn rd + minQty = quantisationFactor @qf + qty :: Rational + qty = r Prelude.* fromIntegral minQty + ceiled :: Natural + ceiled = Prelude.ceiling qty + floored :: Natural + floored = Prelude.floor qty +instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Amount qf unit)) where + fromRational r = Amount <$> fromRational r + +-- | Warning(functional/completeness/partial) +instance QuantFact qf => FromRational (Quantity qf) where + fromRational = fromRational >>> MT.runExcept >>> either (throw @_ @_ @ErrorQuantity) id + +instance QuantFact qf => FromRational (Amount qf unit) where + fromRational = Amount . fromRational + +-- | Turn an amount of money into a 'Ratio'. +-- +-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@. +quantityToRatio :: forall qf. QuantFact qf => Quantity qf -> Ratio Natural +quantityToRatio (Quantity q) = + -- \| isZero qf = Prelude.fromIntegral q :% 0 + -- \| otherwise = + (Prelude.fromIntegral :: Word64 -> Natural) q % (Prelude.fromIntegral :: Word32 -> Natural) qf + where + qf = quantisationFactor @qf + +-- | Turn an amount of money into a 'Rational'. +-- +-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@. +quantityToRational :: QuantFact qf => Quantity qf -> Rational +quantityToRational q = q & quantityToRatio & Prelude.toRational + +-- instance QuantFact qf => FromRational (Amount qf unit) where +-- fromRational = either (throw @_ @_ @ErrorQuantity) id . MT.runExcept . fromRational + +{- +validateNotNaN :: RealFloat a => a -> Validation +validateNotNaN x | isNaN x = + +validateNotInfinite :: RealFloat a => a -> Validation +validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d) + +validateRatioNotNaN :: Integral a => Ratio a -> Validation +validateRatioNotNaN r = declare "The Ratio is not NaN." $ + case r of + (0 :% 0) -> False + _ -> True + +validateRatioNotInfinite :: Integral a => Ratio a -> Validation +validateRatioNotInfinite r = declare "The Ratio is not infinite." $ + case r of + (1 :% 0) -> False + ((-1) :% 0) -> False + _ -> True + +validateRatioNormalised :: Integral a => Ratio a -> Validation +validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $ + case d of + 0 -> False + _ -> + let g = gcd n d + gcdOverflows = g < 0 + n' :% d' = (n `quot` g) :% (d `quot` g) + valueIsNormalised = n' :% d' == n :% d + in not gcdOverflows && valueIsNormalised +-} +{- + +-- | Turn a 'Ratio' into an amount of money. +-- +-- This function will fail if the 'Ratio': +-- +-- * Is NaN (0 :% 0) +-- * Is infinite (1 :% 0) or (-1 :% 0) +-- * Is non-normalised (5 :% 5) +-- * Does represent an integer number of minimal quantisations. +fromRatio :: Word32 -> Ratio Natural -> Maybe Quantity +fromRatio quantisationFactor r = quantityFromRational quantisationFactor (Prelude.quantityToRational r) + +-- | Distribute an amount of money into chunks that are as evenly distributed as possible. +distribute :: Quantity -> Word32 -> QuantityDistribution +distribute (Quantity 0) _ = DistributedZeroQuantity +distribute _ 0 = DistributedIntoZeroChunks +distribute (Quantity a) f = + let smallerChunkSize, rest :: Word64 + (smallerChunkSize, rest) = divMod a ((fromIntegral :: Word32 -> Word64) f) + smallerChunk :: Quantity + smallerChunk = Quantity smallerChunkSize + in if rest == 0 + then DistributedIntoEqualChunks f smallerChunk + else + let -- This 'fromIntegral' is theoretically not safe, but it's + -- necessarily smaller than f so it will fit. + numberOfLargerChunks :: Word32 + numberOfLargerChunks = (fromIntegral :: Word64 -> Word32) rest + numberOfSmallerChunks :: Word32 + numberOfSmallerChunks = f - numberOfLargerChunks + largerChunk :: Quantity + largerChunk = Quantity $ succ smallerChunkSize + in DistributedIntoUnequalChunks + numberOfLargerChunks + largerChunk + numberOfSmallerChunks + smallerChunk + +-- | The result of 'distribute' +data QuantityDistribution + = -- | The second argument was zero. + DistributedIntoZeroChunks + | -- | The first argument was a zero amount. + DistributedZeroQuantity + | -- | Distributed into this many equal chunks of this amount + DistributedIntoEqualChunks !Word32 !Quantity + | -- | Distributed into unequal chunks, this many of the first (larger) amount, and this many of the second (slightly smaller) amount. + DistributedIntoUnequalChunks !Word32 !Quantity !Word32 !Quantity + deriving (Show, Read, Eq, Generic) + +instance Validity QuantityDistribution where + validate ad = + mconcat + [ genericValidate ad, + case ad of + DistributedIntoUnequalChunks _ a1 _ a2 -> + declare "The larger chunks are larger" $ + a1 > a2 + _ -> valid + ] + +instance NFData QuantityDistribution + +-- | Validate that an 'Quantity' is strictly positive. I.e. not 'zero'. +validateStrictlyPositive :: Quantity -> Validation +validateStrictlyPositive amount = declare "The Quantity is strictly positive" $ amount > zero +-} + +-- | Fractional multiplication +fraction :: + Zeroable (Quantity qf) => + Ratio Natural -> + Quantity qf -> + (Quantity qf, Ratio Natural) +fraction frac (Quantity 0) = (zero, frac) +fraction 0 _ = (zero, 0) +fraction frac (Quantity a) = + let + theoreticalResult :: Ratio Natural + theoreticalResult = (fromIntegral :: Word64 -> Ratio Natural) a Prelude.* frac + roundedResult :: Word64 + roundedResult = (Prelude.round :: Ratio Natural -> Word64) theoreticalResult + actualRate :: Ratio Natural + actualRate = + (fromIntegral :: Word64 -> Natural) roundedResult + % (fromIntegral :: Word64 -> Natural) a + in + (Quantity roundedResult, actualRate) diff --git a/src/Literate/Document.hs b/src/Literate/Document.hs new file mode 100644 index 0000000..b26abb2 --- /dev/null +++ b/src/Literate/Document.hs @@ -0,0 +1,8 @@ +module Literate.Document ( + module Literate.Document.Type, + module Literate.Document.Table, +) +where + +import Literate.Document.Table +import Literate.Document.Type diff --git a/src/Literate/Document/HTML.hs b/src/Literate/Document/HTML.hs new file mode 100644 index 0000000..54d5fe2 --- /dev/null +++ b/src/Literate/Document/HTML.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Literate.Document.HTML ( + module Literate.Document.HTML, + module Text.Blaze.Html5, + module Text.Blaze.Renderer.Utf8, +) +where + +import Data.Char qualified as Char +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Short qualified as ShortText +import Literate.Document.Table +import Literate.Document.Type +import Literate.Prelude +import Text.Blaze +import Text.Blaze.Html5 +import Text.Blaze.Html5.Attributes qualified as HA +import Text.Blaze.Renderer.Utf8 +import Prelude qualified + +instance IsString AttributeValue +instance IsString Html + +classes :: [String] -> Attribute +classes cls = + HA.class_ $ + cls + & List.filter (not . null) + <&> toValue + & List.intersperse " " + & mconcat + +className :: Show a => a -> String +className x = + x & show & List.map \c -> + if Char.isAlphaNum c + then c + else '-' + +type CSSBlock = Map String String + +styles :: CSSBlock -> Attribute +styles kvs = + HA.style $ + [ toValue k <> ":" <> toValue v <> ";" + | (k, v) <- kvs & Map.toList + , not (null v) + ] + & mconcat + +type CSS = Map [String] CSSBlock +styleCSS :: CSS -> Markup +styleCSS m = + style + ! HA.type_ "text/css" + $ [ mconcat [n <> " {" | n <- ns] + <> "\n" + <> List.unlines + [ k <> ":" <> v <> ";" + | (k, v) <- kvs & Map.toList + , not (null v) + ] + <> mconcat [" }" | _n <- ns] + <> "\n" + | (ns, kvs) <- m & Map.toList + , kvs & null & not + ] + & List.unlines + & toMarkup + +class ToCSS a where + toCSS :: a -> String + +instance ToMarkup ShortText where + toMarkup = ShortText.toText >>> toMarkup + preEscapedToMarkup = ShortText.toText >>> preEscapedToMarkup + +instance ToCSS Text where + toCSS = Text.unpack + +instance ToCSS Length where + toCSS = \case + LengthAbsolute x -> x & toCSS + LengthRelative x -> x & toCSS +instance ToCSS LengthAbsolute where + toCSS = \case + LengthAbsoluteMillimeters x -> show x <> "mm" +instance ToCSS LengthRelative where + toCSS = \case + LengthRelativeFractionalRatio x -> show x <> "fr" + LengthRelativeMaxContent -> "max-content" + LengthRelativeMinContent -> "min-content" + +cssPageWidth = \case + PageOrientationLandscape -> 29.7 & cm + PageOrientationPortrait -> 21.0 & cm +cssPageHeight = \case + PageOrientationLandscape -> 21.0 & cm + PageOrientationPortrait -> 29.7 & cm +cssPageSize = \case + PageSizeA5 -> "A5" + PageSizeA4 -> "A4" + PageSizeA4Plus -> "A4plus" + PageSizeA3 -> "A3" +cssPageOrientation = \case + PageOrientationPortrait -> "portrait" + PageOrientationLandscape -> "landscape" + +cssPrintPage :: PageOrientation -> PageSize -> CSS +cssPrintPage pageOrient pageSize = + [ + [ ["@page"] := + [ "size" := + List.unwords + [ cssPageSize pageSize + , cssPageOrientation pageOrient + ] + ] + ] + ] + & mconcat + +cssBlockObjectFitCover :: CSSBlock +cssBlockObjectFitCover = ["object-fit" := "cover"] + +instance ToMarkup Blocks where + toMarkup = foldMap toMarkup . unBlocks +instance ToMarkup Block where + toMarkup = \case + BlockDiv x -> div $ x & toMarkup + BlockFlex x -> x & toMarkup + BlockPara (Inlines x) -> p $ x & foldMap toMarkup + BlockTable x -> x & toMarkup +instance ToMarkup Inline where + toMarkup = \case + InlineText x -> x & toMarkup +instance ToMarkup FlexItem where + toMarkup itm = + forM_ (itm & flexItemContent) toMarkup +instance ToMarkup Flex where + toMarkup flx = + div + ! styles + [ "display" := "flex" + , "flex-direction" := flx & flexDirection & toCSS + , "gap" := flx & flexGap & toCSS + ] + $ do + forM_ (flx & flexItems) toMarkup + +instance ToMarkup Table where + toMarkup tbl = + div + ! classes ["table"] + ! styles ["grid-template-columns" := tbl & tableTemplateFinal <&> toCSS & List.unwords] + $ do + forM_ (tbl & tableHeads) \hd -> do + div ! classes ["table-head"] $ do + forM_ (hd & tableHeadColumns) \cel -> do + div ! classes ["table-cell"] $ do + div do + cel & tableCellContent & toMarkup + forM_ (tbl & tableRows & ol1) \(rowCount, row) -> do + div ! classes ["table-body", if even rowCount then "even" else "odd"] $ do + forM_ (row & tableRowColumns) \cel -> do + div + ! classes ["table-cell"] + ! styles ["justify-items" := cel & tableCellJustify & toCSS] + $ do + cel & tableCellContent & toMarkup +instance ToMarkup Dict where + toMarkup dic = + div + ! classes ["dict"] + $ do + forM_ (dic & dictEntries) \(key, val) -> + div ! classes ["dict-entry"] $ do + div ! classes ["dict-key"] $ do + key & toMarkup + div ! classes ["dict-value"] $ do + val & toMarkup +instance ToCSS Justification where + toCSS = \case + JustificationLeft -> "left" + JustificationBegin -> "begin" + JustificationCenter -> "center" + JustificationEnd -> "end" + JustificationRight -> "right" +instance ToCSS FlexDirection where + toCSS = \case + FlexDirectionColumn -> "column" + FlexDirectionRow -> "row" diff --git a/src/Literate/Document/Table.hs b/src/Literate/Document/Table.hs new file mode 100644 index 0000000..52e12d8 --- /dev/null +++ b/src/Literate/Document/Table.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Literate.Document.Table where + +import Data.List qualified as List +import Literate.Document.Type +import Literate.Prelude + +table = + Table + { tableHeads = Nothing + , tableTemplate = [] + , tableRowsEvenOdd = False + , tableRows = [] + } +tableTemplateFinal :: Table -> TableTemplate +tableTemplateFinal tbl + | tbl & tableTemplate & null = 1 & fr & LengthRelative & List.replicate columns + | otherwise = tbl & tableTemplate + where + columns :: Int + columns = + maximum + [ row & tableRowColumns & List.length + | row <- tbl & tableRows + ] +tableRow = + TableRow + { tableRowColumns = [] + } +tableCell = + TableCell + { tableCellContent = "" + , tableCellJustify = JustificationCenter + } + +dict = + Dict + { dictEntries = [] + } diff --git a/src/Literate/Document/Type.hs b/src/Literate/Document/Type.hs new file mode 100644 index 0000000..7363675 --- /dev/null +++ b/src/Literate/Document/Type.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE UndecidableInstances #-} + +module Literate.Document.Type where + +import Literate.Prelude +import Prelude qualified + +newtype Blocks = Blocks {unBlocks :: [Block]} + deriving (Eq, Show, Semigroup, Monoid) +instance IsList Blocks where + type Item Blocks = Block + fromList = Blocks + toList (Blocks xs) = xs +data Block + = BlockPara Inlines + | BlockDiv Blocks + | BlockFlex Flex + | BlockTable Table + deriving (Eq, Show) +instance IsString Block where + fromString x = BlockPara [fromString x] + +newtype Inlines = Inlines [Inline] + deriving (Eq, Show, Semigroup, Monoid) +instance IsString Inlines where + fromString x = Inlines [fromString x] +instance IsList Inlines where + type Item Inlines = Inline + fromList = Inlines + toList (Inlines xs) = xs + +data Inline + = InlineText Text + {- + \| InlineEmph [Inline] -- ^ Emphasized text (list of inlines) + \| InlineUnderline [Inline] -- ^ Underlined text (list of inlines) + \| InlineStrong [Inline] -- ^ Strongly emphasized text (list of inlines) + \| InlineStrikeout [Inline] -- ^ Strikeout text (list of inlines) + \| InlineSuperscript [Inline] -- ^ Superscripted text (list of inlines) + \| InlineSubscript [Inline] -- ^ Subscripted text (list of inlines) + \| InlineSmallCaps [Inline] -- ^ Small caps text (list of inlines) + \| InlineQuoted QuoteType [Inline] -- ^ Quoted text (list of inlines) + \| InlineCite [Citation] [Inline] -- ^ Citation (list of inlines) + \| InlineCode Attr Text -- ^ Inline code (literal) + \| InlineSpace -- ^ Inter-word space + \| InlineSoftBreak -- ^ Soft line break + \| InlineLineBreak -- ^ Hard line break + \| InlineMath MathType Text -- ^ TeX math (literal) + \| InlineRawInline Format Text -- ^ Raw inline + \| InlineLink Attr [Inline] Target -- ^ Hyperlink: alt text (list of inlines), target + \| InlineImage Attr [Inline] Target -- ^ Image: alt text (list of inlines), target + \| InlineNote [Block] -- ^ Footnote or endnote + \| InlineSpan Attr [Inline] -- ^ Generic inline container with attributes + -} + deriving (Eq, Show) +instance IsString Inline where + fromString = InlineText . fromString + +data Flex = Flex + { flexItems :: [FlexItem] + , flexDirection :: FlexDirection + , flexGap :: LengthAbsolute + } + deriving (Eq, Show) +flex = + Flex + { flexItems = [] + , flexDirection = FlexDirectionColumn + , flexGap = 0 & mm + } +data FlexDirection + = FlexDirectionColumn + | FlexDirectionRow + deriving (Eq, Show) +data FlexItem = FlexItem + { flexItemContent :: [Block] + } + deriving (Eq, Show) +flexItem = + FlexItem + { flexItemContent = [] + } + +type TableTemplate = [Length] +data Table = Table + { tableHeads :: Maybe Head + , tableTemplate :: TableTemplate + , tableRowsEvenOdd :: Bool + , tableRows :: [TableRow] + } + deriving (Eq, Show) +data Head = Head + { tableHeadColumns :: [TableCell] + } + deriving (Eq, Show) +data TableRow = TableRow + { tableRowColumns :: [TableCell] + } + deriving (Eq, Show) +data TableCell = TableCell + { tableCellContent :: Block + , tableCellJustify :: Justification + } + deriving (Eq, Show) + +data Dict = Dict + { dictEntries :: [DictEntry] + } + +type DictEntry = (Inline, Block) + +data Justification + = JustificationLeft + | JustificationBegin + | JustificationCenter + | JustificationEnd + | JustificationRight + deriving (Eq, Show) + +data PageSize + = PageSizeA5 + | PageSizeA4 + | PageSizeA4Plus + | PageSizeA3 + deriving (Eq, Show, Generic) + +data PageOrientation + = PageOrientationPortrait + | PageOrientationLandscape + deriving (Eq, Show, Generic) + +data LengthAbsolute + = LengthAbsoluteMillimeters Double + deriving (Eq, Show) +data LengthRelative + = LengthRelativeFractionalRatio Natural + | LengthRelativeMaxContent + | LengthRelativeMinContent + deriving (Eq, Show) + +data Length + = LengthAbsolute LengthAbsolute + | LengthRelative LengthRelative + deriving (Eq, Show) + +cm :: Double -> LengthAbsolute +cm = LengthAbsoluteMillimeters . (Prelude.* 10) +mm :: Double -> LengthAbsolute +mm = LengthAbsoluteMillimeters +fr :: Natural -> LengthRelative +fr = LengthRelativeFractionalRatio + +class ToInlines a where + toInlines :: a -> Inlines +instance ToInlines String where + toInlines x = [InlineText (fromString x)] +instance ToInlines Text where + toInlines x = [InlineText x] + +class ToBlock a where + toBlock :: a -> Block +instance ToBlock Int where + toBlock i = i & show & toBlock +instance ToBlock Integer where + toBlock i = i & show & toBlock +instance ToBlock String where + toBlock = fromString +instance ToBlock Text where + toBlock = BlockPara . toInlines diff --git a/src/Literate/Invoice/HTML.hs b/src/Literate/Invoice/HTML.hs new file mode 100644 index 0000000..7ab7a7f --- /dev/null +++ b/src/Literate/Invoice/HTML.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +-- For QuantFact +{-# LANGUAGE UndecidableInstances #-} +{-# 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 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 (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.ToInlines (Quantity qf), UnitShowS unit) => Doc.ToInlines (Amount qf unit) where + toInlines Amount{..} = + (amountQuantity & Doc.toInlines) + <> (if null unit then "" else "\x202F" <> (unit & Doc.toInlines)) + 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.toInlines + +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.ToInlines (Quantity qf) where + toInlines qty = do + Doc.toInlines $ + 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.toInlines + +instance HTMLIOable (InvoiceId, Invoice) where + htmlIO (invoiceId, invoice@Invoice{..}) = 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/Paper.css" + , "styles/Table.css" + , "styles/Invoice.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"] + $ do + div ! classes ["invoice"] $ do + div ! classes ["key-value", "invoice-id"] $ do + div ! classes ["key"] $ do + ("Invoice#\x202F:" :: String) & toHtml + div ! classes ["value"] $ do + invoiceId & toHtml + div ! classes ["key-value", "invoice-creation"] $ do + div ! classes ["key"] $ do + ("Date\x202F:" :: String) & toHtml + div ! classes ["value"] $ do + invoiceCreation & Time.localDay & Time.iso8601Show & toHtml + div ! classes ["invoice-from-to"] $ do + div ! classes ["invoice-issuer"] $ do + toHtml $ ("Seller" :: String) := invoiceIssuer + div ! classes ["invoice-recipient"] $ do + toHtml $ ("Buyer" :: String) := invoiceCustomer + toHtml $ + Doc.BlockFlex + Doc.flex + { Doc.flexDirection = Doc.FlexDirectionColumn + , Doc.flexGap = 0.5 & Doc.cm + , Doc.flexItems = + [ Doc.flexItem + { Doc.flexItemContent = + [ Doc.BlockTable + Doc.table + { Doc.tableTemplate = + [ Doc.LengthRelative $ Doc.LengthRelativeMaxContent + , Doc.LengthRelative $ 5 & 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 = "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.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) <- invoiceItems & ol1 + ] + } + ] + } + , Doc.flexItem + { Doc.flexItemContent = + [ 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 <- invoiceItems + ] + & fromMaybe 0 + & Doc.toBlock + } + , Doc.tableCell + { Doc.tableCellJustify = Doc.JustificationCenter + , Doc.tableCellContent = + sumAmounts + [ itm & invoiceItemTotal + | itm <- invoiceItems + ] + & fromMaybe 0 + & Doc.toBlock + } + ] + } + ] + } + ] + } + ] + } diff --git a/src/Literate/Invoice/Invoice.hs b/src/Literate/Invoice/Invoice.hs new file mode 100644 index 0000000..2fd95b5 --- /dev/null +++ b/src/Literate/Invoice/Invoice.hs @@ -0,0 +1,74 @@ +module Literate.Invoice.Invoice where + +import Literate.Accounting.Math +import Literate.Prelude +import Literate.Time + +import Data.Text qualified as Text +import Literate.Document.HTML qualified as HTML + +data Id = Id {unId :: Natural} + deriving (Eq, Ord, Show) +instance HTML.ToMarkup Id where + toMarkup (Id idt) = idt & HTML.toHtml + +data InvoiceId = InvoiceId + { invoiceIdBuyer :: Entity + , invoiceIdCount :: Natural + } + deriving (Eq, Ord, Show) +instance HTML.ToMarkup InvoiceId where + toMarkup InvoiceId{..} = + "ent" + <> (invoiceIdBuyer & entityId & HTML.toMarkup) + <> "inv" + <> (invoiceIdCount & HTML.toMarkup) + +type Invoices = Map InvoiceId Invoice + +type EntityId = Id +type Email = Text +data Entity = Entity + { entityId :: EntityId + , entityName :: Text + , entityEmail :: Maybe Email + , entityAddress :: Address + , entitySIREN :: Maybe Text + } + deriving (Eq, Ord, Show) + +data Address = Address + { addressText :: [Text] + , addressZipCode :: ZipCode + , addressCity :: City + , addressCountry :: Country + } + deriving (Eq, Ord, Show) + +type ZipCode = Text +type City = Text +type Country = Text + +data Invoice = Invoice + { invoiceCreation :: LocalTime + , invoiceIssuer :: Entity + , invoiceRecipient :: Entity + , invoiceCustomer :: Entity + , invoiceObjet :: Text + , invoiceDetails :: Text + , invoiceItems :: [InvoiceItem (UnitName "€" :/: UnitName "h") (UnitName "h")] + , invoiceRate :: Double + } + +data InvoiceItem rate qty = InvoiceItem + { invoiceItemDescription :: Text + , invoiceItemRate :: Amount 100 rate + , invoiceItemQuantity :: Amount 100 qty + } +invoiceItemTotal :: InvoiceItem rate qty -> Amount 100 (UnitName "€") +invoiceItemTotal InvoiceItem{..} = + let (res, _actualFrac) = + invoiceItemRate + & amountQuantity + & fraction (invoiceItemQuantity & amountQuantity & quantityToRatio) + in Amount res diff --git a/src/Literate/Prelude.hs b/src/Literate/Prelude.hs new file mode 100644 index 0000000..84045e7 --- /dev/null +++ b/src/Literate/Prelude.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE FieldSelectors #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Literate.Prelude ( + module Literate.Prelude, + module Literate.Rebindable, + ($), + ($>), + (&&), + (&), + (++), + (.), + (<$>), + (<&>), + (>>>), + (||), + uncurry, + curry, + Applicative (..), + Bool (..), + Boolable (..), + Char, + Double, + Down (..), + DropPrefix (..), + Either (..), + Endo (..), + Enum (..), + Eq (..), + FilePath, + Foldable, + Functor (..), + Generic, + Generically (..), + HasCallStack, + IO, + Identity (..), + Int, + Integer, + IsLabel (..), + IsList (..), + IsString (..), + KnownNat (..), + KnownSymbol (..), + Last (..), + Lookup (..), + Map, + MapUnion (..), + Max (..), + Maybe (..), + Min (..), + Monad (..), + Monoid (..), + Natural, + NonEmpty (..), + -- Num (..), + Ord (..), + Ordering (..), + Proxy (..), + Ratio, + Rational, + Real (..), + Semigroup (..), + Set, + ShortText, + Show (..), + String, + Sum (..), + Symbol, + Text, + ToMaybe (..), + Typeable, + all, + and, + any, + catMaybes, + const, + either, + even, + first, + flip, + fold, + foldM, + foldM_, + foldMap, + foldr, + forM, + forM_, + fromMaybe, + fromIntegral, + fst, + id, + isJust, + isNothing, + lefts, + length, + mapM, + mapM_, + fromRight, + mapMaybe, + maximum, + maybe, + maybeToList, + minimum, + natVal, + nonEmpty, + not, + null, + odd, + on, + or, + otherwise, + pShow, + pHPrint, + pShowNoColor, + partitionEithers, + rights, + second, + snd, + sum, + symbolVal, + unless, + void, + when, +) where + +import Control.Applicative (Applicative (..)) +import Control.Arrow (first, second, (>>>)) +import Control.Monad (foldM, foldM_, forM, forM_, mapM, mapM_, unless, void, when) +import Data.Bool (Bool (..), not, otherwise, (&&), (||)) +import Data.Char (Char) +import Data.Either (Either (..), either, fromRight, lefts, partitionEithers, rights) +import Data.Eq (Eq (..)) +import Data.Foldable (Foldable (..), all, and, any, fold, foldMap, foldr, maximum, minimum, null, or) +import Data.Function (const, flip, id, on, ($), (&), (.)) +import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>)) +import Data.Functor.Identity (Identity (..)) +import Data.List ((++)) +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybe, maybeToList) +import Data.Monoid (Ap (..), Endo (..), Last (..), Monoid (..)) +import Data.Ord (Down (..), Ord (..), Ordering (..)) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio, Rational) +import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.String (String) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Lazy qualified as Text.Lazy +import Data.Text.Short (ShortText) +import Data.Text.Short qualified as Text.Short +import Data.Tuple (curry, fst, snd, uncurry) +import Debug.Pretty.Simple (pTrace, pTraceM, pTraceShow, pTraceShowId, pTraceShowM) +import GHC.Generics (Generic, Generically (..)) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal) +import Literate.Rebindable +import Numeric.Natural (Natural) +import Paths_literate_invoice qualified as Self +import System.IO (FilePath, IO) +import System.IO qualified as Sys +import Text.Pretty.Simple (pHPrint, pShow, pShowNoColor) +import Text.Show (Show (..)) +import Type.Reflection (Typeable) +import Prelude (Double, Enum (..), Int, Integer, Real (..), error, even, fromIntegral, odd) + +traceStringM = pTraceM +traceString = pTrace +traceShow = pTraceShow +traceShowId = pTraceShowId +traceShowM = pTraceShowM + +xtraceStringM _ = return () +xtraceString _ = id +xtraceShow _ = id +xtraceShowId = id +xtraceShowM _ = return () + +pattern (:=) :: a -> b -> (a, b) +pattern (:=) x y = (x, y) +infixr 0 := + +class Assoc a b c where + (~>) :: a -> b -> c +instance Assoc a b (a, b) where + (~>) = (,) + +(<&) :: Functor f => a -> f b -> f a +(&>) :: Functor f => f b -> a -> f a +(<&) = flip ($>) +(&>) = flip (<$) +infixl 4 <& +infixl 4 &> + +-- l <>~ n = over l (<> n) +-- {-# INLINE (<>~) #-} + +-- instance IsList a => IsList (Last a) where +-- type Item (Last a) = Item a +-- fromList [] = Last Nothing +-- fromList xs = Last (Just (fromList xs)) +-- toList (Last Nothing) = [] +-- toList (Last (Just x)) = IsList.toList x + +-- | Like `Last` but `mempty` is `[]` instead not `Nothing`. +-- Useful for deriving: +-- +-- @ +-- deriving Semigroup via (ProductSurgery (OnFields Lasts) Foo) +-- @ +newtype Lasts a = Lasts a + deriving (Eq, Ord, Show, Generic) + +instance Semigroup (Lasts [a]) where + Lasts [] <> x = x + x <> Lasts [] = x + _x <> y = y +instance (Monoid a, Semigroup (Lasts a)) => Monoid (Lasts a) where + mempty = Lasts mempty + +newtype Newest a = Newest {unNewest :: a} + deriving (Eq, Ord, Generic) + deriving newtype (Show) +instance Semigroup (Newest a) where + _x <> y = y + +newtype MapUnion k a = MapUnion {unMapUnion :: Map.Map k a} + deriving (Eq, Ord, Generic, Functor) + deriving newtype (Show) + +-- CorrectionWarning: as of GHC 9.6.6, `Monoid` is not derived correctly via `Generically`: +-- it does not reuses `(<>)`. +-- See https://github.com/haskell/core-libraries-committee/issues/324 +-- deriving (Monoid) via (Generically (MapUnion k a)) +instance (Ord k, Semigroup a) => Semigroup (MapUnion k a) where + MapUnion x <> MapUnion y = MapUnion (Map.unionWith (<>) x y) +instance (Ord k, Semigroup a) => Monoid (MapUnion k a) where + mempty = MapUnion mempty +instance (Ord k, Semigroup a) => IsList (MapUnion k a) where + type Item (MapUnion k a) = (k, a) + fromList = MapUnion . Map.fromListWith (<>) + toList = Map.toList . unMapUnion + +forMap :: (Foldable t, Monoid m) => t a -> (a -> m) -> m +forMap = flip foldMap + +class DropPrefix a where + dropPrefix :: a -> a -> a +instance DropPrefix Text.Text where + dropPrefix p t = t & Text.stripPrefix p & fromMaybe t +instance DropPrefix ShortText where + dropPrefix p t = t & Text.Short.stripPrefix p & fromMaybe t + +setSingle = Set.singleton +{-# INLINE setSingle #-} +setInsert = Set.insert +{-# INLINE setInsert #-} +setSize = Set.size +{-# INLINE setSize #-} +mapSize = Map.size +{-# INLINE mapSize #-} +mapEachPiece f g h = Map.merge (Map.mapMissing f) (Map.mapMissing g) (Map.zipWithMatched h) +{-# NOINLINE mapEachPiece #-} + +foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b +foldMapM f = getAp <$> foldMap (Ap . f) + +class ToMaybe a b where + toMaybe :: a -> Maybe b +instance ToMaybe Int Natural where + toMaybe x + | x >= 0 = Just (fromIntegral x) + | otherwise = Nothing + +withDataFile n f = do + path <- Self.getDataFileName $ n & List.stripPrefix "data/" & fromMaybe n + Sys.withFile path Sys.ReadMode f + +-- | Useful to constrain a literal list to a bare list when using `OverloadedLists`. +list :: [a] -> [a] +list = id +{-# INLINE list #-} + +enumAll = enumFrom (toEnum 0) + +last :: a -> Last a +last = Last . Just + +-- instance Fractional a => Fractional (Last a) where +-- fromRational = Last . Just . fromRational +-- (/) = liftA2 (/) +-- recip = fmap recip +-- instance Num a => Num (Last a) where +-- (+) = liftA2 (+) +-- (-) = liftA2 (-) +-- (*) = liftA2 (*) +-- abs = fmap abs +-- signum = fmap signum +-- fromInteger = Last . Just . fromInteger + +class Boolable a where + true :: a + false :: a + +instance Boolable Bool where + true = True + false = False +instance Boolable a => Boolable (Last a) where + true = last true + false = last false + +class Lookup a where + type Key a + type Value a + lookup :: Key a -> a -> Maybe (Value a) +instance Ord k => Lookup (Map k a) where + type Key (Map k a) = k + type Value (Map k a) = a + lookup = Map.lookup +instance Ord a => Lookup (Set a) where + type Key (Set a) = a + type Value (Set a) = () + lookup k m + | Set.member k m = Just () + | otherwise = Nothing +instance Ord a => Lookup [a] where + type Key [a] = a + type Value [a] = () + lookup k m + | List.elem k m = Just () + | otherwise = Nothing +instance Ord k => Lookup (MapUnion k a) where + type Key (MapUnion k a) = Key (Map k a) + type Value (MapUnion k a) = Value (Map k a) + lookup k = unMapUnion >>> lookup k +instance Lookup a => Lookup (Last a) where + type Key (Last a) = Key a + type Value (Last a) = Value a + lookup k = getLast >>> maybe Nothing (lookup k) + +lookupOrDefaultTo d k = lookup k >>> fromMaybe d +{-# INLINE lookupOrDefaultTo #-} + +type Modifier a = a -> a + +nonEmptyHead = NonEmpty.head + +headMaybe = listToMaybe +lastMaybe xs + | null xs = Nothing + | otherwise = Just (List.last xs) + +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = ys : chunksOf n zs + where + (ys, zs) = List.splitAt n xs + +mapFromListCheckingDuplicates :: HasCallStack => Ord k => Show k => [(k, v)] -> Map k v +mapFromListCheckingDuplicates = Map.fromListWithKey (\key -> errorShow ("key duplicate" :: Text, key)) + +errorShow :: HasCallStack => Show a => a -> b +errorShow x = error $ pShowNoColor x & Text.Lazy.unpack + +mapButLast :: (a -> a) -> [a] -> [a] +mapButLast f (x : y : xs) = f x : mapButLast f (y : xs) +mapButLast _f other = other + +ol0 = List.zip [0 :: Integer ..] +ol1 = List.zip [1 :: Integer ..] diff --git a/src/Literate/Rebindable.hs b/src/Literate/Rebindable.hs new file mode 100644 index 0000000..31c8a11 --- /dev/null +++ b/src/Literate/Rebindable.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PostfixOperators #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Literate.Rebindable ( + module Literate.Rebindable, + IsList (..), + IsString (..), + Monad (..), + MonadFail (..), +) where + +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), MonadFail (..)) +import Data.Bool (Bool (..)) +import Data.Foldable (foldr) +import Data.Function (id, ($), (.)) +import Data.Functor (Functor, (<$>)) +import Data.Int (Int) +import Data.Kind +import Data.List qualified as List +import Data.Ratio (Ratio, Rational) +import Data.Semigroup (Semigroup (..)) +import Data.String (String) +import Data.String qualified as String +import Data.Text (Text) +import Data.Typeable +import Data.Word (Word64) +import GHC.Exts qualified as GHC +import GHC.IsList (IsList (..)) +import GHC.Stack +import GHC.TypeLits (ErrorMessage (..), Symbol) +import Numeric.Natural (Natural) +import Text.Show (Show (..)) +import Prelude (Double, Integer, Integral, error) +import Prelude qualified + +ifThenElse :: Bool -> a -> a -> a +ifThenElse True x _ = x +ifThenElse False _ y = y + +-- * Class 'IsString' + +-- | Like 'String.IsString' but with an 'HasCallStack' constraint +-- to report the location of the 'String'. +-- This is to be used with the @OverloadedStrings@ and @RebindableSyntax@ extensions +-- to replace literal strings by this 'fromString'. +class IsString a where + fromString :: HasCallStack => String -> a + default fromString :: + String.IsString a => + HasCallStack => + String -> + a + fromString = String.fromString + +instance IsString String +instance IsString Text + +-- * Class 'FromInteger' +class FromInteger a where + fromInteger :: HasCallStack => Prelude.Integer -> a + default fromInteger :: Prelude.Num a => Prelude.Integer -> a + fromInteger = Prelude.fromInteger +instance FromInteger (Ratio Natural) +instance FromInteger Double +instance FromInteger Int +instance FromInteger Integer +instance FromInteger Natural +instance FromInteger Rational +instance FromInteger Word64 + +-- instance FromInteger Decimal + +-- * Class 'FromRational' +class FromRational a where + fromRational :: HasCallStack => Prelude.Rational -> a + default fromRational :: Prelude.Fractional a => Prelude.Rational -> a + fromRational = Prelude.fromRational + +-- instance FromRational Decimal +instance FromRational Double +instance Integral a => FromRational (Ratio a) + +-- * Class 'IsList' + +{- +class IsList a where + type Item a :: Type + type Item a = GHC.Item a + fromList :: HasCallStack => [Item a] -> a + fromListN :: HasCallStack => Prelude.Int -> [Item a] -> a + toList :: HasCallStack => a -> [Item a] + default fromList :: GHC.Item a ~ Item a => GHC.IsList a => [Item a] -> a + default fromListN :: GHC.Item a ~ Item a => GHC.IsList a => Prelude.Int -> [Item a] -> a + default toList :: GHC.Item a ~ Item a => GHC.IsList a => a -> [Item a] + fromList = GHC.fromList + fromListN = GHC.fromListN + toList = GHC.toList +instance IsList [a] +-} +-- class Listable repr where +-- cons :: repr a -> repr [a] -> repr [a] +-- nil :: repr [a] +-- concat :: repr [a] -> repr [a] -> repr [a] +-- class IsList repr where +-- fromList :: HasCallStack => [repr a] -> repr [a] +-- fromListN :: HasCallStack => Int -> [repr a] -> repr [a] + +-- toList :: HasCallStack => repr [a] -> [repr a] +{- +default fromList :: GHC.Item a ~ Item a => GHC.IsList a => [Item a] -> a +default fromListN :: GHC.Item a ~ Item a => GHC.IsList a => Prelude.Int -> [Item a] -> a +default toList :: GHC.Item a ~ Item a => GHC.IsList a => a -> [Item a] +fromList = GHC.fromList +fromListN = GHC.fromListN +toList = GHC.toList +-} +-- instance Listable repr => IsList repr where +-- fromList = foldr cons nil +-- fromListN _n = foldr cons nil + +-- toList = error "toList" + +{- +class Applicative repr where + fmap :: (a->b) -> repr a -> repr b + pure :: a -> repr a + (<*>) :: repr (a->b) -> repr a -> repr b + join :: repr (repr a) -> repr a +-} diff --git a/src/Literate/Time.hs b/src/Literate/Time.hs new file mode 100644 index 0000000..c8b5ae5 --- /dev/null +++ b/src/Literate/Time.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Literate.Time ( + module Data.Time.Calendar, + module Data.Time.Calendar.Month, + module Data.Time.Clock, + module Data.Time.Format, + module Data.Time.LocalTime, +) +where + +import Data.Fixed (Pico) +import Data.Foldable (asum, or) +import Data.Maybe (fromJust) +import Data.Time.Calendar +import Data.Time.Calendar.Month +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime +import Literate.Prelude +import Prelude (error) + +instance IsString LocalTime where + fromString :: HasCallStack => String -> LocalTime + fromString s = + fromJust $ + asum @[] + [ parseTimeM False timeLocales "%Y-%0m-%0dT%H:%M:%S" s + , parseTimeM False timeLocales "%Y-%0m-%0d %H:%M:%S" s + , parseTimeM False timeLocales "%Y-%0m-%0dT%H:%M" s + , parseTimeM False timeLocales "%Y-%0m-%0d %H:%M" s + , parseTimeM False timeLocales "%Y-%0m-%0d" s + , parseTimeM False timeLocales "%Y-%0m" s + , parseTimeM False timeLocales "%Y" s + ] +instance IsString Day where + fromString :: HasCallStack => String -> Day + fromString s = + fromJust $ + asum @[] + [ parseTimeM False timeLocales "%Y-%0m-%0d" s + ] +instance IsString TimeOfDay where + fromString :: HasCallStack => String -> TimeOfDay + fromString s = + asum @[] @_ @DiffTime + [ parseTimeM False timeLocales "%H" s + , parseTimeM False timeLocales "%H:%M" s + , parseTimeM False timeLocales "%H:%M:%S" s + ] + & fromJust + & pastMidnight + +timeLocales = + defaultTimeLocale + { knownTimeZones = knownTimeZones defaultTimeLocale <> [cet, cest] + } + where + cet = + TimeZone + { timeZoneMinutes = 60 + , timeZoneSummerOnly = False + , timeZoneName = "CET" + } + cest = + TimeZone + { timeZoneMinutes = 120 + , timeZoneSummerOnly = True + , timeZoneName = "CEST" + } + +fromGregorianValid :: HasCallStack => Integer -> Int -> Int -> Day +fromGregorianValid y m d = + fromMaybe (error ("invalid Day: " <> show (y, m, d))) $ + Data.Time.Calendar.fromGregorianValid y m d + +type Hour = Int +type Minute = Int +type Second = Pico + +makeTimeOfDayValid :: HasCallStack => Hour -> Minute -> Second -> TimeOfDay +makeTimeOfDayValid h m s = + fromMaybe (error ("invalid TimeOfDay: " <> show (h, m, s))) $ + Data.Time.LocalTime.makeTimeOfDayValid h m s diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 index 0000000..06a2d53 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -w -Wall -fno-warn-missing-signatures -fno-warn-unused-imports #-} + +module Tests.Spec where + +import Test.Syd + +import GHC.Conc qualified +import Literate.Prelude +import Tests.Invoice qualified + +main :: IO () +main = sydTest spec + +spec = do + Tests.Invoice.spec diff --git a/tests/Tests/Entity.hs b/tests/Tests/Entity.hs new file mode 100644 index 0000000..133a88f --- /dev/null +++ b/tests/Tests/Entity.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Entity where + +import Literate.Invoice.Invoice +import Literate.Prelude + +bureau1 = + Address + { addressText = + [ "3, place du Monument" + , "Mairie - Bureau 1" + ] + , addressCity = "Gentioux-Pigerolles" + , addressZipCode = "23340" + , addressCountry = "France" + } + +julmInfo = + Entity + { entityId = Id 1 + , entityName = "julminfo / Julien Moutinho" + , entityAddress = bureau1 + , entityEmail = Just "julm@sourcephile.fr" + , entitySIREN = Just "942798083" + } +nixosFoundationNGITeam = + Entity + { entityId = Id 2 + , entityName = "NixOS Foundation / Nix@NGI Team" + , entityEmail = Just "ngi@nixos.org" + , entityAddress = + Address + { addressText = + [ "Korte Lijnbaanssteeg 1-4318" + ] + , addressZipCode = "1012 SL" + , addressCity = "Amsterdam" + , addressCountry = "Netherlands" + } + , entitySIREN = Nothing + } diff --git a/tests/Tests/Invoice.hs b/tests/Tests/Invoice.hs new file mode 100644 index 0000000..de59312 --- /dev/null +++ b/tests/Tests/Invoice.hs @@ -0,0 +1,68 @@ +module Tests.Invoice where + +import Data.Map.Strict qualified as Map +import Data.Text.Lazy qualified as Text.Lazy +import Literate.Accounting.Math +import Literate.Document.HTML qualified as HTML +import Literate.Invoice.HTML qualified as HTML +import Literate.Invoice.Invoice +import Literate.Prelude +import Test.Syd +import Tests.Entity qualified +import Tests.Utils.Tests +import Text.Blaze.Renderer.Text qualified as Blaze.Text +import Text.Blaze.Renderer.Utf8 qualified as Blaze +import Prelude (undefined) + +spec :: HasCallStack => Spec +spec = + -- aroundAll readDicts do + describe "Invoice" do + forM_ (invoices & Map.toList) \(invoiceId, invoice) -> do + let idS = invoiceId & HTML.toHtml & Blaze.Text.renderMarkup & Text.Lazy.unpack + outPath <- goldenPath idS "html" + it idS do + goldenByteStringBuilderFile outPath do + HTML.htmlIO (invoiceId, invoice) <&> Blaze.renderMarkupBuilder + +invoices :: Invoices +invoices = + [ InvoiceId{invoiceIdBuyer = Tests.Entity.nixosFoundationNGITeam, invoiceIdCount = 1} := + Invoice + { invoiceCreation = "2025-11-30" + , invoiceIssuer = Tests.Entity.julmInfo + , invoiceRecipient = Tests.Entity.nixosFoundationNGITeam + , invoiceCustomer = Tests.Entity.nixosFoundationNGITeam + , invoiceObjet = "Test" + , invoiceDetails = "" + , invoiceItems = + [ InvoiceItem + { invoiceItemDescription = "Organize work" + , invoiceItemRate = 31.25 + , invoiceItemQuantity = 0.5 + 1 + 1 + 1 + 1 + 1 + } + , InvoiceItem + { invoiceItemDescription = "Share knowledge" + , invoiceItemRate = 31.25 + , invoiceItemQuantity = 0.5 + 1 + 2 + } + , InvoiceItem + { invoiceItemDescription = "Make a package for Bonfire in NGIpkgs" + , invoiceItemRate = 31.25 + , invoiceItemQuantity = 4 + 8 + 0.1 + 8 + 4 + 6 + 4 + 5 + 6 + 4 + 8 + 8 + 4 + 4 + 4 + 10 + 8 + } + , InvoiceItem + { invoiceItemDescription = "Make a service for Bonfire in NGIpkgs" + , invoiceItemRate = 31.25 + , invoiceItemQuantity = 5 + 4 + 8 + 5 + } + , InvoiceItem + { invoiceItemDescription = "Make manuals for NGIpkgs" + , invoiceItemRate = 0 + , invoiceItemQuantity = 0.5 + 2 + 4 + 4 + 4 + 8 + 4 + } + ] + , invoiceRate = 0 + } + ] + & Map.fromListWith undefined diff --git a/tests/Tests/Invoice/ent2inv1.html b/tests/Tests/Invoice/ent2inv1.html new file mode 100644 index 0000000..fe70aac --- /dev/null +++ b/tests/Tests/Invoice/ent2inv1.html @@ -0,0 +1,2 @@ + +invoice
Invoice# :
ent2inv1
Date :
2025-11-30
Seller :
julminfo / Julien Moutinho
3, place du Monument
Mairie - Bureau 1
23340
Gentioux-Pigerolles
France
SIREN :
942798083
Email :
julm@sourcephile.fr
Buyer :
NixOS Foundation / Nix@NGI Team
Korte Lijnbaanssteeg 1-4318
1012 SL
Amsterdam
Netherlands
Email :
ngi@nixos.org

#

Description

Rate (excl. taxes.)

Quantity

Total (excl. taxes.)

1

Organize work

31.25 € / h

5.50 h

171.88 €

2

Share knowledge

31.25 € / h

3.50 h

109.38 €

3

Make a package for Bonfire in NGIpkgs

31.25 € / h

95.10 h

2971.88 €

4

Make a service for Bonfire in NGIpkgs

31.25 € / h

22.00 h

687.50 €

5

Make manuals for NGIpkgs

0.00 € / h

26.50 h

0.00 €

Total quantity

Total (excl. taxes)

152.60 h

3940.64 €

\ No newline at end of file diff --git a/tests/Tests/Utils/Tests.hs b/tests/Tests/Utils/Tests.hs new file mode 100644 index 0000000..dcbd1c2 --- /dev/null +++ b/tests/Tests/Utils/Tests.hs @@ -0,0 +1,26 @@ +module Tests.Utils.Tests where + +import Data.GenValidity.Map () +import Data.GenValidity.Sequence () +import Data.GenValidity.Set () +import Data.GenValidity.Text () +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Validity.Map () +import Data.Validity.Set () +import Data.Validity.Text () +import System.FilePath (joinPath, pathSeparator, (<.>), ()) +import Test.Syd + +import Literate.Prelude + +-- import System.Directory qualified as IO + +goldenPath title ext = do + descrPath <- getTestDescriptionPath + let dirPath = + List.reverse descrPath + <&> Text.unpack + . Text.replace (Text.pack ".") (Text.singleton pathSeparator) + & joinPath + return $ "tests" "Tests" dirPath title <.> ext -- 2.49.0