diff --git a/CHANGELOG.txt b/CHANGELOG.txt new file mode 100644 --- /dev/null +++ b/CHANGELOG.txt @@ -0,0 +1,34 @@ +0.0.1, 2009-01-18: + Initial release. + + Supported flags: + --version + --help + --verbose + --quiet + --parallel[=N] + --use-db + --no-use-db + --no-hashing + + Functions: + coadjute :: Coadjute a -> IO a + rule :: String -> [String] -> ([Source] -> Target -> IO ()) -> [SingleDatum] -> Coadjute () + ruleM :: String -> [String] -> ([Source] -> [Target] -> IO ()) -> [MultiDatum] -> Coadjute () + sourceToDatum :: (Source -> ([Source], a)) -> [Source] -> [TaskDatum a] + rule' :: String -> ([Source] -> Target -> IO ()) -> [SingleDatum] -> Coadjute () + ruleM' :: String -> ([Source] -> [Target] -> IO ()) -> [MultiDatum] -> Coadjute () + sourceToDatum' :: (Source -> a) -> [Source] -> [TaskDatum a] + getUserArgs :: Coadjute [String] + + Types: + data Coadjute a + type Source = FilePath + type Target = FilePath + data TaskDatum a + type SingleDatum = TaskDatum Target + type MultiDatum = TaskDatum [Target] + + Dependencies: base, array, bytestring, containers, directory, filepath, + mtl, old-time, pretty, bytestring-csv, fgl, pureMD5, + regex-dfa, safe, utf8-string. diff --git a/Coadjute.cabal b/Coadjute.cabal new file mode 100644 --- /dev/null +++ b/Coadjute.cabal @@ -0,0 +1,68 @@ +Cabal-Version: >= 1.2 + +Name: Coadjute +Version: 0.0.1 +Homepage: http://iki.fi/matti.niemenmaa/coadjute/ +Synopsis: A generic build tool +Category: Development +Stability: experimental +Description: + Coadjute is a generic build tool, intended as an easier to use and more + portable replacement for make. It's not tailored toward any particular + language, and is not meant to replace tools which target a specific + environment. + + Portability is striven towards in two ways: + - You don't have to deal with the idiosyncrasies of many make implementations + (well, people don't, but they call their GNU Make files makefiles + instead of GNUmakefiles, which causes misunderstandings). + - You have Haskell at your disposal, and are encouraged to use that + whenever possible instead of system-specific binaries like the POSIX + commands we all know and love. + + With support for: + - Parallel task performing. + - Advanced out-of-dateness detection: + - Choice between timestamps and hashes. + - Keeping track of what arguments have been passed. + - Haskell! + +Author: Matti Niemenmaa +Maintainer: Matti Niemenmaa +License: BSD3 +License-File: LICENSE.txt + +Build-Type: Simple + +Extra-Source-Files: CHANGELOG.txt + +-- Executable coadjute +-- Main-Is: Main.hs +-- Build-Depends: base +-- Other-Modules: ?? + +Library + Build-Depends: base >= 4 && < 5 + , array >= 0.1 && < 0.3 + , bytestring >= 0.9 && < 0.10 + , containers >= 0.2 && < 0.3 + , directory >= 1.0 && < 1.1 + , filepath >= 1.1 && < 1.2 + , mtl >= 1.1 && < 1.2 + , old-time >= 1.0 && < 1.1 + , pretty >= 1.0.1 && < 1.1 + , bytestring-csv >= 0.1.2 && < 0.2 + , fgl >= 5.4 && < 5.5 + , pureMD5 >= 0.2.4 && < 0.3 + , regex-dfa >= 0.91 && < 1 + , safe >= 0.2 && < 0.3 + , utf8-string >= 0.3 && < 0.4 + + Exposed-Modules: Coadjute + + Other-Modules: Coadjute.CoData, Coadjute.Main + , Coadjute.Rule, Coadjute.Task + , Coadjute.DB, Coadjute.Hash + , Coadjute.Task.Perform, Coadjute.Task.Required + , Coadjute.Util.File, Coadjute.Util.List + , Coadjute.Util.Misc, Coadjute.Util.Monad diff --git a/Coadjute.hs b/Coadjute.hs new file mode 100644 --- /dev/null +++ b/Coadjute.hs @@ -0,0 +1,117 @@ +-- File created: 2008-07-19 17:53:12 + +-- | Coadjute is a generic build tool, intended as an easier to use and more +-- portable (in the sense that implementations don't differ) replacement for +-- make. It's not tailored toward any particular language, and is not meant to +-- replace tools which target a specific environment. +-- +-- An example of simple usage: +-- +-- > import Coadjute +-- > import System.Directory +-- > +-- > main = coadjute $ do +-- > rule' "Copy foo from src to obj" +-- > (\[s] t -> copyFile s t) +-- > (sourceDatum' (("obj"++) . drop 3) ["src/foo"]) +-- +-- By convention, this file should be called /Adjutant.hs/. +-- +-- Compiled and run, it would copy @src\/foo@ to @obj\/foo@ whenever @src\/foo@ +-- is older than @obj\/foo@. With @-d@ or @--use-db@ passed, it would hash +-- (currently MD5) @src/foo@, using that instead of modification time data to +-- decide whether to run the @copyFile@ or not. +module Coadjute + ( -- * Coadjute blocks + -- + -- | When using Coadjute, you give it all the information it needs within + -- a monad inspiringly called 'Coadjute'. Use 'coadjute' to escape into + -- the IO monad, letting Coadjute do all your hard work for you. + Coadjute + , coadjute + -- ** Defining rules + -- $rules + , rule, ruleM + , sourceToDatum + -- *** Convenience functions + -- $convenience + , rule', ruleM' + , sourceToDatum' + -- ** Other functions within Coadjute + , getUserArgs + -- ** Sources and Targets + -- $sourcesTargets + , Source, Target + -- * TaskDatum + -- $taskdata + , TaskDatum, SingleDatum, MultiDatum + ) where + +import Coadjute.Main (coadjute) +import Coadjute.Rule ( Coadjute + , rule, rule', ruleM, ruleM' + , sourceToDatum, sourceToDatum', getUserArgs + , TaskDatum, SingleDatum, MultiDatum + ) +import Coadjute.Task (Source, Target) + +-- $sourcesTargets +-- +-- Sources and targets are both paths to files or directories. + +-- $taskdata +-- +-- These types pair up a target or targets with a list of dependencies. + +-- $rules +-- +-- These are the primary functions available to you inside a 'Coadjute' block: +-- each one adds a single build rule, on the basis of which many build tasks +-- may be constructed. +-- +-- Each function takes: +-- +-- * A name for the rule. +-- +-- * A build action: this function will be run if the dependencies are deemed +-- out of date compared to the target. +-- +-- * 'TaskDatum's: dependencies paired up with targets. +-- +-- For instance, you might have a rule \"C files\" which handles building of C +-- code, thus: +-- +-- > rule' "C files" +-- > (\_ c -> system ("gcc -c " ++ c)) +-- > (sourceToDatum' (reverse.('o':).drop 1 . reverse) ["foo.c","bar.c"]) +-- +-- This example also demonstrates poor practices: you should really use +-- 'sourceToDatum' and specify complete dependency data, such as header files. +-- +-- The above example did not use command line arguments, so let's have a look +-- at those. Let's say you want to build either a debug or a release version of +-- your program, depending on a flag you pass in. Since this flag will affect +-- all your object files, you want to tell Coadjute that you're interested in +-- it: +-- +-- > rule "C files" ["--debug"] ... +-- +-- Now, if you've built your C files in release mode and want to switch to +-- debug mode, Coadjute will know to rebuild even those files which you haven't +-- changed, based simply on the fact that last time you did not pass @--debug@ +-- and this time you did. +-- +-- You must still handle the flag's presence yourself using 'getUserArgs' and +-- acting on it: the @[String]@ parameter is simply to tell Coadjute which +-- flags that particular rule is affected by. +-- +-- For now, only boolean flags are supported: either they're present or not. +-- +-- Note that you must build with @-d@ to store the argument data. You need +-- specify this only the first time: as long as the database exists it will be +-- used. + +-- $convenience +-- +-- @rule'@ and @ruleM'@ are a pair of convenience functions for when you don't +-- care about command line arguments. diff --git a/Coadjute/CoData.hs b/Coadjute/CoData.hs new file mode 100644 --- /dev/null +++ b/Coadjute/CoData.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +-- File created: 2008-03-23 20:18:32 + +-- |The main monad used internally, and what it stores. +module Coadjute.CoData + ( CoData, asks, runCoData + , CoadjuteData ( coArgs + , coUserArgs + , coVerbosity + , coForceDB + , coForceNoDB + , coForceNoHash + , coDBExists + , coParallel + , coParallelOpt + ) + , coUsingDB + , dbFileName + , Verbosity(..) + , ParallelOpt(..) + , io, MonadIO + ) where + +import Control.Arrow (first, second) +import Control.Monad (foldM, when) +import Control.Monad.Reader (ReaderT, runReaderT, asks) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.List (nub, partition) +import qualified Data.Set as Set +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitWith, ExitCode(..)) +import System.IO (hPutStrLn, stderr) +import Text.Printf (printf) +import Text.PrettyPrint.HughesPJ (renderStyle, style, Style(..), fsep, text) +import Text.Regex.DFA + +import Coadjute.Util.Misc (mread) + +dbFileName :: FilePath +dbFileName = ".coadjute.db" + +versionString :: String +versionString = "0.0.1" + +getHelpString :: IO String +getHelpString = do + pn <- getProgName + return . flip usageInfo (optDesc undefined) . unlines . map prettify $ + [ printf "Usage: %s [-dqvDH] [-p[N]] [USERARGS...]" pn + , "" + , "Apply the build rules specified in the Adjutant to construct build\ + tasks. Then run those tasks which are necessary. Any USERARGS are\ + passed through to the tasks." + , "" + , printf "If a database (%s) exists, it is used by default unless -D is\ + passed." + dbFileName + ] + where + prettify = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) + . fsep . map text . words + +type CoData = ReaderT CoadjuteData IO + +runCoData :: CoData a -> IO a +runCoData co = do + dbExists <- doesFileExist dbFileName + + helpString <- getHelpString + args <- getArgs + let (opts,[],otherOpt,_) = getOpt' (ReturnInOrder (handleNonOpt helpString)) + (optDesc helpString) + args + + let (helpRequests, userOpts) = partition isHelp otherOpt + + let initialMsgs = if null helpRequests then [] else [(helpString,True)] + defaultData = + CoadjuteData + { coArgs = Set.fromList args + , coUserArgs = userOpts + , coVerbosity = Normal + , coDBExists = dbExists + , coForceDB = False + , coForceNoDB = False + , coForceNoHash = False + , coParallel = False + , coParallelOpt = Uncapped + } + (coData,msgs) = foldl (\cd optFunc -> optFunc cd) + (defaultData,initialMsgs) + opts + + when (not.null $ msgs) . io $ do + anyErr <- foldM (\a (s,err) -> + if err + then hPutStrLn stderr s >> return True + else putStrLn s >> return a + ) False (nub.reverse $ msgs) + exitWith (if anyErr then ExitFailure 1 else ExitSuccess) + + runReaderT co coData + +data CoadjuteData = CoadjuteData + { coArgs :: Set.Set String + , coUserArgs :: [String] + , coVerbosity :: Verbosity + , coDBExists :: Bool + , coForceDB :: Bool + , coForceNoDB :: Bool -- double negatives result, but this way one can + , coForceNoHash :: Bool -- think in terms of command line options + , coParallel :: Bool + , coParallelOpt :: ParallelOpt + } + +type OptionData = (CoadjuteData, [(String,Bool)]) + +coUsingDB :: CoadjuteData -> Bool +coUsingDB d = coForceDB d || (coDBExists d && not (coForceNoDB d)) + +data Verbosity = Quiet | Normal | Verbose | VeryVerbose deriving (Eq, Ord) +data ParallelOpt = + Capped Int | Uncapped +#ifdef __GLASGOW_HASKELL__ + | Processor +#endif + +optDesc :: String -> [OptDescr (OptionData -> OptionData)] +optDesc helpString = map (\(Option s l d msg) -> Option s l d (prettify msg)) + [ Option "V" ["version"] + (NoArg$ second ((versionString,True):)) + "Output version string and exit." + + , Option "h" ["help"] + (NoArg$ second ((helpString,True):)) + "Output this help string and exit." + + , Option "v" ["verbose"] + (noArg$ \o@(CoadjuteData {coVerbosity = v}) -> + o { coVerbosity = + if v == Verbose || v == VeryVerbose + then VeryVerbose + else Verbose } + ) + "Verbose output. Specify twice for more verbosity." + + , Option "q" ["quiet"] + (noArg$ \o -> o {coVerbosity = Quiet}) + "Quiet output." + + , Option "p" ["parallel"] + (flip OptArg "N" $ \ma (o,s) -> + let o' = o { coParallel = True } + err m = "Invalid parallel count, expected integer: '" ++ m ++ "'" + in case ma of + Nothing -> (o' { coParallelOpt = Uncapped },s) + Just a -> + let mn = mread a + in case mn of + Nothing -> (o', (err a,False) : s) + Just 1 -> (o, s) + Just n -> + (o' { coParallelOpt = + case compare n 0 of +#ifdef __GLASGOW_HASKELL__ + LT -> Processor +#else + LT -> Capped (abs n) +#endif + GT -> Capped n + EQ -> Uncapped }, s)) + ("Perform tasks in parallel, up to N at a time. If N is negative, the "++ +#ifdef __GLASGOW_HASKELL__ + "number of OS threads (i.e. the +RTS -N setting) is used."++ +#else + "absolute value is used."++ +#endif + " If N is zero or not given, the number of simultaneous tasks will\ + not be limited. If N is 1, the argument is ignored.") + + , Option "d" ["use-db"] + (noArg$ \o -> o {coForceDB = True}) + ("Use a database, creating one if it doesn't exist. If one does\ + exist, it is used by default.") + + , Option "D" ["no-use-db"] + (noArg$ \o -> o {coForceNoDB = True}) + "Don't use a database even if one exists." + + , Option "H" ["no-hashing"] + (noArg$ \o -> o {coForceNoHash = True}) + "Use timestamps, instead of hashes in the database. The database will\ + be used only to store USERARGS specified for storage in the Adjutant." + ] + where + -- like NoArg and OptArg, but works inside OptionData + noArg = NoArg . first + + prettify = renderStyle (style {lineLength = 80}) . fsep . map text . words + +helpRegex :: Regex +helpRegex = + makeRegexOpts CompOption { caseSensitive = False, multiline = False } + defaultExecOpt + "^(--?|/)([?]|h(e?lp)?)$" + +isHelp :: String -> Bool +isHelp = matchTest helpRegex + +handleNonOpt :: String -> String -> OptionData -> OptionData +handleNonOpt helpString opt (cd,s) = + if isHelp opt + then (cd, (helpString,True):s) + else (cd { coUserArgs = opt : coUserArgs cd }, s) + +-- |A convenience. +io :: (MonadIO m) => IO a -> m a +io = liftIO diff --git a/Coadjute/DB.hs b/Coadjute/DB.hs new file mode 100644 --- /dev/null +++ b/Coadjute/DB.hs @@ -0,0 +1,208 @@ +-- File created: 2008-01-22 20:44:58 + +module Coadjute.DB ( + Datum, hasHash, dArgs, + DB (hasHashes), addEntry, dbLookup, + MDB, loadDataBase, writeDataBase) where + +import Control.Arrow ((>>>)) +import Control.Monad (forM_, unless, when, (>=>)) +import Control.Monad.Cont (ContT, runContT, callCC) +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.UTF8 as U8 +import Data.Char (isSpace) +import Data.List (intersperse, mapAccumR) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Map (Map) +import Data.Set (Set) +import Safe (readDef) +import System.IO (withFile, IOMode (WriteMode), hPutStrLn) +import Text.CSV.ByteString (CSV, Record, Field, parseCSV) +import Text.Printf (printf) + +import Coadjute.CoData +import Coadjute.Hash (Hash, readHash, showHash) +import Coadjute.Util.List (replaceList) + +-- Command line arguments and an optional Hash. +data Datum = Datum (Set String) (Maybe Hash) + +dArgs :: Datum -> Set String +dArgs (Datum a _) = a + +hasHash :: Datum -> Hash -> Bool +(Datum _ Nothing) `hasHash` _ = False +(Datum _ (Just h)) `hasHash` h' = h == h' + +type MDB = Maybe DB +data DB = DB + { dbData :: Map FilePath Datum + , hasHashes :: Bool + } + +addEntry :: DB -> FilePath -> Set String -> Maybe Hash -> DB +addEntry db file args hash = + DB (Map.insert file (Datum args hash) (dbData db)) (hasHashes db) + +dbLookup :: DB -> FilePath -> Maybe Datum +dbLookup = flip Map.lookup . dbData + +loadDataBase :: CoData MDB +loadDataBase = (`runContT` return) . callCC $ \exit -> do + verbosity <- asks coVerbosity + + forceNoDB <- asks coForceNoDB + when forceNoDB (exit Nothing) + + exists <- asks coDBExists + forceDB <- asks coForceDB + unless exists $ do + unless forceDB (exit Nothing) + + notHashing <- asks coForceNoHash + exit$ Just (DB Map.empty (not notHashing)) + + parsed <- io (parseDB dbFileName) + case parsed of + Nothing -> + if forceDB + then io.ioError.userError$ + "DB explicitly requested but parse failed, aborting..." + else do + when (verbosity /= Quiet) $ + io.putStrLn $ "Ignoring DB due to parse error..." + return Nothing + Just db -> do + when (verbosity >= Verbose) $ + io$ printf + "Loaded DB containing %d entries.\n" + (Map.size . dbData $ db) + return (Just db) + +-- Reading and Writing +---------------------- + +dbVerString :: ByteString +dbVerString = U8.fromString "CoadjuteDB v1" + +{- Current DB format: + - CoadjuteDB v1 + - on its own line. Followed by datums in a CSV format: + - filename,[args],[hash] + - [] denotes optional + - + - Filenames must be listed in ascending order, and not duplicated! + - If the user messes with this, he can't expect stuff to work properly, as + - these properties are not tested here. + -} +parseDB :: FilePath -> IO (Maybe DB) +parseDB = BS.readFile >>> fmap (checkFirstLine >=> parseCSV >=> return.csvToDB) + +checkFirstLine :: ByteString -> Maybe ByteString +checkFirstLine s = + let i = fromMaybe maxBound . + BS.findIndex (`BS.elem` U8.fromString "\r\n") $ s + j = if BS.index s i == c2w '\r' then 2 else 1 + (v,d) = BS.splitAt i s + in if v == dbVerString + then Just (BS.drop j d) + else Nothing + +csvToDB :: CSV -> DB +csvToDB csv = + let (hadHashes, dats) = mapAccumR scanLine True csv + in DB (Map.fromDistinctAscList dats) hadHashes + +scanLine :: Bool -> Record -> (Bool,(String,Datum)) +scanLine _ [path] = + let p = fromCSVField path + in (False, (p, Datum Set.empty Nothing)) + +scanLine _ [path,args] = + let p = fromCSVField path + a = readDef [] . fromCSVField $ args + in (False, (p, Datum (Set.fromDistinctAscList a) Nothing)) + +scanLine hashes [path,args,hash] = + let p = fromCSVField path + a = readDef [] . fromCSVField $ args + h = fromCSVField hash + in (hashes, (p, Datum (Set.fromDistinctAscList a) + (Just .readHash $ h))) +scanLine _ s = + error$ "DB :: Invalid datum: '" ++ fromCSVField (BS.concat s) ++ "'" + +fromCSVField :: Field -> String +fromCSVField s + | BS.null s = "" + | otherwise = unquote (U8.toString s) + +-- replace "" with " +unquote :: String -> String +unquote = replaceList "\"\"" "\"" + +-- Writing +---------- + +writeDataBase :: MDB -> CoData () +writeDataBase Nothing = return () +writeDataBase (Just db) = do + io (putDB db dbFileName `catch` f) + verbosity <- asks coVerbosity + when (verbosity >= Verbose) $ + io$printf "Wrote DB containing %d entries.\n" (Map.size . dbData $ db) + where + f e = putStrLn "DB :: Failed to write DB:" >> ioError e + +putDB :: DB -> FilePath -> IO () +putDB db f = withFile f WriteMode $ \h -> do + BS.hPutStrLn h dbVerString + let csv = dbToCSV db + forM_ csv $ \record -> do + let rec' = intersperse (U8.fromString ",") (map toCSVField record) + mapM_ (BS.hPutStr h) rec' + hPutStrLn h "" + +dbToCSV :: DB -> CSV +dbToCSV = map (tupleToRecord . uncurry datToTuple) . Map.toAscList . dbData + +datToTuple :: FilePath -> Datum -> (String,String,String) +datToTuple f (Datum args mhash) = + ( f + , if Set.null args + then "" + else show (Set.toAscList args) + , maybe "" showHash mhash + ) + +tupleToRecord :: (String,String,String) -> Record +tupleToRecord (a,b,c) = map U8.fromString [a,b,c] + +toCSVField :: ByteString -> Field +toCSVField s = + if mustBeQuoted s + then quote s + else s + +mustBeQuoted :: ByteString -> Bool +mustBeQuoted s | s == BS.empty = False +mustBeQuoted s = or + [ BS.any (`BS.elem` U8.fromString ",\n\"") s + , isSpace (head . U8.toString $ s) + , isSpace (last . U8.toString $ s) + ] + +quote :: ByteString -> ByteString +quote s = BS.concat [qm, f s, qm] + where + qm = BS.singleton (c2w '"') + dqm = BS.append qm qm + f = BS.concatMap $ + \c -> let c' = BS.singleton c + in if c' == qm + then dqm + else c' diff --git a/Coadjute/Hash.hs b/Coadjute/Hash.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Hash.hs @@ -0,0 +1,19 @@ +-- File created: 2008-03-23 21:46:37 + +module Coadjute.Hash (Hash, hashFile, showHash, readHash) where + +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.ByteString.Lazy as BS + +-- depends on what's most convenient with the hash library used +type Hash = String + +hashFile :: FilePath -> IO Hash +hashFile = fmap (show . MD5.md5) . BS.readFile + +showHash :: Hash -> String +showHash = id + +-- |The length of the input string must be 32. This is not checked. +readHash :: String -> Hash +readHash = id diff --git a/Coadjute/Main.hs b/Coadjute/Main.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Main.hs @@ -0,0 +1,77 @@ +-- File created: 2008-01-20 13:56:21 + +module Coadjute.Main (coadjute) where + +import Control.Monad (when) +import Data.Function (on) +import Data.Graph.Inductive (noNodes) +import Text.Printf (printf) + +import Coadjute.CoData +import Coadjute.DB (loadDataBase, writeDataBase) +import Coadjute.Rule (Coadjute, runCoadjute, rTasks) +import Coadjute.Task +import Coadjute.Task.Perform (performTasks) +import Coadjute.Task.Required (splitUnnecessary) +import Coadjute.Util.List (fullGroupBy, nubSplitBy) + +coadjute :: Coadjute a -> IO a +coadjute st = runCoData $ do + verbosity <- asks coVerbosity + + (rules,ret) <- runCoadjute st + + -- TODO: allow selection of rules to be applied with cmdline args + let allTasks = concatMap rTasks rules + + db <- loadDataBase + + let (reasonableTasks, conflicts) = nubSplitBy sameTarget allTasks + putTaskGroups "Conflicting rules:" conflicts + + (possibleTasks, impossibles) <- splitImpossibles reasonableTasks + putTasks "Unsatisfiable dependencies:" impossibles + + let (doableTaskGraph, cycles) = splitCycles possibleTasks + putTaskGroups "Cycles in rules:" cycles + + when (verbosity >= Verbose).io $ + printf "Built graph containing %d possible tasks.\n" + (noNodes doableTaskGraph) + + (finalTaskGraph,pointless,db') <- splitUnnecessary db doableTaskGraph + + when (verbosity >= Verbose).io $ + printf "%d tasks are unnecessary.\n" + (noNodes doableTaskGraph - noNodes finalTaskGraph) + + when (verbosity >= VeryVerbose) $ + putTasks "Unnecessary tasks:" pointless + + performTasks finalTaskGraph + + writeDataBase db' + + return ret + +putTaskGroups :: MonadIO m => String -> [[Task]] -> m () +putTaskGroups _ [] = return () +putTaskGroups s xs = do + io$ putStrLn s + mapM_ putTasks' xs + +putTasks :: MonadIO m => String -> [Task] -> m () +putTasks _ [] = return () +putTasks s xs = do + io$ putStrLn s + putTasks' xs + +putTasks' :: MonadIO m => [Task] -> m () +putTasks' [] = return () +putTasks' xs = io$ + mapM_ + (\ts -> do + putStrLn $ "\tIn rule '" ++ tName (head ts) ++ "':" + mapM_ (putStrLn.("\t\t"++).showTask) ts + ) + (fullGroupBy ((==) `on` tName) xs) diff --git a/Coadjute/Rule.hs b/Coadjute/Rule.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Rule.hs @@ -0,0 +1,112 @@ +-- File created: 2008-01-12 16:06:32 + +-- |Holds the 'Rule' and 'Coadjute' types and relevant functions which act on +-- them. For user code, the important parts here are the 'rule' family of +-- functions and sourceToDatum. +module Coadjute.Rule( + Rule(..), + Coadjute, runCoadjute, + getUserArgs, + rule, ruleM, + rule', ruleM', + sourceToDatum, sourceToDatum', + TaskDatum, SingleDatum, MultiDatum +) where + +import Control.Arrow (first) +import Control.Monad.State (StateT(..), modify, gets) +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Data.Set as Set + +import Coadjute.CoData +import Coadjute.Task (Task(..), Source, Target) + +data Rule = + Rule { rName :: String + , rTasks :: [Task] + } + +data RuleList = RL [Rule] + +addRule :: Rule -> RuleList -> RuleList +addRule r (RL rs) = RL (r:rs) + +-- |Coadjute is the main monad you'll be working in. You can use the 'rule' +-- family of functions to add rules whilst within this monad, and you can have +-- a look at what arguments were given to you with 'getUserArgs'. +-- +-- For your convenience, a 'MonadIO' instance is provided. +newtype Coadjute a = Co { unCo :: StateT (RuleList, [String]) CoData a } + +instance Monad Coadjute where + return = Co . return + (Co rs) >>= f = Co (rs >>= unCo.f) + +instance MonadIO Coadjute where liftIO = Co . liftIO + +runCoadjute :: Coadjute a -> CoData ([Rule], a) +runCoadjute (Co st) = do + ua <- asks coUserArgs + (ret, (RL l, _)) <- runStateT st (RL [], ua) + return (reverse l, ret) + +-- | You should use this instead of 'System.Environment.getArgs', to let +-- Coadjute handle its own command line arguments first. +getUserArgs :: Coadjute [String] +getUserArgs = Co $ gets snd + +newtype TaskDatum a = TD ([Source], a) + +-- | A SingleDatum stores a single 'Target'. +type SingleDatum = TaskDatum Target + +-- | A MultiDatum stores multiple 'Target's, to be built all at once in one +-- action. +type MultiDatum = TaskDatum [Target] + +-- |A rule for building targets individually. +rule :: String + -> [String] + -> ([Source] -> Target -> IO ()) + -> [SingleDatum] + -> Coadjute () +rule name args action = + Co . modify . first . addRule . Rule name . + map (\(TD (d, t)) -> Task name (Set.fromList args) [t] d (action d t)) + +-- |A rule for building multiple targets at once. +ruleM :: String + -> [String] + -> ([Source] -> [Target] -> IO ()) + -> [MultiDatum] + -> Coadjute () +ruleM name args action = + Co . modify . first . addRule . Rule name . + map (\(TD (d, t)) -> Task name (Set.fromList args) t d (action d t)) + +-- | > rule' = flip rule [] +rule' :: String + -> ([Source] -> Target -> IO ()) + -> [SingleDatum] + -> Coadjute () +rule' = flip rule [] + +-- | > ruleM' = flip ruleM [] +ruleM' :: String + -> ([Source] -> [Target] -> IO ()) + -> [MultiDatum] + -> Coadjute () +ruleM' = flip ruleM [] + +-- |Use a supplied function of type @Source -> ([Source], Target)@ or @Source +-- -> ([Source], [Target])@ to turn a list of Sources to 'SingleDatum's or +-- 'MultiDatum's, for passing to one of the 'rule' functions. +-- +-- The original Source is prepended to the list of dependencies in the Datum. +sourceToDatum :: (Source -> ([Source], a)) -> [Source] -> [TaskDatum a] +sourceToDatum f = map (\x -> TD $ first (x:) (f x)) + +-- |A convenience around 'sourceToDatum' for when you don't wish to provide +-- extra dependencies. +sourceToDatum' :: (Source -> a) -> [Source] -> [TaskDatum a] +sourceToDatum' f = sourceToDatum ((,) [] . f) diff --git a/Coadjute/Task.hs b/Coadjute/Task.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Task.hs @@ -0,0 +1,127 @@ +-- File created: 2008-01-27 14:58:50 + +module Coadjute.Task( + Source, Target, + Task(..), showTask, sameTarget, + TaskGraph, + splitImpossibles, splitCycles +) where + +import Control.Exception (assert) +import Control.Monad (filterM) +import Data.Graph.Inductive (Gr, delNodes, lab, scc, mkGraph) +import Data.List (findIndex) +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as Set + +import Coadjute.CoData +import Coadjute.Util.File (allPathsExist) +import Coadjute.Util.List (length1) + +type Source = FilePath +type Target = FilePath + +-- |An Task represents the process of building a target. +data Task = + Task { + -- |The name of the Rule where the Task is from. + tName :: String, + -- |Any command line arguments which the build action may use. Archived + -- in the database so that changed args incite a rebuild. + -- + -- TODO: support more than just Strings, arbitrary OptDescr would be + -- nice. + tArgs :: Set String, + -- |The target(s) which the Task will build. If there are more than one, + -- they are all built by the action simultaneously. + tTargets :: [Target], + -- |The dependencies which must be satisfied before the Task can be + -- performed. + tDeps :: [Source], + -- |The action, which builds the target on the assumption that the + -- dependencies have been satisfied. + tAction :: IO () + } + +-- |Tasks can't be Show since the tAction can't be output meaningfully. This is +-- the next-best thing. +showTask :: Task -> String +showTask Task {tTargets = t, tDeps = d, tArgs = a} = + concat + [ "Task { tTargets = ", show t + , ", tDeps = ", show d + , ", tArgs = ", show a + , " }" + ] + +sameTarget :: Task -> Task -> Bool +sameTarget (Task {tTargets=ts}) (Task {tTargets=tz}) = any (`elem` ts) tz + +-- Tasks can't be Eq since two Tasks may be the same in every way except for +-- the tAction, which isn't Eq. +-- +-- So we define and use these instead, which compare only the targets. We can +-- do that since we can assume that sameTarget-Tasks have been removed before +-- we need to call this on them. +-- +-- An assertion is there just in case. +(=~=), (!~=) :: Task -> Task -> Bool +Task {tName = n, tTargets = t, tDeps = d} + =~= Task {tName = n', tTargets = t', tDeps = d'} = + assert + (t /= t' || (n == n' && d == d')) + (t == t') + +x !~= y = not (x =~= y) + +type TaskGraph = Gr Task () + + + +-- |Removes dependencies which cannot be satisfied --- that is to say, +-- dependencies that do not exist and are not targeted. The second element of +-- the tuple returned contains the removed dependencies. +splitImpossibles :: [Task] -> CoData ([Task], [Task]) +splitImpossibles ts = do + let targets = concatMap tTargets ts + deps = map (\t -> (t, tDeps t)) ts + untargetedDeps = filter (any (`notElem` targets) . snd) deps + + impossibleDeps <- io$ filterM (fmap not.allPathsExist.snd) untargetedDeps + + let impossibleTasks = map fst impossibleDeps + + return (filter (\x -> all (!~= x) impossibleTasks) ts, impossibleTasks) + +-- |Returns a (graph of tasks, cycles) pair. All cycles are removed from the +-- graph. +splitCycles :: [Task] -> (TaskGraph, [[Task]]) +splitCycles tasks = (delNodes (concat cycleNodes) graph, cycles) + where + pairs = toPairs tasks + edges = toEdges tasks pairs + graph = mkGraph (zip [0..] tasks) edges + cycleNodes = filter (not.length1) . scc $ graph + cycles = (map.map) (fromJust . lab graph) cycleNodes + +-- |For each Task, finds all those which target any of its dependencies. +toPairs :: [Task] -> [(Task, [Task])] +toPairs tasks = map (\t -> (t, findDependencies t)) tasks + where + findDependencies :: Task -> [Task] + findDependencies task = filter (`targets` (tDeps task)) tasks + + targets :: Task -> [Source] -> Bool + targets (Task {tTargets = ts}) = any (`elem` ts) + +-- |fst of each resulting element is the index of the dependency in the pairs +-- |snd of each resulting element is the index of the target in the pairs +toEdges :: [Task] -> [(Task, [Task])] -> [(Int, Int, ())] +toEdges tasks pairs = + let toIndex t = fromJust $ findIndex (=~= t) tasks + in concatMap + (\(target, deps) -> + let tarIdx = toIndex target + in map (\dep -> (toIndex dep, tarIdx, ())) deps) + pairs diff --git a/Coadjute/Task/Perform.hs b/Coadjute/Task/Perform.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Task/Perform.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +-- File created: 2008-05-30 19:23:00 + +module Coadjute.Task.Perform (performTasks) where + +import Control.Monad (foldM, foldM_, forM_, unless, when) +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar, putMVar) +import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) +import qualified Control.Exception as C +import Data.Array.IO (IOUArray, newArray, readArray, writeArray) +import Data.Graph.Inductive (Node, pre, suc, nodes, lab, noNodes, nodeRange) +import Data.IntSet (IntSet) +import qualified Data.IntSet as Set +import Data.List (intercalate) +import Data.Maybe (fromJust) +import System.Directory (createDirectoryIfMissing) +import System.IO (hPutStrLn, stderr) +import System.FilePath (dropFileName) +import Text.Printf (printf, hPrintf) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc (numCapabilities) +#endif + +import Coadjute.CoData +import Coadjute.Task (Task(tTargets, tAction), TaskGraph) +import Coadjute.Util.Misc (plural) + +performTasks :: TaskGraph -> CoData () +performTasks gr = do + parallel <- asks coParallel + if parallel + then parallelPerformTasks gr + else linearPerformTasks gr + +targetString :: Task -> String +targetString = intercalate "," . tTargets + +printMessage :: Verbosity -> Task -> IO () +printMessage v = when (v >= VeryVerbose) . printf "%s...\n" . targetString + +performTask :: Task -> IO String +performTask t = do + -- create directories for a's targets if they don't exist + mapM_ (createDirectoryIfMissing True . dropFileName) (tTargets t) + + (tAction t >> return "") `C.catch` handler + where + handler :: C.SomeException -> IO String + handler = + return . printf "%s failed! %s" (targetString t) . show + -- TODO: remove the targets or we're left with something half-done + -- + -- somewhat nontrivial since I can't find a lib that would handle + -- symlinks properly on all platforms, and System.Directory's + -- removeDirectoryRecursive traverses symlinks + +-- roots are nodes at which no edges end +roots :: TaskGraph -> [Node] +roots graph = filter (null . pre graph) (nodes graph) + +linearPerformTasks :: TaskGraph -> CoData () +linearPerformTasks gr = do + verbosity <- asks coVerbosity + let n = noNodes gr + when (verbosity >= Verbose).io $ printf + "Performing %d tasks linearly.\n" n + + io $ foldM_ (f verbosity) Set.empty (roots gr) + where + f :: Verbosity -> IntSet -> Node -> IO IntSet + f verbosity visited x = + if x `Set.member` visited + then return visited + else do + vs <- foldM (f verbosity) visited (suc gr x) + let task = fromJust . lab gr $ x + printMessage verbosity task + s <- performTask task + when (not.null $ s) $ hPutStrLn stderr s + return (Set.insert x vs) + +-- The task and the channel to notify when the action is completed +data Message = KeepGoing Task (Chan ()) + | ErrorMessage String + | Done +type ManagerChan = Chan Message +type VisitedArray = IOUArray Node Bool + +parallelPerformTasks :: TaskGraph -> CoData () +parallelPerformTasks gr = do + opt <- asks coParallelOpt + verbosity <- asks coVerbosity + + let cap = case opt of + Uncapped -> Nothing + Capped c -> Just c +#ifdef __GLASGOW_HASKELL__ + Processor -> Just numCapabilities +#endif + + io$ do + when (verbosity >= Verbose) $ do + let n = noNodes gr + printf "Performing %d task%s in parallel, " n (plural n) + case cap of + Nothing -> putStrLn "with no limit to the simultaneity." + Just c -> printf "running at most %d at a time.\n" c + + -- setup: no nodes have been visited + arr <- newArray (nodeRange gr) False + visited <- newMVar arr + + -- set the manager thread rolling + managerDone <- newEmptyMVar + managerChan <- newChan + forkIO $ do + manage verbosity cap managerChan + putMVar managerDone () + + -- and let's get to work. + let rs = roots gr + doneChan <- fork gr visited managerChan rs + waitFor rs doneChan + writeChan managerChan Done + takeMVar managerDone + +manage :: Verbosity -> Maybe Int -> ManagerChan -> IO () +manage verbosity limit chan = + case limit of + Nothing -> + doManagement Nothing undefined undefined + Just cap -> do + running <- newQSem cap + doManagement (Just running) waitQSem signalQSem + where + doManagement :: Maybe QSem -> (QSem -> IO ()) -> (QSem -> IO ()) -> IO () + doManagement cap wait signal = do + let + loop n = do + msg <- readChan chan + case msg of + Done -> return n + ErrorMessage err -> do + hPutStrLn stderr err + loop (n+1) + KeepGoing task doneChan -> do + maybe (return ()) wait cap + printMessage verbosity task + forkIO $ do + s <- performTask task + when (not.null $ s) (writeChan chan (ErrorMessage s)) + writeChan doneChan () + maybe (return ()) signal cap + loop n + + n <- loop (0 :: Int) + when (n /= 0) $ hPrintf stderr "%d error%s occurred!\n" n (plural n) + +fork :: TaskGraph -> MVar VisitedArray -> ManagerChan -> [Node] -> IO (Chan ()) +fork gr visited manager xs = do + doneChan <- newChan + forM_ xs (forkIO . traverse gr visited manager doneChan) + return doneChan + +waitFor :: [Node] -> Chan () -> IO () +waitFor xs = forM_ xs . const . readChan + +traverse :: TaskGraph -> MVar VisitedArray -> ManagerChan + -> Chan () -> Node -> IO () +traverse gr visited manager doneChan x = do + + -- do nothing if we've been here before + -- and set that we have been here if we haven't + vis <- takeMVar visited + been <- readArray vis x + unless been (writeArray vis x True) + putMVar visited vis + + unless been $ do + let nexts = suc gr x + task = fromJust . lab gr $ x + + unless (null nexts) $ do + let (n:ns) = nexts + doneChan' <- fork gr visited manager ns + traverse gr visited manager doneChan' n + waitFor ns doneChan' + + writeChan manager (KeepGoing task doneChan) diff --git a/Coadjute/Task/Required.hs b/Coadjute/Task/Required.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Task/Required.hs @@ -0,0 +1,173 @@ +-- File created: 2008-09-20 12:28:56 + +module Coadjute.Task.Required (splitUnnecessary) where + +import Control.Monad (foldM, when) +import Control.Monad.State (get, put, StateT, runStateT) +import Data.Graph.Inductive (labNodes, delNodes) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Set (Set) +import qualified Data.Set as Set +import System.Directory (getModificationTime) +import System.Time (ClockTime) + +import Coadjute.CoData +import Coadjute.DB ( MDB, DB (hasHashes), addEntry + , Datum, dbLookup, hasHash, dArgs) +import Coadjute.Hash (Hash, hashFile) +import Coadjute.Task (TaskGraph, Task(..), Target) +import Coadjute.Util.File (allPathsExist) +import Coadjute.Util.Monad (anyM) + +-- |Returns a (targets to be built, up to date targets, database) triple. +-- +-- The database is updated here, because we may need to hash here to decide +-- whether something needs to be built. Thus if we would not do updating here, +-- we would need to rehash something later on. +-- +-- It's possible that some tasks are removed from the 'to be run' list later, +-- but Datums for them are generated here anyway. Such should be removed by the +-- caller to keep the DB slim. +splitUnnecessary :: MDB -> TaskGraph -> CoData (TaskGraph, [Task], MDB) +splitUnnecessary mdb gr = + let tNodes = labNodes gr + tasks = map snd tNodes + f = do + usingDB <- asks coUsingDB + if usingDB && isJust mdb + then do + let db = fromJust mdb + checkDep <- selectCheckDepFunc db + (needs,db') <- + foldM (needsBuildingWithDB checkDep) ([],db) tasks + + return (reverse needs, Just db') + else do + needs <- io$ mapM needsBuildingWithoutDB tasks + return (needs, mdb) + in do + (needs, mdb') <- f + let (upToDateNodes, upToDateTasks) = + unzip . map snd . filter (not.fst) $ zip needs tNodes + return (delNodes upToDateNodes gr, upToDateTasks, mdb') + +-- This needs to be lazy, which is why we use anyM. +-- (needsBuildingByTimeStamp throws if a target does not exist) +needsBuildingWithoutDB :: Task -> IO Bool +needsBuildingWithoutDB t = + anyM ($t) [needsBuildingByExistence, needsBuildingByTimeStamp] + +-- Do any targets not exist +needsBuildingByExistence :: Task -> IO Bool +needsBuildingByExistence = fmap not . allPathsExist . tTargets + +-- Is any target outdated +needsBuildingByTimeStamp :: Task -> IO Bool +needsBuildingByTimeStamp t = do + oldest <- getOldestModTime (tTargets t) + anyM (fmap (> oldest) . getModificationTime) (tDeps t) + +getOldestModTime :: [Target] -> IO ClockTime +getOldestModTime = fmap minimum . mapM getModificationTime + +needsBuildingWithDB :: (Task -> Bool -> IO CheckDepFunc) + -> ([Bool],DB) -> Task -> CoData ([Bool],DB) +needsBuildingWithDB getCDF (ns,db) task = do + targetsMissing <- io$ needsBuildingByExistence task + + -- Can't short circuit due to targetsMissing: we need to add entries to the + -- database even if it's True. + + checkDep <- io$ getCDF task targetsMissing + + givenArgs <- asks coArgs + let caresAboutArgs = tArgs task + + -- we need to write all Datums to the DB if args differ and even one + -- dependency needs to be rebuilt + -- at least for now, just use foldM and thus always write them all + (need, db') <- + foldM (checkDep (givenArgs `Set.intersection` caresAboutArgs) + caresAboutArgs) + targetsMissing + (tDeps task) `runStateT` db + + return (need:ns, db') + +-- useHash and useTimeStamp are two alternative functions used in +-- needsBuildingWithDB. They are applied to each dependency of a Task, +-- returning True if that dependency causes the Task to need a rebuild, and +-- modifying the database with new information about the dependency if +-- necessary. + +type CheckDepFunc = Set String -> Set String + -> Bool + -> FilePath + -> StateT DB CoData Bool + +selectCheckDepFunc :: DB -> CoData (Task -> Bool -> IO CheckDepFunc) +selectCheckDepFunc db = do + forceNoHash <- asks coForceNoHash + let hashing = not forceNoHash && hasHashes db + + if hashing + then return$ \_ _ -> return useHash + else return$ \task targetsMissing -> + if targetsMissing + then return (useTimeStamp Nothing) + else do + mt <- io.getOldestModTime.tTargets $ task + return (useTimeStamp (Just mt)) + +useHash :: CheckDepFunc +useHash givenCareArgs caresAboutArgs othersNeeds source = do + hash <- io $ hashFile source + db <- get + old <- checkNewness db source givenCareArgs (Just hash) + case old of + Nothing -> return othersNeeds + Just o -> + if o `hasHash` hash && + argsMatch givenCareArgs caresAboutArgs (dArgs o) + + then return othersNeeds + else do put$ addEntry db source givenCareArgs (Just hash) + return True + +useTimeStamp :: Maybe ClockTime -> CheckDepFunc +useTimeStamp oldestMod givenCareArgs caresAboutArgs othersNeeds source = do + db <- get + old <- checkNewness db source givenCareArgs Nothing + case old of + Nothing -> checkTime + Just o -> + if argsMatch givenCareArgs caresAboutArgs (dArgs o) + then checkTime + else do + put$ addEntry db source givenCareArgs Nothing + return True + where + -- Note that the fromJust may error out if othersNeeds is True, which is why + -- we short-circuit. + -- + -- (The initial value of oldestMod, set in selectCheckDepFunc, is Nothing if + -- targetsMissing, the initial value of othersNeeds, is True.) + checkTime + | othersNeeds = return True + | otherwise = + fmap (> fromJust oldestMod) (io$ getModificationTime source) + +-- If the entry isn't already in the DB, add it. +-- Returns Just (the old entry) or Nothing. +checkNewness :: DB -> FilePath -> Set String -> Maybe Hash + -> StateT DB CoData (Maybe Datum) + +checkNewness db file givenArgs mhash = do + let entry = dbLookup db file + when (isNothing entry) $ + put$ addEntry db file givenArgs mhash + return entry + +argsMatch :: Set String -> Set String -> Set String -> Bool +argsMatch givenCareArgs caresAboutArgs builtWithArgs = + givenCareArgs == builtWithArgs `Set.intersection` caresAboutArgs diff --git a/Coadjute/Util/File.hs b/Coadjute/Util/File.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Util/File.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +-- File created: 2008-02-03 13:45:20 + +module Coadjute.Util.File( + doesPathExist, allPathsExist, + toAbsolutePath +) where + +import System.Directory (getCurrentDirectory) +import System.FilePath ((), isAbsolute) + +#if mingw32_HOST_OS +import System.Win32.Types (withTString) +import System.Win32.File (c_GetFileAttributes) +#else +import Foreign.C.String (withCString) +import Foreign.Marshal.Alloc (allocaBytes) +import System.FilePath + (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator) +import System.Posix.Internals (sizeof_stat, lstat) +#endif + +import Coadjute.Util.Monad (allM) + +-- A significant optimization over using System.Directory functions. +doesPathExist :: FilePath -> IO Bool +#if mingw32_HOST_OS +doesPathExist = flip withTString (fmap (/= 0xffffffff).c_GetFileAttributes) +#else +doesPathExist s = + allocaBytes sizeof_stat $ \p -> + withCString + (if isDrive s + then addTrailingPathSeparator s + else dropTrailingPathSeparator s) + $ \c -> fmap (==0) (lstat c p) +#endif + +allPathsExist :: [FilePath] -> IO Bool +allPathsExist = allM doesPathExist + +toAbsolutePath :: FilePath -> IO FilePath +toAbsolutePath p = + if isAbsolute p + then return p + else fmap ( p) getCurrentDirectory diff --git a/Coadjute/Util/List.hs b/Coadjute/Util/List.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Util/List.hs @@ -0,0 +1,84 @@ +-- File created: 2008-02-02 19:40:11 + +module Coadjute.Util.List( + -- * Extensions of standard functions + fullGroupBy, + -- * Replacing sublists + replaceList, replaceListOnce, maxReplaceList, + -- * Miscellaneous + nubSplitBy, + length1 +) where + +import Data.List + +-- |(Elements in the list that appear only once, groups of elements which +-- appear more than once.) +-- +-- > nubSplitBy (==) [1,2,3,1,4,5,2] == ([3,4,5],[[1,1],[2,2]]) +nubSplitBy :: (a -> a -> Bool) -> [a] -> ([a], [[a]]) +nubSplitBy rel xs = + ( filter (`notElemm` nubParts) nubs + , fullGroupBy rel . filter (`elemm` nubParts) $ xs) + where nubs = nubBy rel xs + nubParts = xs \\\ nubs + elemm = any . rel + notElemm x = not . elemm x + (\\\) = deleteFirstsBy rel + +{- +prop_nubSplitPreserves :: [Int] -> Bool +prop_nubSplitPreserves xs = + let (ns,rs) = nubSplitBy (==) xs + in sort (ns ++ concat rs) == sort xs +-} + +-- |Like 'groupBy', but makes groups from the whole list, not only consecutive +-- elements. Essentially '\f -> groupBy f . sort' but doesn't need an Ord +-- instance. +-- +-- > fullGroupBy (==) [1,2,3,1,4,5] == [[1,1],[2],[3],[4],[5]] +-- > fullGroupBy (==) "mississippi" == ["m", "iiii", "ssss", "pp"] +fullGroupBy :: (a -> a -> Bool) -> [a] -> [[a]] +fullGroupBy rel xs = map (\a -> filter (rel a) xs) (nubBy rel xs) + +{- +prop_groupSorted :: [Int] -> Bool +prop_groupSorted xs = sort (fullGroupBy (==) xs ) + == sort ( groupBy (==) (sort xs)) +-} + +-- |Returns 'True' for single-element lists and 'False' for all others. +length1 :: [a] -> Bool +length1 [_] = True +length1 _ = False + +-- |Replaces one list with another as many times as requested. +-- +-- > maxReplaceList 3 "ab" "--" "|abc1abc2abc3abc|" == "|--c1--c2--c3abc|" +maxReplaceList :: Eq a => Int -> [a] -> [a] -> [a] -> [a] +maxReplaceList times what with s = + if times < 0 + then error "maxReplaceList :: negative count" + else go times s + where + len = length what + go _ [] = [] + go 0 xs = xs + go n xs@(c:cs) = + let (prefix,rest) = splitAt len xs + in if prefix == what + then with ++ go (n-1) rest + else c : go n cs + +-- |Performs one replacement of the first sublist with the second. +-- +-- > replaceListOnce "abc" "-" "abcdefabc" == "-defabc" +replaceListOnce :: Eq a => [a] -> [a] -> [a] -> [a] +replaceListOnce = maxReplaceList 1 + +-- |Like 'maxReplaceList', but replaces throughout the list. +-- +-- > replaceList "abc" "--" "abcdefabc" == "--def--" +replaceList :: Eq a => [a] -> [a] -> [a] -> [a] +replaceList = maxReplaceList maxBound diff --git a/Coadjute/Util/Misc.hs b/Coadjute/Util/Misc.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Util/Misc.hs @@ -0,0 +1,30 @@ +-- File created: 2008-03-23 20:09:47 + +module Coadjute.Util.Misc + ( eitherToMaybe + , mread + , partitionEithers + , plural + ) where + +import Data.Char (isSpace) + +partitionEithers :: [Either a b] -> ([a], [b]) +partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe = either (const Nothing) Just + +-- |Like @Prelude.read@, but gives @Nothing@ on failure or ambiguity. +mread :: Read a => String -> Maybe a +mread s = + case reads s of + [(x,r)] -> if all isSpace r then Just x else Nothing + _ -> Nothing + +plural :: Integral a => a -> String +plural 1 = "" +plural _ = "s" diff --git a/Coadjute/Util/Monad.hs b/Coadjute/Util/Monad.hs new file mode 100644 --- /dev/null +++ b/Coadjute/Util/Monad.hs @@ -0,0 +1,20 @@ +-- File created: 2008-02-24 21:12:25 + +module Coadjute.Util.Monad (anyM, allM, whenM, whileM, untilM) where + +import Control.Monad (liftM, when) + +anyM, allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM p (x:xs) = p x >>= \b -> if b then return True else anyM p xs + +allM _ [] = return True +allM p (x:xs) = p x >>= \b -> if b then allM p xs else return False + +whenM :: (Monad m) => m Bool -> m a -> m () +whenM cond body = cond >>= \c -> when c (body >> return ()) + +whileM, untilM :: (Monad m) => m Bool -> m a -> m () +whileM cond body = whenM cond (body >> whileM cond body) + +untilM = whileM . liftM not diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,24 @@ +Copyright (c) 2008-2009, Matti Niemenmaa +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the project nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain