├── .ghci ├── .gitignore ├── .travis.yml ├── CHANGES.txt ├── LICENSE ├── README.md ├── Setup.hs ├── ghc-make.cabal ├── src ├── Arguments.hs ├── Main.hs ├── Makefile.hs └── Test.hs ├── tests ├── complex │ ├── HsBoot.hs │ ├── HsBoot.hs-boot │ ├── HsRec.hs │ ├── Include.h │ ├── Include.hs │ ├── Lhs.lhs │ ├── LhsBoot.lhs │ ├── LhsBoot.lhs-boot │ ├── LhsRec.lhs │ ├── Root.hs │ └── children │ │ ├── BootChild.hs │ │ └── IncludeChild.hs └── simple │ ├── A.hs │ ├── B.hs │ ├── C │ └── C.hs │ └── Main.hs └── travis.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -fno-warn-overlapping-patterns 3 | :set -fwarn-unused-binds -fwarn-unused-imports 4 | :load Test 5 | 6 | :def test \x -> return $ ":main " ++ x 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | .ghc-make.* 3 | .shake.* 4 | *.hi 5 | *.o 6 | *.hi-boot 7 | *.o-boot 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | env: 3 | - GHCVER=7.4.2 4 | - GHCVER=7.6.3 5 | - GHCVER=7.8.4 6 | - GHCVER=7.10.3 7 | - GHCVER=8.0.2 8 | - GHCVER=8.2.1 9 | - GHCVER=head 10 | 11 | script: 12 | - export HLINT_ARGUMENTS=src 13 | - curl -sL https://raw.github.com/ndmitchell/neil/master/travis.sh | sh 14 | -------------------------------------------------------------------------------- /CHANGES.txt: -------------------------------------------------------------------------------- 1 | Changelog for ghc-make 2 | 3 | 0.3.3 4 | Shake 0.16 compatibility 5 | 0.3.2 6 | Shake 0.15 compatibility 7 | 0.3.1 8 | GHC 7.10 compatibility 9 | 0.3 10 | GHC 7.8 compatibility, following -M output changes (GHC #9287) 11 | Fix a bug on Windows with shake-0.14 and filepath separators 12 | 0.2.1 13 | Support GHC-7.8, which requires -dep-suffix 14 | #3, support -no-link flag 15 | 0.2 16 | Support the -hidir flag in conjunction with -j 17 | Support the -o flag in conjunction with -j 18 | Override --help 19 | #2, detect package upgrades and recompile 20 | Add parallelism 21 | Upgrade to shake-0.13 22 | Add test suite 23 | Support other GHC modes such as --version 24 | 0.1 25 | Initial version 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2013-2017. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Neil Mitchell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ghc-make [![Hackage version](https://img.shields.io/hackage/v/ghc-make.svg?label=Hackage)](https://hackage.haskell.org/package/ghc-make) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/ghc-make.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/ghc-make) 2 | 3 | --- 4 | 5 | **WARNING:** This code is mostly unmaintained and probably won't work with recent versions of GHC. 6 | 7 | --- 8 | 9 | An alternative to `ghc --make` which supports parallel compilation of modules and runs faster when nothing needs compiling. 10 | 11 | #### How do I use it? 12 | 13 | Install `ghc-make` (`cabal update && cabal install ghc-make`). Then replace your calls to `ghc my -arguments` with `ghc-make my -arguments`. Almost all arguments and flags supported by `ghc` are supported by `ghc-make` - it is intended as a drop-in replacement. 14 | 15 | #### What should I see? 16 | 17 | Imagine you have a script that runs `ghc --make MyCode && ./MyCode` and that running `ghc --make` when nothing needs compiling takes 5 seconds (I have projects that take as long as 23 seconds). If you switch to `ghc-make MyCode && ./MyCode` then when nothing needs compiling it will take almost no time (less than 0.2 seconds). If things need compiling it will take the compilation time plus the time with `ghc --make` when nothing needs compiling (in this example, 5 seconds extra). If the source changes on less than half the executions you will see a speedup. 18 | 19 | The `ghc-make` program produces a handful of metadata files which are stored with the `.ghc-make` prefix. These files will be placed in the current directory, or the `-hidir`/`-odir` directory if specified. 20 | 21 | #### How do I turn on parallel module compilation? 22 | 23 | Pass `-j4` to build using 4 cores. In my experience you usually need a parallel factor of 3x to match `ghc --make` on a single core, since `ghc --make` does a lot of caching that is unavailable to `ghc-make`. 24 | 25 | To use `ghc-make` with Cabal, try `cabal build --with-ghc=ghc-make --ghc-options=-j4`. (This technique is due to the [`ghc-parmake`](https://github.com/23Skidoo/ghc-parmake) project, which also does parallel `ghc --make` compiles.) 26 | 27 | #### What GHC features are unsupported? 28 | 29 | Anything not captured by `ghc -M` will not be tracked, including dependencies registered by Template Haskell and `#include` files. 30 | 31 | #### Why is it faster? 32 | 33 | When GHC does a compilation check it runs any preprocessors and parses the Haskell files, which can be slow. When `ghc-make` does a compilation check it reads a list of file names and modification times from a database and checks the times still match, and if they do, it does nothing. 34 | 35 | #### Why is it slower? 36 | 37 | When things have changed `ghc-make` also runs `ghc-pkg list` and `ghc -M` to get a list of dependencies. To produce that list, GHC has to run any preprocessors and parse the Haskell files. If GHC was able to produce the dependencies while building (as `gcc` is able to do) then `ghc-make` would never be noticeably slower. 38 | 39 | #### How is it implemented? 40 | 41 | This program uses the [Shake library](https://github.com/ndmitchell/shake#readme) for dependency tracking and `ghc --make` for building. 42 | 43 | To pass options to the underlying Shake build system prefix them with `--shake`, for example `--shake--report=-` will write a profile report to stdout and `--shake--help` will list the available Shake options. 44 | 45 | #### Should GHC just use Shake directly? 46 | 47 | Should _large and important project_ use _authors pet library_? Yes, of course :smiley:. If `ghc --make` used Shake it is likely their builds with no recompilation would be just as fast as `ghc-make`, and they could take advantage of parallel compilation with no additional overhead. However, integrating Shake into such a large code base would be a lot of work - perhaps you should offer to help the GHC team? 48 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ghc-make.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.18 2 | build-type: Simple 3 | name: ghc-make 4 | version: 0.3.3 5 | license: BSD3 6 | license-file: LICENSE 7 | category: Development 8 | author: Neil Mitchell 9 | maintainer: Neil Mitchell 10 | copyright: Neil Mitchell 2013-2017 11 | synopsis: Accelerated version of ghc --make 12 | description: 13 | The @ghc-make@ program can be used as a drop-in replacement for @ghc@. This program 14 | targets two use cases: 15 | . 16 | * If a flag such as @-j4@ is passed, the modules will be compiled in parallel. 17 | If the available parallelism is greater than a factor of 3, the build will probably run faster. 18 | . 19 | * If there is no work to do (i.e. the compiled files are up-to-date), the build will run faster, 20 | sometimes significantly so. 21 | . 22 | See the readme for full details: . 23 | homepage: https://github.com/ndmitchell/ghc-make#readme 24 | bug-reports: https://github.com/ndmitchell/ghc-make/issues 25 | extra-doc-files: 26 | README.md 27 | CHANGES.txt 28 | tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/ndmitchell/ghc-make.git 33 | 34 | executable ghc-make 35 | main-is: Main.hs 36 | default-language: Haskell2010 37 | ghc-options: -threaded 38 | hs-source-dirs: src 39 | build-depends: 40 | base == 4.*, 41 | shake >= 0.16, 42 | unordered-containers >= 0.2.1, 43 | process >= 1.0 44 | other-modules: 45 | Arguments 46 | Makefile 47 | -------------------------------------------------------------------------------- /src/Arguments.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, RecordWildCards #-} 2 | 3 | module Arguments(Arguments(..), getArguments) where 4 | 5 | import Control.Monad 6 | import Data.Char 7 | import Data.Either 8 | import Data.List 9 | import Data.Maybe 10 | import System.Environment 11 | import System.Exit 12 | import Development.Shake.FilePath 13 | import Makefile 14 | 15 | 16 | data Arguments = Arguments 17 | {argsGHC :: [String] -- ^ Arguments to pass to ghc, does not include --make 18 | ,argsShake :: [String] -- ^ Arguments to pass to shake 19 | ,threads :: Int -- ^ Number of threads to use 20 | -- Interpretation of the flags 21 | ,modeGHC :: Bool -- ^ Are these flags which should go direct to GHC, not a --make/-M mode 22 | ,prefix :: FilePath -- ^ Where make should put its files, e.g. .ghc-make 23 | -- Where should things live 24 | ,outputFile :: FilePath -> FilePath -- ^ Root source file, .exe file 25 | ,hiDir :: FilePath -- ^ -hidir 26 | ,oDir :: FilePath -- ^ -odir 27 | ,hiFile :: Module -> FilePath -- ^ .hi files 28 | ,oFile :: Module -> FilePath -- ^ .o files 29 | ,hiModule :: FilePath -> Maybe Module 30 | ,oModule :: FilePath -> Maybe Module 31 | } 32 | 33 | helpMessage = 34 | ["ghc-make, (C) Neil Mitchell" 35 | ,"" 36 | ," ghc-make [ghc-options] --shake[shake-options] [-jN]" 37 | ,"" 38 | ,"ghc-make is a drop-in replacement for 'ghc', and accepts GHC arugments." 39 | ,"For GHC arguments, see 'ghc --help' or ." 40 | ,"" 41 | ,"ghc-make uses 'shake', and accepts Shake arguments prefixed by '--shake'." 42 | ,"For Shake arguments, see 'ghc-make --shake--help'." 43 | ,"As an example, to write a profile report to stdout pass '--shake--report=-'." 44 | ,"" 45 | ,"In addition, 'ghc-make' accepts the following option:" 46 | ,"" 47 | ," -jN --threads=N Allow N modules to compile in parallel (defaults to 1)." 48 | ] 49 | 50 | 51 | getArguments :: IO Arguments 52 | getArguments = do 53 | args <- getArgs 54 | when (any (`elem` helpFlags) args) $ do 55 | putStrLn $ unlines helpMessage 56 | exitSuccess 57 | 58 | let (argsThreads, argsRest) = partition (isJust . parseThreads) args 59 | let threads = max 1 $ fromMaybe 1 $ msum $ map parseThreads argsThreads 60 | let (argsShake, argsGHC) = splitFlags $ delete "--make" argsRest 61 | let hasArg x = x `elem` argsGHC 62 | let getArg b x = findArg b x argsGHC 63 | 64 | let modeGHC = any hasArg $ "--version" : "--numeric-version" : flagsConflictingWithM 65 | let prefix = fromMaybe "" (getArg True ["-outputdir","-odir"] `mplus` getArg True ["-outputdir","-hidir"]) ".ghc-make" 66 | let outputFile file = let s = fromMaybe (dropExtension file) (getArg False ["-o"]) 67 | in if null $ takeExtension s then s <.> exe else s 68 | 69 | let (hiDir, hiFile, hiModule) = extFileModule getArg "hi" 70 | let ( oDir, oFile, oModule) = extFileModule getArg "o" 71 | return Arguments{..} 72 | 73 | 74 | extFileModule :: (Bool -> [String] -> Maybe String) -> String -> (FilePath, Module -> FilePath, FilePath -> Maybe Module) 75 | extFileModule getArg ext = (extDir, extFile, extModule) 76 | where 77 | extDir = fromMaybe "" $ getArg True ["-outputdir","-" ++ ext ++ "dir"] 78 | extSuf = fromMaybe ext $ getArg True ["-" ++ ext ++ "suf"] 79 | extFile (Module name boot) = extDir joinPath name <.> extSuf ++ (if boot then "-boot" else "") 80 | extModule s 81 | | "-boot" `isSuffixOf` s, Just (Module name _) <- extModule $ take (length s - 5) s = newModule name True 82 | | toStandard extDir `isPrefixOf` toStandard s && extSuf `isSuffixOf` s 83 | = newModule (splitDirectories $ dropWhile isPathSeparator $ dropExtensions $ drop (length extDir) s) False 84 | | otherwise = Nothing 85 | 86 | newModule :: [String] -> Bool -> Maybe Module 87 | newModule xs y = if all isValid xs then Just $ Module xs y else Nothing 88 | where isValid (x:xs) = isUpper x && all (\x -> isAlphaNum x || x `elem` "\'_") xs 89 | isValid [] = False 90 | 91 | 92 | parseThreads :: String -> Maybe Int 93 | parseThreads x = do 94 | x <- msum $ map (`stripPrefix` x) ["-threads","--threads","-j"] 95 | x <- return $ fromMaybe x $ stripPrefix "=" x 96 | [(i,"")] <- return $ reads x 97 | return i 98 | 99 | 100 | -- | -odir is implicit since -odirfoo works, but -o is explicit 101 | findArg :: Bool -> [String] -> [String] -> Maybe String 102 | findArg implicit flags xs 103 | | x1:x2:xs <- xs, x1 `elem` flags = add x2 $ rec xs 104 | | implicit, x:xs <- xs, Just x <- msum $ map (`stripPrefix` x) flags 105 | = add (if "=" `isPrefixOf` x then drop 1 x else x) $ rec xs 106 | | x:xs <- xs = rec xs 107 | | otherwise = Nothing 108 | where add a b = Just $ fromMaybe a b 109 | rec = findArg implicit flags 110 | 111 | 112 | helpFlags = words "-? --help" 113 | 114 | -- Obtained from the man page (listed in the same order as they appear there) 115 | -- and ghc/Main.hs, `data PostLoadMode`: 116 | flagsConflictingWithM = words $ 117 | -- "Help and verbosity options" 118 | "-? --help -V " ++ 119 | "--supported-extensions --supported-languages " ++ 120 | "--info --version --numeric-version --print-libdir " ++ 121 | -- "Which phases to run" 122 | "-E -C -S -c " ++ 123 | -- "Alternative modes of operation" 124 | "--interactive -e " ++ 125 | -- "Interface file options" 126 | "--show-iface " ++ 127 | -- Undocumented? 128 | "--abi-hash" 129 | 130 | 131 | 132 | -- | Split flags into (Shake flags, GHC flags) 133 | splitFlags :: [String] -> ([String], [String]) 134 | splitFlags = partitionEithers . map f 135 | where 136 | f x | Just x <- stripPrefix "--shake-" x = Left $ '-':x 137 | | Just x <- stripPrefix "-shake-" x = Left $ '-':x 138 | | otherwise = Right x 139 | 140 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Main(main) where 5 | 6 | import Control.Monad 7 | import Data.Either 8 | import Data.Maybe 9 | import Data.Functor 10 | import Development.Shake 11 | import Development.Shake.Classes 12 | import Development.Shake.FilePath 13 | import System.Environment 14 | import System.Exit 15 | import System.Process 16 | import qualified Data.HashMap.Strict as Map 17 | import Arguments 18 | import Makefile 19 | import Prelude 20 | 21 | 22 | -- | Increment every time I change the rules in an incompatible way 23 | ghcMakeVer :: Int 24 | ghcMakeVer = 3 25 | 26 | 27 | newtype AskImports = AskImports Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) 28 | type instance RuleResult AskImports = [Either FilePath Module] 29 | 30 | newtype AskSource = AskSource Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) 31 | type instance RuleResult AskSource = String 32 | 33 | 34 | main :: IO () 35 | main = do 36 | Arguments{..} <- getArguments 37 | 38 | when modeGHC $ 39 | exitWith =<< rawSystem "ghc" argsGHC 40 | 41 | let opts = shakeOptions 42 | {shakeThreads=threads 43 | ,shakeFiles=prefix 44 | ,shakeVerbosity=if threads == 1 then Quiet else Normal 45 | ,shakeVersion=show ghcMakeVer} 46 | withArgs argsShake $ shakeArgs opts $ do 47 | want [prefix <.> "result"] 48 | 49 | -- A file containing the GHC arguments 50 | prefix <.> "args" %> \out -> do 51 | alwaysRerun 52 | writeFileChanged out $ unlines argsGHC 53 | let needArgs = do need [prefix <.> "args"]; return argsGHC 54 | 55 | -- A file containing the ghc-pkg list output 56 | prefix <.> "pkgs" %> \out -> do 57 | alwaysRerun 58 | (Stdout s, Stderr (_ :: String)) <- cmd "ghc-pkg list --verbose" 59 | writeFileChanged out s 60 | let needPkgs = need [prefix <.> "pkgs"] 61 | 62 | -- A file containing the output of -M 63 | prefix <.> "makefile" %> \out -> do 64 | args <- needArgs 65 | needPkgs 66 | -- Use the default o/hi settings so we can parse the makefile properly 67 | () <- cmd "ghc -M -include-pkg-deps -dep-suffix=" [""] "-dep-makefile" [out] args "-odir. -hidir. -hisuf=hi -osuf=o" 68 | mk <- liftIO $ makefile out 69 | need $ Map.elems $ source mk 70 | needMk <- do cache <- newCache (\x -> do need [x]; liftIO $ makefile x); return $ cache $ prefix <.> "makefile" 71 | askImports <- addOracle $ \(AskImports x) -> do mk <- needMk; return $ Map.lookupDefault [] x $ imports mk 72 | askSource <- addOracle $ \(AskSource x) -> do mk <- needMk; return $ source mk Map.! x 73 | 74 | 75 | -- The result, we can't want the object directly since it is painful to 76 | -- define a build rule for it because its name depends on both args and makefile 77 | prefix <.> "result" %> \out -> do 78 | args <- needArgs 79 | mk <- needMk 80 | let output = if "-no-link" `elem` argsGHC then Nothing 81 | else fmap outputFile $ Map.lookup (Module ["Main"] False) $ source mk 82 | 83 | -- if you don't specify an odir/hidir then impossible to reverse from the file name to the module 84 | let exec = when (isJust output || threads == 1) $ 85 | cmd "ghc --make -odir. -hidir." args 86 | grab = need $ map oFile $ Map.keys $ source mk 87 | if threads == 1 then exec >> grab else grab >> exec 88 | 89 | case output of 90 | Nothing -> return () 91 | Just output -> do 92 | -- ensure that if the file gets deleted we rerun this rule without first trying to 93 | -- need the output, since we don't have a rule to build the output 94 | b <- doesFileExist output 95 | unless b $ 96 | error $ "Failed to build output file: " ++ output ++ "\n" ++ 97 | "Most likely ghc-make has guessed the output location wrongly." 98 | need [output] 99 | writeFile' out "" 100 | 101 | let match x = do m <- oModule x `mplus` hiModule x; return [oFile m, hiFile m] 102 | match &?> \[o,hi] -> do 103 | let Just m = oModule o 104 | source <- askSource (AskSource m) 105 | (files,mods) <- partitionEithers <$> askImports (AskImports m) 106 | need $ source : map hiFile mods ++ files 107 | when (threads /= 1) $ do 108 | args <- needArgs 109 | let isRoot x = x == "Main" || takeExtension x `elem` [".hs",".lhs"] 110 | cmd "ghc -odir. -hidir." (filter (not . isRoot) args) (if hiDir == "" then [] else ["-i" ++ hiDir]) "-o" [o] "-c" [source] 111 | -------------------------------------------------------------------------------- /src/Makefile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, DeriveDataTypeable #-} 2 | 3 | module Makefile(Makefile(..), Module(..), makefile) where 4 | 5 | import Data.List 6 | import Development.Shake.FilePath 7 | import Development.Shake.Classes 8 | import Development.Shake.Util 9 | import Data.Bits 10 | import Data.Functor 11 | import qualified Data.HashMap.Strict as Map 12 | import Prelude 13 | 14 | 15 | data Module = Module {moduleName :: [String], moduleBoot :: Bool} 16 | deriving (Typeable, Eq) 17 | 18 | instance Show Module where 19 | show (Module name boot) = intercalate "." name ++ (if boot then "[boot]" else "") 20 | 21 | instance Hashable Module where 22 | hashWithSalt salt (Module a b) = hashWithSalt salt a `xor` hashWithSalt salt b 23 | 24 | instance NFData Module where 25 | rnf (Module a b) = rnf (a,b) 26 | 27 | instance Binary Module where 28 | put (Module a b) = put a >> put b 29 | get = do a <- get; b <- get; return $ Module a b 30 | 31 | data Makefile = Makefile 32 | {imports :: !(Map.HashMap Module [Either FilePath Module]) -- What does a module import 33 | ,source :: !(Map.HashMap Module FilePath) -- Where is that modules source located 34 | } 35 | deriving Show 36 | 37 | 38 | makefile :: FilePath -> IO Makefile 39 | makefile file = foldl' f z . parseMakefile <$> readFile file 40 | where 41 | z = Makefile Map.empty Map.empty 42 | 43 | -- We rely on the order of the generated makefile, in particular 44 | -- * The Foo.o : Foo.hs line is always the first with Foo.o on the LHS 45 | -- * The root module (often Main.o) is always last 46 | f m (a,[b]) 47 | | Just o <- fromExt "o" a, not $ Map.member o $ source m = m{source=Map.insert o b $ source m} 48 | | Just o <- fromExt "o" a, Just hi <- fromExt "hi" b = m{imports = Map.insertWith (++) o [Right hi] $ imports m} 49 | | Just o <- fromExt "o" a = m{imports = Map.insertWith (++) o [Left b] $ imports m} 50 | | otherwise = m 51 | f m (a,bs) = foldl' f m [(a,[b]) | b <- bs] 52 | 53 | 54 | fromExt ext x 55 | | "-boot" `isSuffixOf` x, Just (Module m _) <- fromExt ext $ take (length x - 5) x = Just $ Module m True 56 | | takeExtension x == "." ++ ext, isRelative x = Just $ Module (splitDirectories $ dropExtension x) False 57 | | otherwise = Nothing 58 | -------------------------------------------------------------------------------- /src/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} 2 | 3 | module Test(main) where 4 | 5 | import qualified Main 6 | import Control.Concurrent 7 | import Control.Exception 8 | import Control.Monad 9 | import Data.Functor 10 | import System.Directory.Extra 11 | import System.Time.Extra 12 | import System.Environment 13 | import System.Exit 14 | import System.Mem 15 | import System.Random 16 | import Development.Shake(removeFiles) 17 | import Development.Shake.FilePath 18 | import Prelude 19 | 20 | 21 | --------------------------------------------------------------------- 22 | -- TEST EXPECTATIONS 23 | 24 | data Expect = Exit 25 | | Change FilePath 26 | | Remain FilePath 27 | deriving Eq 28 | 29 | mtime file = do 30 | b <- doesFileExist file 31 | if b then Just <$> getModificationTime file else return Nothing 32 | 33 | expect :: Expect -> IO (IO ()) 34 | expect Exit = return $ return () 35 | expect (Change x) = do 36 | old <- mtime x 37 | return $ do 38 | new <- mtime x 39 | when (old == new) $ error $ "File did not change, but should have: " ++ x 40 | expect (Remain x) = do 41 | old <- mtime x 42 | return $ do 43 | new <- mtime x 44 | when (old /= new) $ error $ "File changed, but should not have: " ++ x 45 | 46 | 47 | run :: FilePath -> [String] -> [Expect] -> IO () 48 | run dir args es = do 49 | putStrLn $ "Running " ++ unwords (dir:args) 50 | handle (\(e :: ExitCode) -> if Exit `elem` es then return () else error "Unexpected exit") $ 51 | withCurrentDirectory dir $ withArgs args $ do 52 | acts <- mapM expect es 53 | threadDelay 1000000 54 | Main.main 55 | sequence_ acts 56 | 57 | touch :: FilePath -> IO () 58 | touch file = do 59 | putStrLn $ "Touching " ++ file 60 | sleep 1 -- to give the file system time to register it 61 | src <- readFile file 62 | evaluate $ length src 63 | writeFile file src 64 | 65 | retry :: Int -> IO a -> IO a 66 | retry i x | i <= 0 = error "retry ran out of times" 67 | retry 1 x = x 68 | retry i x = do 69 | res <- try x 70 | case res of 71 | Left (_ :: SomeException) -> retry (i-1) x 72 | Right v -> return v 73 | 74 | 75 | --------------------------------------------------------------------- 76 | -- RANDOM TESTS 77 | 78 | clean :: FilePath -> IO () 79 | clean dir = do 80 | putStrLn $ "Cleaning " ++ dir 81 | -- Retry a lot, sometimes Windows gets caught up 82 | retry 10 $ do 83 | performGC 84 | sleep 1 85 | removeFiles dir 86 | ["//*.hi","//*.hi-boot","//*.o","//*.o-boot" 87 | ,"//*.hix","//*.hix-boot","//*.ox","//*.ox-boot" 88 | ,"//.ghc-make.*" 89 | ,"//Result" <.> exe, "//Main" <.> exe, "//Root" <.> exe] 90 | 91 | data Test = Test 92 | {hisuf :: String 93 | ,osuf :: String 94 | ,hidir :: String 95 | ,odir :: String 96 | ,outputdir :: String 97 | ,nolink :: Bool 98 | ,output :: String 99 | ,threads :: Int 100 | } deriving Show 101 | 102 | newTest :: FilePath -> IO Test 103 | newTest prefix = do 104 | hisuf <- pick ["","hi","hix"] 105 | osuf <- pick ["","o","ox"] 106 | hidir <- pick $ prefixed ["","hidir","bothdir"] 107 | odir <- pick $ prefixed ["","odir","bothdir"] 108 | outputdir <- pick $ prefixed ["","","bothdir","oodir"] 109 | output <- pick $ prefixed ["","Result","Result" <.> exe] 110 | nolink <- pick [False,False,True] 111 | threads <- pick [1,2,3,4] 112 | let res = Test{..} 113 | putStrLn $ "Testing with " ++ show res 114 | return res 115 | where 116 | prefixed xs = xs ++ [if x == "" then "" else prefix x | x <- xs] 117 | pick xs = do i <- randomRIO (0, length xs - 1); return $ xs !! i 118 | 119 | testFlags :: Test -> [String] 120 | testFlags Test{..} = 121 | flag "hisuf" hisuf ++ flag "osuf" osuf ++ flag "hidir" hidir ++ flag "odir" odir ++ 122 | flag "outputdir" outputdir ++ 123 | (if nolink then ["-no-link"] else flag "o" output) ++ 124 | ["-j" ++ show threads | threads > 1] 125 | where flag a b = if b == "" then [] else ['-':a, b] 126 | 127 | objName :: Test -> String -> FilePath 128 | objName Test{..} x = 129 | (if outputdir == "" then odir else outputdir) x <.> (if osuf == "" then "o" else osuf) 130 | 131 | 132 | --------------------------------------------------------------------- 133 | -- MAIN DRIVER 134 | 135 | main :: IO () 136 | main = do 137 | args <- getArgs 138 | if args /= [] then 139 | withArgs args Main.main 140 | else do 141 | run "." ["--version"] [Exit] 142 | run "." ["--help"] [Exit] 143 | 144 | let count = 10 145 | cdir <- getCurrentDirectory 146 | forM_ [1..count] $ \i -> do 147 | putStrLn $ "RUNNING TEST " ++ show i ++ " of " ++ show count 148 | 149 | -- Use the simple test to track things rebuild when necessary 150 | do 151 | t <- newTest $ cdir "tests/simple" 152 | let t0 = t{threads=1} 153 | let main_o = objName t "Main" 154 | let a_o = objName t "A" 155 | clean "tests/simple" 156 | run "tests/simple" ("Main.hs":testFlags t0) [Change main_o] 157 | run "tests/simple" ("Main.hs":testFlags t0) [Remain main_o] 158 | touch "tests/simple/Main.hs" 159 | run "tests/simple" ("Main.hs":testFlags t) [Change main_o, Remain a_o] 160 | touch "tests/simple/Main.hs" 161 | run "tests/simple" ("Main.hs":testFlags t) [Change main_o, Remain a_o] 162 | run "tests/simple" ("Main.hs":testFlags t) [Remain main_o] 163 | clean "tests/simple" 164 | 165 | -- Use the complex test to track that we support all the weird features 166 | do 167 | t <- newTest $ cdir "tests/complex" 168 | let main_o = objName t "Main" 169 | clean "tests/complex" 170 | run "tests/complex" ("Root.hs":"-ichildren":"--shake--report=-":testFlags t) [Change main_o] 171 | run "tests/complex" ("Root.hs":"-ichildren":testFlags t) [Remain main_o] 172 | clean "tests/complex" 173 | 174 | putStrLn "Success" 175 | -------------------------------------------------------------------------------- /tests/complex/HsBoot.hs: -------------------------------------------------------------------------------- 1 | module HsBoot where 2 | 3 | import HsRec 4 | import BootChild 5 | -------------------------------------------------------------------------------- /tests/complex/HsBoot.hs-boot: -------------------------------------------------------------------------------- 1 | module HsBoot where 2 | 3 | import BootChild 4 | -------------------------------------------------------------------------------- /tests/complex/HsRec.hs: -------------------------------------------------------------------------------- 1 | module HsRec where 2 | 3 | import {-# SOURCE #-} HsBoot 4 | -------------------------------------------------------------------------------- /tests/complex/Include.h: -------------------------------------------------------------------------------- 1 | import IncludeChild 2 | -------------------------------------------------------------------------------- /tests/complex/Include.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Include where 4 | 5 | #include "Include.h" 6 | -------------------------------------------------------------------------------- /tests/complex/Lhs.lhs: -------------------------------------------------------------------------------- 1 | > module Lhs where 2 | -------------------------------------------------------------------------------- /tests/complex/LhsBoot.lhs: -------------------------------------------------------------------------------- 1 | > module LhsBoot where 2 | > 3 | > import LhsRec 4 | -------------------------------------------------------------------------------- /tests/complex/LhsBoot.lhs-boot: -------------------------------------------------------------------------------- 1 | > module LhsBoot where 2 | -------------------------------------------------------------------------------- /tests/complex/LhsRec.lhs: -------------------------------------------------------------------------------- 1 | > module LhsRec where 2 | > 3 | > import {-# SOURCE #-} LhsBoot 4 | -------------------------------------------------------------------------------- /tests/complex/Root.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main(main) where 3 | 4 | import HsRec 5 | import LhsRec 6 | import Include 7 | import Lhs 8 | 9 | main = print "Root" 10 | -------------------------------------------------------------------------------- /tests/complex/children/BootChild.hs: -------------------------------------------------------------------------------- 1 | module BootChild where 2 | -------------------------------------------------------------------------------- /tests/complex/children/IncludeChild.hs: -------------------------------------------------------------------------------- 1 | module IncludeChild where 2 | -------------------------------------------------------------------------------- /tests/simple/A.hs: -------------------------------------------------------------------------------- 1 | module A(a,b) where 2 | 3 | import B 4 | 5 | a = 1 :: Int 6 | -------------------------------------------------------------------------------- /tests/simple/B.hs: -------------------------------------------------------------------------------- 1 | module B where 2 | 3 | b = 2 :: Int 4 | -------------------------------------------------------------------------------- /tests/simple/C/C.hs: -------------------------------------------------------------------------------- 1 | module C.C where 2 | 3 | c = 3 :: Int 4 | -------------------------------------------------------------------------------- /tests/simple/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import A 3 | import C.C 4 | 5 | main = print $ a + b + c 6 | -------------------------------------------------------------------------------- /travis.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.Process.Extra 3 | 4 | main = do 5 | system_ "runhaskell -isrc Test" 6 | --------------------------------------------------------------------------------