-----------------------------------------------------------------------------
-- |
-- Module      :  Make.Rules
-- Copyright   :  (c) 2008, Andrea Vezzosi
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This modules introduces a set of rules in the Test monad,
-- emulating compilation of haskell sources, and some testcases.
module Make.Rules where
import Make.Rule
import Make.TestMonad
import Data.Maybe (fromMaybe,catMaybes)
import Control.Applicative ((<$>))
import Prelude hiding (log,readFile,writeFile)
import Control.Exception (assert)
import System.FilePath
import Data.List (nub, sort)
import Data.HashTable (hashString)
import qualified Data.Map as M
import Make.MakeM
import Control.Arrow
import Make.Graph (reprs)
import Data.Version
import Distribution.Compiler
import Distribution.Simple.Program
import Distribution.ModuleName
import Distribution.Text (simpleParse)

type TimeStamp = Int


data Target = FileT FilePath -- ^ A file, with a path relative to searchpaths
            | HSource ModuleName
            | Interface ModuleName
            | Object ModuleName
            | Existence FilePath -- ^ Existence dep, the filepath must refer to a concrete file 
            | Record String -- ^ A place to store values
            | Rel ModuleName String -- ^ A record relative to a module
            | CompilerT
            deriving (Read,Show,Eq,Ord)

data Repr = FileR FilePath TimeStamp -- ^ Repr for FileT, with the concrete path and the timestamp
          | Exist Bool               -- ^ Repr for Existence
          | Content [String]         -- ^ Repr for Record, [String] is the cached value.
          | NotBuilt
          | CompilerR CompilerId ConfiguredProgram [String]
          | Modules [ModuleName] -- ^ it was pretty common so it gets a dedicated repr
            deriving (Read,Show,Eq)

-- | The match implementation to be used with @make@
matchTest :: Target -> Repr -> Test Target Repr Bool
matchTest (FileT _) (FileR path t) = fromMaybe False . fmap (t ==) <$> stat path 
matchTest (Existence path) (Exist b) = (b ==) <$> exists path
matchTest (Record name) (Content c) = return True 
matchTest _ _ = return True
                                        
compile :: CompilerId -> ConfiguredProgram -> [String]
        -> ModuleName
        -> FilePath -- ^ source
        -> [FilePath]
        -> FilePath -- ^ destination dir
        -> Test Target Repr (Repr,Repr) -- Interface,Object
compile c prog flags mod src deps dist = do files <- map (\(File _ x) -> x) <$> mapM readFile (src: sort deps)
                                            let hash = map (show . hashString) $ map concat files ++ [show c,show prog, show flags]
                                            mapM (\p -> writeFile p hash) ts
                                            Just times <- fmap sequence . mapM stat $ ts
                                            return . (\[x,y] -> (x,y)) $ zipWith FileR ts times
    where 
      ts = map ((dist </>) . (toFilePath mod <.>)) ["hi","o"]

-- | Add Begin/End events
mkRule :: Rule (Test target repr) target repr -> Rule (Test target repr) target repr
mkRule rule = rule {
  action = \xs -> do
    log $ BeginRuleAction (targets rule) (staticdeps rule)
    reprs <- action rule xs
    log $ EndRuleAction reprs
    return reprs
  }

-- Rules in the absence of preprocessors but in the presence of searchpaths, an *.hs file contains only the imported modules.

-- | Finds the file in the searchpaths
hsRule file = mkRule Rule {
     targets = [HSource file],
     depends = [static $ Rel file "findhs"],
     action = \[(_,Content xs)] -> do
                let path = assert (length xs == 1) (head xs)
                Just t <- stat path
                return [(HSource file ,FileR path t)]
}
              
find [] = []
find (p:ps) = [Existence p >>~ \(Exist b) -> if b then [] else find ps]

--findSourceHs :: ModuleName -> Rule Test Target Repr
findSourceHs mod = mkRule Rule {
      depends = [Record "searchpaths" >>~ \(Content xs) -> find (srcs xs)],
      targets = [Rel mod "findhs"],
      action = \xs -> do
                 let v = [p | (Existence p, Exist True) <- xs ]
                 return [Rel mod "findhs" =: Content v]
}
    where srcs xs = [ dir </> f | dir <- xs, f <- files ]
          files = [toFilePath mod <.> "hs",toFilePath mod <.> "lhs"]

-- | %.hs : %.dep, storing the imported modules
depRule file = mkRule $ Rule {
    targets = [Rel file "dep"],
    depends = [(HSource file,Nothing)],
    action  = \[(_,FileR hs _)] -> do
                imports <- catMaybes . map simpleParse . (\(File _ x) -> x) <$> readFile hs -- a source only lists imports
                return [Rel file "dep" =: Modules imports]
}


depLocal file = mkRule $ Rule {
    targets = [Rel file "dep.local"],
    depends = [Rel file "dep" >>~ \(Modules xs) -> map (static . flip Rel "findhs") xs],
    action = \xs -> return $ [Rel file "dep.local" =: Modules (filterLocal xs)]
}
    where filterLocal xs = [m | Just m <- map aux xs]
          aux (Rel mod "findhs",Content xs) 
              | null xs = Nothing
              | otherwise = Just mod
          aux _ = Nothing
                                                    

depLocalTrans file = mkRule $ Rule {
    targets = [Rel file "dep.trans"],
    depends = [Rel file "dep.local" >>~ \(Modules xs) -> map (static . flip Rel "dep.trans") xs ],
    action = \xs -> do
               let mods = nub . concatMap ((\(Modules c) -> c) . snd ) $ xs
               return [Rel file "dep.trans" =: Modules mods]
}


hiRule file = let r = mkRule Rule {
    targets = [Interface file,Object file],
    depends = [Rel file "findhs" >>~ \(Content xs) ->
                    if null xs 
                    then [] 
                    else [static $ HSource file,static $ CompilerT,static $ Record "buildDir",
                          Rel file "dep" >>~ \(Modules xs) -> map (static . Interface) xs]
              ],
    action = \xs -> do
               let mhs = lookup (HSource file) xs
                   deps = [path | (Interface _,FileR path _) <- xs]
               case mhs of
                 Nothing -> return (zip (targets r) (repeat NotBuilt))
                 Just (FileR hs _) -> do 
                          let CompilerR cId prog flags = fromMaybe undefined $ lookup CompilerT xs
                              Content [dist] = fromMaybe undefined $ lookup (Record "buildDir") xs
                          (hi,o) <- compile cId prog flags file hs deps dist
                          return $ zip (targets r) [hi,o]
} in r

modules = mkRule Rule {
            targets = [Record "modules"],
            depends = [Record "exposed" >>~ \(Modules xs) -> map (static .  flip Rel "dep.trans") xs ],
            action = \xs -> return $ [Record "modules" =: Modules (nub [m | (_,Modules ms) <- xs, m <- ms])]
} 

lib = mkRule Rule {
        targets = [Record "lib"],
        depends = [Record "modules" >>~ \(Modules xs) -> 
                       map static [f m | m <- xs, f <- [Interface,Object]]],
        action = \xs -> return $ [Record "lib" =: Content [ file | (_,FileR file _) <- xs]]
}


existRule file = mkRule Rule {
   targets = [Existence file],
   depends = [],
   action = \[] -> do b <- exists file
                      return [(Existence file, Exist b)]
}

-- | a rule for "constant" records, i.e. that can be regenerated only externally.
inputRule t = mkRule Rule {
    targets = [t],
    depends = [],
    action = error $ "input not set "++ show t
}
searchpaths = inputRule (Record "searchpaths")

-- | The dependency generator.
depGen (Existence p) = [existRule p]
depGen (Record x) = case x of 
                      "lib" -> [lib,modules,inputRule $ Record "exposed"]
                      "modules" -> [modules,inputRule $ Record "exposed"]
                      _         -> [inputRule $ Record x]
depGen (Rel prefix "dep") = [hsRule prefix,depRule prefix,findSourceHs prefix]
depGen (Rel prefix "findhs") = [findSourceHs prefix, searchpaths]
depGen (Rel prefix "dep.trans") = [depLocalTrans prefix,depLocal prefix] ++ [hsRule prefix,depRule prefix,findSourceHs prefix]
depGen (Rel prefix "dep.local") = [depLocal prefix] ++ [hsRule prefix,depRule prefix,findSourceHs prefix]
depGen (HSource m) = [hsRule m,findSourceHs m,searchpaths]
depGen (Interface m) = [hiRule m,findSourceHs m,searchpaths]
depGen (Object m) = [hiRule m,findSourceHs m,searchpaths]
depGen CompilerT = [inputRule CompilerT]
depGen y = error (show y)


invokeMake :: M.Map Target Repr
              -> [(Target, Repr)]
              -> [Target]
              -> Test Target Repr ([(Target, Repr)], M.Map Target Repr)
invokeMake cache inputs targets = do g <- runMakeT matchTest cache (make depGen inputs targets)
                                     let m = reprs g
                                     return $ map (id &&& (m M.!)) targets =: m
invokeMake' cache inputs = invokeMake cache ([Record "buildDir" =: Content ["dist"],CompilerT =: fakeCompiler] ++ inputs)
    where fakeCompiler = CompilerR (CompilerId YHC (Version [] [])) (ConfiguredProgram "yhc" Nothing [] (FoundOnSystem "/usr/local/bin/yhc")) []

sp = Record "searchpaths" =: Content (map (("src" ++) . show) [1..3])
a_hi = Interface $ simple "A"
-- | simple build test
test1 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: []]
           invokeMake' M.empty [sp] []

-- | it doesn't loop on cyclic dependencies but just stops
test2 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: ["C"],"src1/C.hs" =: ["A"]]
           invokeMake' M.empty [sp] [a_hi]
-- | it doens't rerun actions if nothing has changed.
test3 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: []]
           (_,cache) <- invokeMake' M.empty [sp] [a_hi]
           invokeMake' cache [] [a_hi]
-- | rebuilds if something has changed
test4 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: []]
           (_,cache) <- invokeMake' M.empty [sp] [a_hi]
           writeFile "src1/A.hs" ["B"]
           invokeMake' cache [] [a_hi]

test5 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: []]
           prop_fundamental [sp] [a_hi] $ return ()
test6 = do mapM_ (uncurry writeFile) ["src1/A.hs" =: ["B"], "src2/B.hs" =: []]
           prop_fundamental [sp] [a_hi] $ writeFile "src1/A.hs" ["B"]

-- | Assuming the targets are files, we check that rebuilding using the cache or starting from scratch produce the same results
-- the action taken as input is performed after the first build used to generate the cache.
prop_fundamental :: [(Target, Repr)] -> [Target] -> Test Target Repr t -> Test Target Repr Bool
prop_fundamental inputs targets perturbation = do
  (_,cache) <- makeTargets M.empty
  perturbation
  res1 <- inSandBox $ makeTargets M.empty >>= \(x,_) -> readContents x
  res2 <- inSandBox $ makeTargets cache >>= \(x,_) -> readContents x
  return $ res1 == res2
  where 
    makeTargets cache = invokeMake' cache inputs targets
    readContents m = M.fromList <$> mapM (\(t,FileR path _) -> readFile path >>= \(File _ x) -> return (t,(path,x))) m