th-lock (empty) → 0.0.4

raw patch · 20 files changed

+399/−0 lines, 20 filesdep +basedep +tastydep +tasty-discover

Dependencies added: base, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, template-haskell, th-lock

Files

• LICENSE +30/−0
• changelog.md +3/−0
• src/Language/Haskell/TH/Lock.hs +66/−0
• test/Discovery.hs +1/−0
• test/Driver.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleA.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleB.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleC.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleD.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleE.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleF.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleG.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleH.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleI.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleJ.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleX.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleY.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/ModuleZ.hs +12/−0
• test/Tests/Language/Haskell/TH/Lock/State.hs +15/−0
• th-lock.cabal +116/−0

@@ -0,0 +1,30 @@+Copyright (c) 2025 Daniil Iaitskov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Edward Kmett nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+# th-lock changelog++## Version 1.0.0 2025-03-14

@@ -0,0 +1,66 @@+-- | Serial Haskell module compilation+module Language.Haskell.TH.Lock+  ( ensureSerialCompilation+  , ensureSerialCompilationQuietly+  , ensureSerialCompilationVerbose+  ) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryPutMVar, tryReadMVar, MVar)+import Control.Monad (void)+import Language.Haskell.TH.Syntax+import Prelude hiding (log)+import System.IO.Unsafe (unsafePerformIO)++-- | 'MVar' holds a Haskell module name expecting sequentian+-- compilation and which is currently goes through the compilation+-- process.+moduleCompilationLock :: MVar String+moduleCompilationLock = unsafePerformIO (newEmptyMVar)++-- | Call this function right after import section to prevent+-- concurrent TH code exection for modules with mutable compile time+-- shared state.  The function acquires a lock in the scope of GHC+-- process and the lock is released once type checker completes module+-- verification.+ensureSerialCompilation :: (String -> IO ()) -> Q [Dec]+ensureSerialCompilation log = do+  m <- loc_module <$> location+  go moduleCompilationLock m+  addModFinalizer (goAway moduleCompilationLock m)+  pure []+  where+    goAway l m = do+      runIO (tryReadMVar l) >>= \case+        Just holdingModule ->+          if holdingModule == m+          then runIO $ do+            log $ "Module [" <> m <> "] released lock"+            void $ takeMVar l+          else+            reportError $+              "Module [" <> m <> "] attempted to release lock of TH MVar holding by [" <>+                holdingModule <> "]"+        Nothing ->+          reportError $ "Module [" <> m <> "] attempted to release unlocked TH MVar"++    go l m = runIO (goIo l m)+    goIo l m =+      tryPutMVar l m >>= \case+        True -> do+          log $ "Module [" <> m <> "] acquired TH lock"+        False -> tryReadMVar l >>= \case+          Just holdingModule -> do+            log $ "Module [" <> m <> "] is waiting for [" <> holdingModule <> "]"+            putMVar l m+            log $ "Module [" <> m <> "] acquired TH lock"+          Nothing -> do+            log $ "Module [" <> m <> "] retries to acquire TH lock"+            goIo l m++-- | 'ensureSerialCompilation' without lock logging+ensureSerialCompilationQuietly :: Q [Dec]+ensureSerialCompilationQuietly = ensureSerialCompilation (void . pure)++-- | 'ensureSerialCompilation' with lock logging+ensureSerialCompilationVerbose :: Q [Dec]+ensureSerialCompilationVerbose = ensureSerialCompilation putStrLn

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-}

@@ -0,0 +1,12 @@+module Driver where++import qualified Discovery+import Test.Tasty++main :: IO ()+main = defaultMain =<< testTree+  where+    testTree :: IO TestTree+    testTree = do+      tests <- Discovery.tests+      pure $ testGroup "haddock-use-refs" [ tests ]

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleA where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "A"++unit_check_state :: IO ()+unit_check_state = "A" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleB where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "B"++unit_check_state :: IO ()+unit_check_state = "B" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleC where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "C"++unit_check_state :: IO ()+unit_check_state = "C" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleD where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "D"++unit_check_state :: IO ()+unit_check_state = "D" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleE where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "E"++unit_check_state :: IO ()+unit_check_state = "E" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleF where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "F"++unit_check_state :: IO ()+unit_check_state = "F" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleG where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "G"++unit_check_state :: IO ()+unit_check_state = "G" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleH where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "H"++unit_check_state :: IO ()+unit_check_state = "H" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleI where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "I"++unit_check_state :: IO ()+unit_check_state = "I" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleJ where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "J"++unit_check_state :: IO ()+unit_check_state = "J" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleX where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "X"++unit_check_state :: IO ()+unit_check_state = "X" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleY where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "Y"++unit_check_state :: IO ()+unit_check_state = "Y" @=? $(get)

@@ -0,0 +1,12 @@+module Tests.Language.Haskell.TH.Lock.ModuleZ where++import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))+import Tests.Language.Haskell.TH.Lock.State++ensureSerialCompilationVerbose++set "Z"++unit_check_state :: IO ()+unit_check_state = "Z" @=? $(get)

@@ -0,0 +1,15 @@+module Tests.Language.Haskell.TH.Lock.State where++import Data.IORef+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import System.IO.Unsafe++state :: IORef String+state = unsafePerformIO (newIORef "")++set :: String -> Q [Dec]+set s = runIO (atomicWriteIORef state s) >> pure []++get :: Q Exp+get = lift =<< runIO (readIORef state)

@@ -0,0 +1,116 @@+cabal-version:   3.0+name:            th-lock+version:         0.0.4+license:         BSD-3-Clause+license-file:    LICENSE+category:        Development+author:          Daniil Iaitskov <dyaitskov@gmail.com>+maintainer:      Daniil Iaitskov <dyaitskov@gmail.com>+stability:       experimental+synopsis:        Serialize compilation of modules with TH code modifing shared state+homepage:        https://github.com/yaitskov/th-lock+bug-reports:     https://github.com/yaitskov/th-lock/issues+build-type:      Simple+description:+    Recent GHC versions with option @-j\<N>@ where @N@ greater than 1 can+    build modules concurrently. Usually it is cool thing, because build time+    drops, but there is a drawback in form of problems with TH code+    maintaining a shared state.+    +    I encountered such issue while running tests for+    <https://hackage.haskell.org/package/trace-embrace trace-embrace>+    package. Package TH code has a shared state (immutable configuration+    file loaded once), which is not supposed to change after loading, but+    tests require to cover all cases\/branches and achieving this in the+    scope of a single cabal test-suit leads to inconsistencies.+    +    Spreading tests among multiple test suits cause code duplication and+    looks less elegant.+    +    Compilation of conflicting modules can be serialized with+    <https://hackage.haskell.org/package/th-lock/docs/Language-Haskell-TH-Lock.html#v:ensureSerialCompilationVerbose ensureSerialCompilationVerbose>.+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module ModuleA where+    >+    > import Language.Haskell.TH.Lock+    >+    > ensureSerialCompilationVerbose+    +    ________________________________________________________________________+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module ModuleB where+    >+    > import Language.Haskell.TH.Lock+    >+    > ensureSerialCompilationVerbose++tested-with:+  GHC == 9.10.1+extra-doc-files:+  changelog.md+library+  build-depends:+    base < 5,+    template-haskell < 2.24.0.0,++  exposed-modules:+    Language.Haskell.TH.Lock++  ghc-options: -Wall+  hs-source-dirs: src+  default-language: Haskell2010+  default-extensions:+    FlexibleContexts+    FlexibleInstances+    ImportQualifiedPost+    LambdaCase+    TemplateHaskell++test-suite test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+    Discovery+    Paths_th_lock+    Tests.Language.Haskell.TH.Lock.State+    Tests.Language.Haskell.TH.Lock.ModuleA+    Tests.Language.Haskell.TH.Lock.ModuleB+    Tests.Language.Haskell.TH.Lock.ModuleC+    Tests.Language.Haskell.TH.Lock.ModuleD+    Tests.Language.Haskell.TH.Lock.ModuleE+    Tests.Language.Haskell.TH.Lock.ModuleF+    Tests.Language.Haskell.TH.Lock.ModuleG+    Tests.Language.Haskell.TH.Lock.ModuleH+    Tests.Language.Haskell.TH.Lock.ModuleI+    Tests.Language.Haskell.TH.Lock.ModuleJ+    Tests.Language.Haskell.TH.Lock.ModuleX+    Tests.Language.Haskell.TH.Lock.ModuleY+    Tests.Language.Haskell.TH.Lock.ModuleZ+  autogen-modules:+    Paths_th_lock+  hs-source-dirs:+    test+  default-extensions:+    FlexibleContexts+    ImportQualifiedPost+    LambdaCase+    OverloadedLabels+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+  ghc-options: -Wall -rtsopts -threaded -main-is Driver+  build-depends:+      base+    , tasty+    , tasty-discover+    , tasty-hunit+    , tasty-quickcheck+    , template-haskell+    , th-lock+  default-language: Haskell2010++source-repository head+  type:     git+  location: https://github.com/yaitskov/th-lock.git