makedo-0.1: Makedo/Target.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

module Makedo.Target (
              -- * your main function
              redoMain, listing
              -- * creating targets
              , Target(..), RedoArgs(..)
              , TargetLike(..)
              , ExactTarget(..), WildcardTarget(..)
              , ShowPC(..)
              -- * within target actions
              , 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

-- | A makedo script is basically just a list of 'Target'
--
--   If a target matches the input file name, its action is run
data Target = Target
  { match  :: FilePath -> Bool
  , description :: (String, String) -- ^ (name, blurb) for human consumption only
  , action :: RedoArgs -> IO ()
  }

data RedoArgs = RedoArgs
  { rwrite :: FilePath  -- ^ temporary file managed by redo; write your output here
                        --   or to stdout; it will be renamed to 'rname' if the rule
                        --   is successful
  , rname  :: FilePath  -- ^ desired filename
  , rext   :: String
  }

-- | Useful for targets that take parameters which you want to
--   convert into path components
class ShowPC a where
  showPC    :: a -> String

runVerbosely :: ShellCommand a => a -> IO ()
runVerbosely cmd = run cmd >>= hPutStr stderr

-- ----------------------------------------------------------------------

-- | Targets that use an exact filename match
data ExactTarget = ExactTarget
  { ePath  :: FilePath
  , eBlurb :: String
  , eAction :: RedoArgs -> IO ()
  }

data WildcardTarget = WildcardTarget
 { wPrefix    :: FilePath
 , wExtension :: String   -- ^ as recognised by System.FilePath
 , 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) -- NB <.> is clever about not duping

-- ----------------------------------------------------------------------

gussyUp :: [Target] -> [Target]
gussyUp ts = target (listing ts)
           : target (listing2 ts)
           : addAll ts

-- | Special target that prints out the targets you can run
--   Note that makedo automatically includes this
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

-- | Special target that prints out the targets you can run
--   Note that makedo automatically includes this
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

-- | Your main function should probably just invoke this and do nothing
--   else
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

-- Not using HSH for this because of
-- 
-- > Traceback (most recent call last):
-- >   File "/usr/local/redo/redo", line 60, in <module>
-- >    jwack.setup(j)
-- >   File "/usr/local/redo-0.06/jwack.py", line 95, in setup
-- >    raise ValueError('broken --jobserver-fds from make; prefix your Makefile rule with a "+"')
-- > ValueError: broken --jobserver-fds from make; prefix your Makefile rule with a "+"
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_