-----------------------------------------------------------------------------
-- |
-- Module      :  Make.Test
-- Copyright   :  (c) 2008, Andrea Vezzosi
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module mainly tests our make algorithm against the timestamp based model,
-- where a target is up to date if it's younger than its dependencies.
module Test where

import Prelude hiding (readFile, writeFile, log)
import qualified Prelude (writeFile)

import Make.Rule
import qualified Make.MakeM as Mk
import Make.Graph
import Make.TestMonad
import Control.Arrow
import Data.Function
import qualified Test.QuickCheck as QC
import Control.Applicative
import Data.List
import qualified Data.Map as Map
import System.FilePath
import System.Random (mkStdGen)
import System.Cmd
import Data.Tree
import Control.Monad
import Control.Monad.Error
import qualified Data.Set as S
import Data.HashTable (hashString)

newtype Target = Target { unTarget :: String } deriving (Read,Show,Ord,Eq)

make :: (Target -> Either String [Rule (Test Target Int) Target Int]) -> [Target] -> Test Target Int [(Target,Int)]
make dep ts = 
    do File _ xs <- do b <- exists cfile 
                       if b then readFile cfile else return $ File 0 []
       let cache = case xs of
                     [x] -> Just $ read x
                     _ -> Nothing
       log (StartMake ts)
       (cache',x) <- Mk.runMakeT (Mk.Dict matchTest (closure staticdeps (fromRight . dep)) jobcontrol) (Mk.make [] ts) cache
       log FinishMake
       writeFile cfile [show cache']
       return x
    where 
      fromRight (Right x) = x
      matchTest (Target s) time = maybe False (time ==) <$> stat s

cfile = "cache"

cleanCache = touch "cache"

closure :: (b -> [a]) -> (a -> [b]) -> a -> [b]
closure g dep = fix $ \f t -> -- obfuscation ftw, FIXME
              (++) <*> concatMap f . concatMap g $ dep t

newtype TestDepGraph = TestDepGraph [Dep] deriving (Eq, Show)

deps :: TestDepGraph -> [Dep]
deps (TestDepGraph ds) = ds

-- all the files refered to in the dependency graph
files :: TestDepGraph -> [Target]
files graph = nub [ target | t1 :<= t2  <- deps graph, target <- [t1, t2] ]

data Dep = Target :<= Target deriving (Eq, Show)
        -- foo :<= bar   means that we generate foo from bar

instance QC.Arbitrary Target where
  arbitrary = mapM (const $ QC.elements ['a'..'z']) [1..5]
              >>= return . Target
  coarbitrary = error "not implemented"

instance QC.Arbitrary TestDepGraph where
  arbitrary = (TestDepGraph . nub) `fmap` QC.sized genDepGraphSized
  coarbitrary = error "not implemented"

data Rules = Rules {graph :: TestDepGraph, rules :: [Rule (Test Target Int) Target Int]} deriving (Show)

instance QC.Arbitrary (Rules) where
    arbitrary = do g <- QC.arbitrary
                   rules <- genRules g
                   return $ Rules g rules
    coarbitrary = error "not implemented"
                   

genDepGraphSized :: Int -> QC.Gen [Dep]
genDepGraphSized 0 = return []
genDepGraphSized 1 = do x <- QC.arbitrary
                        y <- QC.arbitrary
                        case compare x y of
                          LT -> return [x :<= y]
                          EQ -> genDepGraphSized 1
                          GT -> return [y :<= x]
genDepGraphSized size = do
    -- generate a tree of size N
    someDeps <- genDepGraphSized (size - 1) -- or whatever
    -- generate a tree of size N + 1 by adding a rule for an arbitrary
    -- file occuring in this tree
    let fs = files (TestDepGraph someDeps)
    -- XXX: we assume that files is non-empty here
    (x, y) <- QC.frequency
              [ (1,  do x <- QC.elements fs
                        y <- QC.elements fs
                        return (x, y))
              , (2,  do x <- QC.elements fs
                        y <- QC.arbitrary
                        return (x, y)) ]
    case compare x y of
      LT -> return $ (x :<= y) : someDeps
      EQ -> return $             someDeps
      GT -> return $ (y :<= x) : someDeps

succMap :: [Dep] -> Map.Map Target [Target]
succMap = Map.fromListWith (++) . map (\(x :<= y) -> (y, [x]))

predMap :: [Dep] -> Map.Map Target [Target]
predMap = Map.fromListWith (++) . map (\(x :<= y) -> (x, [y]))

sinks :: TestDepGraph -> [Target]
sinks (TestDepGraph deps) =
    nub [ a | a :<= _ <- deps, null (succs a) ]
  where
    succm = succMap deps
    succs d = Map.findWithDefault [] d succm

roots :: TestDepGraph -> [Target]
roots (TestDepGraph deps) =
    nub [ b | _ :<= b <- deps, null (preds b) ]
  where
    predm = predMap deps
    preds d = Map.findWithDefault [] d predm

-- | generates a list of rules from a graph
genRules :: TestDepGraph -> QC.Gen [Rule (Test Target Timestamp) Target Timestamp]
genRules graph@(TestDepGraph deps) = sequence
    [ mkRule [target] deps <$> makedyn deps | target <- files graph, let deps = (preds target) ]

  where
    succm = succMap deps
    predm = predMap deps
    succs d = Map.findWithDefault [] d succm
    preds d = Map.findWithDefault [] d predm

makedyn xs = map todeps <$> rosetree' (length xs) xs
    where rosetree' _ [] = return $ []
          rosetree' _ [x] = return $ [Node x []]
          rosetree' n (x:xs) = 
              do l <- QC.choose (0,n-1)
                 let (a,b) = splitAt l xs
                 ((:) . Node x) `fmap` rosetree' l a `ap` rosetree' (n-l-1) b
          todeps (Node t []) = static t
          todeps (Node t xs) = t >>~ \_ -> map todeps xs

mkRule :: [Target]
          -> [Target]
          -> [(Target, Maybe (DepMaker Target Timestamp))]
          -> Rule (Test Target Timestamp) Target Timestamp
mkRule targets depends' deps = Rule {
          targets = targets,
          depends = deps,  
          action = \xs -> do
            log (BeginRuleAction targets (map fst xs))
            unless (null depends') $ 
                   do contents <- map (show . hashString . concat . content) 
                                  <$> mapM (readFile . unTarget) depends'
                      mapM_ (flip writeFile contents . unTarget) targets
            ts <- mapM ((maybe undefined id <$>) .  stat . unTarget) targets
            let r = zip targets ts
            log (EndRuleAction r)
            return r
       }

-- we must produce a DepGenerator based on the random graph we made. 
mkgen :: Monad m => Rules -> Target -> m [Rule (Test Target Int) Target Int]
mkgen Rules{rules=rules} =
   let
      gen target = case [ rule | rule <- rules, target `elem` targets rule ] of
        [x] -> return [x]
        []  -> fail $ "no rule for target " ++ show target
        _   -> fail $ "multiple rules for target " ++ show target
   in gen


genDepGraph :: Int -> TestDepGraph
genDepGraph size = QC.generate size (mkStdGen 42) QC.arbitrary

-- so a Dep being up to date means foo is more recent than bar:
depUpToDate :: FileSystem -> Dep -> Bool
depUpToDate fs (Target path1 :<= Target path2) = --hah!
    case (Map.lookup path1 fs, Map.lookup path2 fs) of
      (Just file1, Just file2) -> timestamp file1 > timestamp file2
      _ -> False

allUpToDate :: TestDepGraph -> State -> Bool
allUpToDate graph st =
  all (depUpToDate (filesystem st)) (deps graph)

-- | Split a build trace into chunks for each rule action. For each action
-- return (targets, deps, trace)
ruleActionTraces :: [Event Target r] -> [([Target], [Target], [Event Target r])]
ruleActionTraces trace = [(targets,deps,takeWhile (\x -> case x of EndRuleAction{} -> False; _ -> True) $ xs)
                                        | ((BeginRuleAction targets deps):xs) <- tails trace]

-- | Properties

prop_makeUpToDate :: QC.Property
prop_makeUpToDate =
  QC.forAll QC.arbitrary $ \r@Rules{graph=graph} ->
    let buildtargets = sinks graph
        gen = mkgen r
        build = do
          mapM_ (touch . unTarget) (files graph)
          make gen buildtargets
     in allUpToDate graph (finalState build)

prop_rebuildUpToDate :: QC.Property
prop_rebuildUpToDate =
  QC.forAll QC.arbitrary $ \r@Rules{graph=graph} ->
    let buildtargets = sinks graph
        gen = mkgen r
        build = do
          mapM_ (touch . unTarget) (files graph)
          make gen buildtargets
        build1 = do
          build
          -- touch a random selection of files
          mapM_ (touch . unTarget) (selection (files graph))
          make gen buildtargets
        build2 = do
          build
          -- touch all the source files
          mapM_ (touch . unTarget) (roots graph)
          make gen buildtargets
        build3 = do
          build
          -- touch some of the source files
          mapM_ (touch . unTarget) (selection (roots graph))
          make gen buildtargets
     in allUpToDate graph (finalState build)
     && allUpToDate graph (finalState build1)
     && allUpToDate graph (finalState build2)
     && allUpToDate graph (finalState build3)
  where selection xs = reverse [ x | (n,x) <- zip [0..] xs, even n ]

prop_fundamental :: Rules -> Bool
prop_fundamental r@Rules{graph=graph} = uncurry check $ runTest build
    where 
      sources = roots graph
      runmake = make (mkgen r) (sinks graph)
      build = do 
            zipWithM (\(Target a) b -> writeFile a [show b]) sources [1..]
            runmake
            perturbation
            (_,t1) <- inSandBox $ cleanCache >> runmake 
            runmake 
            return $ t1 
      perturbation = mapM_ (uncurry $ writeFile . unTarget) (reverse [ (x,[show $ 100*n]) | (n,x) <- zip [0..] sources, even n ])
      check t1 t2 = results t1 == results t2 
      results = Map.delete cfile . Map.map content . filesystem . snd . last


prop_rebuildOnlyWhatsNecessary :: (Rules, [Int]) -> Bool
prop_rebuildOnlyWhatsNecessary (r@Rules{graph=graph},xs) =
    let build = do
          mapM_ (touch . unTarget) (files graph)
          make gen buildtargets
          mapM_ (touch . unTarget) sel'
          make gen buildtargets
        buildtargets = sinks graph
        gen = mkgen r
     in onlyNecessaryRebuilds (subforest graph sel') . trace $ build
    where
      onlyNecessaryRebuilds torebuild trace = sort torebuild == sort (rebuiltTargets . map fst . (!!2) . splitRuns $ trace)
      sel' = selection xs graph
      selection xs graph = nub [ys !! x | x <- (map abs xs), x < l]
          where l = length ys
                ys = files graph

prop_noUntrackedDeps :: Rules -> Bool
prop_noUntrackedDeps r@Rules{graph=graph} = 
    check . events $ 
          do mapM_ (touch . unTarget) (roots graph) 
             make (mkgen r) (sinks graph)
    where 
      check ts = and [deps `seteq` reads trace | (_,deps,trace) <- ruleActionTraces ts]
      reads xs = [Target path | ReadFile path <- xs]


-- tests that we properly record from which deps a target has been built
prop_cacheCoherence :: Rules -> Bool
prop_cacheCoherence r@Rules{graph=g}= allUpToDate g . finalState $ 
    do mapM_ (touch . unTarget) (roots g) -- init
       make gen sinks'
       mapM_ (touch . unTarget) (roots g)
       make gen subset
       make gen sinks'     
    where
      gen = mkgen r
      Rules{graph=g} = r
      sinks' = sinks g
      subset = [t | (n,t) <- zip [0..] $ sinks g, even n]

-- tests that we don't forget cached values for not updated targets
-- there should be no recompilation in the last two runs
testcase :: Trace Target Int
testcase = trace $ do
             mapM_ (touch . unTarget) [b]
             make gen [a,c]
             make gen [a]
             make gen [a,c]
    where
        gen = mkgen r
        Rules{graph=g} = r
        sinks' = sinks g

a = Target "a"
b = Target "b"
c = Target "c"
r :: Rules
r = Rules {
            graph= TestDepGraph [a :<= b,c :<= b],
            rules= [
             mkRule [b] [] [],
             mkRule [c] [b] [static b],
             mkRule [a] [b] [static b]]
          }

-- | Utils

rebuiltTargets :: [Event t t1] -> [t]
rebuiltTargets xs = [t | BeginRuleAction ts _ <- xs, t <- ts]

subforest :: TestDepGraph -> [Target] -> [Target]
subforest (TestDepGraph deps) ts = nub $ ts ++ concatMap (closure return succs) ts
  where
    succm = succMap deps
    succs d = Map.findWithDefault [] d succm

upforest :: TestDepGraph -> [Target] -> [Target]
upforest (TestDepGraph deps) ts = nub $ ts ++ concatMap (closure return preds) ts
  where
    predm = predMap deps
    preds d = Map.findWithDefault [] d predm

seteq :: (Ord a) => [a] -> [a] -> Bool
seteq xs ys = S.fromList xs == S.fromList ys                              

isStartMake (StartMake{}) = True
isStartMake _ = False

splitRuns :: (Eq t, Eq r) => [(Event t r, b)] -> [[(Event t r, b)]]
splitRuns xs = map (takeWhile ((/=FinishMake) . fst)) . groupBy (const (not . isStartMake)`on`fst) $ xs

notUpToDateForest :: FileSystem -> TestDepGraph -> [Target]
notUpToDateForest fs g@(TestDepGraph deps) = subforest g . map (\(t :<= _) -> t) . filter (not . depUpToDate fs) $ deps

{-onlyNecessary g ((StartMake ts,st):xs) = (sort torebuild , sort (rebuiltTargets $ map fst xs))
    where 
      torebuild = upforest g ts `intersect` notUpToDateForest (filesystem st) g-}