ENH use mostly dhall types
This commit is contained in:
parent
8c5a68a4b4
commit
c2c30caf69
|
|
@ -29,6 +29,7 @@ library
|
|||
Internal.Database.Ops
|
||||
Internal.Insert
|
||||
Internal.Statement
|
||||
Internal.TH
|
||||
Internal.Types
|
||||
Internal.Utils
|
||||
other-modules:
|
||||
|
|
|
|||
|
|
@ -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,12 +154,13 @@ let ToTx =
|
|||
, ttSplit : List ExpSplit.Type
|
||||
}
|
||||
|
||||
let Match =
|
||||
let Match_ =
|
||||
\(re : Type) ->
|
||||
{ Type =
|
||||
{ mDate : Optional MatchDate
|
||||
, mVal : MatchVal.Type
|
||||
, mDesc : Optional Text
|
||||
, mOther : List MatchOther
|
||||
, mDesc : Optional re
|
||||
, mOther : List (MatchOther_ re)
|
||||
, mTx : Optional ToTx
|
||||
, mTimes : Optional Natural
|
||||
, mPriority : Integer
|
||||
|
|
@ -165,13 +169,15 @@ let Match =
|
|||
{ mDate = None MatchDate
|
||||
, mVal = MatchVal::{=}
|
||||
, mDesc = None Text
|
||||
, mOther = [] : List MatchOther
|
||||
, mOther = [] : List (MatchOther_ re)
|
||||
, mTx = None ToTx
|
||||
, mTimes = None Natural
|
||||
, mPriority = +0
|
||||
}
|
||||
}
|
||||
|
||||
let Match = Match_ Text
|
||||
|
||||
let Manual =
|
||||
{ manualDate : DatePat
|
||||
, manualFrom : AcntID
|
||||
|
|
@ -303,10 +309,12 @@ in { CurID
|
|||
, Decimal
|
||||
, TxOpts
|
||||
, Match
|
||||
, Match_
|
||||
, MatchVal
|
||||
, MatchYMD
|
||||
, MatchDate
|
||||
, MatchOther
|
||||
, MatchOther_
|
||||
, SplitNum
|
||||
, Field
|
||||
, FieldMap
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue