ENH use mostly dhall types

This commit is contained in:
Nathan Dwarshuis 2023-04-17 00:34:09 -04:00
parent 8c5a68a4b4
commit c2c30caf69
5 changed files with 139 additions and 195 deletions

View File

@ -29,6 +29,7 @@ library
Internal.Database.Ops Internal.Database.Ops
Internal.Insert Internal.Insert
Internal.Statement Internal.Statement
Internal.TH
Internal.Types Internal.Types
Internal.Utils Internal.Utils
other-modules: other-modules:

View File

@ -112,7 +112,10 @@ let MatchYMD = < Y : Natural | YM : GregorianM | YMD : Gregorian >
let MatchDate = < On : MatchYMD | In : { _1 : MatchYMD, _2 : Natural } > let MatchDate = < On : MatchYMD | In : { _1 : MatchYMD, _2 : Natural } >
let MatchOther = < Desc : Field Text Text | Val : Field Text MatchVal.Type > let MatchOther_ =
\(re : Type) -> < Desc : Field Text re | Val : Field Text MatchVal.Type >
let MatchOther = MatchOther_ Text
let SplitNum = < LookupN : Text | ConstN : Decimal | AmountN > let SplitNum = < LookupN : Text | ConstN : Decimal | AmountN >
@ -151,26 +154,29 @@ let ToTx =
, ttSplit : List ExpSplit.Type , ttSplit : List ExpSplit.Type
} }
let Match = let Match_ =
{ Type = \(re : Type) ->
{ mDate : Optional MatchDate { Type =
, mVal : MatchVal.Type { mDate : Optional MatchDate
, mDesc : Optional Text , mVal : MatchVal.Type
, mOther : List MatchOther , mDesc : Optional re
, mTx : Optional ToTx , mOther : List (MatchOther_ re)
, mTimes : Optional Natural , mTx : Optional ToTx
, mPriority : Integer , mTimes : Optional Natural
, mPriority : Integer
}
, default =
{ mDate = None MatchDate
, mVal = MatchVal::{=}
, mDesc = None Text
, mOther = [] : List (MatchOther_ re)
, mTx = None ToTx
, mTimes = None Natural
, mPriority = +0
} }
, default =
{ mDate = None MatchDate
, mVal = MatchVal::{=}
, mDesc = None Text
, mOther = [] : List MatchOther
, mTx = None ToTx
, mTimes = None Natural
, mPriority = +0
} }
}
let Match = Match_ Text
let Manual = let Manual =
{ manualDate : DatePat { manualDate : DatePat
@ -303,10 +309,12 @@ in { CurID
, Decimal , Decimal
, TxOpts , TxOpts
, Match , Match
, Match_
, MatchVal , MatchVal
, MatchYMD , MatchYMD
, MatchDate , MatchDate
, MatchOther , MatchOther
, MatchOther_
, SplitNum , SplitNum
, Field , Field
, FieldMap , FieldMap

View File

@ -326,7 +326,7 @@ fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
-- res <- expandTarget alloPath -- res <- expandTarget alloPath
return $ fmap toBT alloAmts return $ fmap toBT alloAmts
where where
toBT (Amount desc v) = toBT (Amount {amtDesc = desc, amtValue = v}) =
BudgetTxType BudgetTxType
{ bttTx = { bttTx =
BudgetTx BudgetTx
@ -400,7 +400,7 @@ expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersis
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
-- whenHash CTExpense t (Right []) $ \key -> -- whenHash CTExpense t (Right []) $ \key ->
fmap (fmap concat . concatEithersL) $ fmap (fmap concat . concatEithersL) $
forM transAmounts $ \(TimeAmount pat (Amount desc v) atype) -> do forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do
withDates pat $ \day -> withDates pat $ \day ->
let meta = let meta =
BudgetMeta BudgetMeta

12
lib/Internal/TH.hs Normal file
View File

@ -0,0 +1,12 @@
module Internal.TH where
import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
import RIO
deriveProduct :: [String] -> [String] -> Q [Dec]
deriveProduct cs ss =
return $
[ StandaloneDerivD Nothing [] (AppT x y)
| x <- ConT . mkName <$> cs
, y <- ConT . mkName <$> ss
]

View File

@ -12,6 +12,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH import Database.Persist.TH
import Dhall hiding (embed, maybe) import Dhall hiding (embed, maybe)
import Dhall.TH import Dhall.TH
import Internal.TH (deriveProduct)
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import RIO import RIO
import qualified RIO.Map as M import qualified RIO.Map as M
@ -25,7 +26,7 @@ import Text.Regex.TDFA
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeHaskellTypesWith makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False}) (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@ -50,84 +51,93 @@ makeHaskellTypesWith
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount" , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt" , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type" , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer" , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
]
deriveProduct
["Eq", "Show", "Generic", "FromDhall"]
[ "Currency"
, "Tag"
, "TimeUnit"
, "Weekday"
, "WeekdayPat"
, "RepeatPat"
, "MDYPat"
, "Gregorian"
, "GregorianM"
, "Interval"
, "ModPat"
, "CronPat"
, "DatePat"
, "TaggedAcnt"
, "Budget"
, "Income"
, "ShadowTransfer"
, "ShadowMatch"
, "AcntSet"
, "MatchDate"
, "MatchVal"
, "MatchYMD"
, "Decimal"
, "Transfer"
, "BudgetCurrency"
, "Manual"
, "Exchange"
, "Amount"
, "AmountType"
, "SplitNum"
, "Global"
, "SqlConfig"
] ]
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- lots of instances for dhall types -- lots of instances for dhall types
deriving instance Eq Currency
deriving instance Lift Currency deriving instance Lift Currency
deriving instance Hashable Currency deriving instance Hashable Currency
deriving instance Eq Tag
deriving instance Lift Tag deriving instance Lift Tag
deriving instance Hashable Tag deriving instance Hashable Tag
deriving instance Eq TimeUnit
deriving instance Ord TimeUnit deriving instance Ord TimeUnit
deriving instance Show TimeUnit
deriving instance Hashable TimeUnit deriving instance Hashable TimeUnit
deriving instance Eq Weekday
deriving instance Ord Weekday deriving instance Ord Weekday
deriving instance Show Weekday
deriving instance Hashable Weekday deriving instance Hashable Weekday
deriving instance Enum Weekday deriving instance Enum Weekday
deriving instance Eq WeekdayPat
deriving instance Ord WeekdayPat deriving instance Ord WeekdayPat
deriving instance Show WeekdayPat
deriving instance Hashable WeekdayPat deriving instance Hashable WeekdayPat
deriving instance Show RepeatPat
deriving instance Eq RepeatPat
deriving instance Ord RepeatPat deriving instance Ord RepeatPat
deriving instance Hashable RepeatPat deriving instance Hashable RepeatPat
deriving instance Show MDYPat
deriving instance Eq MDYPat
deriving instance Ord MDYPat deriving instance Ord MDYPat
deriving instance Hashable MDYPat deriving instance Hashable MDYPat
deriving instance Eq Gregorian
deriving instance Show Gregorian
deriving instance Hashable Gregorian deriving instance Hashable Gregorian
deriving instance Eq GregorianM
deriving instance Show GregorianM
deriving instance Hashable GregorianM deriving instance Hashable GregorianM
-- Dhall.TH rearranges my fields :( -- Dhall.TH rearranges my fields :(
@ -144,34 +154,18 @@ instance Ord GregorianM where
GregorianM {gmYear = y, gmMonth = m} GregorianM {gmYear = y, gmMonth = m}
GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m' GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq Interval
deriving instance Ord Interval
deriving instance Hashable Interval deriving instance Hashable Interval
deriving instance Eq ModPat
deriving instance Ord ModPat deriving instance Ord ModPat
deriving instance Show ModPat
deriving instance Hashable ModPat deriving instance Hashable ModPat
deriving instance Eq CronPat
deriving instance Ord CronPat deriving instance Ord CronPat
deriving instance Show CronPat
deriving instance Hashable CronPat deriving instance Hashable CronPat
deriving instance Eq DatePat
deriving instance Ord DatePat deriving instance Ord DatePat
deriving instance Show DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
data Budget = Budget data Budget = Budget
@ -184,18 +178,8 @@ data Budget = Budget
, shadowTransfers :: [ShadowTransfer] , shadowTransfers :: [ShadowTransfer]
} }
deriving instance Eq Budget
deriving instance Generic Budget
deriving instance Hashable Budget deriving instance Hashable Budget
deriving instance FromDhall Budget
deriving instance Show TaggedAcnt
deriving instance Eq TaggedAcnt
deriving instance Hashable TaggedAcnt deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt deriving instance Ord TaggedAcnt
@ -213,32 +197,14 @@ data Income = Income
, incToBal :: TaggedAcnt , incToBal :: TaggedAcnt
} }
deriving instance Eq Income
deriving instance Generic Income
deriving instance Hashable Income deriving instance Hashable Income
deriving instance FromDhall Income
deriving instance Show Amount
deriving instance Eq Amount
deriving instance Ord Amount deriving instance Ord Amount
deriving instance Hashable Amount deriving instance Hashable Amount
deriving instance Show Exchange
deriving instance Eq Exchange
deriving instance Hashable Exchange deriving instance Hashable Exchange
deriving instance Show BudgetCurrency
deriving instance Eq BudgetCurrency
deriving instance Hashable BudgetCurrency deriving instance Hashable BudgetCurrency
data Allocation_ a = Allocation_ data Allocation_ a = Allocation_
@ -246,28 +212,14 @@ data Allocation_ a = Allocation_
, alloAmts :: [a] , alloAmts :: [a]
, alloCur :: BudgetCurrency , alloCur :: BudgetCurrency
} }
deriving (Show) deriving (Eq, Show, Generic, Hashable)
deriving instance FromDhall a => FromDhall (Allocation_ a)
type Allocation = Allocation_ Amount type Allocation = Allocation_ Amount
deriving instance Eq Allocation
deriving instance Generic Allocation
deriving instance Hashable Allocation
deriving instance FromDhall Allocation
type IntervalAllocation = Allocation_ IntervalAmount type IntervalAllocation = Allocation_ IntervalAmount
deriving instance Eq IntervalAllocation
deriving instance Generic IntervalAllocation
deriving instance Hashable IntervalAllocation
deriving instance FromDhall IntervalAllocation
toPersistText :: Show a => a -> PersistValue toPersistText :: Show a => a -> PersistValue
toPersistText = PersistText . T.pack . show toPersistText = PersistText . T.pack . show
@ -278,42 +230,40 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
fromPersistText what x = fromPersistText what x =
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)] Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
deriving instance Show AmountType
deriving instance Eq AmountType
deriving instance Ord AmountType deriving instance Ord AmountType
deriving instance Hashable AmountType deriving instance Hashable AmountType
data TimeAmount a = TimeAmount -- data TimeAmount a = TimeAmount
{ taWhen :: a -- { taWhen :: a
, taAmt :: Amount -- , taAmt :: Amount
, taAmtType :: AmountType -- , taAmtType :: AmountType
} -- }
deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable) -- deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
deriving instance Show a => Show (TimeAmount a)
deriving instance Eq a => Eq (TimeAmount a)
deriving instance Ord a => Ord (TimeAmount a)
deriving instance Functor TimeAmount
deriving instance Foldable TimeAmount
deriving instance Traversable TimeAmount
deriving instance Generic (TimeAmount a)
deriving instance Hashable a => Hashable (TimeAmount a)
deriving instance FromDhall a => FromDhall (TimeAmount a)
type DateAmount = TimeAmount DatePat type DateAmount = TimeAmount DatePat
-- deriving instance Eq DateAmount
-- deriving instance Generic DateAmount
-- deriving instance Hashable DateAmount
-- deriving instance FromDhall DateAmount
type IntervalAmount = TimeAmount Interval type IntervalAmount = TimeAmount Interval
-- deriving instance Eq IntervalAmount deriving instance Ord Interval
-- deriving instance Ord IntervalAmount
-- deriving instance Generic IntervalAmount
-- deriving instance Hashable IntervalAmount
-- deriving instance FromDhall IntervalAmount
data Transfer = Transfer data Transfer = Transfer
{ transFrom :: TaggedAcnt { transFrom :: TaggedAcnt
@ -322,52 +272,24 @@ data Transfer = Transfer
, transCurrency :: BudgetCurrency , transCurrency :: BudgetCurrency
} }
deriving instance Eq Transfer
deriving instance Generic Transfer
deriving instance Hashable Transfer deriving instance Hashable Transfer
deriving instance FromDhall Transfer
deriving instance Eq ShadowTransfer
deriving instance Hashable ShadowTransfer deriving instance Hashable ShadowTransfer
deriving instance Eq AcntSet
deriving instance Hashable AcntSet deriving instance Hashable AcntSet
deriving instance Eq ShadowMatch
deriving instance Hashable ShadowMatch deriving instance Hashable ShadowMatch
deriving instance Eq MatchVal
deriving instance Hashable MatchVal deriving instance Hashable MatchVal
deriving instance Show MatchVal
deriving instance Eq MatchYMD
deriving instance Hashable MatchYMD deriving instance Hashable MatchYMD
deriving instance Show MatchYMD
deriving instance Eq MatchDate
deriving instance Hashable MatchDate deriving instance Hashable MatchDate
deriving instance Show MatchDate
deriving instance Eq Decimal
deriving instance Ord Decimal deriving instance Ord Decimal
deriving instance Hashable Decimal deriving instance Hashable Decimal
deriving instance Show Decimal
-- TODO this just looks silly...but not sure how to simplify it -- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where instance Ord MatchYMD where
compare (Y y) (Y y') = compare y y' compare (Y y) (Y y') = compare y y'
@ -390,14 +312,8 @@ instance Ord MatchDate where
compare (On d) (In d' _) = compare d d' <> LT compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT compare (In d _) (On d') = compare d d' <> GT
deriving instance Eq SplitNum
deriving instance Hashable SplitNum deriving instance Hashable SplitNum
deriving instance Show SplitNum
deriving instance Eq Manual
deriving instance Hashable Manual deriving instance Hashable Manual
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -473,19 +389,18 @@ data Statement
| StmtImport !Import | StmtImport !Import
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Split a v c t = Split
{ sAcnt :: !a
, sValue :: !v
, sCurrency :: !c
, sComment :: !T.Text
, sTags :: ![t]
}
deriving (Eq, Generic, Hashable, Show)
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
instance FromDhall ExpSplit instance FromDhall ExpSplit
deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
deriving instance Generic (Split a v c t)
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
data Tx s = Tx data Tx s = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
, txDate :: !Day , txDate :: !Day
@ -530,11 +445,19 @@ type SplitCur = SplitText CurID
type SplitAcnt = SplitText AcntID type SplitAcnt = SplitText AcntID
data Field k v = Field deriving instance (Show k, Show v) => Show (Field k v)
{ fKey :: !k
, fVal :: !v deriving instance (Eq k, Eq v) => Eq (Field k v)
}
deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable) deriving instance Generic (Field k v)
deriving instance (Hashable k, Hashable v) => Hashable (Field k v)
deriving instance Foldable (Field k)
deriving instance Traversable (Field k)
deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)
instance Functor (Field f) where instance Functor (Field f) where
fmap f (Field k v) = Field k $ f v fmap f (Field k v) = Field k $ f v