From c2c30caf6993f04c26147761cc8c28fa758847f6 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 17 Apr 2023 00:34:09 -0400
Subject: [PATCH] ENH use mostly dhall types

---
 budget.cabal           |   1 +
 dhall/Types.dhall      |  46 ++++---
 lib/Internal/Insert.hs |   4 +-
 lib/Internal/TH.hs     |  12 ++
 lib/Internal/Types.hs  | 271 +++++++++++++++--------------------------
 5 files changed, 139 insertions(+), 195 deletions(-)
 create mode 100644 lib/Internal/TH.hs

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