-----------------------------------------------------------------------------
-- |
-- Module      :  Make.RulesIO
-- Copyright   :  (c) 2008, Andrea Vezzosi
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Defines a set of working rules for compilation of haskell modules,
-- it supports only YHC and GHC, not performing linking for now.
{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
module Make.RulesIO where
import Make.Rule
import Data.Maybe (fromMaybe,catMaybes)
import Control.Applicative
import Control.Exception.Extensible (assert,try,evaluate)
import System.FilePath
import System.Directory
import Data.List hiding (find)
import qualified Data.Map as M
import Control.Arrow --hiding (pure)
import System.Time
import Make.Imports
import Make.Memo
import Make.Module
import Distribution.Simple.Utils
import Data.Monoid
import System.Environment
import Debug.Trace
import Make.JobControl
import System.IO.Error (catch,ioError,isDoesNotExistError)
import Data.Maybe
import Distribution.Compiler
import Distribution.Simple.Program
import Distribution.ModuleName
import Distribution.Text (simpleParse,display)
import Data.Version
import Distribution.Simple.LocalBuildInfo hiding (buildDir,compiler)
import Distribution.PackageDescription hiding (extensions)
import Data.Traversable hiding (mapM,sequence)
import Control.Monad.Trans
import Make.Graph.Utils
type TimeStamp = Int

-- Some of the constructors if @Target@ and @Repr@ are only used in Make.Suffix

data Target = FileT FilePath -- ^ A file, with a path relative to searchpaths
            | HSource ModuleName
            | Interface ModuleName
            | Object ModuleName
            | Existence Path -- ^ 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
            | With String Target
            | ProgramT String
            deriving (Read,Show,Eq,Ord)

data Repr = FileR Path TimeStamp -- ^ Repr for FileT, with the concrete path and the timestamp
          | Exist Bool               -- ^ Repr for Existence
          | Content {unC :: [String] }        -- ^ Repr for Record, [String] is the cached value.
          | NotBuilt
          | CompilerR CompilerId ConfiguredProgram [String]
          | Modules { unM :: [ModuleName] } -- ^ it was pretty common so it gets a dedicated repr
          | Paths {unP :: [Path]}
          | Chain Path [(String,String)]
          | ProgramR ConfiguredProgram [String]
          | LBI (Wrap LocalBuildInfo)
          | BI (Wrap BuildInfo)
            deriving (Read,Show,Eq)

-- takes a list of (Modules xs) and returns the union
--mergeMods :: [Repr] -> [ModuleName]
mergeMods a = nub . concatMap unM $ a


-- | The match implementation to be used with @make@
matchIO :: MonadIO m => Target -> Repr -> m Bool
matchIO (_) (FileR p t) = liftIO $ fromMaybe False . fmap (t ==) <$> stat (fullPath p)
matchIO (Existence path) (Exist b) = liftIO $ (b ==) <$> exists (fullPath path)
matchIO (Record name) (_) = return True  
matchIO (Rel _ _) (_) = return True
matchIO (_) (NotBuilt) = return True
matchIO x y = fail $ "target/repr mismatch: "++ show x ++ " " ++ show y


data Path = Path { baseDir::FilePath, relPath :: FilePath } deriving (Eq,Read,Show,Ord)

fullPath :: Path -> FilePath
fullPath x@Path{}= baseDir x </> relPath x

toTuple :: Path -> (FilePath, FilePath)
toTuple (Path x y) = (x,y)


-- | fails if the file doesn't exist
getFileRepr :: Path -> IO Repr
getFileRepr path = do Just t <- stat (fullPath path)
                      return (FileR path t)

stat :: FilePath -> IO (Maybe TimeStamp)
stat path = (Just . toInt <$> getModificationTime path) `catch` (\e -> if isDoesNotExistError e then return Nothing else ioError e)
    where toInt (TOD x y) = fromIntegral x -- approximative

exists :: FilePath -> IO Bool
exists = doesFileExist

-- | Wrapper for dependencies we don't care about yet.
newtype Wrap a = Wrap { unW :: a } deriving (Read,Show)
instance Eq (Wrap a) where
    _ == _ = True                                        

-- | minimal abstraction over haskell compilers
compile :: CompilerId -> ConfiguredProgram -> [String]
        -> ModuleName
        -> Path -- ^ source
        -> [Path]
        -> FilePath -- ^ destination dir
        -> IO (Repr,Repr) -- Interface,Object
compile c
        prog flags mod src deps dist = do 
          cwd <- getCurrentDirectory 
          rawSystemProgram maxBound prog $ flags ++ compilerFlags c src (cwd </> dist)
          let (hi,o) = pre *** pre $ compilerSuffixes c
          Just [t1,t2] <- fmap sequence . mapM (stat . fullPath) $ [hi,o]
          return $ (FileR hi t1,FileR o t2)
    where 
      pre = (Path dist . (toFilePath mod <.>))

compilerFlags :: CompilerId -> Path -> FilePath -> [String]
compilerFlags (CompilerId YHC _) src dist = ["-c","-d",dist,"-i",dist,"-I",dist,fullPath src]
compilerFlags (CompilerId GHC _) src dist = ["-c", fullPath src,"-hidir "++ dist,"-odir " ++ dist,"-i","-i"++dist]
compilerSuffixes :: CompilerId -> (String,String)
compilerSuffixes (CompilerId YHC _) = ("hi","hbc")
compilerSuffixes (CompilerId GHC _) = ("hi","o")


-- | Finds the file in the searchpaths

hs :: (MonadMemo Target Repr IO m, ModuleM RulesIO m) =>
      ModuleName -> m Repr
hs file = 
     HSource file `memo1` do
     (Paths xs) <- findSourceHs file 
     return $ do
       case xs of
         [path] -> do
                 Just t <- stat (fullPath path)
                 return $ FileR path t
         [] -> return NotBuilt
             

find :: (MonadMemo Target Repr IO m) => [Path] -> m (Maybe Path)
find [] = return Nothing
find (p:ps) = exist p >>= \(Exist b) -> 
              if b then return $ Just p 
                   else find ps


findSourceHs :: (MonadMemo Target Repr IO m, ModuleM RulesIO m) =>
                ModuleName -> m Repr
findSourceHs mod = 
      Rel mod "findhs" `memoPure1` 
      do xs <- imp searchpaths  
         Paths . maybeToList <$> find (srcs xs) 
    where 
      srcs xs = [ Path dir f | dir <- xs, f <- files ]
      files = [toFilePath mod <.> "hs",toFilePath mod <.> "lhs"]

-- | %.hs : %.dep, storing the imported modules
dep file = memo1 (Rel file "dep") $
    imp (flip hsSource file) >>= \x -> return $ do
       case x of
        (FileR hs _) -> do 
                imports <- catMaybes . map simpleParse . importsHs (fullPath hs) <$> readFile (fullPath hs)
                return $ Modules imports
        _ -> fail ("trying to determine the imports of a not-found module: " ++ display file)

exts :: (MonadMemo Target Repr IO m, ModuleM RulesIO m) => ModuleName -> m [String]
exts file = fmap unC . memo1 (Rel file "exts") $
    imp (flip hsSource file) >>= \x -> return $ do
       case x of
        (FileR hs _) -> do 
                Content . languageExtensions (fullPath hs) <$> readFile (fullPath hs)
        _ -> fail ("trying to determine the imports of a not-found module: " ++ display file)

localModules :: (MonadMemo Target Repr IO f, ModuleM RulesIO f) =>
                [ModuleName] -> f [ModuleName]
localModules xs = fmap unM . memoPure1 (Record "localModules") . fmap Modules $ closure xs depLocal

extensions :: (ModuleM RulesIO n, MonadMemo Target Repr IO n) =>
              [ModuleName] -> n [String]
extensions xs = 
    fmap unC . memoPure1 (Record "extensions") . fmap Content $ do
      mods <- localModules xs
      nub . sort . concat <$> traverse exts mods

allModules :: (MonadMemo Target Repr IO f, ModuleM RulesIO f) =>
              [ModuleName] -> f [ModuleName]
allModules xs = nub . sort . concat <$> (traverse (fmap unM . dep) =<< localModules xs)

depLocal :: (ModuleM RulesIO m, MonadMemo Target Repr IO m) =>
            ModuleName -> m [ModuleName]
depLocal file = 
    fmap unM . memoPure1 (Rel file "dep.local") . fmap Modules $ do
      (Modules xs) <- dep file
      filterLocal <$> traverse (\m -> fmap ((,) m) $ findSourceHs m) xs 
      
    where 
      filterLocal xs = [m | (m,Paths ps) <- xs, not $ null ps ]
                                                    

depLocalTrans :: (MonadMemo Target Repr IO m, ModuleM RulesIO m) =>
                 ModuleName -> m [ModuleName]
depLocalTrans file = 
    fmap unM . memoPure1 (Rel file "dep.local.trans") . fmap Modules $ do 
      mods <- depLocal file 
      nub . sort . concat . (mods:) <$> traverse depLocalTrans mods
      



depTrans :: (MonadMemo Target Repr IO m, ModuleM RulesIO m) =>
            ModuleName -> m Repr
depTrans file = 
    memoPure1 (Rel file "dep.trans") $ do
      xs <- (:) <$> dep file <*> (depLocal file >>= \xs -> traverse depTrans xs)
      let mods = mergeMods $ xs
      return $ Modules mods


hi :: (ModuleM RulesIO m, MonadMemo Target Repr IO m) =>
      ModuleName -> (m Repr, m Repr)
hi file =
    memo2 (Interface file,Object file) $ do
      src <- imp $ flip hsSource file
      case src of
        NotBuilt -> return $ return (NotBuilt,NotBuilt)
        (FileR hs _) -> 
           let comp (cId, prog, flags) dist deps = 
                   compile cId prog flags file hs (map (\(FileR path _) -> path) deps) dist
           in comp <$> imp compiler <*> imp buildDir <*> (dep file >>= \(Modules xs) -> traverse (fst . hi) xs) 

data RulesIO m = 
    RulesIO { 
      compiler :: m (CompilerId,ConfiguredProgram,[String])
     ,buildDir :: m FilePath
     ,hsSource :: ModuleName -> m Repr
     ,searchpaths :: m [FilePath]
    }


rulesIO (a,b,c) buildDir paths = RulesIO {
       compiler = fmap (\(CompilerR a b c) -> (a,b,c)) $ inputRule CompilerT (CompilerR a b c)
      ,buildDir = fmap (head . unC) $ inputRule (Record "buildDir") (Content [buildDir])
      ,searchpaths = fmap unC $ inputRule (Record "searchpaths") (Content paths)
      ,hsSource = hs
}


modules :: (MonadMemo Target Repr IO m,
            ModuleM RulesIO m,
            ModuleM Lib m) =>
           m [ModuleName]
modules = fmap unM . memoPure1 (Record "modules") . fmap Modules $ do 
            ms <- imp exposed 
            nub . sort . concat . (ms:) <$> traverse depLocalTrans ms


data Lib m = Lib { exposed :: m [ModuleName] }

mkLib :: (MonadMemo Target Repr m m1) =>
         [ModuleName] -> Lib m1
mkLib ms = Lib { exposed = fmap unM $ inputRule (Record "exposed") (Modules ms) }


lib :: (ModuleM Lib m,
        ModuleM RulesIO m,
        MonadMemo Target Repr IO m) =>
       m [Path]
lib = fmap unP . memoPure1 (Record "lib") . fmap Paths $ do 
        xs <- modules
        files <- concat <$> traverse (\(a,b) -> (\a b -> [a,b]) <$> a <*> b) [hi m | m <- xs] 
        return $ [ file | FileR file _ <- files]

exist :: (MonadMemo Target Repr IO m) => Path -> m Repr
exist file = 
   Existence file `memo1`
   (return $ do 
      b <- exists (fullPath file)
      return $ Exist b)


-- | a rule for "constant" records, i.e. that can be regenerated only externally.
inputRule :: (MonadMemo target a m m1) => target -> a -> m1 a
inputRule t r = 
    memoPure1 t $ return $ r

{-
-- | convenience function: runs a MakeT action using the rules defined in this module.
invoke :: FilePath -> MakeT Target Repr IO a -> IO a
invoke cachefile m = do 
  jc <- sequentialJC
  withCacheFile cachefile (runMakeT (Dict matchIO jc) m )
-}
{-
invokeMake :: FilePath -> [(Target, Repr)] -> [Target] -> IO [(Target, Repr)]
invokeMake c i t = invoke c (make i t)

-- Example program 
main = do args <- getArgs
          let (sp,ts) = case break (=="T") args of
                           (x,[]) -> (["."],x)
                           (x,_:y) -> (x,y)
              ts' = catMaybes . map simpleParse $ ts
          createDirectoryIfMissing True dist
          invokeMake cachefile [Record "searchpaths" =: Content sp
                               ,Record "buildDir" =: Content [dist]
                               ,CompilerT =: CompilerR (CompilerId GHC (Version [] [])) 
                                             (ConfiguredProgram "ghc" Nothing [] 
                                              (FoundOnSystem "/usr/local/bin/ghc")) []] 
                         (map Interface ts')
    where
      cachefile = dist </> "cache"
      dist :: FilePath
      dist = "dist/build"
-}