diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,10 @@ Changelog for Shake (* = breaking change) +0.9.8, released 2024, 2024-01-14 + Test with GHC 9.8 + #844, optimise database reading/writing with use unsafeUseAsCString + #836, add threaded flag to disable using threaded runtime + #837, require filepath-1.14 0.9.7, released 2022-09-15 #815, improve corrupt database handling code Don't say (changed) for files that don't build diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2011-2022. +Copyright Neil Mitchell 2011-2024. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/shake/ci/master.svg)](https://github.com/ndmitchell/shake/actions) +# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Build status](https://img.shields.io/github/actions/workflow/status/ndmitchell/shake/ci.yml?branch=master)](https://github.com/ndmitchell/shake/actions) Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com). diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 build-type: Simple name: shake -version: 0.19.7 +version: 0.19.8 license: BSD3 license-file: LICENSE category: Development, Shake author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2011-2022 +copyright: Neil Mitchell 2011-2024 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a @@ -30,7 +30,7 @@ (e.g. compiler version). homepage: https://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues -tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6 +tested-with: GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8 extra-doc-files: CHANGES.txt README.md @@ -81,6 +81,11 @@ manual: True description: Embed data files into the shake library +flag threaded + default: True + manual: True + description: Build shake with the threaded RTS + library default-language: Haskell2010 hs-source-dirs: src @@ -91,7 +96,7 @@ deepseq >= 1.1, directory >= 1.2.7.0, extra >= 1.6.19, - filepath, + filepath >= 1.4, filepattern, hashable >= 1.1.2.3, heaps >= 0.3.6.1, @@ -205,7 +210,9 @@ executable shake default-language: Haskell2010 hs-source-dirs: src - ghc-options: -main-is Run.main -rtsopts -threaded "-with-rtsopts=-I0 -qg" + ghc-options: -main-is Run.main -rtsopts + if flag(threaded) + ghc-options: -threaded "-with-rtsopts=-I0 -qg" main-is: Run.hs build-depends: base == 4.*, @@ -328,7 +335,9 @@ type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: src - ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K -threaded + ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K + if flag(threaded) + ghc-options: -threaded build-depends: base == 4.*, diff --git a/src/Development/Ninja/All.hs b/src/Development/Ninja/All.hs --- a/src/Development/Ninja/All.hs +++ b/src/Development/Ninja/All.hs @@ -22,7 +22,7 @@ import System.Info.Extra -- Internal imports -import General.Extra(removeFile_) +import General.Extra(removeFile_, headErr) import General.Timing(addTiming) import General.Makefile(parseMakefile) import Development.Shake.Internal.FileName(filepathNormalise, fileNameFromString) @@ -83,7 +83,7 @@ else Map.keys singles ++ Map.keys multiples (\x -> map BS.unpack . fst <$> Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in - build needDeps phonys rules pools out2 $ snd $ multiples Map.! head out2 + build needDeps phonys rules pools out2 $ snd $ multiples Map.! headErr out2 (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in build needDeps phonys rules pools [out2] $ singles Map.! out2 diff --git a/src/Development/Ninja/Parse.hs b/src/Development/Ninja/Parse.hs --- a/src/Development/Ninja/Parse.hs +++ b/src/Development/Ninja/Parse.hs @@ -7,6 +7,7 @@ import Development.Ninja.Type import Development.Ninja.Lexer import Control.Monad +import General.Extra parse :: FilePath -> Env Str Str -> IO Ninja @@ -37,7 +38,7 @@ let build = Build rule env normal implicit orderOnly binds pure $ if rule == BS.pack "phony" then ninja{phonys = [(x, normal ++ implicit ++ orderOnly) | x <- outputs] ++ phonys} - else if length outputs == 1 then ninja{singles = (head outputs, build) : singles} + else if length outputs == 1 then ninja{singles = (headErr outputs, build) : singles} else ninja{multiples = (outputs, build) : multiples} LexRule name -> pure ninja{rules = (name, Rule binds) : rules} diff --git a/src/Development/Shake.hs b/src/Development/Shake.hs --- a/src/Development/Shake.hs +++ b/src/Development/Shake.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, ConstraintKinds, PatternSynonyms #-} +{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds, PatternSynonyms #-} -- | This module is used for defining Shake build systems. As a simple example of a Shake build system, -- let us build the file @result.tar@ from the files listed by @result.txt@: diff --git a/src/Development/Shake/Command.hs b/src/Development/Shake/Command.hs --- a/src/Development/Shake/Command.hs +++ b/src/Development/Shake/Command.hs @@ -295,7 +295,7 @@ let cwd = listToMaybe $ reverse [x | Cwd x <- opts] putVerbose $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ - last (showCommandForUser2 prog args : [x | UserCommand x <- opts]) + lastDef (showCommandForUser2 prog args) [x | UserCommand x <- opts] verb <- getVerbosity -- run quietly to suppress the tracer (don't want to print twice) (if verb >= Verbose then quietly else id) act diff --git a/src/Development/Shake/FilePath.hs b/src/Development/Shake/FilePath.hs --- a/src/Development/Shake/FilePath.hs +++ b/src/Development/Shake/FilePath.hs @@ -15,6 +15,7 @@ import System.Directory (canonicalizePath) import System.Info.Extra import Data.List.Extra +import Data.Maybe import qualified System.FilePath as Native import System.FilePath hiding @@ -128,8 +129,8 @@ (True,False) -> "/." (False,True) -> "./" (False,False) -> "." - | otherwise = (if pre then id else tail) $ (if pos then id else init) x - where pre = sep $ head $ o ++ " " + | otherwise = (if pre then id else drop1) $ (if pos then id else init) x + where pre = sep $ fromMaybe ' ' $ listToMaybe o pos = sep $ last $ " " ++ o g i [] = replicate i ".." diff --git a/src/Development/Shake/Internal/Args.hs b/src/Development/Shake/Internal/Args.hs --- a/src/Development/Shake/Internal/Args.hs +++ b/src/Development/Shake/Internal/Args.hs @@ -401,8 +401,8 @@ _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument" progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of - Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id) - Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id) + Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tailErr file], id) + Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tailErr file], id) _ -> ([],) <$> func x progress _ = throwImpure $ errorInternal "incomplete pattern, progress" diff --git a/src/Development/Shake/Internal/Core/Action.hs b/src/Development/Shake/Internal/Core/Action.hs --- a/src/Development/Shake/Internal/Core/Action.hs +++ b/src/Development/Shake/Internal/Core/Action.hs @@ -583,7 +583,7 @@ res <- Action $ tryRAW $ do -- make sure we are using one of the local's that we are computing -- we things like stack, blockApply etc. work as expected - modifyRW $ const $ localClearMutable $ snd3 $ head now + modifyRW $ const $ localClearMutable $ snd3 $ headErr now start <- liftIO offsetTime fromAction $ many $ map fst3 now end <- liftIO start diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs --- a/src/Development/Shake/Internal/Core/Build.hs +++ b/src/Development/Shake/Internal/Core/Build.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables, NamedFieldPuns, GADTs #-} -{-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-} +{-# LANGUAGE Rank2Types, ConstraintKinds, TypeOperators, TupleSections, ViewPatterns #-} module Development.Shake.Internal.Core.Build( getDatabaseValue, getDatabaseValueGeneric, @@ -244,7 +244,7 @@ -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible, -- use 'apply' to allow parallelism. apply1 :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value -apply1 = withFrozenCallStack $ fmap head . apply . pure +apply1 = withFrozenCallStack $ fmap headErr . apply . pure diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs --- a/src/Development/Shake/Internal/Core/Rules.hs +++ b/src/Development/Shake/Internal/Core/Rules.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, NamedFieldPuns #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-} -{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies, TypeOperators, DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} module Development.Shake.Internal.Core.Rules( diff --git a/src/Development/Shake/Internal/Core/Storage.hs b/src/Development/Shake/Internal/Core/Storage.hs --- a/src/Development/Shake/Internal/Core/Storage.hs +++ b/src/Development/Shake/Internal/Core/Storage.hs @@ -49,8 +49,8 @@ -- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8 -- * Duration and Time should be stored as number of 1/10000th seconds Int32 databaseVersion x = "SHAKE-DATABASE-14-" ++ os ++ "-" ++ arch ++ "-" ++ s ++ "\r\n" - where s = tail $ init $ show x -- call show, then take off the leading/trailing quotes - -- ensures we do not get \r or \n in the user portion + where s = tailErr $ init $ show x -- call show, then take off the leading/trailing quotes + -- ensures we do not get \r or \n in the user portion messageCorrupt :: FilePath -> SomeException -> IO [String] diff --git a/src/Development/Shake/Internal/Demo.hs b/src/Development/Shake/Internal/Demo.hs --- a/src/Development/Shake/Internal/Demo.hs +++ b/src/Development/Shake/Internal/Demo.hs @@ -41,7 +41,7 @@ dir <- if empty then getCurrentDirectory else do home <- getHomeDirectory dir <- getDirectoryContents home - pure $ home head (map ("shake-demo" ++) ("":map show [2..]) \\ dir) + pure $ home headErr (map ("shake-demo" ++) ("":map show [2..]) \\ dir) putStrLn "% The Shake demo uses an empty directory, OK to use:" putStrLn $ "% " ++ dir diff --git a/src/Development/Shake/Internal/Rules/Directory.hs b/src/Development/Shake/Internal/Rules/Directory.hs --- a/src/Development/Shake/Internal/Rules/Directory.hs +++ b/src/Development/Shake/Internal/Rules/Directory.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds #-} -- | Both System.Directory and System.Environment wrappers module Development.Shake.Internal.Rules.Directory( diff --git a/src/Development/Shake/Internal/Rules/Files.hs b/src/Development/Shake/Internal/Rules/Files.hs --- a/src/Development/Shake/Internal/Rules/Files.hs +++ b/src/Development/Shake/Internal/Rules/Files.hs @@ -165,7 +165,7 @@ ps &%> act | not $ compatible ps = error $ unlines $ "All patterns to &%> must have the same number and position of ** and * wildcards" : - ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps] + ["* " ++ p ++ (if compatible [p, headErr ps] then "" else " (incompatible)") | p <- ps] | otherwise = withFrozenCallStack $ do forM_ (zipFrom 0 ps) $ \(i,p) -> (if simple p then id else priority 0.5) $ diff --git a/src/Development/Shake/Internal/Rules/Oracle.hs b/src/Development/Shake/Internal/Rules/Oracle.hs --- a/src/Development/Shake/Internal/Rules/Oracle.hs +++ b/src/Development/Shake/Internal/Rules/Oracle.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds #-} module Development.Shake.Internal.Rules.Oracle( addOracle, addOracleCache, addOracleHash, diff --git a/src/General/Binary.hs b/src/General/Binary.hs --- a/src/General/Binary.hs +++ b/src/General/Binary.hs @@ -14,6 +14,7 @@ import Data.Binary import Data.List.Extra import Data.Tuple.Extra +import Foreign.Marshal.Utils import Foreign.Storable import Foreign.Ptr import System.IO.Unsafe as U @@ -91,7 +92,7 @@ getEx :: BS.ByteString -> a instance BinaryEx BS.ByteString where - putEx x = Builder n $ \ptr i -> BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) + putEx x = Builder n $ \ptr i -> BS.unsafeUseAsCString x $ \bs -> copyBytes (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) where n = BS.length x getEx = id @@ -100,7 +101,7 @@ let go _ [] = pure () go i (x:xs) = do let n = BS.length x - BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) + BS.unsafeUseAsCString x $ \bs -> copyBytes (ptr `plusPtr` i) (castPtr bs) (fromIntegral n) go (i+n) xs go i $ LBS.toChunks x getEx = LBS.fromChunks . pure @@ -114,12 +115,12 @@ pokeByteOff p i (fromIntegral n :: Word32) for2M_ [4+i,8+i..] ns $ \i x -> pokeByteOff p i (fromIntegral x :: Word32) p<- pure $ p `plusPtr` (i + 4 + (n * 4)) - for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.useAsCStringLen x $ \(bs, n) -> - BS.memcpy (p `plusPtr` i) (castPtr bs) (fromIntegral n) + for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.unsafeUseAsCStringLen x $ \(bs, n) -> + copyBytes (p `plusPtr` i) (castPtr bs) (fromIntegral n) where ns = map BS.length xs n = length ns - getEx bs = unsafePerformIO $ BS.useAsCString bs $ \p -> do + getEx bs = unsafePerformIO $ BS.unsafeUseAsCString bs $ \p -> do n <- fromIntegral <$> (peekByteOff p 0 :: IO Word32) ns :: [Word32] <- forM [1..fromIntegral n] $ \i -> peekByteOff p (i * 4) pure $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns @@ -175,7 +176,7 @@ putExStorable x = Builder (sizeOf x) $ \p i -> pokeByteOff p i x getExStorable :: forall a . Storable a => BS.ByteString -> a -getExStorable = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) -> +getExStorable = \bs -> unsafePerformIO $ BS.unsafeUseAsCStringLen bs $ \(p, size) -> if size /= n then error "size mismatch" else peek (castPtr p) where n = sizeOf (undefined :: a) @@ -186,7 +187,7 @@ where n = sizeOf (undefined :: a) getExStorableList :: forall a . Storable a => BS.ByteString -> [a] -getExStorableList = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) -> +getExStorableList = \bs -> unsafePerformIO $ BS.unsafeUseAsCStringLen bs $ \(p, size) -> let (d,m) = size `divMod` n in if m /= 0 then error "size mismatch" else forM [0..d-1] $ \i -> peekElemOff (castPtr p) i where n = sizeOf (undefined :: a) diff --git a/src/General/Extra.hs b/src/General/Extra.hs --- a/src/General/Extra.hs +++ b/src/General/Extra.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, ConstraintKinds, GeneralizedNewtypeDeriving, ViewPatterns #-} +{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-} module General.Extra( getProcessorCount, @@ -10,6 +11,7 @@ maximum', maximumBy', unconcat, fastAt, + headErr, tailErr, zipExact, zipWithExact, isAsyncException, showDurationSecs, @@ -69,6 +71,12 @@ unconcat [] _ = [] unconcat (a:as) bs = b1 : unconcat as b2 where (b1,b2) = splitAt (length a) bs + +headErr :: [a] -> a +headErr = head + +tailErr :: [a] -> [a] +tailErr = tail --------------------------------------------------------------------- diff --git a/src/Test/Existence.hs b/src/Test/Existence.hs --- a/src/Test/Existence.hs +++ b/src/Test/Existence.hs @@ -1,16 +1,17 @@ module Test.Existence(main) where -import Development.Shake (getDirectoryFilesIO) -import Development.Shake.Internal.FileInfo (getFileInfo) -import Development.Shake.Internal.FileName (fileNameFromString) -import System.Directory (getCurrentDirectory) -import System.FilePath (()) +import Development.Shake +import Development.Shake.Internal.FileInfo +import Development.Shake.Internal.FileName +import System.Directory +import System.FilePath +import General.Extra main :: IO () -> IO () main _ = do cwd <- getCurrentDirectory someFiles <- getDirectoryFilesIO cwd ["*"] - let someFile = head someFiles + let someFile = headErr someFiles assertIsJust $ getFileInfo False $ fileNameFromString someFile let fileThatCantExist = someFile "fileThatCantExist" diff --git a/src/Test/FilePath.hs b/src/Test/FilePath.hs --- a/src/Test/FilePath.hs +++ b/src/Test/FilePath.hs @@ -13,6 +13,7 @@ import System.Info.Extra import System.Directory import qualified System.IO.Extra as IO +import General.Extra newtype File = File String deriving Show @@ -68,7 +69,7 @@ sep = Native.isPathSeparator noDrive = if isWindows then drop1 else id ps = [y /= "" - ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y)) + ,null x || (sep (headErr x) == sep (headErr y) && sep (last x) == sep (last y)) ,not $ "/./" `isInfixOf` y ,not isWindows || '\\' `notElem` y ,not $ "//" `isInfixOf` noDrive y diff --git a/src/Test/History.hs b/src/Test/History.hs --- a/src/Test/History.hs +++ b/src/Test/History.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.History(main) where diff --git a/src/Test/Oracle.hs b/src/Test/Oracle.hs --- a/src/Test/Oracle.hs +++ b/src/Test/Oracle.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds, ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, TypeOperators, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Oracle(main) where @@ -12,6 +13,7 @@ import Test.Type hiding (RandomType) import qualified Test.Type as T import Control.Monad +import General.Extra -- These are instances we'll compute over @@ -32,7 +34,7 @@ type instance RuleResult T.RandomType = Int data Define = Define String String -- this type produces this result -opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tail . breakOn "=") "type=value") ""] +opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tailErr . breakOn "=") "type=value") ""] main = testBuildArgs test opt $ \args -> do addOracle $ \(T.RandomType _) -> pure 42 diff --git a/src/Test/Progress.hs b/src/Test/Progress.hs --- a/src/Test/Progress.hs +++ b/src/Test/Progress.hs @@ -5,6 +5,7 @@ import Test.Type import System.Directory.Extra import System.FilePath +import General.Extra main = testBuild test $ pure () @@ -17,8 +18,8 @@ progEx :: Double -> [Double] -> IO [Double] progEx mxDone todo = do let resolution = 10000 -- Use resolution to get extra detail on the numbers - let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo) - let res = progressReplay $ zip (map (*resolution) [1..]) $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done + let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tailErr todo) + let res = progressReplay $ zip (map (*resolution) [1..]) $ tailErr $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done pure $ (0/0) : map ((/ resolution) . actualSecs) res @@ -40,7 +41,7 @@ -- the first value must be plausible, or missing xs <- prog [187] - assertBool (isNaN $ head xs) "No first value" + assertBool (isNaN $ headErr xs) "No first value" -- desirable properties, could be weakened xs <- progEx 2 $ 100:map (*2) [10,9..1] diff --git a/src/Test/Random.hs b/src/Test/Random.hs --- a/src/Test/Random.hs +++ b/src/Test/Random.hs @@ -106,7 +106,7 @@ build $ ("-j" ++ show j) : map ((++) "--arg=" . show) (xs ++ map Want wants) let value i = - let ys = head [ys | Logic j ys <- xs, j == i] + let ys = headErr [ys | Logic j ys <- xs, j == i] in Multiple $ flip map ys $ map $ \case Input i -> Single $ if i `elem` negated then negate i else i Output i -> value i diff --git a/src/Test/Self.hs b/src/Test/Self.hs --- a/src/Test/Self.hs +++ b/src/Test/Self.hs @@ -19,8 +19,8 @@ type instance RuleResult GhcPkg = [String] type instance RuleResult GhcFlags = [String] --- Doesn't work on the Windows CI for reasons I don't understand -main = testBuild (notWindowsCI . defaultTest) $ do +-- Doesn't work on CI, seems self-building under `cabal test` is just hard +main = testBuild (notCI . defaultTest) $ do let moduleToFile ext xs = replace "." "/" xs <.> ext want ["Main" <.> exe] diff --git a/src/Test/SelfMake.hs b/src/Test/SelfMake.hs --- a/src/Test/SelfMake.hs +++ b/src/Test/SelfMake.hs @@ -18,7 +18,8 @@ type instance RuleResult GhcPkg = [String] type instance RuleResult GhcFlags = [String] -main = testBuild (notWindowsCI . defaultTest) $ do +-- Doesn't work on CI, seems self-building under `cabal test` is just hard +main = testBuild (notCI . defaultTest) $ do want ["Main" <.> exe] ghcPkg <- addOracleHash $ \GhcPkg{} -> do @@ -45,7 +46,7 @@ trackAllow ["**/*.o","**/*.hi","Makefile"] ghc $ ["-M",run] ++ flags - need . filter (\x -> takeExtension x == ".hs") . concatMap snd . parseMakefile =<< liftIO (readFile "Makefile") + need . concatMap (filter (\x -> takeExtension x == ".hs") . snd) . parseMakefile =<< liftIO (readFile "Makefile") ghc $ ["-o",out,run,"-j4"] ++ flags ".pkgs" %> \out -> do