module Makedo.Target (
redoMain, listing
, Target(..), RedoArgs(..)
, TargetLike(..)
, ExactTarget(..), WildcardTarget(..)
, ShowPC(..)
, redoIfChange, redo, stampAll
, runVerbosely
) where
import HSH
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import System.IO
data Target = Target
{ match :: FilePath -> Bool
, description :: (String, String)
, action :: RedoArgs -> IO ()
}
data RedoArgs = RedoArgs
{ rwrite :: FilePath
, rname :: FilePath
, rext :: String
}
class ShowPC a where
showPC :: a -> String
runVerbosely :: ShellCommand a => a -> IO ()
runVerbosely cmd = run cmd >>= hPutStr stderr
data ExactTarget = ExactTarget
{ ePath :: FilePath
, eBlurb :: String
, eAction :: RedoArgs -> IO ()
}
data WildcardTarget = WildcardTarget
{ wPrefix :: FilePath
, wExtension :: String
, wBlurb :: String
, wAction :: RedoArgs -> IO ()
}
class TargetLike t where
target :: t -> Target
instance TargetLike Target where
target = id
instance TargetLike ExactTarget where
target (ExactTarget {..}) = Target (== ePath) (ePath, eBlurb) eAction
instance TargetLike WildcardTarget where
target (WildcardTarget {..}) = Target (matchDirExt wPrefix wExtension)
(wPrefix </> "*" <.> wExtension, wBlurb)
wAction
matchDirExt :: FilePath -> String -> FilePath -> Bool
matchDirExt d x f = takeDirectory f == d
&& takeExtensions f == ("" <.> x)
gussyUp :: [Target] -> [Target]
gussyUp ts = target (listing ts)
: target (listing2 ts)
: addAll ts
listing :: [Target] -> ExactTarget
listing ts = ExactTarget "targets" "list known targets" $
const $ do listingBody (filter described ts)
hPutStrLn stderr $ "Try `redo " ++ ePath (listing2 ts) ++ "` for a full list"
where
described = not . null . snd . description
listing2 :: [Target] -> ExactTarget
listing2 ts = ExactTarget "targets2" "list all known targets" $
const $ listingBody ts
listingBody :: [Target] -> IO ()
listingBody ts = hPutStr stderr . unlines . map (showd . description) $ ts
where
maxl = maximum $ map (length . fst . description) ts
padRight x = x ++ replicate (maxl length x) ' '
showd (d,blurb) = padRight d ++ " " ++ blurb
addAll :: [Target] -> [Target]
addAll ts =
if any (\t -> fst (description t) == "all") ts
then ts
else allT : ts
where
allT = target $ ExactTarget "all" "help text" $ const $ do
hPutStrLn stderr "run 'redo targets' to see your options"
exitFailure
redoMain :: [Target] -> IO ()
redoMain ts = do
args <- getArgs
case args of
[x1, x2, x3] -> fromRedo (gussyUp ts)
(RedoArgs { rwrite = x3, rname = x1, rext = x2 })
_ -> fail ("Was expecting exactly 3 arguments\n" ++
"This script should only be run by redo")
fromRedo :: [Target] -> RedoArgs -> IO ()
fromRedo ts args@(RedoArgs {rname}) =
case filter (flip match rname) ts of
[] -> fail ("No matches for " ++ rname)
ms -> mapM_ (flip action args) ms
redoIfChange :: [String] -> IO ()
redoIfChange args =
runProcess "redo-ifchange" args Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return ()
redo :: [String] -> IO ()
redo args =
runProcess "redo" args Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return ()
stampAll :: FilePath -> [String] -> IO ()
stampAll d exts_ = do
cs <- getDirectoryContents d
runIO $ ("cat", [ d </> c | c <- cs, takeExtensions c `elem` exts ]) -|- "redo-stamp"
where
exts = map ("" <.>) exts_