-----------------------------------------------------------------------------
-- |
-- 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, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving #-}
module Make.Rules.Dyn where
import Data.DynamicC
import Make.Rule
import Data.Maybe (fromMaybe,catMaybes)
import Data.Typeable
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 (MonadMemo)
import Make.Memo.Dynamic
import Make.Module hiding (get)
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 Make.Rules.Dyn.Program.Builtin
import Distribution.Simple.Program (ConfiguredProgram(..),rawSystemProgram)
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
import Data.DeriveTH
import Data.Binary
import Control.Monad
import Unsafe.Coerce
import qualified Distribution.Simple.Utils as U
import Distribution.Verbosity
import Make.Rules.Dyn.Types


matchIO _ _ = return True


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

readFileR :: (MonadMemo
                (DynamicC TargetCxt) (DynamicC Cxt) IO n) =>
             Path -> n FileR
readFileR path = path `memo1` return (getFileRepr path)
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

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

ghc = GHC `memoPure1` do
        prog <- ghcProgram
        case prog of
          Nothing -> fail "no GHC found"
          Just prog -> return $ Compiler (CompilerId GHC (fromMaybe (Version [][]) (programVersion prog))) prog
-- | minimal abstraction over haskell compilers
compile :: Compiler
        -> ModuleName
        -> Path -- ^ source
        -> [Maybe Path]
        -> FilePath -- ^ destination dir
        -> IO (FileR,FileR) -- Interface,Object
compile (Compiler c
        prog) mod src deps dist = do 
          cwd <- getCurrentDirectory 
          rawSystemProgram maxBound prog $ 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")


data RulesIO m = 
    RulesIO { 
      compiler :: m Compiler
     ,buildDir :: m FilePath
     ,hsSource :: ModuleName -> m (Maybe FileR)
     ,searchpaths :: m [FilePath]
    }




getFile :: (MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO n) =>
           Path -> n (Maybe FileR)
getFile p = memo1 ("getFile",p) . return $ do
                fmap (fmap (FileR p)) $ stat (fullPath p)

-- | Finds the file in the searchpaths


hs :: (MonadMemo
         (DynamicC TargetCxt) (DynamicC Cxt) IO m,
       ModuleM RulesIO m) =>
      ModuleName -> m (Maybe FileR)
hs file = 
     ("HSource",file) `memoPure1` do
     xs <- findSourceHs file 
     case xs of
         Just path -> getFile path
               
         Nothing -> return Nothing
             


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



findSourceHs :: (MonadMemo
                   (DynamicC TargetCxt) (DynamicC Cxt) IO m,
                 ModuleM RulesIO m) =>
                ModuleName -> m (Maybe Path)
findSourceHs mod = 
      (mod, "findhs") `memoPure1` 
      do xs <- imp searchpaths  
         find (srcs xs) 
    where 
      srcs xs = [ Path dir f | dir <- xs, f <- files ]
      files = [toFilePath mod <.> "hs",toFilePath mod <.> "lhs"]


--exist :: (MonadMemo Target Repr IO m) => Path -> m Repr



-- | %.hs : %.dep, storing the imported modules

dep :: (MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m,
        ModuleM RulesIO m) =>
       ModuleName -> m [ModuleName]
dep file = memo1 (file,"dep") $
    imp (flip hsSource file) >>= \x -> return $ do
       case x of
        Just (FileR hs _) -> do 
                imports <- catMaybes . map simpleParse . importsHs (fullPath hs) <$> readFile (fullPath hs)
                return $ (imports :: [ModuleName])
        _ -> fail ("trying to determine the imports of a not-found module: " ++ display file)



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



localModules :: (ModuleM RulesIO n,
                 MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO n,
                 ModuleM Lib n) =>
                n [ModuleName]
localModules = memoPure1 "localModules" $ do 
                    xs <- imp exposed
                    closure xs depLocal

extensions :: (ModuleM Lib n,
               MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO n,
               ModuleM RulesIO n) =>
              n [String]
extensions = memoPure1 "extensions" $ do
      mods <- localModules
      nub . sort . concat <$> traverse exts mods


allModules :: (ModuleM Lib n,
               ModuleM RulesIO n,
               MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO n) =>
              n [ModuleName]
allModules = memoPure1 "allModules" $ nub . sort . concat <$> (traverse dep =<< localModules)



depLocal file = 
    memoPure1 (file , "dep.local") $ do
      xs <- dep file
      filterLocal <$> traverse (\m -> fmap ((,) m) $ findSourceHs m) xs 
      
    where 
      filterLocal xs = [m | (m,Just _) <- xs ]
                                                    

depLocalTrans :: (MonadMemo
                    (DynamicC TargetCxt) (DynamicC Cxt) IO n,
                  ModuleM RulesIO n) =>
                 ModuleName -> n [ModuleName]
depLocalTrans file = 
    memoPure1 (file, "dep.local.trans") $ do 
      mods <- depLocal file 
      nub . sort . concat . (mods:) <$> traverse depLocalTrans mods
      

depTrans file = 
    memoPure1 (file,"dep.trans") $ do
      xs <- (:) <$> dep file <*> (depLocal file >>= \xs -> traverse depTrans xs)
      let mods = mergeMods $ xs
      return $ mods


hi :: (ModuleM RulesIO m,
       MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m) =>
      ModuleName -> (m (Maybe FileR), m (Maybe FileR))
hi file =
    memo2 (("Interface", file),("Object", file)) $ do
      src <- imp $ flip hsSource file
      case src of
        Nothing -> return $ return (Nothing,Nothing)
        Just (FileR hs _) -> comp <$> imp compiler <*> imp buildDir <*> (traverse (fst . hi) =<< dep file) 
            where
              comp c dist deps = 
                (Just *** Just) <$> compile c file hs (map (fmap (\(FileR path _) -> path)) deps) dist

rulesIO :: (ModuleM RulesIO m,
            MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m) =>
           m Compiler
           -> FilePath
           -> [FilePath]
           -> RulesIO m
rulesIO comp buildDir paths = RulesIO {
       compiler = "CompilerT" `memoPure1` comp
      ,buildDir = inputRule "buildDir" buildDir
      ,searchpaths = inputRule "searchpaths" paths
      ,hsSource = hs
}



modules :: (MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO n,
            ModuleM RulesIO n,
            ModuleM Lib n) =>
           n [ModuleName]
modules = memoPure1 "modules" $ do 
            ms <- imp exposed 
            nub . sort . concat . (ms:) <$> traverse depLocalTrans ms


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


mkLib :: (MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) m m1) =>
         [ModuleName] -> Lib m1
mkLib ms = Lib { exposed = inputRule "exposed" ms }


lib :: (ModuleM Lib m,
        ModuleM RulesIO m,
        MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m) =>
       m [Path]
lib = memoPure1 "lib" $ do 
        xs <- modules
        files <- concat <$> traverse (\(a,b) -> (\a b -> [a,b]) <$> a <*> b) [hi m | m <- xs] 
        return $ [ file | Just (FileR file _) <- files]



-- | a rule for "constant" records, i.e. that can be regenerated only externally.

inputRule t r = 
    memoPure1 t $ return $ r


foo name x = case x of
               Nothing -> fmap read $ readFile name
               Just x -> writeFile name (show x) >> return x