src/Symantic/Compta/Lang.hs

   1 --{-# LANGUAGE ApplicativeDo #-}
   2 {-# LANGUAGE AllowAmbiguousTypes #-}
   3 {-# LANGUAGE BlockArguments #-}
   4 {-# LANGUAGE ConstraintKinds #-}
   5 {-# LANGUAGE DataKinds #-}
   6 {-# LANGUAGE DefaultSignatures #-}
   7 {-# LANGUAGE FlexibleContexts #-}
   8 {-# LANGUAGE GADTs #-}
   9 {-# LANGUAGE KindSignatures #-}
  10 {-# LANGUAGE LambdaCase #-}
  11 {-# LANGUAGE MultiParamTypeClasses #-}
  12 {-# LANGUAGE NoImplicitPrelude #-}
  13 {-# LANGUAGE OverloadedLabels #-}
  14 {-# LANGUAGE OverloadedLists #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16 {-# LANGUAGE PatternSynonyms #-}
  17 {-# LANGUAGE PolyKinds #-}
  18 {-# LANGUAGE PostfixOperators #-}
  19 {-# LANGUAGE RebindableSyntax #-}
  20 {-# LANGUAGE StandaloneDeriving #-}
  21 {-# LANGUAGE TupleSections #-}
  22 {-# LANGUAGE TypeFamilies #-}
  23 {-# LANGUAGE UndecidableInstances #-}
  24 {-# LANGUAGE UnicodeSyntax #-}
  25 {-# LANGUAGE ViewPatterns #-}
  26 {-# OPTIONS_GHC -Wno-missing-signatures #-}
  27 {-# OPTIONS_GHC -Wno-unused-do-bind #-}
  28 {-# OPTIONS_GHC -Wno-orphans #-}
  29 {-# OPTIONS_GHC -Wno-unused-imports #-}
  30 module Symantic.Compta.Lang
  31   ( module Symantic.Compta.Lang
  32   , module Symantic.Compta.Lang.Math
  33   , module Symantic.Compta.Lang.Rebindable
  34   ) where
  35 import Control.Applicative (Applicative(..))
  36 import Control.DeepSeq (NFData(..))
  37 import Control.Monad (Monad(..))
  38 import Data.Decimal (Decimal)
  39 import Data.Eq (Eq)
  40 import Data.Function (($), (.), id)
  41 import Data.Functor (Functor, (<$>))
  42 import Data.Int (Int)
  43 import Data.Kind
  44 import Data.List.NonEmpty (NonEmpty)
  45 import Data.Map.Strict (Map)
  46 import Data.Maybe (Maybe)
  47 import Data.Ord (Ord)
  48 import Data.Semigroup (Semigroup(..))
  49 import Data.Monoid (Monoid)
  50 import Data.String (String)
  51 import Data.Typeable (Typeable)
  52 import GHC.Generics (Generic)
  53 import GHC.Stack (HasCallStack)
  54 import GHC.TypeLits (Symbol, ErrorMessage(..))
  55 import Numeric.Natural (Natural)
  56 import Prelude (Integer, Enum(..))
  57 import Text.Show (Show(..))
  58 import Type.Reflection
  59 import qualified Data.Char as Char
  60 import qualified Data.List as List
  61 import qualified Data.Maybe as Maybe
  62 import qualified Data.String as String
  63 import qualified Data.Time.Calendar as Time
  64 import qualified GHC.Exts as GHC
  65 import qualified Prelude
  66
  67 import Symantic.Compta.Lang.Math
  68 import Symantic.Compta.Lang.Rebindable
  69 import Symantic.Compta.Utils.Error
  70
  71 data TyQuantity
  72 data TyUnit
  73 data TyAmount = TyAmount
  74 data TyAccount = TyAccount
  75 data TyAccountSection
  76 data TyPost = TyPost deriving (Show)
  77 data TyPosts = TyPosts deriving (Show)
  78 data TyMove = TyMove deriving (Show)
  79 data TyMoves = TyMoves deriving (Show, Semigroup, Monoid)
  80 type family Tr (repr::Type -> Type) (ty::Type) :: Type
  81
  82
  83 type Repr = Type -> Type
  84
  85 --type ErrorNumAmount (unit::Symbol) = 'Text "err unit:" ':$$: 'ShowType unit
  86 --instance TypeError (ErrorNumAmount unit) => Num (AmountOf unit repr)
  87
  88 -- | Usual syntax for type-preserving term-abstraction.
  89 class Abstractable repr where
  90   -- | Lambda term (abstract).
  91   lam :: (repr a -> repr b) -> repr (a -> b)
  92   -- | Term application (unabstract).
  93   (.@) :: repr (a -> b) -> repr a -> repr b; infixl 9 .@
  94
  95 type DataRepr = Type -> Type
  96 data family Data (able :: DataRepr -> Constraint) :: DataRepr -> DataRepr
  97 data SomeData repr a = forall able. (Unliftable (Data able) repr, Typeable able) => SomeData (Data able repr a)
  98 -- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
  99 -- extract the data-constructor from the given 'SomeData'
 100 -- iif. it belongs to the @('Data' able repr a)@ data-instance.
 101 unSomeData ::
 102   forall able repr a.
 103   Typeable able =>
 104   SomeData repr a -> Maybe (Data able repr a)
 105 unSomeData (SomeData (c::Data c repr a)) =
 106   case typeRep @able `eqTypeRep` typeRep @c of
 107     Maybe.Just HRefl -> Maybe.Just c
 108     Maybe.Nothing -> Maybe.Nothing
 109 -- | Convenient utility to pattern-match a 'SomeData'.
 110 pattern Data :: Typeable able => Data able repr a -> SomeData repr a
 111 pattern Data x <- (unSomeData -> Maybe.Just x)
 112
 113 class Unliftable r repr where
 114   unlift :: r repr a -> repr a
 115 class Liftable r repr where
 116   lift :: repr a -> r repr a
 117 class Trans from to where
 118   trans :: from a -> to a
 119
 120 type family Ty (repr::Type -> Type) (a::Type) :: Type
 121
 122 class Accountable repr where
 123   account :: Ty repr TyAccount -> repr TyAccount
 124 class Amountable repr where
 125   amount :: Ty repr TyAmount -> repr TyAmount
 126
 127 class Inject a repr ty where
 128   inject :: a -> repr ty
 129
 130 {-
 131 type family AccountOf (t::k) :: Type
 132 type family AccountSectionOf (t::k) :: Type
 133 type family AmountOf (t::k) :: Type
 134 type family QuantityOf (t::k) :: Type
 135 type family UnitOf (t::k) :: Type
 136 type family PostOf (t::k) :: Type
 137 type family MoveOf (t::k) :: Type
 138 type family TransactionsOf (t::k) :: Type
 139 type family ChartSectionOf (t::k) :: Type
 140 type family ChartOf (t::k) :: Type
 141 type instance UnitOf (Maybe amt) = UnitOf amt
 142 type instance QuantityOf (Maybe amt) = QuantityOf amt
 143 type instance UnitOf (Map unit qty) = unit
 144 type instance QuantityOf (Map unit qty) = qty
 145 -}
 146 {-
 147 type family AccountOf (repr::Repr) :: Type
 148 type family AccountSectionOf (repr::Repr) :: Type
 149 type family AmountOf (repr::Repr) :: Type
 150 type family QuantityOf (repr::Repr) :: Type
 151 type family UnitOf (repr::Repr) :: Type
 152 type family PostOf (repr::Repr) :: Type
 153 type family MoveOf (repr::Repr) :: Type
 154 type family TransactionsOf (repr::Repr) :: Type
 155 type family ChartSectionOf (repr::Repr) :: Type
 156 type family ChartOf (repr::Repr) :: Type
 157
 158 -- * Class 'Accountable'
 159 class Accountable repr where
 160   account :: AccountOf repr -> repr (AccountOf repr)
 161 class Amountable repr where
 162   amount :: AmountOf repr -> repr (AmountOf repr)
 163 -}
 164   --account :: acct -> repr a -> repr a
 165   --accountFromStrings :: [String] -> repr (AccountOf repr)
 166   --accountFromNatural :: Natural -> repr (AccountOf repr)
 167 --class Literable repr where
 168 --  lit :: a -> repr a
 169
 170 -- * Class 'Postable'
 171 class Postable repr where
 172   post :: HasCallStack => repr TyAccount -> repr TyAmount -> repr TyPost
 173 infixr 4 -=, +=
 174 (-=) ::
 175   HasCallStack =>
 176   Postable repr => Negable (repr TyAmount) =>
 177   repr TyAccount -> repr TyAmount -> repr TyPost
 178 (+=) ::
 179   HasCallStack => Postable repr =>
 180   repr TyAccount -> repr TyAmount -> repr TyPost
 181 (-=) acct = post acct . negate
 182 (+=) = post
 183
 184 --(>>) = cons
 185
 186 -- * Class 'Moveable'
 187 class Moveable repr where
 188   move :: HasCallStack => repr [TyPost] -> repr TyMove
 189
 190 {-
 191 class Postingable repr where
 192   (+=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 +=
 193   (-=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 -=
 194 -}
 195
 196 -- * Class 'Transactionable'
 197 {-
 198 class Transactionable repr where
 199   txn :: String -> repr (PostingsOf repr) -> repr (TransactionsOf repr)
 200 -}
 201
 202 -- * Class 'Datable'
 203 type Year = Natural
 204 data Month = January | February | March | April | May | June | July | September | October | November | December
 205   deriving (Enum, Show)
 206 type Day = Time.Day
 207 class Datable a repr where
 208   year :: Year -> repr a -> repr a
 209   month :: Month -> repr a -> repr a
 210   day :: Int -> repr a -> repr a
 211   date :: Year -> Month -> Int -> repr a -> repr a
 212
 213 -- * Class 'Chartable'
 214 class Chartable chart section repr where
 215   section :: HasCallStack => section -> repr chart -> repr chart
 216 class ChartableLeaf chart repr where
 217   anySection :: HasCallStack => repr chart
 218
 219 -- * Class 'Descriptionable'
 220 class Descriptionable repr where
 221   description :: HasCallStack => String -> repr ()
 222
 223 -- * Class 'Namable'
 224 class Namable repr where
 225   name :: HasCallStack => String -> repr ()
 226
 227 {-
 228 -- * Class 'Journalable'
 229 class
 230   ( EUR repr
 231   , USD repr
 232   , Functor repr
 233   , Applicative repr
 234   , Monad repr
 235   , Accountable repr
 236   , Datable (PostingsOf repr) repr
 237   , Datable (TransactionsOf repr) repr
 238   , FromInteger (repr (AccountOf repr))
 239   , IsString (repr (AccountOf repr))
 240   , Postingable repr
 241   , Transactionable repr
 242   ) => Journalable repr
 243 instance
 244   ( EUR repr
 245   , USD repr
 246   , Functor repr
 247   , Applicative repr
 248   , Monad repr
 249   , Accountable repr
 250   , Datable (PostingsOf repr) repr
 251   , Datable (TransactionsOf repr) repr
 252   , FromInteger (repr (AccountOf repr))
 253   , IsString (repr (AccountOf repr))
 254   , Postingable repr
 255   , Transactionable repr
 256   ) => Journalable repr
 257
 258
 259 t0 :: Journalable repr => repr (TransactionsOf repr)
 260 t0 =
 261   year 2020 do
 262     month January do
 263       day 1 $ do
 264         txn "w0" do
 265           accountFromStrings ["A"] -= eur 10
 266           accountFromStrings ["B"] += usd 5
 267           accountFromStrings ["C"] += (5€)
 268         txn "w1" do
 269           "A" -= eur 10
 270           "B" += eur 10
 271         txn "w2" do
 272           accountFromNatural 511 -= eur 10
 273           701 += eur 10
 274         txn "w3" do
 275           "Capital/Tiers" -= eur 10
 276           --["Capital","Tiers"] -= eur 10
 277           "B" += eur 10
 278           "B" += eur 10
 279 -}
 280
 281 (&) r f = f r
 282 infix 0 &