commit 7dfc1692c01d5ff80c4c4bc86e164c63172dd656 · pyrox.dev/nixpkgs

+22 -8
pkgs/development/julia-modules/tests/julia-top-n/app/Main.hs
···

       12
       12
        
       

     

       13
       13
        
       module Main (main) where

     

       14
       14
        
       

     

       15
       15
       -
       import Control.Exception

     

       16
       15
        
       import Control.Monad

     

       16
       16
       +
       import Control.Monad.IO.Class

     

       17
       17
        
       import Data.Aeson as A hiding (Options, defaultOptions)

     

       18
       18
        
       import qualified Data.Aeson.Key             as A

     

       19
       19
        
       import qualified Data.Aeson.KeyMap          as HM

     
···

       24
       24
        
       import qualified Data.Vector as V

     

       25
       25
        
       import qualified Data.Yaml as Yaml

     

       26
       26
        
       import GHC.Generics

     

       27
       27
       -
       import Options.Applicative

     

       27
       27
       +
       import Options.Applicative hiding (info)

     

       28
       28
        
       import System.Exit

     

       29
       29
        
       import System.FilePath

     

       30
       30
       -
       import Test.Sandwich hiding (info)

     

       30
       30
       +
       import Test.Sandwich

     

       31
       31
       +
       import UnliftIO.Exception

     

       31
       32
        
       import UnliftIO.MVar

     

       32
       33
        
       import UnliftIO.Process

     

       34
       34
       +
       import UnliftIO.QSem

     

       33
       35
        
       

     

       34
       36
        
       

     

       35
       37
        
       data Args = Args {

     
···

       67
       69
        
           Left err -> throwIO $ userError ("Couldn't decode names and counts YAML file: " <> show err)

     

       68
       70
        
           Right x -> pure x

     

       69
       71
        
       

     

       70
       70
       -
         runSandwichWithCommandLineArgs' defaultOptions argsParser $ do

     

       72
       72
       +
         runSandwichWithCommandLineArgs' defaultOptions argsParser $ parallel $ do

     

       71
       73
        
           miscTests args

     

       72
       74
        
       

     

       73
       75
        
           describe ("Building environments for top " <> show topN <> " Julia packages") $

     

       74
       74
       -
             parallelN parallelism $

     

       75
       75
       -
               forM_ (L.take topN namesAndCounts) $ \(NameAndCount {..}) ->

     

       76
       76
       -
                 testExpr args name [i|#{juliaAttr}.withPackages ["#{name}"]|]

     

       76
       76
       +
             introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem parallelism) (const $ return ()) $

     

       77
       77
       +
             parallel $

     

       78
       78
       +
             forM_ (L.take topN namesAndCounts) $ \(NameAndCount {..}) ->

     

       79
       79
       +
             around "Claim semaphore" claimRunSlot $

     

       80
       80
       +
             testExpr args name [i|#{juliaAttr}.withPackages ["#{name}"]|]

     

       77
       81
        
       

     

       78
       82
        
       miscTests :: Args -> SpecFree ctx IO ()

     

       79
       83
        
       miscTests args@(Args {..}) = describe "Misc tests" $ do

     
···

       89
       93
        
                                             };

     

       90
       94
        
                                           }) [ "HelloWorld" ]|]

     

       91
       95
        
       

     

       96
       96
       +
         describe "misc cases" $ do

     

       97
       97
       +
           testExpr args "Optimization" [iii|(#{juliaAttr}.withPackages) [ "Optimization" "OptimizationOptimJL" ]|]

     

       98
       98
       +
       

     

       92
       99
        
       -- * Low-level

     

       93
       100
        
       

     

       94
       101
        
       testExpr :: Args -> Text -> String -> SpecFree ctx IO ()

     
···

       98
       105
        
             let cp = proc "nix" ["build", "--impure", "--no-link", "--json", "--expr", [i|with import ../../../../. {}; #{expr}|]]

     

       99
       106
        
             output <- readCreateProcessWithLogging cp ""

     

       100
       107
        
             juliaPath <- case A.eitherDecode (BL8.pack output) of

     

       101
       101
       -
               Right (A.Array ((V.!? 0) -> Just (A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String t))))))) -> pure (JuliaPath ((T.unpack t) </> "bin" </> "julia"))

     

       108
       108
       +
               Right (A.Array ((V.!? 0) -> Just (A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String t))))))) -> do

     

       109
       109
       +
                 info [i|built: #{t}|]

     

       110
       110
       +
                 pure (JuliaPath ((T.unpack t) </> "bin" </> "julia"))

     

       102
       111
        
               x -> expectationFailure ("Couldn't parse output: " <> show x)

     

       103
       112
        
       

     

       104
       113
        
             getContext julia >>= flip modifyMVar_ (const $ return (Just juliaPath))

     
···

       113
       122
        
         where

     

       114
       123
        
           aesonLookup :: Text -> HM.KeyMap v -> Maybe v

     

       115
       124
        
           aesonLookup = HM.lookup . A.fromText

     

       125
       125
       +
       

     

       126
       126
       +
       claimRunSlot :: (HasParallelSemaphore ctx) => ExampleT ctx IO a -> ExampleT ctx IO ()

     

       127
       127
       +
       claimRunSlot f = do

     

       128
       128
       +
         s <- getContext parallelSemaphore

     

       129
       129
       +
         bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f)