hmk 0.9.5 → 0.9.6
raw patch · 7 files changed
+99/−52 lines, 7 files
Files
- Control/Hmk.lhs +2/−3
- Control/Hmk/IO.lhs +1/−9
- Eval.lhs +45/−23
- Main.lhs +18/−4
- Metarule.lhs +27/−6
- Parse.lhs +1/−2
- hmk.cabal +5/−5
Control/Hmk.lhs view
@@ -85,10 +85,9 @@ > if x `Set.member` visited then > error "Cycle detected." else > case find (\r -> target r == x) rules of-> Just rule -> mdo-> let n = Node x ps rule+> Just rule -> do > ps <- local (Set.insert x) $ mapM aux (prereqs rule)-> return n+> return $ Node x ps rule > Nothing -> error "Invariant 3 violated." From the mk(1) manual:
Control/Hmk/IO.lhs view
@@ -19,8 +19,8 @@ This module should be imported qualified. > module Control.Hmk.IO where+> > import Control.Hmk hiding (isStale)-> import Control.Monad (foldM) > import System.FilePath > import System.Posix.Files > import System.Exit@@ -44,11 +44,3 @@ > testExitCode :: ExitCode -> IO Result > testExitCode ExitSuccess = return TaskSuccess > testExitCode (ExitFailure _) = return TaskFailure--Perform each system action, aborting if an action returns-non-zero exit code.--> abortOnError :: [IO Result] -> IO Result-> abortOnError = foldM f TaskSuccess where-> f TaskSuccess k = k-> f TaskFailure _ = error "Command exited with non-zero status."
Eval.lhs view
@@ -13,7 +13,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. -> module Eval (Target(..), eval, evalNoMeta, Eval.isStale, substituteStem) where+> module Eval (Target(..), Stem(..), eval, evalNoMeta, Eval.isStale, substituteStem) where > > import Parse > import Control.Hmk@@ -21,16 +21,17 @@ > > import Data.Sequence (Seq) > import qualified Data.Sequence as Seq-> import qualified Data.Traversable as Seq > import qualified Data.Foldable as Seq+> import qualified Data.Traversable as Seq+> import Data.Map (Map) > import qualified Data.Map as Map-> import qualified Data.Foldable as Map > import qualified Data.Set as Set > import Control.Applicative > import Control.Monad.State > import Control.Monad.Writer > import Data.List (intercalate) > import Data.Maybe (isNothing)+> import Data.Char (isDigit) > > import System.IO > import System.Directory@@ -62,6 +63,7 @@ > data Target = File { name :: FilePath } > | Virtual { name :: String } > | Pattern { name :: String }+> | REPattern { name :: String } > deriving Show > newtype RevAppend a = RevAppend a@@ -104,15 +106,27 @@ because stems are synthesized as a by-product of meta-rule instantiaton, but this instantiation is performed post evaluation. -> type Stem = String+> data Stem = Stem String | RESubMatches [String] | NoStem > > addVariable attr var val = do-> modify (Map.insert var (val :: Seq String))+> modify (fmap (Map.insert var (val :: Seq String))) > case attr of > Export -> liftIO $ setEnv var (freeze val) True > Local -> return ()->-> lookupVariable var = Map.findWithDefault (Seq.empty) var <$> get++The value of a variable is looked up by decreasing order of precedence in the+following places:++ - assignments on the command line,+ - assignments in the mkfile,+ - the environment.++> lookupVariable var = do+> maybe Seq.empty id . msum <$>+> sequence [ Map.lookup var . fst <$> get+> , Map.lookup var . snd <$> get+> , fmap Seq.singleton <$> liftIO (getEnv var)+> , return (Just Seq.empty) ] > > evalToken (Lit x) = return (Seq.singleton x) > evalToken (Coll toks) = Seq.singleton <$> Seq.concat <$>@@ -123,25 +137,24 @@ > var <- evalToken tok > lookupVariable (freeze var) >-> eval :: Mkfile -> IO (Seq (Stem -> Rule IO Target))-> eval mkfile = evalStateT (init >> go) Map.empty+> eval :: Map String (Seq String) -> Mkfile -> IO (Seq (Stem -> Rule IO Target))+> eval cmdline mkfile = evalStateT (init >> go) (cmdline, Map.empty) > where init = addVariable Export "MKSHELL" (Seq.singleton defaultShell) > go = mdo (rules, RevAppend virtuals) <- runWriterT (eval' virtuals mkfile) > return rules > > eval' virtuals (Mkrule ts flags ps r cont) = do-> let tag t = if t `elem` virtuals-> then Virtual t-> else case t of-> '%':_ -> Pattern t-> _ -> File t+> flagsv <- evalFlags flags+> let tag t | t `elem` virtuals = Virtual t+> | Set.member Flag_R flagsv = REPattern t+> | '%':_ <- t = Pattern t+> | otherwise = File t > tsv <- Seq.msum <$> Seq.mapM evalToken ts > psv <- fmap tag <$> Seq.msum <$> Seq.mapM evalToken ps-> flagsv <- evalFlags flags > shell <- (`Seq.index` 0) <$> lookupVariable "MKSHELL"-> let f tv stem = let t | Set.member Flag_V flagsv = Virtual tv-> | '%':_ <- tv = Pattern tv-> | otherwise = File tv+> let f tv stem = let t = if Set.member Flag_V flagsv+> then Virtual tv+> else tag tv > rv = if Set.member Flag_N flagsv && isNothing r > then Just $ evalRecipe tsv t flagsv psv stem shell ("touch " ++ name t) > else fmap (evalRecipe tsv t flagsv psv stem shell) r@@ -183,8 +196,12 @@ (Note that unlike make, hmk feeds the entire recipe to the shell rather than running each line of the recipe separately.) -> substituteStem stem (Pattern ('%':suffix)) = File (stem ++ suffix)-> substituteStem stem x = x+> substituteStem (Stem stem) (Pattern ('%':suffix)) = File (stem ++ suffix)+> substituteStem (RESubMatches matches) (REPattern pat) = File (subst pat)+> where subst "" = ""+> subst ('\\':n:xs) | isDigit n = matches !! (read [n] - 1) ++ subst xs+> subst (x:xs) = x : subst xs+> substituteStem _ x = x > > evalRecipe alltarget target flags prereq stem shell text newprereq = do > pid <- show <$> getProcessID@@ -194,7 +211,12 @@ > setEnv "nproc" (show 0) True > setEnv "pid" pid True > setEnv "prereq" (freeze (fmap (name . substituteStem stem) prereq)) True-> setEnv "stem" stem True+> case stem of+> Stem stem -> setEnv "stem" stem True+> RESubMatches stems -> do+> let nstems = zip [1..] stems+> mapM_ (\(n, stem) -> setEnv ("stem" ++ show n) stem True) nstems+> NoStem -> return () > setEnv "target" (name $ substituteStem stem $ target) True > let p = if Set.member Flag_Q flags > then proc shell ["-e"]@@ -248,5 +270,5 @@ Version of eval where stems are instantiated to the empty string. -> evalNoMeta :: Mkfile -> IO (Seq (Rule IO Target))-> evalNoMeta mkfile = fmap ($ "") <$> eval mkfile+> evalNoMeta :: Map String (Seq String) -> Mkfile -> IO (Seq (Rule IO Target))+> evalNoMeta cmdline mkfile = fmap ($ NoStem) <$> eval cmdline mkfile
Main.lhs view
@@ -34,6 +34,9 @@ > import Control.Applicative > import qualified Data.Sequence as Seq > import qualified Data.Foldable as Seq+> import qualified Data.Map as Map+> import Data.Either+> import Data.Char (isAlphaNum) > import System.IO > import System.Environment > import System.Exit@@ -55,7 +58,7 @@ > , Option ['h'] ["help"] (NoArg OptHelp) > "This usage information." ] >-> usage = "Usage: hmk [OPTION]... [TARGET]..."+> usage = "Usage: hmk [OPTION]... [ASSIGNMENT]... [TARGET]..." > > printUsage = hPutStrLn stderr usage >@@ -64,7 +67,18 @@ > putStrLn (usageInfo header options) > > bailout = printUsage >> exitFailure->++The arguments given on the command line can be of the form a=b. This pins the+value for variable $a to be 'b'. The following function splits out arguments+of this form from the rest.++> getAssignments :: [String] -> (Map.Map String (Seq.Seq String), [String])+> getAssignments args = (Map.fromList assigns, targets) where+> (assigns, targets) = partitionEithers $ map p_assignment args+> p_assignment arg = case span isAlphaNum arg of+> (var, '=':rest) -> Left (var, Seq.fromList $ words rest)+> _ -> Right arg+ > main :: IO () > main = do > (opts, other, errs) <- getOpt RequireOrder options <$> getArgs@@ -72,11 +86,11 @@ > hPutStr stderr (concat errs) > exitFailure > when (OptHelp `elem` opts) (printHelp >> exitSuccess)-> let targets = map File other+> let (assigns, targets) = fmap (map File) (getAssignments other) > -- number of jobs to run simultaneously. > slots = foldr (\x y -> case x of OptJobs j -> j; _ -> y) 1 opts > mkfile = foldr (\x y -> case x of OptMkfile f -> f; _ -> y) "mkfile" opts-> metarules <- eval =<< parse mkfile <$> readFile mkfile+> metarules <- eval assigns =<< parse mkfile <$> readFile mkfile > let rules = Seq.toList $ instantiateRecurse (Seq.fromList targets) metarules > let arules = if OptAll `elem` opts > then map (\r -> r{Control.Hmk.isStale = \_ _ -> return True}) rules
Metarule.lhs view
@@ -33,6 +33,7 @@ > cleanup = Seq.foldr f Seq.empty where > f r rs = case target r of > Pattern _ -> rs+> REPattern _ -> rs > _ -> r Seq.<| rs Instantiation of meta-rules. 'instantiate' is a helper function for@@ -40,8 +41,6 @@ and then recursively instantiates meta-rules with the prerequesites of the matching rules. -> type Stem = String-> > seqFilter :: (a -> Bool) -> Seq a -> Seq a > seqFilter f = Seq.foldr (\x xs -> if f x then x Seq.<| xs else xs) Seq.empty >@@ -58,24 +57,46 @@ > collectMatches (Pattern ('%':suffix)) ts = > let re = compile ("(.*)" ++ suffix ++ "$") [anchored, dollar_endonly] > -- The prefix is in the captured sub-pattern at index 1.-> in seqCatMaybes (fmap (\t -> fmap (!! 1) (match re t [])) (fmap name ts))+> in fmap Stem $ seqCatMaybes (fmap (\t -> fmap (!! 1) (match re t [])) (fmap name ts)) > collectMatches s ts = Seq.empty > -- Substitute the stem for the percent characters in targets and > -- prerequesites. > expand stem r@Rule{target,prereqs} = r { target = substituteStem stem target > , prereqs = map (substituteStem stem) prereqs }->++Also instantiate meta-rules whose patterns are regular expressions.++> instantiateRE :: Seq Target -- ^ Targets.+> -> Seq (Stem -> Rule a Target)+> -> Seq (Rule a Target)+> instantiateRE targets closures = join $ fmap f closures where+> f clo = let schema = target (clo undefined)+> matchdata = collectMatches schema targets+> in fmap (\(match, subs) -> expand match subs (clo subs)) matchdata+> collectMatches (REPattern re_string) ts =+> let re = compile re_string []+> -- Match is first element, captured submatches are in the tail.+> in fmap (\xs -> (head xs, RESubMatches (tail xs))) $+> seqCatMaybes (fmap (\t -> match re t []) (fmap name ts))+> collectMatches s ts = Seq.empty+> -- Substitute match for target and submatches for references in+> -- prerequesites.+> expand match submatches r@Rule{target,prereqs} =+> r { target = File match+> , prereqs = map (substituteStem submatches) prereqs }+ > instantiateRecurse :: Seq Target > -> Seq (Stem -> Rule a Target) > -> Seq (Rule a Target) > instantiateRecurse targets closures = > let new = evalState (go targets) Set.empty > in cleanup origrules Seq.>< new-> where origrules = fmap ($ "") closures+> where origrules = fmap ($ NoStem) closures > go targets | Seq.null targets = return Seq.empty > | otherwise = do > seen <- get-> let rules = instantiate targets closures+> let rules = --instantiate targets closures Seq.><+> instantiateRE targets closures > ts = (Set.\\ seen) $ Set.unions $ Seq.toList $ > fmap (Set.fromList . prereqs) $ > seqFilter (\r -> target r `Seq.elem` targets) origrules
Parse.lhs view
@@ -24,7 +24,6 @@ > import Data.Sequence (Seq) > import qualified Data.Sequence as Seq > import Control.Applicative hiding ((<|>), many)-> import System.FilePath (FilePath) "A mkfile consists of assignments (described under `Environment') and rules. A@@ -49,7 +48,7 @@ Rule flags, according to the mk manual for plan9: - status, the target is deleted.+D : If the recipe exits with a non-null status, the target is deleted. E : Continue execution if the recipe draws errors.
hmk.cabal view
@@ -1,5 +1,5 @@ name: hmk-version: 0.9.5+version: 0.9.6 author: Mathieu Boespflug maintainer: Mathieu Boespflug <mboes@tweag.net> homepage: http://www.github.com/mboes/hmk@@ -15,8 +15,8 @@ . The documentation is embedded in the literate Haskell source. .- /Note:/ the library portion is released to the /public- domain/. Those source files that are not part of the library+ /Note:/ the library portion is released to the /public domain/.+ Those source files that are not part of the library are released under GPLv3 or later. category: Control, Development, Distribution license: GPL@@ -28,7 +28,7 @@ library build-depends: base < 5, containers- extensions: RecursiveDo, PatternGuards+ extensions: PatternGuards exposed-modules: Control.Hmk Control.Hmk.Analyze Control.Hmk.IO@@ -38,7 +38,7 @@ main-is: Main.lhs ghc-options: -fwarn-unused-imports other-modules: Parse, Eval, Metarule- extensions: RecursiveDo, PatternGuards, NamedFieldPuns+ extensions: PatternGuards, NamedFieldPuns build-depends: base < 5, bytestring, containers, directory, process, unix, filepath >= 1.1, mtl, parsec >= 3.0.0, pcre-light >= 0.3