diff --git a/Arguments.hs b/Arguments.hs deleted file mode 100644 --- a/Arguments.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE PatternGuards, RecordWildCards #-} - -module Arguments(Arguments(..), getArguments) where - -import Control.Monad -import Data.Char -import Data.Either -import Data.List -import Data.Maybe -import System.Environment -import System.Exit -import Development.Shake.FilePath -import Makefile - - -data Arguments = Arguments - {argsGHC :: [String] -- ^ Arguments to pass to ghc, does not include --make - ,argsShake :: [String] -- ^ Arguments to pass to shake - ,threads :: Int -- ^ Number of threads to use - -- Interpretation of the flags - ,modeGHC :: Bool -- ^ Are these flags which should go direct to GHC, not a --make/-M mode - ,prefix :: FilePath -- ^ Where make should put its files, e.g. .ghc-make - -- Where should things live - ,outputFile :: FilePath -> FilePath -- ^ Root source file, .exe file - ,hiDir :: FilePath -- ^ -hidir - ,oDir :: FilePath -- ^ -odir - ,hiFile :: Module -> FilePath -- ^ .hi files - ,oFile :: Module -> FilePath -- ^ .o files - ,hiModule :: FilePath -> Maybe Module - ,oModule :: FilePath -> Maybe Module - } - -helpMessage = - ["ghc-make, (C) Neil Mitchell" - ,"" - ," ghc-make [ghc-options] --shake[shake-options] [-jN]" - ,"" - ,"ghc-make is a drop-in replacement for 'ghc', and accepts GHC arugments." - ,"For GHC arguments, see 'ghc --help' or ." - ,"" - ,"ghc-make uses 'shake', and accepts Shake arguments prefixed by '--shake'." - ,"For Shake arguments, see 'ghc-make --shake--help'." - ,"As an example, to write a profile report to stdout pass '--shake--report=-'." - ,"" - ,"In addition, 'ghc-make' accepts the following option:" - ,"" - ," -jN --threads=N Allow N modules to compile in parallel (defaults to 1)." - ] - - -getArguments :: IO Arguments -getArguments = do - args <- getArgs - when (any (`elem` helpFlags) args) $ do - putStrLn $ unlines helpMessage - exitSuccess - - let (argsThreads, argsRest) = partition (isJust . parseThreads) args - let threads = max 1 $ fromMaybe 1 $ msum $ map parseThreads argsThreads - let (argsShake, argsGHC) = splitFlags $ delete "--make" argsRest - let hasArg x = x `elem` argsGHC - let getArg b x = findArg b x argsGHC - - let modeGHC = any hasArg $ "--version" : "--numeric-version" : flagsConflictingWithM - let prefix = fromMaybe "" (getArg True ["-outputdir","-odir"] `mplus` getArg True ["-outputdir","-hidir"]) ".ghc-make" - let outputFile file = let s = fromMaybe (dropExtension file) (getArg False ["-o"]) - in if null $ takeExtension s then s <.> exe else s - - let (hiDir, hiFile, hiModule) = extFileModule getArg "hi" - let ( oDir, oFile, oModule) = extFileModule getArg "o" - return Arguments{..} - - -extFileModule :: (Bool -> [String] -> Maybe String) -> String -> (FilePath, Module -> FilePath, FilePath -> Maybe Module) -extFileModule getArg ext = (extDir, extFile, extModule) - where - extDir = fromMaybe "" $ getArg True ["-outputdir","-" ++ ext ++ "dir"] - extSuf = fromMaybe ext $ getArg True ["-" ++ ext ++ "suf"] - extFile (Module name boot) = extDir joinPath name <.> extSuf ++ (if boot then "-boot" else "") - extModule s - | "-boot" `isSuffixOf` s, Just (Module name _) <- extModule $ take (length s - 5) s = newModule name True - | extDir `isPrefixOf` s && extSuf `isSuffixOf` s - = newModule (splitDirectories $ dropWhile isPathSeparator $ dropExtensions $ drop (length extDir) s) False - | otherwise = Nothing - -newModule :: [String] -> Bool -> Maybe Module -newModule xs y = if all isValid xs then Just $ Module xs y else Nothing - where isValid (x:xs) = isUpper x && all (\x -> isAlphaNum x || x `elem` "\'_") xs - isValid [] = False - - -parseThreads :: String -> Maybe Int -parseThreads x = do - x <- msum $ map (`stripPrefix` x) ["-threads","--threads","-j"] - x <- return $ fromMaybe x $ stripPrefix "=" x - [(i,"")] <- return $ reads x - return i - - --- | -odir is implicit since -odirfoo works, but -o is explicit -findArg :: Bool -> [String] -> [String] -> Maybe String -findArg implicit flags xs - | x1:x2:xs <- xs, x1 `elem` flags = add x2 $ rec xs - | implicit, x:xs <- xs, Just x <- msum $ map (`stripPrefix` x) flags - = add (if "=" `isPrefixOf` x then drop 1 x else x) $ rec xs - | x:xs <- xs = rec xs - | otherwise = Nothing - where add a b = Just $ fromMaybe a b - rec = findArg implicit flags - - -helpFlags = words "-? --help" - --- Obtained from the man page (listed in the same order as they appear there) --- and ghc/Main.hs, `data PostLoadMode`: -flagsConflictingWithM = words $ - -- "Help and verbosity options" - "-? --help -V " ++ - "--supported-extensions --supported-languages " ++ - "--info --version --numeric-version --print-libdir " ++ - -- "Which phases to run" - "-E -C -S -c " ++ - -- "Alternative modes of operation" - "--interactive -e " ++ - -- "Interface file options" - "--show-iface " ++ - -- Undocumented? - "--abi-hash" - - - --- | Split flags into (Shake flags, GHC flags) -splitFlags :: [String] -> ([String], [String]) -splitFlags = partitionEithers . map f - where - f x | Just x <- stripPrefix "--shake-" x = Left $ '-':x - | Just x <- stripPrefix "-shake-" x = Left $ '-':x - | otherwise = Right x - diff --git a/Build.hs b/Build.hs deleted file mode 100644 --- a/Build.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} - -module Build(main) where - -import Control.Monad -import Data.Either -import Data.Maybe -import Development.Shake -import Development.Shake.Classes -import Development.Shake.FilePath -import System.Environment -import System.Exit -import System.Process -import qualified Data.HashMap.Strict as Map -import Arguments -import Makefile - - --- | Increment every time I change the rules in an incompatible way -ghcMakeVer :: Int -ghcMakeVer = 3 - - -newtype AskImports = AskImports Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) - -newtype AskSource = AskSource Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) - - -main :: IO () -main = do - Arguments{..} <- getArguments - - when modeGHC $ - exitWith =<< rawSystem "ghc" argsGHC - - let opts = shakeOptions - {shakeThreads=threads - ,shakeFiles=prefix - ,shakeVerbosity=if threads == 1 then Quiet else Normal - ,shakeVersion=show ghcMakeVer} - withArgs argsShake $ shakeArgs opts $ do - want [prefix <.> "result"] - - -- A file containing the GHC arguments - prefix <.> "args" *> \out -> do - alwaysRerun - writeFileChanged out $ unlines argsGHC - needArgs <- return $ do need [prefix <.> "args"]; return argsGHC - - -- A file containing the ghc-pkg list output - prefix <.> "pkgs" *> \out -> do - alwaysRerun - (Stdout s, Stderr _) <- cmd "ghc-pkg list --verbose" - writeFileChanged out s - needPkgs <- return $ need [prefix <.> "pkgs"] - - -- A file containing the output of -M - prefix <.> "makefile" *> \out -> do - args <- needArgs - needPkgs - -- Use the default o/hi settings so we can parse the makefile properly - () <- cmd "ghc -M -include-pkg-deps -dep-suffix='' -dep-makefile" [out] args "-odir. -hidir. -hisuf=_hi_ -osuf=_o_" - mk <- liftIO $ makefile out - need $ Map.elems $ source mk - needMk <- do cache <- newCache (\x -> do need [x]; liftIO $ makefile x); return $ cache $ prefix <.> "makefile" - askImports <- addOracle $ \(AskImports x) -> do mk <- needMk; return $ Map.lookupDefault [] x $ imports mk - askSource <- addOracle $ \(AskSource x) -> do mk <- needMk; return $ source mk Map.! x - - - -- The result, we can't want the object directly since it is painful to - -- define a build rule for it because its name depends on both args and makefile - prefix <.> "result" *> \out -> do - args <- needArgs - mk <- needMk - let output = if "-no-link" `elem` argsGHC then Nothing - else fmap outputFile $ Map.lookup (Module ["Main"] False) $ source mk - - -- if you don't specify an odir/hidir then impossible to reverse from the file name to the module - let exec = when (isJust output || threads == 1) $ - cmd "ghc --make -odir. -hidir." args - grab = need $ map oFile $ Map.keys $ source mk - if threads == 1 then exec >> grab else grab >> exec - - case output of - Nothing -> return () - Just output -> do - -- ensure that if the file gets deleted we rerun this rule without first trying to - -- need the output, since we don't have a rule to build the output - b <- doesFileExist output - unless b $ - error $ "Failed to build output file: " ++ output ++ "\n" ++ - "Most likely ghc-make has guessed the output location wrongly." - need [output] - writeFile' out "" - - let match x = do m <- oModule x `mplus` hiModule x; return [oFile m, hiFile m] - match &?> \[o,hi] -> do - let Just m = oModule o - source <- askSource (AskSource m) - (files,mods) <- fmap partitionEithers $ askImports (AskImports m) - need $ source : map hiFile mods ++ files - when (threads /= 1) $ do - args <- needArgs - let isRoot x = x == "Main" || takeExtension x `elem` [".hs",".lhs"] - cmd "ghc -odir. -hidir." (filter (not . isRoot) args) (if hiDir == "" then [] else ["-i" ++ hiDir]) "-o" [o] "-c" [source] diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for ghc-make +0.3 + GHC 7.8 compatibility, following -M output changes (GHC #9287) + Fix a bug on Windows with shake-0.14 and filepath separators 0.2.1 Support GHC-7.8, which requires -dep-suffix #3, support -no-link flag diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ - -module Main(main) where - -import Build diff --git a/Makefile.hs b/Makefile.hs deleted file mode 100644 --- a/Makefile.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE RecordWildCards, PatternGuards, DeriveDataTypeable #-} - -module Makefile(Makefile(..), Module(..), makefile) where - -import Data.List -import Development.Shake.FilePath -import Development.Shake.Classes -import Development.Shake.Util -import Data.Bits -import qualified Data.HashMap.Strict as Map - - -data Module = Module {moduleName :: [String], moduleBoot :: Bool} - deriving (Typeable, Eq) - -instance Show Module where - show (Module name boot) = intercalate "." name ++ (if boot then "[boot]" else "") - -instance Hashable Module where - hashWithSalt salt (Module a b) = hashWithSalt salt a `xor` hashWithSalt salt b - -instance NFData Module where - rnf (Module a b) = rnf (a,b) - -instance Binary Module where - put (Module a b) = put a >> put b - get = do a <- get; b <- get; return $ Module a b - -data Makefile = Makefile - {imports :: !(Map.HashMap Module [Either FilePath Module]) -- What does a module import - ,source :: !(Map.HashMap Module FilePath) -- Where is that modules source located - } - deriving Show - - -makefile :: FilePath -> IO Makefile -makefile file = fmap (foldl' f z . parseMakefile) $ readFile file - where - z = Makefile Map.empty Map.empty - - -- We rely on the order of the generated makefile, in particular - -- * The Foo.o : Foo.hs line is always the first with Foo.o on the LHS - -- * The root module (often Main.o) is always last - f m (a,[b]) - | Just o <- fromExt "_o_" a, not $ Map.member o $ source m = m{source=Map.insert o b $ source m} - | Just o <- fromExt "_o_" a, Just hi <- fromExt "_hi_" b = m{imports = Map.insertWith (++) o [Right hi] $ imports m} - | Just o <- fromExt "_o_" a = m{imports = Map.insertWith (++) o [Left b] $ imports m} - | otherwise = m - f m (a,bs) = foldl' f m [(a,[b]) | b <- bs] - - -fromExt ext x - | "-boot" `isSuffixOf` x, Just (Module m _) <- fromExt ext $ take (length x - 5) x = Just $ Module m True - | takeExtension x == "." ++ ext = Just $ Module (splitDirectories $ dropExtension x) False - | otherwise = Nothing diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# ghc-make [![Build Status](https://travis-ci.org/ndmitchell/ghc-make.svg)](https://travis-ci.org/ndmitchell/ghc-make) +# ghc-make [![Hackage version](https://img.shields.io/hackage/v/ghc-make.svg?style=flat)](https://hackage.haskell.org/package/ghc-make) [![Build Status](https://img.shields.io/travis/ndmitchell/ghc-make.svg?style=flat)](https://travis-ci.org/ndmitchell/ghc-make) An alternative to `ghc --make` which supports parallel compilation of modules and runs faster when nothing needs compiling. diff --git a/ghc-make.cabal b/ghc-make.cabal --- a/ghc-make.cabal +++ b/ghc-make.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: ghc-make -version: 0.2.1 +version: 0.3 license: BSD3 license-file: LICENSE category: Development @@ -25,7 +25,7 @@ extra-source-files: README.md CHANGES.txt -tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 source-repository head type: git @@ -34,12 +34,12 @@ executable ghc-make main-is: Main.hs ghc-options: -threaded + hs-source-dirs: src build-depends: base == 4.*, - shake >= 0.13, + shake >= 0.13.3, unordered-containers >= 0.2.1, process >= 1.0 other-modules: Arguments - Build Makefile diff --git a/src/Arguments.hs b/src/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Arguments.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE PatternGuards, RecordWildCards #-} + +module Arguments(Arguments(..), getArguments) where + +import Control.Monad +import Data.Char +import Data.Either +import Data.List +import Data.Maybe +import System.Environment +import System.Exit +import Development.Shake.FilePath +import Makefile + + +data Arguments = Arguments + {argsGHC :: [String] -- ^ Arguments to pass to ghc, does not include --make + ,argsShake :: [String] -- ^ Arguments to pass to shake + ,threads :: Int -- ^ Number of threads to use + -- Interpretation of the flags + ,modeGHC :: Bool -- ^ Are these flags which should go direct to GHC, not a --make/-M mode + ,prefix :: FilePath -- ^ Where make should put its files, e.g. .ghc-make + -- Where should things live + ,outputFile :: FilePath -> FilePath -- ^ Root source file, .exe file + ,hiDir :: FilePath -- ^ -hidir + ,oDir :: FilePath -- ^ -odir + ,hiFile :: Module -> FilePath -- ^ .hi files + ,oFile :: Module -> FilePath -- ^ .o files + ,hiModule :: FilePath -> Maybe Module + ,oModule :: FilePath -> Maybe Module + } + +helpMessage = + ["ghc-make, (C) Neil Mitchell" + ,"" + ," ghc-make [ghc-options] --shake[shake-options] [-jN]" + ,"" + ,"ghc-make is a drop-in replacement for 'ghc', and accepts GHC arugments." + ,"For GHC arguments, see 'ghc --help' or ." + ,"" + ,"ghc-make uses 'shake', and accepts Shake arguments prefixed by '--shake'." + ,"For Shake arguments, see 'ghc-make --shake--help'." + ,"As an example, to write a profile report to stdout pass '--shake--report=-'." + ,"" + ,"In addition, 'ghc-make' accepts the following option:" + ,"" + ," -jN --threads=N Allow N modules to compile in parallel (defaults to 1)." + ] + + +getArguments :: IO Arguments +getArguments = do + args <- getArgs + when (any (`elem` helpFlags) args) $ do + putStrLn $ unlines helpMessage + exitSuccess + + let (argsThreads, argsRest) = partition (isJust . parseThreads) args + let threads = max 1 $ fromMaybe 1 $ msum $ map parseThreads argsThreads + let (argsShake, argsGHC) = splitFlags $ delete "--make" argsRest + let hasArg x = x `elem` argsGHC + let getArg b x = findArg b x argsGHC + + let modeGHC = any hasArg $ "--version" : "--numeric-version" : flagsConflictingWithM + let prefix = fromMaybe "" (getArg True ["-outputdir","-odir"] `mplus` getArg True ["-outputdir","-hidir"]) ".ghc-make" + let outputFile file = let s = fromMaybe (dropExtension file) (getArg False ["-o"]) + in if null $ takeExtension s then s <.> exe else s + + let (hiDir, hiFile, hiModule) = extFileModule getArg "hi" + let ( oDir, oFile, oModule) = extFileModule getArg "o" + return Arguments{..} + + +extFileModule :: (Bool -> [String] -> Maybe String) -> String -> (FilePath, Module -> FilePath, FilePath -> Maybe Module) +extFileModule getArg ext = (extDir, extFile, extModule) + where + extDir = fromMaybe "" $ getArg True ["-outputdir","-" ++ ext ++ "dir"] + extSuf = fromMaybe ext $ getArg True ["-" ++ ext ++ "suf"] + extFile (Module name boot) = extDir joinPath name <.> extSuf ++ (if boot then "-boot" else "") + extModule s + | "-boot" `isSuffixOf` s, Just (Module name _) <- extModule $ take (length s - 5) s = newModule name True + | toStandard extDir `isPrefixOf` toStandard s && extSuf `isSuffixOf` s + = newModule (splitDirectories $ dropWhile isPathSeparator $ dropExtensions $ drop (length extDir) s) False + | otherwise = Nothing + +newModule :: [String] -> Bool -> Maybe Module +newModule xs y = if all isValid xs then Just $ Module xs y else Nothing + where isValid (x:xs) = isUpper x && all (\x -> isAlphaNum x || x `elem` "\'_") xs + isValid [] = False + + +parseThreads :: String -> Maybe Int +parseThreads x = do + x <- msum $ map (`stripPrefix` x) ["-threads","--threads","-j"] + x <- return $ fromMaybe x $ stripPrefix "=" x + [(i,"")] <- return $ reads x + return i + + +-- | -odir is implicit since -odirfoo works, but -o is explicit +findArg :: Bool -> [String] -> [String] -> Maybe String +findArg implicit flags xs + | x1:x2:xs <- xs, x1 `elem` flags = add x2 $ rec xs + | implicit, x:xs <- xs, Just x <- msum $ map (`stripPrefix` x) flags + = add (if "=" `isPrefixOf` x then drop 1 x else x) $ rec xs + | x:xs <- xs = rec xs + | otherwise = Nothing + where add a b = Just $ fromMaybe a b + rec = findArg implicit flags + + +helpFlags = words "-? --help" + +-- Obtained from the man page (listed in the same order as they appear there) +-- and ghc/Main.hs, `data PostLoadMode`: +flagsConflictingWithM = words $ + -- "Help and verbosity options" + "-? --help -V " ++ + "--supported-extensions --supported-languages " ++ + "--info --version --numeric-version --print-libdir " ++ + -- "Which phases to run" + "-E -C -S -c " ++ + -- "Alternative modes of operation" + "--interactive -e " ++ + -- "Interface file options" + "--show-iface " ++ + -- Undocumented? + "--abi-hash" + + + +-- | Split flags into (Shake flags, GHC flags) +splitFlags :: [String] -> ([String], [String]) +splitFlags = partitionEithers . map f + where + f x | Just x <- stripPrefix "--shake-" x = Left $ '-':x + | Just x <- stripPrefix "-shake-" x = Left $ '-':x + | otherwise = Right x + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +module Main(main) where + +import Control.Monad +import Data.Either +import Data.Maybe +import Development.Shake +import Development.Shake.Classes +import Development.Shake.FilePath +import System.Environment +import System.Exit +import System.Process +import qualified Data.HashMap.Strict as Map +import Arguments +import Makefile + + +-- | Increment every time I change the rules in an incompatible way +ghcMakeVer :: Int +ghcMakeVer = 3 + + +newtype AskImports = AskImports Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) + +newtype AskSource = AskSource Module deriving (Show,Typeable,Eq,Hashable,Binary,NFData) + + +main :: IO () +main = do + Arguments{..} <- getArguments + + when modeGHC $ + exitWith =<< rawSystem "ghc" argsGHC + + let opts = shakeOptions + {shakeThreads=threads + ,shakeFiles=prefix + ,shakeVerbosity=if threads == 1 then Quiet else Normal + ,shakeVersion=show ghcMakeVer} + withArgs argsShake $ shakeArgs opts $ do + want [prefix <.> "result"] + + -- A file containing the GHC arguments + prefix <.> "args" *> \out -> do + alwaysRerun + writeFileChanged out $ unlines argsGHC + needArgs <- return $ do need [prefix <.> "args"]; return argsGHC + + -- A file containing the ghc-pkg list output + prefix <.> "pkgs" *> \out -> do + alwaysRerun + (Stdout s, Stderr _) <- cmd "ghc-pkg list --verbose" + writeFileChanged out s + needPkgs <- return $ need [prefix <.> "pkgs"] + + -- A file containing the output of -M + prefix <.> "makefile" *> \out -> do + args <- needArgs + needPkgs + -- Use the default o/hi settings so we can parse the makefile properly + () <- cmd "ghc -M -include-pkg-deps -dep-suffix=" [""] "-dep-makefile" [out] args "-odir. -hidir. -hisuf=hi -osuf=o" + mk <- liftIO $ makefile out + need $ Map.elems $ source mk + needMk <- do cache <- newCache (\x -> do need [x]; liftIO $ makefile x); return $ cache $ prefix <.> "makefile" + askImports <- addOracle $ \(AskImports x) -> do mk <- needMk; return $ Map.lookupDefault [] x $ imports mk + askSource <- addOracle $ \(AskSource x) -> do mk <- needMk; return $ source mk Map.! x + + + -- The result, we can't want the object directly since it is painful to + -- define a build rule for it because its name depends on both args and makefile + prefix <.> "result" *> \out -> do + args <- needArgs + mk <- needMk + let output = if "-no-link" `elem` argsGHC then Nothing + else fmap outputFile $ Map.lookup (Module ["Main"] False) $ source mk + + -- if you don't specify an odir/hidir then impossible to reverse from the file name to the module + let exec = when (isJust output || threads == 1) $ + cmd "ghc --make -odir. -hidir." args + grab = need $ map oFile $ Map.keys $ source mk + if threads == 1 then exec >> grab else grab >> exec + + case output of + Nothing -> return () + Just output -> do + -- ensure that if the file gets deleted we rerun this rule without first trying to + -- need the output, since we don't have a rule to build the output + b <- doesFileExist output + unless b $ + error $ "Failed to build output file: " ++ output ++ "\n" ++ + "Most likely ghc-make has guessed the output location wrongly." + need [output] + writeFile' out "" + + let match x = do m <- oModule x `mplus` hiModule x; return [oFile m, hiFile m] + match &?> \[o,hi] -> do + let Just m = oModule o + source <- askSource (AskSource m) + (files,mods) <- fmap partitionEithers $ askImports (AskImports m) + need $ source : map hiFile mods ++ files + when (threads /= 1) $ do + args <- needArgs + let isRoot x = x == "Main" || takeExtension x `elem` [".hs",".lhs"] + cmd "ghc -odir. -hidir." (filter (not . isRoot) args) (if hiDir == "" then [] else ["-i" ++ hiDir]) "-o" [o] "-c" [source] diff --git a/src/Makefile.hs b/src/Makefile.hs new file mode 100644 --- /dev/null +++ b/src/Makefile.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RecordWildCards, PatternGuards, DeriveDataTypeable #-} + +module Makefile(Makefile(..), Module(..), makefile) where + +import Data.List +import Development.Shake.FilePath +import Development.Shake.Classes +import Development.Shake.Util +import Data.Bits +import qualified Data.HashMap.Strict as Map + + +data Module = Module {moduleName :: [String], moduleBoot :: Bool} + deriving (Typeable, Eq) + +instance Show Module where + show (Module name boot) = intercalate "." name ++ (if boot then "[boot]" else "") + +instance Hashable Module where + hashWithSalt salt (Module a b) = hashWithSalt salt a `xor` hashWithSalt salt b + +instance NFData Module where + rnf (Module a b) = rnf (a,b) + +instance Binary Module where + put (Module a b) = put a >> put b + get = do a <- get; b <- get; return $ Module a b + +data Makefile = Makefile + {imports :: !(Map.HashMap Module [Either FilePath Module]) -- What does a module import + ,source :: !(Map.HashMap Module FilePath) -- Where is that modules source located + } + deriving Show + + +makefile :: FilePath -> IO Makefile +makefile file = fmap (foldl' f z . parseMakefile) $ readFile file + where + z = Makefile Map.empty Map.empty + + -- We rely on the order of the generated makefile, in particular + -- * The Foo.o : Foo.hs line is always the first with Foo.o on the LHS + -- * The root module (often Main.o) is always last + f m (a,[b]) + | Just o <- fromExt "o" a, not $ Map.member o $ source m = m{source=Map.insert o b $ source m} + | Just o <- fromExt "o" a, Just hi <- fromExt "hi" b = m{imports = Map.insertWith (++) o [Right hi] $ imports m} + | Just o <- fromExt "o" a = m{imports = Map.insertWith (++) o [Left b] $ imports m} + | otherwise = m + f m (a,bs) = foldl' f m [(a,[b]) | b <- bs] + + +fromExt ext x + | "-boot" `isSuffixOf` x, Just (Module m _) <- fromExt ext $ take (length x - 5) x = Just $ Module m True + | takeExtension x == "." ++ ext, isRelative x = Just $ Module (splitDirectories $ dropExtension x) False + | otherwise = Nothing