{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Make.Suffix
-- Copyright   :  (c) 2008, Andrea Vezzosi
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- In this module we handle preprocessor chaining via a restricted implementation of suffix rules.
-- The idea is that with preprocessors we have multiple ways to build a source (which can be e.g. .hs from .chs,.hs from .y, but also .y from .y.pp )
-- but instead of having multiple rules with the same target, we use different targets by adding a specific tag for each preprocessor:
-- e.g. c2hs will produce (With "chs" (Rel m "hs")), happy (With "y" (Rel m "hs")), ans so on..
-- This way the rule for Rel m "hs" can decide which preprocessor to use by depending on the corresponding target.
module Make.Suffix
{-    (
     Suffix, Tag, Chain
    ,PPDescriptor(..)
    ,suffixesToTry
    ,depGen
    ,preprocess
    ,findSources
    )-}
    where

import Distribution.Text
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.PackageDescription

import Control.Applicative
import Control.Monad.Writer
import Control.Arrow (first)
import System.FilePath
import Control.Monad.Fix
import Data.List hiding (find)
import qualified Data.List
import Data.Maybe

import Make.Imports
import Make.Rule
import Make.RulesIO 
import Make.JobControl
import Make.Memo
import Make.Module
--import Make.MakeM

-- | A suffix in a filename, e.g. "hs"
type Suffix = String 

-- | Each preprocessor is identified by a unique Tag, which will be used to mark its targets
type Tag = String

-- | A chain of preprocessors is represented as a list of Tags with the suffix that preprocessor is supposed to produce.
type Chain = [(Tag,Suffix)]

-- | A PreProcessor descriptor contains the tag and a function that works like a matcher on suffixes,
-- | if  given a suffix s it returns (Just (xs,f)), then (f m) is supposed to have (With tag (Rel m s)) among its targets
-- | and depend on (Rel m tag) to get at the file with suffix s' where s' `elem` xs, which is considered the "source" for the preprocessor.
data PPDescriptor m = PPDescriptor { ppTag :: Tag, ppRule :: Suffix -> Maybe ([Suffix],ModuleName -> m Repr) }

-- | Generates the levels of the tree of suffixes implied by the concatenation of the preprocessors
suffixesToTry :: [Suffix] -- ^ base suffixes, like ["hs","lhs"]
              -> [PPDescriptor m] 
              -> [(Suffix,Chain)] 
suffixesToTry ss xs = concat . takeWhile (not . null) . 
                       map runWriterT $ iterate (>>= f) (foo ss)
    where f = toWriter xs 
          toWriter xs = \v -> msum . 
                        map (\(PPDescriptor tag f) -> do 
                               tell [(tag,v)] 
                               convert f v) 
                        $ xs
          -- it just adjusts the type
          convert f = lift . concat . fmap fst . maybeToList . f
          foo ss = msum $ map (\s -> tell [("hs",s)] >> return s) ss
{-

preprocess :: [Suffix] -- ^ sources suffixes, e.g. hs lhs
              -> [PPDescriptor] 
              -> FilePath  -- ^ buildDir
              -> [FilePath] -- ^ searchpaths
              -> [ModuleName] -- ^ modules to preprocess
              -> BuildInfo
              -> LocalBuildInfo
              -> IO [(ModuleName, Maybe FilePath)]
preprocess xs pps dist sp ts bi lbi = do
  dict <- mkDict xs pps
  rs <- withCacheFile (dist </> "cache") $ runMakeT dict $ 
      make [Record "searchpaths" =: Content sp
           ,Record "buildDir" =: Content [dist]
           ,Record "BI" =: BI (Wrap bi)
           ,Record "LBI" =: LBI (Wrap lbi)]
           (map HSource ts)
  return [(m,mpath) | (HSource m,r) <- rs, 
          let mpath = case r of 
                        FileR p _ -> Just $ fullPath p
                        _ -> Nothing] 

findSources :: [Suffix]
               -> [PPDescriptor]
               -> FilePath  -- ^ where to save the cache
               -> [String]
               -> [ModuleName]
               -> IO [(ModuleName, Maybe FilePath)]
findSources xs pps dist sp ts = do
  dict <- mkDict xs pps
  rs <- withCacheFile (dist </> "cache") $ runMakeT dict $ 
      make [Record "searchpaths" =: Content sp]
           (map (flip Rel "chain") ts)
  return [(m,mpath) | (Rel m "chain",r) <- rs, 
          let mpath = case r of 
                        Chain p _ -> Just $ fullPath p
                        _ -> Nothing]



-}
-- The following rules are defined as Target -> Maybe (Rule ..) 
-- this way they can be automatically composed to create a DepGenerator.

-- | The computed chain can be either (1) empty, meaning that no source has been found, or (2) contain a (source:preprocessors) list.

mkChain suffixes m 
    = Rel m "chain" `memo1`
       do 
         sp <- imp searchpaths
         whileM (return NotBuilt) (chains sp) $ \(path,c) k -> do
           (Exist b) <- exist path
           if b then return $ return $ Chain path c else k 

   where chains sp = [first (Path a) b | a <- sp, b <- map (first (toFilePath m <.>)) suffixes]
data SuffixM m = SuffixM { ppChain :: ModuleName -> m Repr, ppSource :: Tag -> ModuleName -> m Repr }
whileM :: (Monad m) => a -> [t] -> (t -> m a -> m a) -> m a
whileM a xs f = foldr f (return a) xs

mkSuffixM ss pps = SuffixM { ppChain = mkChain (suffixesToTry ss pps), ppSource = mkSource pps }

hs' m = HSource m `memo1`
     do
       chain <- imp $ flip ppChain m
       r <- case chain of
              NotBuilt -> return NotBuilt
              Chain _ _ -> imp $ \r -> ppSource r "hs" m
       return $ return r


mkRulesIO comp dist sps = RulesIO comp dist hs' sps
rulesIO = mkRulesIO undefined undefined undefined
suffixM = mkSuffixM undefined undefined

-- | Selects the right rule for a "source" by looking at the Chain
mkSource pps tag m = 
 Rel m tag `memo1` do
   (Chain path chain) <- imp $ flip ppChain m
   file <- select m tag chain
   return $ case file of 
       Nothing -> do 
              Just t <- stat (fullPath path)
              return (FileR path t)
       Just r -> return r
     where
      next x xs = case dropWhile ((/=x).fst) xs of
                    [] -> Nothing
                    (_:ys) -> Just ys       
      select m x xs = case fromJust (next x xs) of
                        [] -> return Nothing
                        ((pre,src):_) -> Just <$> case Data.List.find ((==pre) . ppTag) pps of
                                                    Just pp -> fromJust $ fmap (\g -> snd g m) (ppRule pp src)


-- chiRule and chsdepRule shouldn't be here but defined together with the rule for chs, 
-- but we don't have a proper abstraction for related rules yet.
chi m = Rel m "chi" `memo1` do
        c <- imp $ flip ppChain m 
        case c of
          NotBuilt -> return (return NotBuilt)
          Chain _ c | "c2hs" `elem` (map fst c) -> fmap return . readT (With "c2hs" (Rel m "chi")) $  undefined
                    | otherwise -> return $ fail "Suffix.chiRule: not available"


expr1 () = liftA2 (,) (chsdep undefined) (imp searchpaths)
u = undefined                            

chsdep file = Rel file "chsdep" `memo1` do
      (FileR hs _) <- imp $ \r -> ppSource r "c2hs" file
      return $ do
        imports <- catMaybes . map simpleParse . importsChs (fullPath hs) <$> readFile (fullPath hs)
        return $ Modules imports


-- | msum lifted in the naked Reader monad
msumR :: MonadPlus m => [a -> m b] -> a -> m b
msumR = (msum .) . sequence