module Development.Hake (
  Rule
, hake
, hakeT
, hakefileIs

, file
, task
, rule
, dflt
, mkfl

, lift
, systemE
, getSrcs
, isSuffixOf
, changeSuffix
, ExitCode(ExitSuccess)
) where

import System.Environment           (getArgs)
import Data.List                    (isSuffixOf)
import System.Exit                  (ExitCode(ExitSuccess), exitWith)
import System.Cmd                   (system)
import System.Directory             (doesFileExist)
import Control.Applicative          ((<$>))
import Development.Hake.HiddenTools (isOldThanSomeOf, runHake, hakefileUpdateOption)
import Control.Monad.Reader         (asks, ReaderT(runReaderT), lift)
#ifdef DEBUG
import Control.Monad.Reader         (ask)
#endif /* DEBUG */
import Control.Monad.Utils          (ifM, whenM)
import System.IO.Unsafe             (unsafeInterleaveIO
#ifdef DEBUG
                                     , unsafePerformIO
#endif /* DEBUG */
                                     )

type Targets   = [ String -> Bool ]
type Sources   = String -> SourcesRet
type Commands  = String -> [ String ] -> [ CommandRet ]
type Rule      = ( Targets, Sources, Commands )
type RuleInner = ( Targets, (Sources, Commands) )

type TargetRet   = String
type SourcesRet  = [ String ]
type CommandIO   = ReaderT (Bool, MadeFromList) IO
type CommandRet  = CommandIO ExitCode
type RuleRet     = ( TargetRet, (SourcesRet, [CommandRet]) )

type MadeFromList = [ (FilePath, [FilePath]) ]

ruleToRuleInner :: Rule -> RuleInner
ruleToRuleInner ( x, y, z ) = ( x, (y, z) )

ruleRetToMadeFromList :: [ RuleRet ] -> MadeFromList
ruleRetToMadeFromList = map (\(x, (y, _)) -> (x, y))

hake :: [ Rule ] -> IO ()
hake rl = do args <- getArgs
             let ud    = elem hakefileUpdateOption args
	         args_ = filter (/=hakefileUpdateOption) args
             case args_ of
	          [ trgt ] -> hakeTarget ud (map ruleToRuleInner rl) trgt
		  _        -> error "function (hake): argument error"

hakeT :: [ Rule ] -> FilePath -> IO ()
hakeT = hakeTarget True . map ruleToRuleInner

hakeTarget :: Bool -> [ RuleInner ] -> FilePath -> IO ()
hakeTarget ud rls fn = do
  rl <- traceRule fn rls
#ifdef DEBUG
--          >>= return . d (map $ map st)
--  print $ map (map st) rl
#endif /* DEBUG */
  flip runReaderT (ud, ruleRetToMadeFromList $ head rl) $ mapM_ applyRule $ reverse $ head rl

#ifdef DEBUG
d :: Show b => (a -> b) -> a -> a
d f x = unsafePerformIO $ print (f x) >> return x
st :: RuleRet -> (TargetRet, SourcesRet)
st (t, (s, _)) = (t, s)
#endif /* DEBUG */

infixr 9 <.>
(<.>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
f1 <.> f2 = fmap f1 . f2

traceRule :: FilePath -> [ RuleInner ] -> IO [[ RuleRet ]]
traceRule trgt rls
  =
#ifdef DEBUG
 do putStrLn $ "traceRule " ++ show trgt ++ " rls"
#endif /* DEBUG */
    case myLookup trgt rls of
      []    ->
#ifdef DEBUG
            do exStat <- ifM (doesFileExist trgt) (return " exist") (return " does not exist")
	       putStrLn $ "DEBUG (traceRule) : target " ++ trgt ++ exStat
#endif /* DEBUG */
               ifM (doesFileExist trgt) (return [[]]) (return [])
      finds -> do
        optional <- ifM (doesFileExist trgt) (return [[]]) (return [])
        fmap (++optional) $ concat <.> flip mapM finds $ \((tToS, tsToCmds), restRls) -> do
          let srcs = tToS trgt
	      cmds = tsToCmds trgt srcs
          obtainedRls <- mapM (unsafeInterleaveIO . flip traceRule restRls) srcs
	  return $ map ( (( trgt, (srcs, cmds) ):) . concat ) $ mulLists obtainedRls

mulLists :: [[a]] -> [[a]]
mulLists [] = [[]]
mulLists (xs:xss) = [ x:xs_ | x <- xs, xs_ <- mulLists xss ]

applyRule :: (TargetRet, (SourcesRet, [CommandRet])) -> CommandRet
applyRule (src, (dsts, cmds))
  = ifM ( lift $ isOldThanSomeOf src dsts )
        ( last <$> mapM (>>= (\ec -> if ec == ExitSuccess then return ec else lift $ exitWith ec)) cmds )
        ( return ExitSuccess )

myLookup :: a -> [ ([a -> Bool], b) ] -> [ (b, [ ([a -> Bool], b) ]) ]
myLookup _ []            = []
myLookup x (pair@(p, y):rest)
  | or $ map ($x) p
    = (y, rest) : ( (\(z, ps) -> (z, pair:ps)) <$> myLookup x rest )
  | otherwise
    =               (\(z, ps) -> (z, pair:ps)) <$> myLookup x rest

changeSuffix :: String -> String -> String -> String
changeSuffix oldSfx newSfx fn
  | isSuffixOf oldSfx fn = take (length fn - length oldSfx) fn ++ newSfx
  | otherwise            = error $ "changeSuffix: " ++ oldSfx ++ " is not suffix of " ++ fn

const2 :: a -> b -> c -> a
const2 = const . const

systemE :: String -> CommandRet
systemE cmd = lift $ putStrLn cmd >> system cmd

dflt :: [ String ] -> Rule
dflt trgts = ( [ (=="default") ], const trgts, const2 [] )

file :: ( [String], [String], [String] ) -> Rule
file ( trgts, srcs, cmd ) = ( map (==) trgts, const srcs, const2 $ map systemE cmd )

task :: ( String, [String] ) -> Rule
task ( trgts, cmd )       = ( [(==trgts)], const [], const2 $ map systemE cmd )

rule :: ( String, String, String -> String -> [String] ) -> Rule
rule ( trgt, src, cmd )
  = ( [isSuffixOf trgt], \dst -> [changeSuffix trgt src dst ],
      \t [s] -> map systemE $ cmd t s )

mkfl :: ( String, [ String ] ) -> Rule
mkfl ( trgt, cont )
  = ( [(==trgt)], const [], \t -> const [ do
        whenM getUpdateStatus $ do lift $ putStrLn $ "make file `" ++ trgt ++ "' (hake)"
	                           lift $ writeFile t $ unlines cont
	return ExitSuccess ] )

hakefileIs :: FilePath -> [ FilePath ] -> IO ExitCode
hakefileIs src others = do
  args <- getArgs
  runHake src "hake_" others $ if null args then [ "default" ] else args

getUpdateStatus :: CommandIO Bool
getUpdateStatus = asks fst

getSrcs :: FilePath -> CommandIO [FilePath]
getSrcs fp = 
#ifdef DEBUG
--  (ask >>= lift . print >>) .
#endif /* DEBUG */
     asks (maybe [] id . lookup fp . snd)