packages feed

Coadjute (empty) → 0.0.1

raw patch · 17 files changed

+1553/−0 lines, 17 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, bytestring-csv, containers, directory, fgl, filepath, mtl, old-time, pretty, pureMD5, regex-dfa, safe, utf8-string

Files

+ CHANGELOG.txt view
@@ -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.
+ Coadjute.cabal view
@@ -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 <matti.niemenmaa+coadjute@iki.fi>+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
+ Coadjute.hs view
@@ -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.
+ Coadjute/CoData.hs view
@@ -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
+ Coadjute/DB.hs view
@@ -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'
+ Coadjute/Hash.hs view
@@ -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
+ Coadjute/Main.hs view
@@ -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)
+ Coadjute/Rule.hs view
@@ -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)
+ Coadjute/Task.hs view
@@ -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
+ Coadjute/Task/Perform.hs view
@@ -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)
+ Coadjute/Task/Required.hs view
@@ -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
+ Coadjute/Util/File.hs view
@@ -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
+ Coadjute/Util/List.hs view
@@ -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
+ Coadjute/Util/Misc.hs view
@@ -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"
+ Coadjute/Util/Monad.hs view
@@ -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
+ LICENSE.txt view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain