--- /dev/null
+p {
+ margin:0 0;
+}
--- /dev/null
+.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;
+}
+
+
--- /dev/null
+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 }
+}
+**/
--- /dev/null
+.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;
+}
--- /dev/null
+{
+ "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
+}
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:
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"
+ # { };
}
);
})
--- /dev/null
+cabal-version: 3.0
+name: literate-invoice
+maintainer: Julien Moutinho <julm+literate-invoice@sourcephile.fr>
+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 <julm+literate-invoice@sourcephile.fr>
+copyright: Julien Moutinho <julm+literate-invoice@sourcephile.fr>
+
+-- 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
+
--- /dev/null
+{-# 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)
--- /dev/null
+module Literate.Document (
+ module Literate.Document.Type,
+ module Literate.Document.Table,
+)
+where
+
+import Literate.Document.Table
+import Literate.Document.Type
--- /dev/null
+{-# 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"
--- /dev/null
+{-# 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 = []
+ }
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
+ }
+ ]
+ }
+ ]
+ }
+ ]
+ }
+ ]
+ }
--- /dev/null
+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
--- /dev/null
+{-# 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 ..]
--- /dev/null
+{-# 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
+-}
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
+ }
--- /dev/null
+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
--- /dev/null
+<!DOCTYPE HTML>
+<html><head><title>invoice</title><link rel="stylesheet" type="text/css" href="/home/julm/work/sourcephile/haskell/literate-invoice/data/styles/Document.css"><link rel="stylesheet" type="text/css" href="/home/julm/work/sourcephile/haskell/literate-invoice/data/styles/Paper.css"><link rel="stylesheet" type="text/css" href="/home/julm/work/sourcephile/haskell/literate-invoice/data/styles/Table.css"><link rel="stylesheet" type="text/css" href="/home/julm/work/sourcephile/haskell/literate-invoice/data/styles/Invoice.css"></head><body><section class="A4 portrait sheet" style="size:A4 portrait;"><div class="invoice"><div class="key-value invoice-id"><div class="key">Invoice# :</div><div class="value">ent2inv1</div></div><div class="key-value invoice-creation"><div class="key">Date :</div><div class="value">2025-11-30</div></div><div class="invoice-from-to"><div class="invoice-issuer"><div class="entity"><div class="key-value entity-name"><div class="key">Seller :</div><div class="value">julminfo / Julien Moutinho</div></div><div class="entity-address"><div class="address"><div>3, place du Monument</div><div>Mairie - Bureau 1</div><div class="address-bottom"><div>23340</div><div>Gentioux-Pigerolles</div><div>France</div></div></div></div><div class="key-value entity-siren"><div class="key">SIREN :</div><div class="value">942798083</div></div><div class="key-value entity-email"><div class="key">Email :</div><div class="value"><a href="mailto:julm@sourcephile.fr">julm@sourcephile.fr</a></div></div></div></div><div class="invoice-recipient"><div class="entity"><div class="key-value entity-name"><div class="key">Buyer :</div><div class="value">NixOS Foundation / Nix@NGI Team</div></div><div class="entity-address"><div class="address"><div>Korte Lijnbaanssteeg 1-4318</div><div class="address-bottom"><div>1012 SL</div><div>Amsterdam</div><div>Netherlands</div></div></div></div><div class="key-value entity-email"><div class="key">Email :</div><div class="value"><a href="mailto:ngi@nixos.org">ngi@nixos.org</a></div></div></div></div></div><div style="display:flex;flex-direction:column;gap:5.0mm;"><div class="table" style="grid-template-columns:max-content 5fr 1fr 1fr 1fr;"><div class="table-head"><div class="table-cell"><div><p>#</p></div></div><div class="table-cell"><div><p>Description</p></div></div><div class="table-cell"><div><p>Rate (excl. taxes.)</p></div></div><div class="table-cell"><div><p>Quantity</p></div></div><div class="table-cell"><div><p>Total (excl. taxes.)</p></div></div></div><div class="table-body odd"><div class="table-cell" style="justify-items:end;"><p>1</p></div><div class="table-cell" style="justify-items:left;"><p>Organize work</p></div><div class="table-cell" style="justify-items:end;"><p>31.25 € / h</p></div><div class="table-cell" style="justify-items:end;"><p>5.50 h</p></div><div class="table-cell" style="justify-items:end;"><p>171.88 €</p></div></div><div class="table-body even"><div class="table-cell" style="justify-items:end;"><p>2</p></div><div class="table-cell" style="justify-items:left;"><p>Share knowledge</p></div><div class="table-cell" style="justify-items:end;"><p>31.25 € / h</p></div><div class="table-cell" style="justify-items:end;"><p>3.50 h</p></div><div class="table-cell" style="justify-items:end;"><p>109.38 €</p></div></div><div class="table-body odd"><div class="table-cell" style="justify-items:end;"><p>3</p></div><div class="table-cell" style="justify-items:left;"><p>Make a package for Bonfire in NGIpkgs</p></div><div class="table-cell" style="justify-items:end;"><p>31.25 € / h</p></div><div class="table-cell" style="justify-items:end;"><p>95.10 h</p></div><div class="table-cell" style="justify-items:end;"><p>2971.88 €</p></div></div><div class="table-body even"><div class="table-cell" style="justify-items:end;"><p>4</p></div><div class="table-cell" style="justify-items:left;"><p>Make a service for Bonfire in NGIpkgs</p></div><div class="table-cell" style="justify-items:end;"><p>31.25 € / h</p></div><div class="table-cell" style="justify-items:end;"><p>22.00 h</p></div><div class="table-cell" style="justify-items:end;"><p>687.50 €</p></div></div><div class="table-body odd"><div class="table-cell" style="justify-items:end;"><p>5</p></div><div class="table-cell" style="justify-items:left;"><p>Make manuals for NGIpkgs</p></div><div class="table-cell" style="justify-items:end;"><p>0.00 € / h</p></div><div class="table-cell" style="justify-items:end;"><p>26.50 h</p></div><div class="table-cell" style="justify-items:end;"><p>0.00 €</p></div></div></div><div class="table" style="grid-template-columns:1fr 1fr;"><div class="table-head"><div class="table-cell"><div><p>Total quantity</p></div></div><div class="table-cell"><div><p>Total (excl. taxes)</p></div></div></div><div class="table-body odd"><div class="table-cell" style="justify-items:center;"><p>152.60 h</p></div><div class="table-cell" style="justify-items:center;"><p>3940.64 €</p></div></div></div></div></div></section></body></html>
\ No newline at end of file
--- /dev/null
+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
sourcephile / git / tmp / julm / literate-invoice.git / commitdiff