Experimental fourmolu branch.

.buildkite/check-fourmolu.sh

@@ -0,0 +1,9 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+echo "+++ fourmolu"
+
+git ls-files -z '*.hs' | xargs -0 fourmolu --mode inplace
+
+git diff --exit-code

.buildkite/pipeline.yml

@@ -61,9 +61,9 @@ steps:
     env:
       TMPDIR: "/cache"
 
-  - label: 'Check Stylish Haskell'
+  - label: 'Check Haskell code format'
     depends_on: linux-nix
-    command: 'nix develop --command .buildkite/check-stylish.sh'
+    command: 'nix develop --command .buildkite/check-fourmolu.sh'
     agents:
       system: ${linux}
     env:

docs/site/src/contributor/what/building.md

@@ -167,7 +167,7 @@ for `cardano-wallet`. This will contain:
 - `cabal-install` and a GHC configured with a package database containing all Haskell package dependencies;
 - system library dependencies;
 - a Hoogle index and `hoogle` command for searching documentation;
-- development tools such as `haskell-language-server`, `hlint`, `stylish-haskell`, and `weeder`;
+- development tools such as `haskell-language-server`, `hlint`, `fourmolu`, and `weeder`;
 - the `sqlite3` command;
 - the Shelley node backend `cardano-node` and `cardano-cli`; and
 - other Adrestia utility programs such as `cardano-address` and `bech32`

fourmolu.yaml

@@ -1,21 +1,16 @@
+indentation: 2
+column-limit: 80
+newlines-between-decls: 1
 comma-style: leading
 function-arrows: leading
 import-export-style: leading
-fixities:
-  - infixr 9  .
-  - infixr 5  ++
-  - infixl 4  <$, <$>
-  - infixl 2  >>, >>=
-  - infixr 2  =<<, <=<
-  - infixr 1  $, $!
-  - infixl 4 <*>, <*, *>, <**>
-  - infixl 6 ^.
-  - infixl 3 =.
 haddock-style: single-line
+haddock-style-module: single-line
+let-style: newline
 in-style: left-align
-indent-wheres: false
-indentation: 4
-let-style: auto
-newlines-between-decls: 1
-record-brace-space: false
-respectful: true
+indent-wheres: true
+record-brace-space: true
+respectful: false
+single-constraint-parens: auto
+fixities:
+  - infixr 1 $

lib/balance-tx/cardano-balance-tx.cabal

@@ -14,6 +14,7 @@ build-type:         Simple
 common language
   default-language:   Haskell2010
   default-extensions:
+    ImportQualifiedPost
     NoImplicitPrelude
     OverloadedStrings
 

lib/balance-tx/lib/Cardano/Tx/Balance.hs

@@ -1,7 +1,4 @@
 -- |
 -- Copyright: © 2022 IOHK
 -- License: Apache-2.0
---
-module Cardano.Tx.Balance
-    ()
-    where
+module Cardano.Tx.Balance () where

lib/balance-tx/lib/Cardano/Tx/Balance/Internal/CoinSelection/Gen.hs

@@ -1,26 +1,39 @@
 module Cardano.Tx.Balance.Internal.CoinSelection.Gen
-    ( coarbitraryWalletUTxO
-    , genWalletUTxO
-    , genWalletUTxOFunction
-    , genWalletUTxOLargeRange
-    , shrinkWalletUTxO
-    )
-    where
-
-import Prelude
+  ( coarbitraryWalletUTxO
+  , genWalletUTxO
+  , genWalletUTxOFunction
+  , genWalletUTxOLargeRange
+  , shrinkWalletUTxO
+  )
+where
 
 import Cardano.Tx.Balance.Internal.CoinSelection
-    ( WalletUTxO (..) )
+  ( WalletUTxO (..)
+  )
 import Cardano.Wallet.Primitive.Types.Address.Gen
-    ( genAddress, shrinkAddress )
+  ( genAddress
+  , shrinkAddress
+  )
 import Cardano.Wallet.Primitive.Types.Tx.TxIn.Gen
-    ( genTxIn, genTxInLargeRange, shrinkTxIn )
+  ( genTxIn
+  , genTxInLargeRange
+  , shrinkTxIn
+  )
 import Generics.SOP
-    ( NP (..) )
+  ( NP (..)
+  )
 import Test.QuickCheck
-    ( Gen, coarbitrary )
+  ( Gen
+  , coarbitrary
+  )
 import Test.QuickCheck.Extra
-    ( genFunction, genSized2, genericRoundRobinShrink, (<:>), (<@>) )
+  ( genFunction
+  , genSized2
+  , genericRoundRobinShrink
+  , (<:>)
+  , (<@>)
+  )
+import Prelude
 
 --------------------------------------------------------------------------------
 -- Wallet UTxO identifiers chosen according to the size parameter
@@ -33,7 +46,8 @@ genWalletUTxO :: Gen WalletUTxO
 genWalletUTxO = uncurry WalletUTxO <$> genSized2 genTxIn genAddress
 
 shrinkWalletUTxO :: WalletUTxO -> [WalletUTxO]
-shrinkWalletUTxO = genericRoundRobinShrink
+shrinkWalletUTxO =
+  genericRoundRobinShrink
     <@> shrinkTxIn
     <:> shrinkAddress
     <:> Nil

lib/balance-tx/test/spec/Cardano/Tx/Balance/Internal/CoinSelectionSpec.hs

@@ -1,111 +1,142 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Cardano.Tx.Balance.Internal.CoinSelectionSpec
-    where
-
-import Prelude
+module Cardano.Tx.Balance.Internal.CoinSelectionSpec where
 
 import Cardano.Tx.Balance.Internal.CoinSelection
-    ( Selection
-    , SelectionOf (..)
-    , toExternalSelection
-    , toExternalUTxO
-    , toExternalUTxOMap
-    , toInternalSelection
-    , toInternalUTxO
-    , toInternalUTxOMap
-    )
+  ( Selection
+  , SelectionOf (..)
+  , toExternalSelection
+  , toExternalUTxO
+  , toExternalUTxOMap
+  , toInternalSelection
+  , toInternalUTxO
+  , toInternalUTxOMap
+  )
 import Cardano.Wallet.Primitive.Types.Address.Gen
-    ( genAddress )
+  ( genAddress
+  )
 import Cardano.Wallet.Primitive.Types.Coin.Gen
-    ( genCoin, shrinkCoin )
+  ( genCoin
+  , shrinkCoin
+  )
+import Cardano.Wallet.Primitive.Types.TokenBundle qualified as TokenBundle
 import Cardano.Wallet.Primitive.Types.TokenBundle.Gen
-    ( genTokenBundle, shrinkTokenBundle )
+  ( genTokenBundle
+  , shrinkTokenBundle
+  )
 import Cardano.Wallet.Primitive.Types.TokenMap.Gen
-    ( genTokenMap, shrinkTokenMap )
+  ( genTokenMap
+  , shrinkTokenMap
+  )
 import Cardano.Wallet.Primitive.Types.Tx.TxIn
-    ( TxIn )
+  ( TxIn
+  )
 import Cardano.Wallet.Primitive.Types.Tx.TxIn.Gen
-    ( genTxIn, shrinkTxIn )
+  ( genTxIn
+  , shrinkTxIn
+  )
 import Cardano.Wallet.Primitive.Types.Tx.TxOut
-    ( TxOut (..) )
+  ( TxOut (..)
+  )
 import Cardano.Wallet.Primitive.Types.Tx.TxOut.Gen
-    ( genTxOut, shrinkTxOut )
+  ( genTxOut
+  , shrinkTxOut
+  )
 import Cardano.Wallet.Primitive.Types.UTxO
-    ( UTxO )
+  ( UTxO
+  )
 import Cardano.Wallet.Primitive.Types.UTxO.Gen
-    ( genUTxO, genUTxOLarge, shrinkUTxO )
+  ( genUTxO
+  , genUTxOLarge
+  , shrinkUTxO
+  )
 import Data.Function
-    ( (&) )
+  ( (&)
+  )
 import Generics.SOP
-    ( NP (..) )
+  ( NP (..)
+  )
 import Test.Hspec
-    ( Spec, describe, it )
+  ( Spec
+  , describe
+  , it
+  )
 import Test.Hspec.Extra
-    ( parallel )
+  ( parallel
+  )
 import Test.QuickCheck
-    ( Arbitrary (..)
-    , Gen
-    , Property
-    , liftShrink2
-    , listOf
-    , oneof
-    , property
-    , shrinkList
-    , (===)
-    )
+  ( Arbitrary (..)
+  , Gen
+  , Property
+  , liftShrink2
+  , listOf
+  , oneof
+  , property
+  , shrinkList
+  , (===)
+  )
 import Test.QuickCheck.Extra
-    ( genNonEmpty, genericRoundRobinShrink, shrinkNonEmpty, (<:>), (<@>) )
+  ( genNonEmpty
+  , genericRoundRobinShrink
+  , shrinkNonEmpty
+  , (<:>)
+  , (<@>)
+  )
 import Test.Utils.Pretty
-    ( (====) )
-
-import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
+  ( (====)
+  )
+import Prelude
 
 spec :: Spec
 spec = describe "Cardano.Wallet.CoinSelectionSpec" $ do
-
-    parallel $ describe
-        "Conversion between external (wallet) and internal UTxOs" $ do
-
-        it "prop_toInternalUTxO_toExternalUTxO" $
-            prop_toInternalUTxO_toExternalUTxO & property
-
-        it "prop_toInternalUTxOMap_toExternalUTxOMap" $
-            prop_toInternalUTxOMap_toExternalUTxOMap & property
-
-    parallel $ describe
-        "Conversion between external (wallet) and internal selections" $ do
-
-        it "prop_toInternalSelection_toExternalSelection" $
-            prop_toInternalSelection_toExternalSelection & property
+  parallel
+    $ describe
+      "Conversion between external (wallet) and internal UTxOs"
+    $ do
+      it "prop_toInternalUTxO_toExternalUTxO"
+        $ prop_toInternalUTxO_toExternalUTxO
+        & property
+
+      it "prop_toInternalUTxOMap_toExternalUTxOMap"
+        $ prop_toInternalUTxOMap_toExternalUTxOMap
+        & property
+
+  parallel
+    $ describe
+      "Conversion between external (wallet) and internal selections"
+    $ do
+      it "prop_toInternalSelection_toExternalSelection"
+        $ prop_toInternalSelection_toExternalSelection
+        & property
 
 --------------------------------------------------------------------------------
 -- Conversion between external (wallet) and internal UTxOs
 --------------------------------------------------------------------------------
 
 prop_toInternalUTxO_toExternalUTxO :: TxIn -> TxOut -> Property
 prop_toInternalUTxO_toExternalUTxO i o =
-    (toExternalUTxO . toInternalUTxO) (i, o) === (i, o)
+  (toExternalUTxO . toInternalUTxO) (i, o) === (i, o)
 
 prop_toInternalUTxOMap_toExternalUTxOMap :: UTxO -> Property
 prop_toInternalUTxOMap_toExternalUTxOMap u =
-    (toExternalUTxOMap . toInternalUTxOMap) u === u
+  (toExternalUTxOMap . toInternalUTxOMap) u === u
 
 --------------------------------------------------------------------------------
 -- Conversion between external (wallet) and internal selections
 --------------------------------------------------------------------------------
 
 prop_toInternalSelection_toExternalSelection :: Selection -> Property
 prop_toInternalSelection_toExternalSelection s =
-    (toExternalSelection . toInternalSelection id) s ==== s
+  (toExternalSelection . toInternalSelection id) s ==== s
 
 --------------------------------------------------------------------------------
 -- External (wallet) selections
 --------------------------------------------------------------------------------
 
 genSelection :: Gen Selection
-genSelection = Selection
+genSelection =
+  Selection
     <$> genInputs
     <*> genCollateral
     <*> genOutputs
@@ -126,7 +157,8 @@ genSelection = Selection
     genTxOutCoin = TxOut <$> genAddress <*> (TokenBundle.fromCoin <$> genCoin)
 
 shrinkSelection :: Selection -> [Selection]
-shrinkSelection = genericRoundRobinShrink
+shrinkSelection =
+  genericRoundRobinShrink
     <@> shrinkInputs
     <:> shrinkCollateral
     <:> shrinkOutputs
@@ -151,20 +183,21 @@ shrinkSelection = genericRoundRobinShrink
 --------------------------------------------------------------------------------
 
 instance Arbitrary Selection where
-    arbitrary = genSelection
-    shrink = shrinkSelection
+  arbitrary = genSelection
+  shrink = shrinkSelection
 
 instance Arbitrary TxIn where
-    arbitrary = genTxIn
-    shrink = shrinkTxIn
+  arbitrary = genTxIn
+  shrink = shrinkTxIn
 
 instance Arbitrary TxOut where
-    arbitrary = genTxOut
-    shrink = shrinkTxOut
+  arbitrary = genTxOut
+  shrink = shrinkTxOut
 
 instance Arbitrary UTxO where
-    arbitrary = oneof
-        [ genUTxO
-        , genUTxOLarge
-        ]
-    shrink = shrinkUTxO
+  arbitrary =
+    oneof
+      [ genUTxO
+      , genUTxOLarge
+      ]
+  shrink = shrinkUTxO

lib/balance-tx/test/spec/run-test-suite.hs

@@ -1,13 +1,13 @@
 module Main where
 
-import Prelude
-
 import Cardano.Startup
-    ( withUtf8Encoding )
+  ( withUtf8Encoding
+  )
+import Spec qualified
 import Test.Hspec.Extra
-    ( hspecMain )
-
-import qualified Spec
+  ( hspecMain
+  )
+import Prelude
 
 main :: IO ()
 main = withUtf8Encoding $ hspecMain Spec.spec

lib/coin-selection/cardano-coin-selection.cabal

@@ -14,6 +14,7 @@ build-type:         Simple
 common language
   default-language:   Haskell2010
   default-extensions:
+    ImportQualifiedPost
     NoImplicitPrelude
     OverloadedStrings
 

lib/coin-selection/lib/Cardano/CoinSelection/Balance/Gen.hs

@@ -2,87 +2,102 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.CoinSelection.Balance.Gen
-    ( genSelectionSkeleton
-    , genSelectionStrategy
-    , shrinkSelectionSkeleton
-    , shrinkSelectionStrategy
-    )
-    where
-
-import Prelude
+  ( genSelectionSkeleton
+  , genSelectionStrategy
+  , shrinkSelectionSkeleton
+  , shrinkSelectionStrategy
+  )
+where
 
 import Cardano.CoinSelection.Balance
-    ( SelectionSkeleton (..), SelectionStrategy (..) )
+  ( SelectionSkeleton (..)
+  , SelectionStrategy (..)
+  )
 import Cardano.CoinSelection.Context
-    ( SelectionContext (..) )
+  ( SelectionContext (..)
+  )
 import Cardano.Wallet.Primitive.Types.Coin
-    ( Coin (..) )
+  ( Coin (..)
+  )
 import Cardano.Wallet.Primitive.Types.TokenBundle
-    ( TokenBundle )
+  ( TokenBundle
+  )
+import Cardano.Wallet.Primitive.Types.TokenBundle qualified as TokenBundle
 import Cardano.Wallet.Primitive.Types.TokenBundle.Gen
-    ( genTokenBundleSmallRange, shrinkTokenBundleSmallRange )
+  ( genTokenBundleSmallRange
+  , shrinkTokenBundleSmallRange
+  )
 import Cardano.Wallet.Primitive.Types.TokenMap.Gen
-    ( genAssetId, shrinkAssetId )
+  ( genAssetId
+  , shrinkAssetId
+  )
+import Data.Set qualified as Set
 import Generics.SOP
-    ( NP (..) )
+  ( NP (..)
+  )
 import Test.QuickCheck
-    ( Gen
-    , NonNegative (..)
-    , arbitrary
-    , arbitraryBoundedEnum
-    , listOf
-    , shrink
-    , shrinkList
-    , shrinkMapBy
-    , suchThat
-    )
+  ( Gen
+  , NonNegative (..)
+  , arbitrary
+  , arbitraryBoundedEnum
+  , listOf
+  , shrink
+  , shrinkList
+  , shrinkMapBy
+  , suchThat
+  )
 import Test.QuickCheck.Extra
-    ( genericRoundRobinShrink, (<:>), (<@>) )
-
-import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
-import qualified Data.Set as Set
+  ( genericRoundRobinShrink
+  , (<:>)
+  , (<@>)
+  )
+import Prelude
 
 --------------------------------------------------------------------------------
 -- Selection skeletons
 --------------------------------------------------------------------------------
 
 genSelectionSkeleton :: Gen (Address ctx) -> Gen (SelectionSkeleton ctx)
-genSelectionSkeleton genAddress = SelectionSkeleton
+genSelectionSkeleton genAddress =
+  SelectionSkeleton
     <$> genSkeletonInputCount
     <*> genSkeletonOutputs
     <*> genSkeletonChange
   where
     genSkeletonInputCount =
-        getNonNegative <$> arbitrary @(NonNegative Int)
+      getNonNegative <$> arbitrary @(NonNegative Int)
     genSkeletonOutputs =
-        listOf genSkeletonOutput
-    genSkeletonOutput = (,)
+      listOf genSkeletonOutput
+    genSkeletonOutput =
+      (,)
         <$> genAddress
         <*> genTokenBundleSmallRange `suchThat` tokenBundleHasNonZeroCoin
     genSkeletonChange =
-        listOf (Set.fromList <$> listOf genAssetId)
+      listOf (Set.fromList <$> listOf genAssetId)
 
 shrinkSelectionSkeleton
-    :: (Address ctx -> [Address ctx])
-    -> (SelectionSkeleton ctx -> [SelectionSkeleton ctx])
-shrinkSelectionSkeleton shrinkAddress = genericRoundRobinShrink
+  :: (Address ctx -> [Address ctx])
+  -> (SelectionSkeleton ctx -> [SelectionSkeleton ctx])
+shrinkSelectionSkeleton shrinkAddress =
+  genericRoundRobinShrink
     <@> shrinkSkeletonInputCount
     <:> shrinkSkeletonOutputs
     <:> shrinkSkeletonChange
     <:> Nil
   where
     shrinkSkeletonInputCount =
-        shrink @Int
+      shrink @Int
     shrinkSkeletonOutputs =
-        shrinkList shrinkSkeletonOutput
+      shrinkList shrinkSkeletonOutput
     shrinkSkeletonOutput =
-        genericRoundRobinShrink
-            <@> shrinkAddress
-            <:> filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange
-            <:> Nil
+      genericRoundRobinShrink
+        <@> shrinkAddress
+        <:> filter tokenBundleHasNonZeroCoin
+        . shrinkTokenBundleSmallRange
+        <:> Nil
     shrinkSkeletonChange =
-        shrinkList $
-        shrinkMapBy Set.fromList Set.toList (shrinkList shrinkAssetId)
+      shrinkList
+        $ shrinkMapBy Set.fromList Set.toList (shrinkList shrinkAssetId)
 
 tokenBundleHasNonZeroCoin :: TokenBundle -> Bool
 tokenBundleHasNonZeroCoin b = TokenBundle.getCoin b /= Coin 0
@@ -96,8 +111,8 @@ genSelectionStrategy = arbitraryBoundedEnum
 
 shrinkSelectionStrategy :: SelectionStrategy -> [SelectionStrategy]
 shrinkSelectionStrategy = \case
-    -- Shrinking from "optimal" to "minimal" should increase the likelihood of
-    -- making a successful selection, as the "minimal" strategy is designed to
-    -- generate smaller selections.
-    SelectionStrategyMinimal -> []
-    SelectionStrategyOptimal -> [SelectionStrategyMinimal]
+  -- Shrinking from "optimal" to "minimal" should increase the likelihood of
+  -- making a successful selection, as the "minimal" strategy is designed to
+  -- generate smaller selections.
+  SelectionStrategyMinimal -> []
+  SelectionStrategyOptimal -> [SelectionStrategyMinimal]

lib/coin-selection/lib/Cardano/CoinSelection/Context.hs

@@ -8,34 +8,30 @@
 --
 -- This module provides the 'SelectionContext' class, which provides a shared
 -- context for types used by coin selection.
---
 module Cardano.CoinSelection.Context
-    (
-    -- * Selection contexts
-      SelectionContext (..)
-    )
-    where
-
-import Prelude
+  ( -- * Selection contexts
+    SelectionContext (..)
+  )
+where
 
 import Fmt
-    ( Buildable )
+  ( Buildable
+  )
+import Prelude
 
 -- | Provides a shared context for types used by coin selection.
---
 class
-    ( Buildable (Address c)
-    , Buildable (UTxO c)
-    , Ord (Address c)
-    , Ord (UTxO c)
-    , Show (Address c)
-    , Show (UTxO c)
-    ) =>
-    SelectionContext c
+  ( Buildable (Address c)
+  , Buildable (UTxO c)
+  , Ord (Address c)
+  , Ord (UTxO c)
+  , Show (Address c)
+  , Show (UTxO c)
+  ) =>
+  SelectionContext c
   where
+  -- | A target address to which payments can be made.
+  type Address c
 
-    -- | A target address to which payments can be made.
-    type Address c
-
-    -- | A unique identifier for an individual UTxO.
-    type UTxO c
+  -- | A unique identifier for an individual UTxO.
+  type UTxO c

lib/coin-selection/test/spec/run-test-suite.hs

@@ -1,13 +1,13 @@
 module Main where
 
-import Prelude
-
 import Cardano.Startup
-    ( withUtf8Encoding )
+  ( withUtf8Encoding
+  )
+import Spec qualified
 import Test.Hspec.Extra
-    ( hspecMain )
-
-import qualified Spec
+  ( hspecMain
+  )
+import Prelude
 
 main :: IO ()
 main = withUtf8Encoding $ hspecMain Spec.spec

lib/delta-store/delta-store.cabal

@@ -19,6 +19,7 @@ library
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:
@@ -54,6 +55,7 @@ test-suite unit
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:

lib/delta-store/src/Data/DBVar.hs

@@ -1,14 +1,16 @@
-{-# OPTIONS_GHC -Wno-redundant-constraints#-}
 -- We intentionally specify more constraints than necessary for some exports.
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
 -- |
 -- Copyright: © 2023 IOHK
 -- License: Apache-2.0
-module Data.DBVar (
-    -- * Synopsis
+module Data.DBVar
+  ( -- * Synopsis
+
     -- | 'DBVar' represents a mutable variable whose value is kept in memory,
     -- but which is written to the hard drive on every update.
     -- This provides a convenient interface for persisting
@@ -19,25 +21,47 @@ module Data.DBVar (
     -- is written.
 
     -- * DBVar
-      DBVar
-    , readDBVar, updateDBVar, modifyDBVar, modifyDBMaybe
-    , initDBVar, loadDBVar
-    ) where
-
-import Prelude
+    DBVar
+  , readDBVar
+  , updateDBVar
+  , modifyDBVar
+  , modifyDBMaybe
+  , initDBVar
+  , loadDBVar
+  )
+where
 
 import Control.Concurrent.Class.MonadSTM
-    ( MonadSTM, atomically, newTVarIO, readTVar, readTVarIO, retry, writeTVar )
+  ( MonadSTM
+  , atomically
+  , newTVarIO
+  , readTVar
+  , readTVarIO
+  , retry
+  , writeTVar
+  )
 import Control.Monad.Class.MonadThrow
-    ( MonadEvaluate, MonadMask, MonadThrow, bracket, evaluate, mask, throwIO )
+  ( MonadEvaluate
+  , MonadMask
+  , MonadThrow
+  , bracket
+  , evaluate
+  , mask
+  , throwIO
+  )
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
 import Data.Store
-    ( Store (..), UpdateStore )
+  ( Store (..)
+  , UpdateStore
+  )
+import Prelude
 
 {-------------------------------------------------------------------------------
     DBVar
 -------------------------------------------------------------------------------}
+
 -- | A 'DBVar'@ m delta@ is a mutable reference to a Haskell value of type @a@.
 -- The type @delta@ is a delta encoding for this value type @a@,
 -- that is we have @a ~ @'Base'@ delta@.
@@ -55,9 +79,9 @@ import Data.Store
 --   (except for a small moment where the new value atomically
 --    replaces the old one).
 data DBVar m delta = DBVar
-    { readDBVar_     :: m (Base delta)
-    , modifyDBMaybe_ :: forall b. (Base delta -> (Maybe delta, b)) -> m b
-    }
+  { readDBVar_ :: m (Base delta)
+  , modifyDBMaybe_ :: forall b. (Base delta -> (Maybe delta, b)) -> m b
+  }
 
 -- | Read the current value of the 'DBVar'.
 readDBVar :: (Delta da, a ~ Base da) => DBVar m da -> m a
@@ -67,48 +91,63 @@ readDBVar = readDBVar_
 --
 -- The new value will be evaluated to weak head normal form.
 updateDBVar :: (Delta da, Monad m) => DBVar m da -> da -> m ()
-updateDBVar var delta = modifyDBMaybe var $ \_ -> (Just delta,())
+updateDBVar var delta = modifyDBMaybe var $ \_ -> (Just delta, ())
 
 -- | Modify the value in a 'DBVar'.
 --
 -- The new value will be evaluated to weak head normal form.
 modifyDBVar
-    :: (Delta da, Monad m, a ~ Base da)
-    => DBVar m da -> (a -> (da, b)) -> m b
-modifyDBVar var f = modifyDBMaybe var $ \a -> let (da,b) = f a in (Just da,b)
+  :: (Delta da, Monad m, a ~ Base da)
+  => DBVar m da
+  -> (a -> (da, b))
+  -> m b
+modifyDBVar var f = modifyDBMaybe var $ \a -> let (da, b) = f a in (Just da, b)
 
 -- | Maybe modify the value in a 'DBVar'
 --
 -- If updated, the new value will be evaluated to weak head normal form.
 modifyDBMaybe
-    :: (Delta da, Monad m, a ~ Base da)
-    => DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
+  :: (Delta da, Monad m, a ~ Base da)
+  => DBVar m da
+  -> forall b
+   . (a -> (Maybe da, b))
+  -> m b
 modifyDBMaybe = modifyDBMaybe_
 
 -- | Initialize a new 'DBVar' for a given 'Store'.
 initDBVar
-    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
-        , Delta da, a ~ Base da
-        )
-    => UpdateStore m da -- ^ 'Store' for writing.
-    -> a -- ^ Initial value.
-    -> m (DBVar m da)
+  :: ( MonadSTM m
+     , MonadThrow m
+     , MonadEvaluate m
+     , MonadMask m
+     , Delta da
+     , a ~ Base da
+     )
+  => UpdateStore m da
+  -- ^ 'Store' for writing.
+  -> a
+  -- ^ Initial value.
+  -> m (DBVar m da)
 initDBVar store v = do
-    writeS store v
-    newWithCache (updateS store . Just) v
+  writeS store v
+  newWithCache (updateS store . Just) v
 
 -- | Create a 'DBVar' by loading its value from an existing 'Store'.
 -- Throws an exception if the value cannot be loaded.
 loadDBVar
-    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
-        , Delta da
-        )
-    => UpdateStore m da -- ^ 'Store' for writing and for reading the initial value.
-    -> m (DBVar m da)
+  :: ( MonadSTM m
+     , MonadThrow m
+     , MonadEvaluate m
+     , MonadMask m
+     , Delta da
+     )
+  => UpdateStore m da
+  -- ^ 'Store' for writing and for reading the initial value.
+  -> m (DBVar m da)
 loadDBVar store =
-    loadS store >>= \case
-        Left  e -> throwIO e
-        Right a -> newWithCache (updateS store . Just) a
+  loadS store >>= \case
+    Left e -> throwIO e
+    Right a -> newWithCache (updateS store . Just) a
 
 -- | Create 'DBVar' from an initial value and an update function
 -- using a 'TVar' as in-memory cache.
@@ -118,35 +157,44 @@ loadDBVar store =
 -- Concurrency: The update function needs to be atomic even in the presence
 -- of asynchronous exceptions.
 newWithCache
-    ::  ( MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m
-        , Delta da, a ~ Base da
-        )
-    => (a -> da -> m ()) -> a -> m (DBVar m da)
+  :: ( MonadSTM m
+     , MonadThrow m
+     , MonadMask m
+     , MonadEvaluate m
+     , Delta da
+     , a ~ Base da
+     )
+  => (a -> da -> m ())
+  -> a
+  -> m (DBVar m da)
 newWithCache update a = do
-    cache  <- newTVarIO a
-    locked <- newTVarIO False   -- lock for updating the cache
-    pure $ DBVar
-        { readDBVar_     = readTVarIO cache
-        , modifyDBMaybe_ = \f -> do
-            let before = atomically $ do
-                    readTVar locked >>= \case
-                        True  -> retry
-                        False -> do
-                            writeTVar locked True
-                            readTVar cache
-                after _ = atomically $ writeTVar locked False
-                action old = do
-                    let (mdelta, b) = f old
-                    case mdelta of
-                        Nothing    -> pure ()
-                        Just delta -> do
-                            new <- evaluate $ apply delta old
-                            mask $ \restore -> do
-                                -- We mask asynchronous exceptions here
-                                -- to ensure that the TVar will be updated
-                                -- whenever @update@ succeeds without exception.
-                                restore $ update old delta
-                                atomically $ writeTVar cache new
-                    pure b
-            bracket before after action
-        }
+  cache <- newTVarIO a
+  locked <- newTVarIO False -- lock for updating the cache
+  pure
+    $ DBVar
+      { readDBVar_ = readTVarIO cache
+      , modifyDBMaybe_ = \f -> do
+          let
+            before = atomically $ do
+              readTVar locked >>= \case
+                True -> retry
+                False -> do
+                  writeTVar locked True
+                  readTVar cache
+            after _ = atomically $ writeTVar locked False
+            action old = do
+              let
+                (mdelta, b) = f old
+              case mdelta of
+                Nothing -> pure ()
+                Just delta -> do
+                  new <- evaluate $ apply delta old
+                  mask $ \restore -> do
+                    -- We mask asynchronous exceptions here
+                    -- to ensure that the TVar will be updated
+                    -- whenever @update@ succeeds without exception.
+                    restore $ update old delta
+                    atomically $ writeTVar cache new
+              pure b
+          bracket before after action
+      }

lib/delta-store/src/Data/Delta/Update.hs

@@ -1,77 +1,92 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- |
 -- Copyright: © 2023 IOHK
 -- License: Apache-2.0
-module Data.Delta.Update (
-    -- * Synopsis
+module Data.Delta.Update
+  ( -- * Synopsis
+
     -- | 'Update' represents a computation which produces a delta and
     -- a result.
     --
     -- Note: This module is preliminary.
 
     -- * Update
+
     -- ** Type
-      Update
+    Update
+
     -- ** View
-    , runUpdate
-    , applyUpdate
-    , onDBVar
+  , runUpdate
+  , applyUpdate
+  , onDBVar
+
     -- ** Combinators
-    , nop
-    , update
-    , updateWithResult
-    -- ** Helpers
-    , updateWithError
-    , updateWithResultAndError
-    , updateMany
-    , updateField
-    ) where
+  , nop
+  , update
+  , updateWithResult
 
-import Prelude
+    -- ** Helpers
+  , updateWithError
+  , updateWithResultAndError
+  , updateMany
+  , updateField
+  )
+where
 
 import Data.DBVar
-    ( DBVar, modifyDBMaybe )
+  ( DBVar
+  , modifyDBMaybe
+  )
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
+import Prelude
 
 {-------------------------------------------------------------------------------
     Update
     Type, View
 -------------------------------------------------------------------------------}
+
 -- | A computation which inspects a value @a ~ Base da@
 -- and produces a delta @da@ and a result of type @r@.
 --
 -- Similar to the 'Control.Monad.Trans.State.State' computation,
 -- but involving 'Delta' types.
-newtype Update da r = Update { runUpdate_ :: Base da -> (Maybe da, r) }
+newtype Update da r = Update {runUpdate_ :: Base da -> (Maybe da, r)}
 
 -- | Run the 'Update' computation.
 runUpdate :: (a ~ Base da) => Update da r -> a -> (Maybe da, r)
 runUpdate = runUpdate_
 
 -- | Semantics.
 applyUpdate
-    :: (Delta da, a ~ Base da)
-    => Update da r -> a -> (a,r)
+  :: (Delta da, a ~ Base da)
+  => Update da r
+  -> a
+  -> (a, r)
 applyUpdate (Update g) a =
-    case g a of
-        (da, r) -> (da `apply` a, r)
+  case g a of
+    (da, r) -> (da `apply` a, r)
 
 -- | Apply an 'Update' to a 'DBVar'.
 onDBVar
-    :: (Monad m, Delta da)
-    => DBVar m da -> Update da r -> m r
+  :: (Monad m, Delta da)
+  => DBVar m da
+  -> Update da r
+  -> m r
 onDBVar dbvar = modifyDBMaybe dbvar . runUpdate
 
 {-------------------------------------------------------------------------------
     Combinators
 -------------------------------------------------------------------------------}
+
 -- | Map results.
 instance Functor (Update da) where
-    fmap f (Update g) = Update $ \a ->
-        case g a of
-            (da, r) -> (da, f r)
+  fmap f (Update g) = Update $ \a ->
+    case g a of
+      (da, r) -> (da, f r)
 
 -- | No operation.
 --
@@ -86,69 +101,68 @@ update f = Update $ \a -> (Just (f a), ())
 
 -- | Compute a delta with result.
 updateWithResult
-    :: (a ~ Base da)
-    => (a -> (da, r)) -- Delta with result.
-    -> Update da r
+  :: (a ~ Base da)
+  => (a -> (da, r)) -- Delta with result.
+  -> Update da r
 updateWithResult f = Update $ \a ->
-    case f a of
-        (da, r) -> (Just da, r)
+  case f a of
+    (da, r) -> (Just da, r)
 
 -- | Computer a delta or fail.
 updateWithError
-    :: (a ~ Base da)
-    => (a -> Either e da)
-    -> Update da (Either e ())
+  :: (a ~ Base da)
+  => (a -> Either e da)
+  -> Update da (Either e ())
 updateWithError f = Update $ \a ->
-    case f a of
-        Left e -> (Nothing, Left e)
-        Right da -> (Just da, Right ())
+  case f a of
+    Left e -> (Nothing, Left e)
+    Right da -> (Just da, Right ())
 
 -- | Compute a delta with result or fail.
 updateWithResultAndError
-    :: (a ~ Base da)
-    => (a -> Either e (da, r))
-    -> Update da (Either e r)
+  :: (a ~ Base da)
+  => (a -> Either e (da, r))
+  -> Update da (Either e r)
 updateWithResultAndError f = Update $ \a ->
-    case f a of
-        Left e -> (Nothing, Left e)
-        Right (da,r) -> (Just da, Right r)
+  case f a of
+    Left e -> (Nothing, Left e)
+    Right (da, r) -> (Just da, Right r)
 
 -- | Lift an update for a single delta to a list of deltas.
 updateMany
-    :: Update da r
-    -> Update [da] r
+  :: Update da r
+  -> Update [da] r
 updateMany (Update g) = Update $ \a ->
-    case g a of
-        (Nothing, r) -> (Nothing, r)
-        (Just da, r) -> (Just [da], r)
-
-{- | Helper function for lifting the 'Update' from a
-record field to the record.
-
-Example:
-
-@
-data Pair a b = Pair a b
-first :: Pair a b -> a
+  case g a of
+    (Nothing, r) -> (Nothing, r)
+    (Just da, r) -> (Just [da], r)
 
-data DeltaPair da db
-    = UpdateFirst da
-    | UpdateSecond db
-
-updateField first UpdateFirst
-    :: (a -> Update da r)
-    -> (Pair a b -> Update (DeltaPair da db) r)
-@
--}
+-- | Helper function for lifting the 'Update' from a
+-- record field to the record.
+--
+-- Example:
+--
+-- @
+-- data Pair a b = Pair a b
+-- first :: Pair a b -> a
+--
+-- data DeltaPair da db
+--     = UpdateFirst da
+--     | UpdateSecond db
+--
+-- updateField first UpdateFirst
+--     :: (a -> Update da r)
+--     -> (Pair a b -> Update (DeltaPair da db) r)
+-- @
 updateField
-    :: (a ~ Base da, b ~ Base db)
-    => (b -> a)
-        -- ^ View field.
-    -> (da -> db)
-        -- ^ Lift delta to
-    -> Update da r
-    -> Update db r
+  :: (a ~ Base da, b ~ Base db)
+  => (b -> a)
+  -- ^ View field.
+  -> (da -> db)
+  -- ^ Lift delta to
+  -> Update da r
+  -> Update db r
 updateField view embed (Update g) =
-    Update $ lift . g . view
+  Update $ lift . g . view
   where
     lift (mda, r) = (embed <$> mda, r)

lib/delta-store/src/Test/Store.hs

@@ -7,63 +7,79 @@
 -- Copyright: © 2023 IOHK
 -- License: Apache-2.0
 module Test.Store
-    ( -- * Store laws
-      GenDelta
-    , prop_StoreUpdate
+  ( -- * Store laws
+    GenDelta
+  , prop_StoreUpdate
 
     -- * Generators
-    , Chain (..)
-    , genChain
-    , shrinkChain
+  , Chain (..)
+  , genChain
+  , shrinkChain
 
     -- * Unit test DSL for developing a Store
-    , unitTestStore
-    , applyS
-    , checkLaw
-    , reset
-    , context
-    , observe
-    , ignore
-    ) where
-
-import Prelude
+  , unitTestStore
+  , applyS
+  , checkLaw
+  , reset
+  , context
+  , observe
+  , ignore
+  )
+where
 
 import Control.Exception
-    ( throwIO )
+  ( throwIO
+  )
 import Control.Monad
-    ( forM_ )
+  ( forM_
+  )
 import Control.Monad.RWS
-    ( RWST, evalRWST, lift )
+  ( RWST
+  , evalRWST
+  , lift
+  )
 import Control.Monad.RWS.Class
-    ( MonadReader (ask)
-    , MonadState (get, put)
-    , MonadWriter (listen, tell)
-    , censor
-    )
+  ( MonadReader (ask)
+  , MonadState (get, put)
+  , MonadWriter (listen, tell)
+  , censor
+  )
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
 import Data.Either
-    ( isRight )
+  ( isRight
+  )
 import Data.Store
-    ( Store (loadS, updateS, writeS) )
+  ( Store (loadS, updateS, writeS)
+  )
 import Fmt
-    ( Buildable, listF, pretty )
+  ( Buildable
+  , listF
+  , pretty
+  )
 import Test.QuickCheck
-    ( Gen
-    , Property
-    , conjoin
-    , counterexample
-    , forAll
-    , forAllShrink
-    , getSize
-    , (===)
-    )
+  ( Gen
+  , Property
+  , conjoin
+  , counterexample
+  , forAll
+  , forAllShrink
+  , getSize
+  , (===)
+  )
 import Test.QuickCheck.Monadic
-    ( assert, monadicIO, monitor, run )
+  ( assert
+  , monadicIO
+  , monitor
+  , run
+  )
+import Prelude
 
 {-----------------------------------------------------------------------------
     Store laws
 ------------------------------------------------------------------------------}
+
 -- | Given a value, generate a random delta that applies to this value.
 type GenDelta da = Base da -> Gen da
 
@@ -73,95 +89,103 @@ type GenDelta da = Base da -> Gen da
 data Chain da = Chain [(Base da, da)] (Base da)
 
 instance Show da => Show (Chain da) where
-    show (Chain adas _) = show . map snd $ adas
+  show (Chain adas _) = show . map snd $ adas
 
 -- | Randomly generate a chain of deltas.
 genChain :: Delta da => Gen (Base da) -> GenDelta da -> Gen (Chain da)
 genChain gen0 more = do
-    n <- getSize
-    a0 <- gen0
-    go n a0 [] a0
+  n <- getSize
+  a0 <- gen0
+  go n a0 [] a0
   where
-    go 0 _  das a0 = pure $ Chain das a0
+    go 0 _ das a0 = pure $ Chain das a0
     go n alast das a0 = do
-        da <- more alast
-        let a = apply da alast
-        go (n - 1) a ((a, da) : das) a0
+      da <- more alast
+      let
+        a = apply da alast
+      go (n - 1) a ((a, da) : das) a0
 
 -- | Shrink a chain of deltas.
 shrinkChain :: Chain da -> [Chain da]
 shrinkChain (Chain [] _) = []
 shrinkChain (Chain das a0) =
-    [ Chain [] a0, Chain [last das] a0, Chain (tail das) a0 ]
+  [Chain [] a0, Chain [last das] a0, Chain (tail das) a0]
 
 -- | Test whether the law on 'updateS' is satisfied.
 --
 -- Subsumes test for the law on 'writeS' / 'loadS'.
 prop_StoreUpdate
-    :: (Monad m, Delta da, Eq (Base da), Buildable da, Show da, Show (Base da))
-    => (forall b. m b -> IO b)
-    -- ^ Function to embed the monad in 'IO'
-    -> m (Store m qa da)
-    -- ^ Creation for 'Store' that is to be tested.
-    -> Gen (Base da)
-    -- ^ Generator for the initial value.
-    -> GenDelta da
-    -- ^ Generator for deltas.
-    -> Property
+  :: (Monad m, Delta da, Eq (Base da), Buildable da, Show da, Show (Base da))
+  => (forall b. m b -> IO b)
+  -- ^ Function to embed the monad in 'IO'
+  -> m (Store m qa da)
+  -- ^ Creation for 'Store' that is to be tested.
+  -> Gen (Base da)
+  -- ^ Generator for the initial value.
+  -> GenDelta da
+  -- ^ Generator for deltas.
+  -> Property
 prop_StoreUpdate toIO mkStore gen0 more =
-    forAll gen0 $ \a0' ->
+  forAll gen0 $ \a0' ->
     forAllShrink (genChain (pure a0') more) shrinkChain $ \chain ->
-        let Chain adas a0 = chain
-            as = map fst adas ++ [a0]
-            das = map snd adas
-        in  counterexample ("\nUpdates applied:\n" <> pretty (listF das))
-            $ monadicIO $ do
-                ea <- run . toIO $ do
-                    store <- mkStore
-                    writeS store a0
-                    -- first update is applied last!
-                    let updates = reverse $ zip das (drop 1 as)
-                    forM_ updates $ \(da, a) -> updateS store (Just a) da
-                    loadS store
-                case ea of
-                    Left err -> run $ throwIO err
-                    Right a -> do
-                        monitor $ counterexample
-                            $ "\nExpected:\n" <> show (head as)
-                        monitor $ counterexample
-                            $ "\nGot:\n" <> show a
-                        assert $ a == head as
+      let
+        Chain adas a0 = chain
+        as = map fst adas ++ [a0]
+        das = map snd adas
+      in
+        counterexample ("\nUpdates applied:\n" <> pretty (listF das))
+          $ monadicIO
+          $ do
+            ea <- run . toIO $ do
+              store <- mkStore
+              writeS store a0
+              -- first update is applied last!
+              let
+                updates = reverse $ zip das (drop 1 as)
+              forM_ updates $ \(da, a) -> updateS store (Just a) da
+              loadS store
+            case ea of
+              Left err -> run $ throwIO err
+              Right a -> do
+                monitor
+                  $ counterexample
+                  $ "\nExpected:\n" <> show (head as)
+                monitor
+                  $ counterexample
+                  $ "\nGot:\n" <> show a
+                assert $ a == head as
 
 {-----------------------------------------------------------------------------
     DSL for developing
 ------------------------------------------------------------------------------}
+
 -- | A DSL to unit test a 'Store'.
 type StoreUnitTest m qa da =
-    RWST
-        (Store m qa da)
-        [Property]
-        (Base da, Base da, [da])
-        m
+  RWST
+    (Store m qa da)
+    [Property]
+    (Base da, Base da, [da])
+    m
 
 -- | Apply a delta to the current value.
 applyS :: (Monad m, Delta da) => da -> StoreUnitTest m qa da ()
 applyS r = do
-    s <- ask
-    (q, x, ds) <- get
-    put (q, apply r x, r : ds)
-    lift $ updateS s (Just x) r
+  s <- ask
+  (q, x, ds) <- get
+  put (q, apply r x, r : ds)
+  lift $ updateS s (Just x) r
 
 -- | Check the store laws.
 checkLaw
-    :: (Monad m, Eq (Base da), Show (Base da), Show da)
-    => StoreUnitTest m qa da ()
+  :: (Monad m, Eq (Base da), Show (Base da), Show da)
+  => StoreUnitTest m qa da ()
 checkLaw = do
-    (_, x, reverse -> ds) <- get
-    x' <- ask >>= lift . loadS
-    tell
-        [ counterexample (show (ds, leftOf x')) (isRight x')
-        , counterexample (show ds) $ rightOf x' === x
-        ]
+  (_, x, reverse -> ds) <- get
+  x' <- ask >>= lift . loadS
+  tell
+    [ counterexample (show (ds, leftOf x')) (isRight x')
+    , counterexample (show ds) $ rightOf x' === x
+    ]
   where
     leftOf (Left x) = x
     leftOf _ = undefined
@@ -171,36 +195,36 @@ checkLaw = do
 -- | Reset the store state to the initial value.
 reset :: Monad m => StoreUnitTest m qa da ()
 reset = do
-    s <- ask
-    (q, _, _) <- get
-    lift $ writeS s q
-    put (q, q, [])
+  s <- ask
+  (q, _, _) <- get
+  lift $ writeS s q
+  put (q, q, [])
 
 -- | Run a unit test for a 'Store'.
 unitTestStore
-    :: (Monad m, Eq (Base da), Show (Base da), Show da)
-    => Base da
-    -> Store m qa da
-    -> StoreUnitTest m qa da a
-    -> m Property
+  :: (Monad m, Eq (Base da), Show (Base da), Show da)
+  => Base da
+  -> Store m qa da
+  -> StoreUnitTest m qa da a
+  -> m Property
 unitTestStore x s f = conjoin . snd <$> evalRWST (f >> checkLaw) s (x, x, [])
 
 -- | Add a context to test.
 context
-    :: Monad m
-    => (Property -> Property)
-    -> StoreUnitTest m qa da x
-    -> StoreUnitTest m qa da x
+  :: Monad m
+  => (Property -> Property)
+  -> StoreUnitTest m qa da x
+  -> StoreUnitTest m qa da x
 context d f = do
-    (x, w) <- listen f
-    tell $ fmap d w
-    pure x
+  (x, w) <- listen f
+  tell $ fmap d w
+  pure x
 
 -- | Observe a property on the current value of the store.
 observe :: Monad m => (Base da -> Property) -> StoreUnitTest m qa da ()
 observe f = do
-    (_, s, _) <- get
-    tell [f s]
+  (_, s, _) <- get
+  tell [f s]
 
 -- | Ignore the properties of a sub-test.
 ignore :: Monad m => StoreUnitTest m qa da x -> StoreUnitTest m qa da x

lib/delta-store/test/unit/Data/StoreSpec.hs

@@ -1,65 +1,86 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- |
 -- Copyright: © 2023 IOHK
 -- License: Apache-2.0
 module Data.StoreSpec
-    ( spec
-    ) where
-
-import Prelude
+  ( spec
+  )
+where
 
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
 import Data.Store
-    ( Store (..), UpdateStore, newCachedStore, newStore )
+  ( Store (..)
+  , UpdateStore
+  , newCachedStore
+  , newStore
+  )
 import Fmt
-    ( Buildable (..) )
+  ( Buildable (..)
+  )
 import Test.Hspec
-    ( Spec, describe, it, parallel )
+  ( Spec
+  , describe
+  , it
+  , parallel
+  )
 import Test.QuickCheck
-    ( elements, generate, (===) )
+  ( elements
+  , generate
+  , (===)
+  )
 import Test.QuickCheck.Gen
-    ( Gen, listOf )
+  ( Gen
+  , listOf
+  )
 import Test.QuickCheck.Monadic
-    ( monadicIO, run )
+  ( monadicIO
+  , run
+  )
 import Test.Store
-    ( prop_StoreUpdate )
+  ( prop_StoreUpdate
+  )
+import Prelude
 
 spec :: Spec
 spec = do
-    parallel $ describe "Data.Delta" $ do
-        it "Dummy test, to be expanded"
-            True
-    describe "CachedStore" $ do
-        it "respects store laws" $
-            let setupStore = do
-                    testStore <- newTestStore
-                    resetTestStoreBase testStore
-                    newCachedStore testStore
-            in  prop_StoreUpdate
-                    id
-                    setupStore
-                    (pure emptyTestStore)
-                    $ const genTestStoreDeltas
-
-        it "behaves like the cached one" $ monadicIO $ run $ do
-
-            das <- generate $ listOf genTestStoreDeltas
-
+  parallel $ describe "Data.Delta" $ do
+    it
+      "Dummy test, to be expanded"
+      True
+  describe "CachedStore" $ do
+    it "respects store laws"
+      $ let
+          setupStore = do
             testStore <- newTestStore
+            resetTestStoreBase testStore
+            newCachedStore testStore
+        in
+          prop_StoreUpdate
+            id
+            setupStore
+            (pure emptyTestStore)
+            $ const genTestStoreDeltas
 
-            cachedStore <- newCachedStore testStore
+    it "behaves like the cached one" $ monadicIO $ run $ do
+      das <- generate $ listOf genTestStoreDeltas
 
-            resetTestStoreBase testStore
-            updateStore cachedStore das
-            Right cachedFinal <- loadS cachedStore
+      testStore <- newTestStore
 
-            resetTestStoreBase testStore
-            updateStore testStore das
-            Right originalFinal <- loadS testStore
+      cachedStore <- newCachedStore testStore
+
+      resetTestStoreBase testStore
+      updateStore cachedStore das
+      Right cachedFinal <- loadS cachedStore
+
+      resetTestStoreBase testStore
+      updateStore testStore das
+      Right originalFinal <- loadS testStore
 
-            pure $ cachedFinal === originalFinal
+      pure $ cachedFinal === originalFinal
 
 newTestStore :: IO (UpdateStore IO TestStoreDelta)
 newTestStore = newStore
@@ -77,22 +98,22 @@ emptyTestStore :: TestStoreBase
 emptyTestStore = TestStoreBase []
 
 newtype TestStoreBase = TestStoreBase [Int]
-    deriving (Show, Eq)
+  deriving (Show, Eq)
 
 data TestStoreDelta
-    = AddOne
-    | AddTwo
-    | RemoveOne
+  = AddOne
+  | AddTwo
+  | RemoveOne
+  deriving (Show, Eq)
 
-    deriving (Show, Eq)
 instance Buildable TestStoreDelta where
-    build = build . show
+  build = build . show
 
 instance Delta TestStoreDelta where
-    type Base TestStoreDelta = TestStoreBase
-    apply AddOne = overTestStoreBase (1:)
-    apply AddTwo = overTestStoreBase (2:)
-    apply RemoveOne = overTestStoreBase (drop 1)
+  type Base TestStoreDelta = TestStoreBase
+  apply AddOne = overTestStoreBase (1 :)
+  apply AddTwo = overTestStoreBase (2 :)
+  apply RemoveOne = overTestStoreBase (drop 1)
 
 overTestStoreBase :: ([Int] -> [Int]) -> TestStoreBase -> TestStoreBase
 overTestStoreBase f (TestStoreBase xs) = TestStoreBase (f xs)

lib/delta-table/delta-table.cabal

@@ -19,6 +19,7 @@ library
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:
@@ -63,6 +64,7 @@ test-suite unit
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:

lib/delta-table/src/Data/Table.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
-module Data.Table (
-    -- * Synopsis
+
+module Data.Table
+  ( -- * Synopsis
+
     -- | 'Table' models a database table.
     -- It corresponds to a collection of rows.
     -- Each row has a unique ID, but this is transparent to the API user.
@@ -15,70 +17,90 @@ module Data.Table (
 
     -- * Table
     Table (..)
-    , empty, fromRows, fromList, toPile, toRows
-    , selectWhere, insertMany, deleteWhere, updateWhere
-    , DeltaTable (..)
-    , DeltaDB (..)
-    , tableIntoDatabase
+  , empty
+  , fromRows
+  , fromList
+  , toPile
+  , toRows
+  , selectWhere
+  , insertMany
+  , deleteWhere
+  , updateWhere
+  , DeltaTable (..)
+  , DeltaDB (..)
+  , tableIntoDatabase
 
     -- * Pile
-    , Pile (..)
-    , fromSet
-    , deltaListToPile, deltaListFromPile
-    , deltaSetToPile, deltaSetFromPile
+  , Pile (..)
+  , fromSet
+  , deltaListToPile
+  , deltaListFromPile
+  , deltaSetToPile
+  , deltaSetFromPile
 
     -- * Supply
-    , Supply
-    , abundance, fresh, consume
-    ) where
-
-import Prelude
+  , Supply
+  , abundance
+  , fresh
+  , consume
+  )
+where
 
 import Control.Monad
-    ( forM )
+  ( forM
+  )
 import Control.Monad.Trans.State.Strict
-    ( evalState, state )
+  ( evalState
+  , state
+  )
 import Data.Delta
-    ( Delta (..)
-    , DeltaList (..)
-    , DeltaSet
-    , DeltaSet1 (..)
-    , Embedding
-    , Embedding' (..)
-    , mkEmbedding
-    )
+  ( Delta (..)
+  , DeltaList (..)
+  , DeltaSet
+  , DeltaSet1 (..)
+  , Embedding
+  , Embedding' (..)
+  , mkEmbedding
+  )
+import Data.Delta qualified as Delta
 import Data.IntMap.Strict
-    ( IntMap )
+  ( IntMap
+  )
+import Data.IntMap.Strict qualified as Map
 import Data.List
-    ( sort, sortOn )
+  ( sort
+  , sortOn
+  )
 import Data.Ord
-    ( Down (..) )
+  ( Down (..)
+  )
 import Data.Set
-    ( Set )
-
-import qualified Data.Delta as Delta
-import qualified Data.IntMap.Strict as Map
-import qualified Data.Set as Set
+  ( Set
+  )
+import Data.Set qualified as Set
+import Prelude
 
 {-------------------------------------------------------------------------------
     Table
 -------------------------------------------------------------------------------}
+
 -- | A 'Table' is a collection of rows.
 data Table row = Table
-    { rows :: IntMap row
-    -- ^ Rows indexed by unique ID.
-    , uids :: Supply
-    -- ^ Unique ID supply.
-    -- WARNING: This is an internal part of the structure.
-    -- Changing it may lead to an inconsistent state.
-    } deriving (Show)
+  { rows :: IntMap row
+  -- ^ Rows indexed by unique ID.
+  , uids :: Supply
+  -- ^ Unique ID supply.
+  -- WARNING: This is an internal part of the structure.
+  -- Changing it may lead to an inconsistent state.
+  }
+  deriving (Show)
 
 instance Functor Table where
-    fmap f table@Table{rows} = table{ rows = Map.map f rows }
+  fmap f table@Table {rows} = table {rows = Map.map f rows}
 
 -- | The empty 'Table', containing no rows.
 empty :: Table row
-empty = Table{ rows = Map.empty, uids = abundance }
+empty = Table {rows = Map.empty, uids = abundance}
 
 -- | List all rows satisfying the predicate.
 selectWhere :: (row -> Bool) -> Table row -> Pile row
@@ -88,109 +110,122 @@ selectWhere p = Pile . filter p . Map.elems . rows
 insertMany :: [row] -> Table row -> Table row
 insertMany rs table = foldr insertRow table rs
   where
-    insertRow row Table{rows,uids} =
-        Table{ rows = Map.insert uid row rows, uids = uids2 }
-      where (uid, uids2) = fresh uids
+    insertRow row Table {rows, uids} =
+      Table {rows = Map.insert uid row rows, uids = uids2}
+      where
+        (uid, uids2) = fresh uids
 
 -- | Construct a 'Table' from a list of rows
 fromList :: [row] -> Table row
 fromList rows = insertMany rows empty
 
 -- | Construct a 'Table' from a list of rows with unique IDs.
 fromRows :: [(Int, row)] -> Table row
-fromRows rows = Table
+fromRows rows =
+  Table
     { rows = Map.fromList rows
     , uids = consume keys abundance
     }
-  where keys = map fst rows
+  where
+    keys = map fst rows
 
 -- | Pile of rows contained in the 'Table'.
 toPile :: Table row -> Pile row
 toPile = Pile . Map.elems . rows
 
 -- | Pile of rows with unique IDs contained in the 'Table'.
-toRows :: Table row -> Pile (Int,row)
+toRows :: Table row -> Pile (Int, row)
 toRows = Pile . Map.toList . rows
 
 -- | Delete all rows satisfying the predicate.
 deleteWhere :: (row -> Bool) -> Table row -> Table row
-deleteWhere p table@Table{rows} = table{ rows = Map.filter (not . p) rows }
+deleteWhere p table@Table {rows} = table {rows = Map.filter (not . p) rows}
 
 -- | Update all rows satisfying the predicate
 updateWhere :: (row -> Bool) -> (row -> row) -> Table row -> Table row
-updateWhere p f table@Table{rows} = table{ rows = Map.map g rows }
-  where g row = if p row then f row else row
+updateWhere p f table@Table {rows} = table {rows = Map.map g rows}
+  where
+    g row = if p row then f row else row
 
 -- | Delta encoding for changes to a 'Table'.
 data DeltaTable row
-    = InsertMany [row]
-    | DeleteWhere (row -> Bool)
-    | UpdateWhere (row -> Bool) (row -> row)
+  = InsertMany [row]
+  | DeleteWhere (row -> Bool)
+  | UpdateWhere (row -> Bool) (row -> row)
 
 instance Show row => Show (DeltaTable row) where
-    showsPrec d delta = showParen (d > app_prec) $ case delta of
-        InsertMany rs -> showString "InsertMany " . showsPrec (app_prec+1) rs
-        DeleteWhere _ -> showString "DeleteWhere (..)"
-        UpdateWhere _ _ -> showString "UpdateWhere (..)"
-      where app_prec = 10
+  showsPrec d delta = showParen (d > app_prec) $ case delta of
+    InsertMany rs -> showString "InsertMany " . showsPrec (app_prec + 1) rs
+    DeleteWhere _ -> showString "DeleteWhere (..)"
+    UpdateWhere _ _ -> showString "UpdateWhere (..)"
+    where
+      app_prec = 10
 
 instance Delta (DeltaTable row) where
-    type Base (DeltaTable row) = Table row
-    apply (InsertMany rows) = insertMany rows
-    apply (DeleteWhere p)   = deleteWhere p
-    apply (UpdateWhere p f) = updateWhere p f
+  type Base (DeltaTable row) = Table row
+  apply (InsertMany rows) = insertMany rows
+  apply (DeleteWhere p) = deleteWhere p
+  apply (UpdateWhere p f) = updateWhere p f
 
 -- | Delta encoding for changes to a database table with unique IDs.
 data DeltaDB key row
-    = InsertManyDB [(key, row)]
-    | DeleteManyDB [key]
-    | UpdateManyDB [(key, row)]
-    deriving (Eq, Show)
+  = InsertManyDB [(key, row)]
+  | DeleteManyDB [key]
+  | UpdateManyDB [(key, row)]
+  deriving (Eq, Show)
 
 instance Functor (DeltaDB key) where
-    fmap f (InsertManyDB zs) = InsertManyDB [ (k, f r) | (k,r) <- zs ]
-    fmap _ (DeleteManyDB ks) = DeleteManyDB ks
-    fmap f (UpdateManyDB zs) = UpdateManyDB [ (k, f r) | (k,r) <- zs ]
+  fmap f (InsertManyDB zs) = InsertManyDB [(k, f r) | (k, r) <- zs]
+  fmap _ (DeleteManyDB ks) = DeleteManyDB ks
+  fmap f (UpdateManyDB zs) = UpdateManyDB [(k, f r) | (k, r) <- zs]
 
 instance (key ~ Int) => Delta (DeltaDB key row) where
-    type Base (DeltaDB key row) = Table row
-    apply (InsertManyDB zs) table@Table{rows,uids} = table
-        { rows = foldr ($) rows [ Map.insert k r | (k,r) <- zs ]
-        , uids = consume (map fst zs) uids
-        }
-    apply (DeleteManyDB ks) table@Table{rows} =
-        table{ rows = foldr ($) rows [ Map.delete k | k <- ks ] }
-    apply (UpdateManyDB zs) table@Table{rows} =
-        table{ rows = foldr ($) rows [ Map.adjust (const r) k | (k,r) <- zs ] }
+  type Base (DeltaDB key row) = Table row
+  apply (InsertManyDB zs) table@Table {rows, uids} =
+    table
+      { rows = foldr ($) rows [Map.insert k r | (k, r) <- zs]
+      , uids = consume (map fst zs) uids
+      }
+  apply (DeleteManyDB ks) table@Table {rows} =
+    table {rows = foldr ($) rows [Map.delete k | k <- ks]}
+  apply (UpdateManyDB zs) table@Table {rows} =
+    table {rows = foldr ($) rows [Map.adjust (const r) k | (k, r) <- zs]}
 
 tableIntoDatabase :: Embedding [DeltaTable row] [DeltaDB Int row]
-tableIntoDatabase = mkEmbedding Embedding'
-    { load, write, update = \_ b -> map (update1 b) }
+tableIntoDatabase =
+  mkEmbedding
+    Embedding'
+      { load
+      , write
+      , update = \_ b -> map (update1 b)
+      }
   where
     load = Right . id
     write = id
-    update1 Table{uids} (InsertMany rs) = InsertManyDB (zip keys rs)
+    update1 Table {uids} (InsertMany rs) = InsertManyDB (zip keys rs)
       where
         keys = flip evalState uids $ forM (reverse rs) $ \_ -> state fresh
-    update1 Table{rows} (DeleteWhere p)
-        = DeleteManyDB [ key | (key,row) <- Map.toList rows, p row ]
-    update1 Table{rows} (UpdateWhere p f)
-        = UpdateManyDB [ (key, f row) | (key,row) <- Map.toList rows, p row ]
+    update1 Table {rows} (DeleteWhere p) =
+      DeleteManyDB [key | (key, row) <- Map.toList rows, p row]
+    update1 Table {rows} (UpdateWhere p f) =
+      UpdateManyDB [(key, f row) | (key, row) <- Map.toList rows, p row]
+
 -- FIXME! Be careful about the order of updates here.
 
 {-------------------------------------------------------------------------------
     Pile
 -------------------------------------------------------------------------------}
+
 -- | A 'Pile' is a set of values.
 -- Unlike 'Set', it is represented as a list, and avoids the 'Ord' constraint.
 --
 -- This type is useful for highlighting that a collection of values
 -- has no specific order, even though it is not represented as a 'Set'.
-newtype Pile a = Pile { getPile :: [a] }
-    deriving Show
+newtype Pile a = Pile {getPile :: [a]}
+  deriving (Show)
 
 instance Ord a => Eq (Pile a) where
-    (Pile x) == (Pile y) = sort x == sort y
+  (Pile x) == (Pile y) = sort x == sort y
 
 fromSet :: Set a -> Pile a
 fromSet = Pile . Set.toList
@@ -219,7 +254,7 @@ deltaSetFromPile = Delta.deltaSetFromList . getPile
 -- | Map a 'DeltaList' to a 'Pile' of indexed single element concatenations.
 -- Higher indices are prepended later.
 deltaListToPile :: DeltaList a -> Pile (Int, a)
-deltaListToPile (Append xs) = Pile $ zip [0..] (reverse xs)
+deltaListToPile (Append xs) = Pile $ zip [0 ..] (reverse xs)
 
 -- | Restore a 'DeltaList' from a 'Pile'.
 --
@@ -230,26 +265,32 @@ deltaListFromPile = Append . map snd . sortOn (Down . fst) . getPile
 {-------------------------------------------------------------------------------
     Supply
 -------------------------------------------------------------------------------}
+
 -- | A supply of unique IDs.
 newtype Supply = Supply
-    { now  :: Int -- ^ Largest unique ID that is *in use*.
-    }
+  { now :: Int
+  -- ^ Largest unique ID that is *in use*.
+  }
 
 instance Show Supply where
-    showsPrec d (Supply{now}) = showParen (d > app_prec) $
-        showString "Supply {now = " . shows now . showString "} "
-      where app_prec = 10
+  showsPrec d (Supply {now}) =
+    showParen (d > app_prec)
+      $ showString "Supply {now = " . shows now . showString "} "
+    where
+      app_prec = 10
 
 -- | Fresh supply of unique IDs.
 abundance :: Supply
-abundance = Supply{ now = 0 }
+abundance = Supply {now = 0}
 
 -- | Retrieve a fresh unique ID.
 fresh :: Supply -> (Int, Supply)
-fresh supply@Supply{now=old} = new `seq` (new, supply{now=new})
-  where new = succ old -- smallest unused unique ID
+fresh supply@Supply {now = old} = new `seq` (new, supply {now = new})
+  where
+    new = succ old -- smallest unused unique ID
 
 -- | Remove a list of unique IDs from the 'Supply' if necessary.
 consume :: [Int] -> Supply -> Supply
-consume xs supply@Supply{now=old} = new `seq` supply{now=new}
-  where new = old `max` maximum xs
+consume xs supply@Supply {now = old} = new `seq` supply {now = new}
+  where
+    new = old `max` maximum xs

lib/delta-table/src/Database/Persist/Delta.hs

@@ -6,78 +6,117 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Database.Persist.Delta (
-    -- * Synopsis
+module Database.Persist.Delta
+  ( -- * Synopsis
+
     -- | Manipulating SQL database tables using delta encodings
     -- via the "persistent" package.
 
     -- * Store
-    newEntityStore, newSqlStore
-    ) where
-
-import Prelude hiding
-    ( all )
+    newEntityStore
+  , newSqlStore
+  )
+where
 
+-- FIXME: Replace with IOSim stuff later.
+import Conduit
+  ( ResourceT
+  )
 import Control.Monad
-    ( forM_, void, when )
+  ( forM_
+  , void
+  , when
+  )
+import Control.Monad.Class.MonadThrow
+  ( MonadThrow
+  )
 import Control.Monad.IO.Class
-    ( MonadIO, liftIO )
+  ( MonadIO
+  , liftIO
+  )
+import Control.Monad.Logger
+  ( NoLoggingT (..)
+  )
 import Data.Bifunctor
-    ( first )
+  ( first
+  )
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
+import Data.IORef
+  ( newIORef
+  , readIORef
+  , writeIORef
+  )
 import Data.Proxy
-    ( Proxy (..) )
+  ( Proxy (..)
+  )
 import Data.Store
-    ( UpdateStore, mkUpdateStore, updateLoad )
+  ( UpdateStore
+  , mkUpdateStore
+  , updateLoad
+  )
 import Data.Table
-    ( DeltaDB (..), Pile (..), Table (..) )
+  ( DeltaDB (..)
+  , Pile (..)
+  , Table (..)
+  )
+import Data.Table qualified as Table
 import Database.Persist
-    ( Filter, Key, PersistRecordBackend, ToBackendKey )
+  ( Filter
+  , Key
+  , PersistRecordBackend
+  , ToBackendKey
+  )
+import Database.Persist qualified as Persist
 import Database.Persist.Sql
-    ( SqlBackend, SqlPersistM, fromSqlKey, toSqlKey )
+  ( SqlBackend
+  , SqlPersistM
+  , fromSqlKey
+  , toSqlKey
+  )
 import Database.Schema
-    ( (:.) (..), Col (..), IsRow, Primary (..) )
+  ( Col (..)
+  , IsRow
+  , Primary (..)
+  , (:.) (..)
+  )
+import Database.Schema qualified as Sql
 import Say
-    ( say, sayShow )
--- FIXME: Replace with IOSim stuff later.
-import Conduit
-    ( ResourceT )
-import Control.Monad.Class.MonadThrow
-    ( MonadThrow )
-import Control.Monad.Logger
-    ( NoLoggingT (..) )
-import Data.IORef
-    ( newIORef, readIORef, writeIORef )
-
-import qualified Data.Table as Table
-import qualified Database.Persist as Persist
-import qualified Database.Schema as Sql
-
+  ( say
+  , sayShow
+  )
+import Prelude hiding
+  ( all
+  )
 
 {-------------------------------------------------------------------------------
     Database operations
 -------------------------------------------------------------------------------}
+
 -- | Helper abstraction for a Database backend
 data Database m key row = Database
-    { selectAll   :: m [(key, row)]
-    , deleteAll   :: m ()
-    , repsertMany :: [(key, row)] -> m ()
-    , deleteOne   :: key -> m ()
-    , updateOne   :: (key, row) -> m ()
-    }
+  { selectAll :: m [(key, row)]
+  , deleteAll :: m ()
+  , repsertMany :: [(key, row)] -> m ()
+  , deleteOne :: key -> m ()
+  , updateOne :: (key, row) -> m ()
+  }
 
 -- | Database table for 'Entity'.
 persistDB
-    :: forall row. ( PersistRecordBackend row SqlBackend
-    , ToBackendKey SqlBackend row )
-    => Database SqlPersistM Int row
-persistDB = Database
+  :: forall row
+   . ( PersistRecordBackend row SqlBackend
+     , ToBackendKey SqlBackend row
+     )
+  => Database SqlPersistM Int row
+persistDB =
+  Database
     { selectAll = map toPair <$> Persist.selectList all []
     , deleteAll = Persist.deleteWhere all
     , repsertMany = Persist.repsertMany . map (first toKey)
     , deleteOne = Persist.delete . toKey
-    , updateOne = \(key,val) -> Persist.replace (toKey key) val
+    , updateOne = \(key, val) -> Persist.replace (toKey key) val
     }
   where
     all = [] :: [Filter row]
@@ -90,24 +129,27 @@ persistDB = Database
 
 -- | SQL database backend
 sqlDB
-    :: forall row. (IsRow row, IsRow (row :. Col "id" Primary))
-    => Database SqlPersistM Int row
-sqlDB = Database
+  :: forall row
+   . (IsRow row, IsRow (row :. Col "id" Primary))
+  => Database SqlPersistM Int row
+sqlDB =
+  Database
     { selectAll = map toPair <$> Sql.callSql Sql.selectAll
     , deleteAll = Sql.runSql $ Sql.deleteAll proxy
-    , repsertMany = \zs -> forM_ zs $
-        Sql.runSql . Sql.repsertOne . fromPair
+    , repsertMany = \zs ->
+        forM_ zs
+          $ Sql.runSql . Sql.repsertOne . fromPair
     , deleteOne = Sql.runSql . Sql.deleteOne proxy . Col . Primary
     , updateOne = Sql.runSql . Sql.updateOne . fromPair
     }
   where
     proxy = Proxy :: Proxy row
 
-    fromPair :: (Int,row) -> (row :. Col "id" Primary)
-    fromPair (key,row) = row :. (Col (Primary key) :: Col "id" Primary)
+    fromPair :: (Int, row) -> (row :. Col "id" Primary)
+    fromPair (key, row) = row :. (Col (Primary key) :: Col "id" Primary)
 
-    toPair :: (row :. Col "id" Primary) -> (Int,row)
-    toPair (row :. Col (Primary key)) = (key,row)
+    toPair :: (row :. Col "id" Primary) -> (Int, row)
+    toPair (row :. Col (Primary key)) = (key, row)
 
 {-------------------------------------------------------------------------------
     Database operations
@@ -117,67 +159,71 @@ sqlDB = Database
 --
 -- The unique IDs will be stored in a column "id" at the end of
 -- each row in the database table.
-
-
 newSqlStore
-    :: ( MonadIO m
-       , IsRow row
-       , IsRow (row :. Col "id" Primary)
-       , Show row
-       , MonadThrow (NoLoggingT (ResourceT IO))
-       )
-    => m (UpdateStore SqlPersistM [DeltaDB Int row])
+  :: ( MonadIO m
+     , IsRow row
+     , IsRow (row :. Col "id" Primary)
+     , Show row
+     , MonadThrow (NoLoggingT (ResourceT IO))
+     )
+  => m (UpdateStore SqlPersistM [DeltaDB Int row])
 newSqlStore = newDatabaseStore sqlDB
 
 -- | Construct a 'UpdateStore' for 'Entity'.
 --
 -- FIXME: This function should also do \"migrations\", i.e.
 -- create the database table in the first place.
 newEntityStore
-    :: forall row m.
-    ( PersistRecordBackend row SqlBackend
-    , ToBackendKey SqlBackend row, Show row
-    , MonadIO m, MonadThrow (NoLoggingT (ResourceT IO)))
-    => m (UpdateStore SqlPersistM [DeltaDB Int row])
+  :: forall row m
+   . ( PersistRecordBackend row SqlBackend
+     , ToBackendKey SqlBackend row
+     , Show row
+     , MonadIO m
+     , MonadThrow (NoLoggingT (ResourceT IO))
+     )
+  => m (UpdateStore SqlPersistM [DeltaDB Int row])
 newEntityStore = newDatabaseStore persistDB
 
 -- | Helper function to create a 'UpdateStore' using a 'Database' backend.
 newDatabaseStore
-    :: forall m n row. (MonadIO m, MonadIO n, Show row, MonadThrow m)
-    => Database m Int row
-    -> n (UpdateStore m [DeltaDB Int row])
+  :: forall m n row
+   . (MonadIO m, MonadIO n, Show row, MonadThrow m)
+  => Database m Int row
+  -> n (UpdateStore m [DeltaDB Int row])
 newDatabaseStore db = do
-    ref <- liftIO $ newIORef Nothing
-    let rememberSupply table = liftIO $ writeIORef ref $ Just $ uids table
-        load = do
-            debug $ do
-                say "\n** loadS"
-                liftIO . print =<< selectAll db
-            -- read database table, preserve keys
-            table <- Table.fromRows <$> selectAll db
-            -- but use our own unique ID supply
-            liftIO (readIORef ref) >>= \case
-                Just supply  -> pure $ Right table{uids = supply}
-                Nothing      -> do
-                    rememberSupply table
-                    pure $ Right table
-        write table = void $ do
-            deleteAll db -- delete any old data in the table first
-            repsertMany db $ getPile $ Table.toRows table
-            rememberSupply table
-        update = updateLoad load
-                (\err -> debug $ do
-                    say "Error in updateLoadEither"
-                    sayShow err
-                )
-                $ \table ds -> do
-                    debug $ do
-                        say "\n** updateS table deltas"
-                        sayShow table
-                        sayShow ds
-                    mapM_ (update1 table) ds
-                    rememberSupply (apply ds table) -- need to use updated supply
-    pure $ mkUpdateStore load write update
+  ref <- liftIO $ newIORef Nothing
+  let
+    rememberSupply table = liftIO $ writeIORef ref $ Just $ uids table
+    load = do
+      debug $ do
+        say "\n** loadS"
+        liftIO . print =<< selectAll db
+      -- read database table, preserve keys
+      table <- Table.fromRows <$> selectAll db
+      -- but use our own unique ID supply
+      liftIO (readIORef ref) >>= \case
+        Just supply -> pure $ Right table {uids = supply}
+        Nothing -> do
+          rememberSupply table
+          pure $ Right table
+    write table = void $ do
+      deleteAll db -- delete any old data in the table first
+      repsertMany db $ getPile $ Table.toRows table
+      rememberSupply table
+    update = updateLoad
+      load
+      ( \err -> debug $ do
+          say "Error in updateLoadEither"
+          sayShow err
+      )
+      $ \table ds -> do
+        debug $ do
+          say "\n** updateS table deltas"
+          sayShow table
+          sayShow ds
+        mapM_ (update1 table) ds
+        rememberSupply (apply ds table) -- need to use updated supply
+  pure $ mkUpdateStore load write update
   where
     debug = when False
 

lib/delta-types/delta-types.cabal

@@ -19,6 +19,7 @@ library
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:
@@ -45,6 +46,7 @@ test-suite unit
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:

lib/delta-types/src/Data/DeltaMap.hs

@@ -4,38 +4,46 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Data.DeltaMap
-    ( DeltaMap(..)
-    ) where
-
-import Prelude
+  ( DeltaMap (..)
+  )
+where
 
 import Data.Delta
-    ( Delta (..) )
+  ( Delta (..)
+  )
 import Data.Map.Strict
-    ( Map )
+  ( Map
+  )
+import Data.Map.Strict qualified as Map
 import Fmt
-    ( Buildable (..) )
-
-import qualified Data.Map.Strict as Map
+  ( Buildable (..)
+  )
+import Prelude
 
 {-------------------------------------------------------------------------------
     A Delta type for Maps,
     useful for handling multiple wallets.
 -------------------------------------------------------------------------------}
+
 -- | Delta type for 'Map'.
 data DeltaMap key da
-    = Insert key (Base da)
-    | Delete key
-    | Adjust key da
+  = Insert key (Base da)
+  | Delete key
+  | Adjust key da
 
 deriving instance (Show key, Show da, Show (Base da)) => Show (DeltaMap key da)
-instance (Ord key, Delta da)
-    => Delta (DeltaMap key da) where
-    type Base (DeltaMap key da) = Map key (Base da)
-    apply (Insert key a) = Map.insert key a
-    apply (Delete key) = Map.delete key
-    apply (Adjust key da) = Map.adjust (apply da) key
 
-instance (Show key, Show da, Show (Base da))
-    => Buildable (DeltaMap key da) where
-    build = build . show
+instance
+  (Ord key, Delta da)
+  => Delta (DeltaMap key da)
+  where
+  type Base (DeltaMap key da) = Map key (Base da)
+  apply (Insert key a) = Map.insert key a
+  apply (Delete key) = Map.delete key
+  apply (Adjust key da) = Map.adjust (apply da) key
+
+instance
+  (Show key, Show da, Show (Base da))
+  => Buildable (DeltaMap key da)
+  where
+  build = build . show

lib/delta-types/test/unit/Data/DeltaSpec.hs

@@ -1,16 +1,21 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Data.DeltaSpec
-    ( spec
-    ) where
-
-import Prelude
+  ( spec
+  )
+where
 
 import Test.Hspec
-    ( Spec, describe, it, parallel )
+  ( Spec
+  , describe
+  , it
+  , parallel
+  )
+import Prelude
 
 spec :: Spec
 spec = do
-    parallel $ describe "Data.Delta" $ do
-        it "Dummy test, to be expanded"
-            True
+  parallel $ describe "Data.Delta" $ do
+    it
+      "Dummy test, to be expanded"
+      True

lib/launcher/cardano-wallet-launcher.cabal

@@ -19,6 +19,7 @@ library
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:
@@ -63,6 +64,7 @@ test-suite unit
   default-language:
       Haskell2010
   default-extensions:
+      ImportQualifiedPost
       NoImplicitPrelude
       OverloadedStrings
   ghc-options:

lib/launcher/src/Cardano/Launcher/Node.hs

@@ -1,51 +1,68 @@
 {-# LANGUAGE TupleSections #-}
+
 -- |
 -- Copyright: © 2018-2020 IOHK
 -- License: Apache-2.0
 --
 -- Provides a function to launch @cardano-node@.
-
 module Cardano.Launcher.Node
-    ( -- * Startup
-      withCardanoNode
-    , CardanoNodeConfig (..)
-    , NodePort (..)
-
-      -- * cardano-node Snockets
-    , CardanoNodeConn
-    , cardanoNodeConn
-    , nodeSocketFile
-    , isWindows
-    ) where
-
-import Prelude
+  ( -- * Startup
+    withCardanoNode
+  , CardanoNodeConfig (..)
+  , NodePort (..)
+
+    -- * cardano-node Snockets
+  , CardanoNodeConn
+  , cardanoNodeConn
+  , nodeSocketFile
+  , isWindows
+  )
+where
 
 import Cardano.Launcher
-    ( LauncherLog, ProcessHasExited, withBackendCreateProcess )
+  ( LauncherLog
+  , ProcessHasExited
+  , withBackendCreateProcess
+  )
 import Control.Tracer
-    ( Tracer (..) )
+  ( Tracer (..)
+  )
 import Data.Bifunctor
-    ( first )
+  ( first
+  )
 import Data.List
-    ( isPrefixOf )
+  ( isPrefixOf
+  )
 import Data.Maybe
-    ( fromMaybe, maybeToList )
+  ( fromMaybe
+  , maybeToList
+  )
+import Data.Text qualified as T
 import Data.Text.Class
-    ( FromText (..), TextDecodingError (..), ToText (..) )
+  ( FromText (..)
+  , TextDecodingError (..)
+  , ToText (..)
+  )
 import System.Environment
-    ( getEnvironment )
+  ( getEnvironment
+  )
 import System.FilePath
-    ( isValid, takeFileName, (</>) )
+  ( isValid
+  , takeFileName
+  , (</>)
+  )
 import System.Info
-    ( os )
+  ( os
+  )
 import UnliftIO.Process
-    ( CreateProcess (..), proc )
-
-import qualified Data.Text as T
+  ( CreateProcess (..)
+  , proc
+  )
+import Prelude
 
 -- | Parameters for connecting to the node.
 newtype CardanoNodeConn = CardanoNodeConn FilePath
-    deriving (Show, Eq)
+  deriving (Show, Eq)
 
 -- | Gets the socket filename or pipe name from 'CardanoNodeConn'. Whether it's
 -- a unix socket or named pipe depends on the value of 'isWindows'.
@@ -56,62 +73,67 @@ nodeSocketFile (CardanoNodeConn name) = name
 -- 'isWindows') is valid.
 cardanoNodeConn :: FilePath -> Either String CardanoNodeConn
 cardanoNodeConn name
-    | isWindows = if isValidWindowsPipeName name
+  | isWindows =
+      if isValidWindowsPipeName name
         then Right $ CardanoNodeConn name
         else Left "Invalid pipe name."
-    | otherwise = if isValid name
+  | otherwise =
+      if isValid name
         then Right $ CardanoNodeConn name
         else Left "Invalid file path."
 
 isWindows :: Bool
 isWindows = os == "mingw32"
 
 isValidWindowsPipeName :: FilePath -> Bool
-isValidWindowsPipeName name = slashPipe `isPrefixOf` name
+isValidWindowsPipeName name =
+  slashPipe `isPrefixOf` name
     && isValid (drop (length slashPipe) name)
   where
     slashPipe = "\\\\.\\pipe\\"
 
 instance ToText CardanoNodeConn where
-    toText = T.pack . nodeSocketFile
+  toText = T.pack . nodeSocketFile
 
 instance FromText CardanoNodeConn where
-    fromText = first TextDecodingError . cardanoNodeConn . T.unpack
+  fromText = first TextDecodingError . cardanoNodeConn . T.unpack
 
-newtype NodePort = NodePort { unNodePort :: Int }
-    deriving (Show, Eq)
+newtype NodePort = NodePort {unNodePort :: Int}
+  deriving (Show, Eq)
 
 -- | A subset of the @cardano-node@ CLI parameters, used for starting the
 -- backend.
 data CardanoNodeConfig = CardanoNodeConfig
-    { nodeDir             :: FilePath
-    , nodeConfigFile      :: FilePath
-    , nodeTopologyFile    :: FilePath
-    , nodeDatabaseDir     :: FilePath
-    , nodeDlgCertFile     :: Maybe FilePath
-    , nodeSignKeyFile     :: Maybe FilePath
-    , nodeOpCertFile      :: Maybe FilePath
-    , nodeKesKeyFile      :: Maybe FilePath
-    , nodeVrfKeyFile      :: Maybe FilePath
-    , nodePort            :: Maybe NodePort
-    , nodeLoggingHostname :: Maybe String
-    , nodeExecutable      :: Maybe FilePath
-    } deriving (Show, Eq)
+  { nodeDir :: FilePath
+  , nodeConfigFile :: FilePath
+  , nodeTopologyFile :: FilePath
+  , nodeDatabaseDir :: FilePath
+  , nodeDlgCertFile :: Maybe FilePath
+  , nodeSignKeyFile :: Maybe FilePath
+  , nodeOpCertFile :: Maybe FilePath
+  , nodeKesKeyFile :: Maybe FilePath
+  , nodeVrfKeyFile :: Maybe FilePath
+  , nodePort :: Maybe NodePort
+  , nodeLoggingHostname :: Maybe String
+  , nodeExecutable :: Maybe FilePath
+  }
+  deriving (Show, Eq)
 
 -- | Spawns a @cardano-node@ process.
 --
 -- IMPORTANT: @cardano-node@ must be available on the current path.
 withCardanoNode
-    :: Tracer IO LauncherLog
-    -- ^ Trace for subprocess control logging
-    -> CardanoNodeConfig
-    -> (CardanoNodeConn -> IO a)
-    -- ^ Callback function with a socket filename and genesis params
-    -> IO (Either ProcessHasExited a)
+  :: Tracer IO LauncherLog
+  -- ^ Trace for subprocess control logging
+  -> CardanoNodeConfig
+  -> (CardanoNodeConn -> IO a)
+  -- ^ Callback function with a socket filename and genesis params
+  -> IO (Either ProcessHasExited a)
 withCardanoNode tr cfg action = do
-    let socketPath = nodeSocketPath (nodeDir cfg)
-    cp <- cardanoNodeProcess cfg socketPath
-    withBackendCreateProcess tr cp $ \_ _ -> action $ CardanoNodeConn socketPath
+  let
+    socketPath = nodeSocketPath (nodeDir cfg)
+  cp <- cardanoNodeProcess cfg socketPath
+  withBackendCreateProcess tr cp $ \_ _ -> action $ CardanoNodeConn socketPath
 
 {-------------------------------------------------------------------------------
                                     Helpers
@@ -120,21 +142,27 @@ withCardanoNode tr cfg action = do
 -- | Generate command-line arguments for launching @cardano-node@.
 cardanoNodeProcess :: CardanoNodeConfig -> FilePath -> IO CreateProcess
 cardanoNodeProcess cfg socketPath = do
-    myEnv <- getEnvironment
-    let env' = ("CARDANO_NODE_LOGGING_HOSTNAME",) <$> nodeLoggingHostname cfg
-
-    pure $ (proc (fromMaybe "cardano-node" $ nodeExecutable cfg) args)
-        { env = Just $ maybeToList env' ++ myEnv
-        , cwd = Just $ nodeDir cfg
-        }
+  myEnv <- getEnvironment
+  let
+    env' = ("CARDANO_NODE_LOGGING_HOSTNAME",) <$> nodeLoggingHostname cfg
+
+  pure
+    $ (proc (fromMaybe "cardano-node" $ nodeExecutable cfg) args)
+      { env = Just $ maybeToList env' ++ myEnv
+      , cwd = Just $ nodeDir cfg
+      }
   where
     args =
-        [ "run"
-        , "--config", nodeConfigFile cfg
-        , "--topology", nodeTopologyFile cfg
-        , "--database-path", nodeDatabaseDir cfg
-        , "--socket-path", socketPath
-        ]
+      [ "run"
+      , "--config"
+      , nodeConfigFile cfg
+      , "--topology"
+      , nodeTopologyFile cfg
+      , "--database-path"
+      , nodeDatabaseDir cfg
+      , "--socket-path"
+      , socketPath
+      ]
         ++ opt "--port" (show . unNodePort <$> nodePort cfg)
         ++ opt "--byron-signing-key" (nodeSignKeyFile cfg)
         ++ opt "--byron-delegation-certificate" (nodeDlgCertFile cfg)
@@ -148,8 +176,10 @@ cardanoNodeProcess cfg socketPath = do
 
 -- | Generate a 'FilePath' for the @cardano-node@ domain socket/named pipe.
 nodeSocketPath
-    :: FilePath -- ^ @cardano-node@ state directory
-    -> FilePath -- ^ UNIX socket file path or Windows named pipe name
+  :: FilePath
+  -- ^ @cardano-node@ state directory
+  -> FilePath
+  -- ^ UNIX socket file path or Windows named pipe name
 nodeSocketPath dir
-    | os == "mingw32" = "\\\\.\\pipe\\" ++ takeFileName dir
-    | otherwise = dir </> "node.socket"
+  | os == "mingw32" = "\\\\.\\pipe\\" ++ takeFileName dir
+  | otherwise = dir </> "node.socket"

lib/launcher/src/Cardano/Launcher/Wallet.hs

@@ -6,98 +6,112 @@
 --
 -- Provides a function to launch @cardano-wallet@.
 module Cardano.Launcher.Wallet
-    ( -- * Startup
-      withCardanoWallet
-    , CardanoWalletConfig (..)
-    , NetworkConfig (..)
+  ( -- * Startup
+    withCardanoWallet
+  , CardanoWalletConfig (..)
+  , NetworkConfig (..)
 
-      -- * Run
-    , CardanoWalletConn
-    , getWalletPort
-    ) where
-
-import Prelude
+    -- * Run
+  , CardanoWalletConn
+  , getWalletPort
+  )
+where
 
 import Cardano.Launcher
-    ( LauncherLog, ProcessHasExited, withBackendCreateProcess )
+  ( LauncherLog
+  , ProcessHasExited
+  , withBackendCreateProcess
+  )
 import Cardano.Launcher.Node
-    ( CardanoNodeConn, nodeSocketFile )
+  ( CardanoNodeConn
+  , nodeSocketFile
+  )
 import Control.Tracer
-    ( Tracer (..) )
+  ( Tracer (..)
+  )
 import Data.Maybe
-    ( fromMaybe )
+  ( fromMaybe
+  )
 import Data.Text.Class
-    ( FromText (..), ToText (..) )
+  ( FromText (..)
+  , ToText (..)
+  )
 import Network.Socket
-    ( PortNumber )
+  ( PortNumber
+  )
 import UnliftIO.Process
-    ( CreateProcess (..), proc )
+  ( CreateProcess (..)
+  , proc
+  )
+import Prelude
 
 {-----------------------------------------------------------------------------
     Launching a `cardano-wallet` process
 ------------------------------------------------------------------------------}
 
 -- | Parameters for connecting to the running wallet process.
 newtype CardanoWalletConn = CardanoWalletConn {getWalletPort :: PortNumber}
-    deriving (Show, Eq)
+  deriving (Show, Eq)
 
 instance ToText CardanoWalletConn where
-    toText = toText . fromEnum . getWalletPort
+  toText = toText . fromEnum . getWalletPort
 
 instance FromText CardanoWalletConn where
-    fromText = fmap (CardanoWalletConn . toEnum) . fromText
+  fromText = fmap (CardanoWalletConn . toEnum) . fromText
 
 data NetworkConfig
-    = Mainnet
-    | Testnet {nodeByronGenesis :: FilePath}
-    deriving (Show, Eq)
+  = Mainnet
+  | Testnet {nodeByronGenesis :: FilePath}
+  deriving (Show, Eq)
 
 -- | A subset of the @cardano-wallet@ CLI parameters,
 -- used for starting the process.
 data CardanoWalletConfig = CardanoWalletConfig
-    { walletPort :: PortNumber
-    -- ^ Port number for HTTP API. Good default: 8090.
-    , walletDatabaseDir :: FilePath
-    -- ^ Path to the wallet database file.
-    , walletNetwork :: NetworkConfig
-    -- ^ Network (mainnet or a testnet) that we connect to.
-    , extraArgs :: [String]
-    -- ^ Extra arguments to be passed to the process
-    , executable :: Maybe FilePath
-    -- ^ Path to the @cardano-wallet@ executable.
-    , workingDir :: Maybe FilePath
-    }
-    deriving (Show, Eq)
+  { walletPort :: PortNumber
+  -- ^ Port number for HTTP API. Good default: 8090.
+  , walletDatabaseDir :: FilePath
+  -- ^ Path to the wallet database file.
+  , walletNetwork :: NetworkConfig
+  -- ^ Network (mainnet or a testnet) that we connect to.
+  , extraArgs :: [String]
+  -- ^ Extra arguments to be passed to the process
+  , executable :: Maybe FilePath
+  -- ^ Path to the @cardano-wallet@ executable.
+  , workingDir :: Maybe FilePath
+  }
+  deriving (Show, Eq)
 
 -- | Spawns a @cardano-wallet@ process.
 --
 -- IMPORTANT: @cardano-wallet@ must be available on the current path.
 withCardanoWallet
-    :: Tracer IO LauncherLog
-    -- ^ Trace for subprocess control logging
-    -> CardanoNodeConn
-    -> CardanoWalletConfig
-    -> (CardanoWalletConn -> IO a)
-    -- ^ Callback function with a socket filename and genesis params
-    -> IO (Either ProcessHasExited a)
-withCardanoWallet tr node cfg@CardanoWalletConfig{..} action =
-    withBackendCreateProcess tr (cardanoWallet cfg node)
-        $ \_ _ -> action $ CardanoWalletConn walletPort
+  :: Tracer IO LauncherLog
+  -- ^ Trace for subprocess control logging
+  -> CardanoNodeConn
+  -> CardanoWalletConfig
+  -> (CardanoWalletConn -> IO a)
+  -- ^ Callback function with a socket filename and genesis params
+  -> IO (Either ProcessHasExited a)
+withCardanoWallet tr node cfg@CardanoWalletConfig {..} action =
+  withBackendCreateProcess tr (cardanoWallet cfg node)
+    $ \_ _ -> action $ CardanoWalletConn walletPort
 
 cardanoWallet :: CardanoWalletConfig -> CardanoNodeConn -> CreateProcess
-cardanoWallet CardanoWalletConfig{..} node =
-
-    let cp = proc (fromMaybe "cardano-wallet" executable)
-            $ [ "serve"
-            , "--node-socket"
-            , nodeSocketFile node
-            , "--database"
-            , walletDatabaseDir
-            , "--port"
-            , show walletPort
-            ]
-                <> case walletNetwork of
-                    Mainnet -> ["--mainnet"]
-                    Testnet path -> ["--testnet", path]
-                <> extraArgs
-    in cp { cwd = workingDir }
+cardanoWallet CardanoWalletConfig {..} node =
+  let
+    cp =
+      proc (fromMaybe "cardano-wallet" executable)
+        $ [ "serve"
+          , "--node-socket"
+          , nodeSocketFile node
+          , "--database"
+          , walletDatabaseDir
+          , "--port"
+          , show walletPort
+          ]
+          <> case walletNetwork of
+            Mainnet -> ["--mainnet"]
+            Testnet path -> ["--testnet", path]
+          <> extraArgs
+  in
+    cp {cwd = workingDir}