diff --git a/budget.cabal b/budget.cabal index 3516b37..6c1cdb4 100644 --- a/budget.cabal +++ b/budget.cabal @@ -29,6 +29,7 @@ library Internal.Database.Ops Internal.Insert Internal.Statement + Internal.TH Internal.Types Internal.Utils other-modules: diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 3bf6b48..0425e75 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -112,7 +112,10 @@ let MatchYMD = < Y : Natural | YM : GregorianM | YMD : Gregorian > 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 > @@ -151,26 +154,29 @@ let ToTx = , ttSplit : List ExpSplit.Type } -let Match = - { Type = - { mDate : Optional MatchDate - , mVal : MatchVal.Type - , mDesc : Optional Text - , mOther : List MatchOther - , mTx : Optional ToTx - , mTimes : Optional Natural - , mPriority : Integer +let Match_ = + \(re : Type) -> + { Type = + { mDate : Optional MatchDate + , mVal : MatchVal.Type + , mDesc : Optional re + , mOther : List (MatchOther_ re) + , mTx : Optional ToTx + , 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 = { manualDate : DatePat @@ -303,10 +309,12 @@ in { CurID , Decimal , TxOpts , Match + , Match_ , MatchVal , MatchYMD , MatchDate , MatchOther + , MatchOther_ , SplitNum , Field , FieldMap diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index c07b276..3d50823 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -326,7 +326,7 @@ fromAllo day meta from Allocation_ {alloTo, alloAmts} = do -- res <- expandTarget alloPath return $ fmap toBT alloAmts where - toBT (Amount desc v) = + toBT (Amount {amtDesc = desc, amtValue = v}) = BudgetTxType { bttTx = BudgetTx @@ -400,7 +400,7 @@ expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersis expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = -- whenHash CTExpense t (Right []) $ \key -> 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 -> let meta = BudgetMeta diff --git a/lib/Internal/TH.hs b/lib/Internal/TH.hs new file mode 100644 index 0000000..51c0ce1 --- /dev/null +++ b/lib/Internal/TH.hs @@ -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 + ] diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 3730fe0..c2a58ff 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -12,6 +12,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.TH import Dhall hiding (embed, maybe) import Dhall.TH +import Internal.TH (deriveProduct) import Language.Haskell.TH.Syntax (Lift) import RIO import qualified RIO.Map as M @@ -25,7 +26,7 @@ import Text.Regex.TDFA ------------------------------------------------------------------------------- makeHaskellTypesWith - (defaultGenerateOptions {generateToDhallInstance = False}) + (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False}) [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" @@ -50,84 +51,93 @@ makeHaskellTypesWith , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount" - , -- , 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 "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount" , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type" , 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 -deriving instance Eq Currency - deriving instance Lift Currency deriving instance Hashable Currency -deriving instance Eq Tag - deriving instance Lift Tag deriving instance Hashable Tag -deriving instance Eq TimeUnit - deriving instance Ord TimeUnit -deriving instance Show TimeUnit - deriving instance Hashable TimeUnit -deriving instance Eq Weekday - deriving instance Ord Weekday -deriving instance Show Weekday - deriving instance Hashable Weekday deriving instance Enum Weekday -deriving instance Eq WeekdayPat - deriving instance Ord WeekdayPat -deriving instance Show WeekdayPat - deriving instance Hashable WeekdayPat -deriving instance Show RepeatPat - -deriving instance Eq RepeatPat - deriving instance Ord RepeatPat deriving instance Hashable RepeatPat -deriving instance Show MDYPat - -deriving instance Eq MDYPat - deriving instance Ord MDYPat deriving instance Hashable MDYPat -deriving instance Eq Gregorian - -deriving instance Show Gregorian - deriving instance Hashable Gregorian -deriving instance Eq GregorianM - -deriving instance Show GregorianM - deriving instance Hashable GregorianM -- Dhall.TH rearranges my fields :( @@ -144,34 +154,18 @@ instance Ord GregorianM where GregorianM {gmYear = y, gmMonth = 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 Eq ModPat - deriving instance Ord ModPat -deriving instance Show ModPat - deriving instance Hashable ModPat -deriving instance Eq CronPat - deriving instance Ord CronPat -deriving instance Show CronPat - deriving instance Hashable CronPat -deriving instance Eq DatePat - deriving instance Ord DatePat -deriving instance Show DatePat - deriving instance Hashable DatePat data Budget = Budget @@ -184,18 +178,8 @@ data Budget = Budget , shadowTransfers :: [ShadowTransfer] } -deriving instance Eq Budget - -deriving instance Generic Budget - deriving instance Hashable Budget -deriving instance FromDhall Budget - -deriving instance Show TaggedAcnt - -deriving instance Eq TaggedAcnt - deriving instance Hashable TaggedAcnt deriving instance Ord TaggedAcnt @@ -213,32 +197,14 @@ data Income = Income , incToBal :: TaggedAcnt } -deriving instance Eq Income - -deriving instance Generic Income - deriving instance Hashable Income -deriving instance FromDhall Income - -deriving instance Show Amount - -deriving instance Eq Amount - deriving instance Ord Amount deriving instance Hashable Amount -deriving instance Show Exchange - -deriving instance Eq Exchange - deriving instance Hashable Exchange -deriving instance Show BudgetCurrency - -deriving instance Eq BudgetCurrency - deriving instance Hashable BudgetCurrency data Allocation_ a = Allocation_ @@ -246,28 +212,14 @@ data Allocation_ a = Allocation_ , alloAmts :: [a] , alloCur :: BudgetCurrency } - deriving (Show) + deriving (Eq, Show, Generic, Hashable) + +deriving instance FromDhall a => FromDhall (Allocation_ a) type Allocation = Allocation_ Amount -deriving instance Eq Allocation - -deriving instance Generic Allocation - -deriving instance Hashable Allocation - -deriving instance FromDhall Allocation - 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 = PersistText . T.pack . show @@ -278,42 +230,40 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of fromPersistText what 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 Hashable AmountType -data TimeAmount a = TimeAmount - { taWhen :: a - , taAmt :: Amount - , taAmtType :: AmountType - } - deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable) +-- data TimeAmount a = TimeAmount +-- { taWhen :: a +-- , taAmt :: Amount +-- , taAmtType :: AmountType +-- } +-- 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 --- deriving instance Eq DateAmount - --- deriving instance Generic DateAmount - --- deriving instance Hashable DateAmount - --- deriving instance FromDhall DateAmount - type IntervalAmount = TimeAmount Interval --- deriving instance Eq IntervalAmount - --- deriving instance Ord IntervalAmount - --- deriving instance Generic IntervalAmount - --- deriving instance Hashable IntervalAmount - --- deriving instance FromDhall IntervalAmount +deriving instance Ord Interval data Transfer = Transfer { transFrom :: TaggedAcnt @@ -322,52 +272,24 @@ data Transfer = Transfer , transCurrency :: BudgetCurrency } -deriving instance Eq Transfer - -deriving instance Generic Transfer - deriving instance Hashable Transfer -deriving instance FromDhall Transfer - -deriving instance Eq ShadowTransfer - deriving instance Hashable ShadowTransfer -deriving instance Eq AcntSet - deriving instance Hashable AcntSet -deriving instance Eq ShadowMatch - deriving instance Hashable ShadowMatch -deriving instance Eq MatchVal - deriving instance Hashable MatchVal -deriving instance Show MatchVal - -deriving instance Eq MatchYMD - deriving instance Hashable MatchYMD -deriving instance Show MatchYMD - -deriving instance Eq MatchDate - deriving instance Hashable MatchDate -deriving instance Show MatchDate - -deriving instance Eq Decimal - deriving instance Ord Decimal deriving instance Hashable Decimal -deriving instance Show Decimal - -- TODO this just looks silly...but not sure how to simplify it instance Ord MatchYMD where 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 (In d _) (On d') = compare d d' <> GT -deriving instance Eq SplitNum - deriving instance Hashable SplitNum -deriving instance Show SplitNum - -deriving instance Eq Manual - deriving instance Hashable Manual ------------------------------------------------------------------------------- @@ -473,19 +389,18 @@ data Statement | StmtImport !Import 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 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 { txDescr :: !T.Text , txDate :: !Day @@ -530,11 +445,19 @@ type SplitCur = SplitText CurID type SplitAcnt = SplitText AcntID -data Field k v = Field - { fKey :: !k - , fVal :: !v - } - deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable) +deriving instance (Show k, Show v) => Show (Field k v) + +deriving instance (Eq k, Eq v) => Eq (Field k v) + +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 fmap f (Field k v) = Field k $ f v