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 type family Ty (repr::Type -> Type) (a::Type) :: Type
  72 data TyQuantity
  73 data TyUnit
  74 data TyAmount = TyAmount
  75 data TyAccount = TyAccount
  76 data TyAccountSection
  77 data TyPost = TyPost deriving (Show)
  78 data TyPosts = TyPosts deriving (Show)
  79 data TyMove = TyMove deriving (Show)
  80 data TyMoves = TyMoves deriving (Show, Semigroup, Monoid)
  81 --type family Tr (repr::Type -> Type) (ty::Type) :: Type
  82
  83
  84 {-
  85 type Repr = Type -> Type
  86
  87 --type ErrorNumAmount (unit::Symbol) = 'Text "err unit:" ':$$: 'ShowType unit
  88 --instance TypeError (ErrorNumAmount unit) => Num (AmountOf unit repr)
  89
  90 -- | Usual syntax for type-preserving term-abstraction.
  91 class Abstractable repr where
  92   -- | Lambda term (abstract).
  93   lam :: (repr a -> repr b) -> repr (a -> b)
  94   -- | Term application (unabstract).
  95   (.@) :: repr (a -> b) -> repr a -> repr b; infixl 9 .@
  96
  97 type DataRepr = Type -> Type
  98 data family Data (able :: DataRepr -> Constraint) :: DataRepr -> DataRepr
  99 data SomeData repr a = forall able. (Trans ((Data able) repr) repr, Typeable able) => SomeData (Data able repr a)
 100 -- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
 101 -- extract the data-constructor from the given 'SomeData'
 102 -- iif. it belongs to the @('Data' able repr a)@ data-instance.
 103 unSomeData ::
 104   forall able repr a.
 105   Typeable able =>
 106   SomeData repr a -> Maybe (Data able repr a)
 107 unSomeData (SomeData (c::Data c repr a)) =
 108   case typeRep @able `eqTypeRep` typeRep @c of
 109     Maybe.Just HRefl -> Maybe.Just c
 110     Maybe.Nothing -> Maybe.Nothing
 111 -- | Convenient utility to pattern-match a 'SomeData'.
 112 pattern Data :: Typeable able => Data able repr a -> SomeData repr a
 113 pattern Data x <- (unSomeData -> Maybe.Just x)
 114
 115 class Unliftable r repr where
 116   unlift :: r repr a -> repr a
 117 class Liftable r repr where
 118   lift :: repr a -> r repr a
 119 -}
 120 class Trans from to where
 121   trans :: from a -> to a
 122
 123 class Accountable repr where
 124   account :: Ty repr TyAccount -> repr TyAccount
 125 class Amountable repr where
 126   amount :: Ty repr TyAmount -> repr TyAmount
 127
 128 class Inject a repr ty where
 129   inject :: a -> repr ty
 130
 131 {-
 132 type family AccountOf (t::k) :: Type
 133 type family AccountSectionOf (t::k) :: Type
 134 type family AmountOf (t::k) :: Type
 135 type family QuantityOf (t::k) :: Type
 136 type family UnitOf (t::k) :: Type
 137 type family PostOf (t::k) :: Type
 138 type family MoveOf (t::k) :: Type
 139 type family TransactionsOf (t::k) :: Type
 140 type family ChartSectionOf (t::k) :: Type
 141 type family ChartOf (t::k) :: Type
 142 type instance UnitOf (Maybe amt) = UnitOf amt
 143 type instance QuantityOf (Maybe amt) = QuantityOf amt
 144 type instance UnitOf (Map unit qty) = unit
 145 type instance QuantityOf (Map unit qty) = qty
 146 -}
 147 {-
 148 type family AccountOf (repr::Repr) :: Type
 149 type family AccountSectionOf (repr::Repr) :: Type
 150 type family AmountOf (repr::Repr) :: Type
 151 type family QuantityOf (repr::Repr) :: Type
 152 type family UnitOf (repr::Repr) :: Type
 153 type family PostOf (repr::Repr) :: Type
 154 type family MoveOf (repr::Repr) :: Type
 155 type family TransactionsOf (repr::Repr) :: Type
 156 type family ChartSectionOf (repr::Repr) :: Type
 157 type family ChartOf (repr::Repr) :: Type
 158
 159 -- * Class 'Accountable'
 160 class Accountable repr where
 161   account :: AccountOf repr -> repr (AccountOf repr)
 162 class Amountable repr where
 163   amount :: AmountOf repr -> repr (AmountOf repr)
 164 -}
 165   --account :: acct -> repr a -> repr a
 166   --accountFromStrings :: [String] -> repr (AccountOf repr)
 167   --accountFromNatural :: Natural -> repr (AccountOf repr)
 168 --class Literable repr where
 169 --  lit :: a -> repr a
 170
 171 -- * Class 'Postable'
 172 class Postable repr where
 173   post :: HasCallStack => repr TyAccount -> repr TyAmount -> repr TyPost
 174 infixr 4 -=, +=
 175 (-=) ::
 176   HasCallStack =>
 177   Postable repr => Negable (repr TyAmount) =>
 178   repr TyAccount -> repr TyAmount -> repr TyPost
 179 (+=) ::
 180   HasCallStack => Postable repr =>
 181   repr TyAccount -> repr TyAmount -> repr TyPost
 182 (-=) acct = post acct . negate
 183 (+=) = post
 184
 185 --(>>) = cons
 186
 187 -- * Class 'Moveable'
 188 class Moveable repr where
 189   move :: HasCallStack => repr [TyPost] -> repr TyMove
 190
 191 {-
 192 class Postingable repr where
 193   (+=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 +=
 194   (-=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 -=
 195 -}
 196
 197 -- * Class 'Transactionable'
 198 {-
 199 class Transactionable repr where
 200   txn :: String -> repr (PostingsOf repr) -> repr (TransactionsOf repr)
 201 -}
 202
 203 -- * Class 'Datable'
 204 type Year = Natural
 205 data Month = January | February | March | April | May | June | July | September | October | November | December
 206   deriving (Enum, Show)
 207 type Day = Time.Day
 208 class Datable a repr where
 209   year :: Year -> repr a -> repr a
 210   month :: Month -> repr a -> repr a
 211   day :: Int -> repr a -> repr a
 212   date :: Year -> Month -> Int -> repr a -> repr a
 213
 214 -- * Class 'Chartable'
 215 class Chartable chart section repr where
 216   section :: HasCallStack => section -> repr chart -> repr chart
 217 class ChartableLeaf chart repr where
 218   anySection :: HasCallStack => repr chart
 219
 220 -- * Class 'Descriptionable'
 221 class Descriptionable repr where
 222   description :: HasCallStack => String -> repr ()
 223
 224 -- * Class 'Namable'
 225 class Namable repr where
 226   name :: HasCallStack => String -> repr ()
 227
 228 {-
 229 -- * Class 'Journalable'
 230 class
 231   ( EUR repr
 232   , USD repr
 233   , Functor repr
 234   , Applicative repr
 235   , Monad repr
 236   , Accountable repr
 237   , Datable (PostingsOf repr) repr
 238   , Datable (TransactionsOf repr) repr
 239   , FromInteger (repr (AccountOf repr))
 240   , IsString (repr (AccountOf repr))
 241   , Postingable repr
 242   , Transactionable repr
 243   ) => Journalable repr
 244 instance
 245   ( EUR repr
 246   , USD repr
 247   , Functor repr
 248   , Applicative repr
 249   , Monad repr
 250   , Accountable repr
 251   , Datable (PostingsOf repr) repr
 252   , Datable (TransactionsOf repr) repr
 253   , FromInteger (repr (AccountOf repr))
 254   , IsString (repr (AccountOf repr))
 255   , Postingable repr
 256   , Transactionable repr
 257   ) => Journalable repr
 258
 259
 260 t0 :: Journalable repr => repr (TransactionsOf repr)
 261 t0 =
 262   year 2020 do
 263     month January do
 264       day 1 $ do
 265         txn "w0" do
 266           accountFromStrings ["A"] -= eur 10
 267           accountFromStrings ["B"] += usd 5
 268           accountFromStrings ["C"] += (5€)
 269         txn "w1" do
 270           "A" -= eur 10
 271           "B" += eur 10
 272         txn "w2" do
 273           accountFromNatural 511 -= eur 10
 274           701 += eur 10
 275         txn "w3" do
 276           "Capital/Tiers" -= eur 10
 277           --["Capital","Tiers"] -= eur 10
 278           "B" += eur 10
 279           "B" += eur 10
 280 -}
 281
 282 (&) r f = f r
 283 infix 0 &