{-# LANGUAGE EmptyDataDecls, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, TemplateHaskell #-}
module Make.Rules.Dyn.Suffix where

import Control.Arrow
import Control.Applicative
import Data.Typeable
import Data.Monoid
import Data.Binary
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Make.Rules.Dyn.Types
import Make.Rules.Dyn
import Make.Memo.Dynamic
import Make.Module hiding (get)
import System.FilePath
import Control.Monad.Writer
import Control.Monad.Stream
import Data.Maybe
import Data.DeriveTH
import Control.Monad
import Data.List

newtype Suffix = Suffix [String] 
    deriving (Typeable,Show,Monoid,Eq,Ord,Binary)

newtype Tag = Tag String 
    deriving (Eq,Ord,Show,Binary)

mkTag :: Clause Pattern -> Tag
mkTag c = Tag $ pprint (source c) ++ "," ++ unwords (map pprint (targets c))

data Clause a = Clause { source :: a, targets :: [a] }
              deriving (Eq,Ord,Typeable,Show)

instance Functor Clause where
    fmap f (Clause a b) = Clause (f a) (fmap f b)

data Link a = Link { clause :: Clause a, tag :: Tag } 
            deriving (Eq,Ord,Typeable,Show)

linkTargets = targets . clause
linkSource = source . clause

instance Functor Link where
    fmap f (Link c t) = Link (fmap f c) t

data Chain r = Base Suffix r | Snoc (Link Suffix) (Chain r) deriving (Eq,Ord,Typeable,Show)

extract (Base _ x) = x
extract (Snoc _ x) = extract x

query :: Suffix -> Chain a -> Maybe (Either a (Link Suffix))
query t (Base s r) | s == t    = Just $ Left r
                   | otherwise = Nothing
query t (Snoc l c) | t `elem` linkTargets l = Just $ Right l
                   | otherwise = query t c

instance Functor Chain where
    fmap f (Base s r) = Base s (f r)
    fmap f (Snoc l c) = Snoc l (fmap f c)

nodeTargets (Base s _) = [s]
nodeTargets (Snoc l _) = linkTargets l
chainTargets = nodeTargets
chainSource (Base s _) = s
chainSource (Snoc _ c) = chainSource c
chain_invariant1 (Base _ _) = True
chain_invariant1 (Snoc l c) = chain_invariant1 c && linkSource l `elem` chainTargets c

append (Base _ _) x = x
append (Snoc l c) x = Snoc l (append c x)


prop_append x y = (chainSource x `elem` chainTargets y) ==> 
                    chain_invariant1 xy && 
                    chainSource xy == chainSource y && 
                    chainTargets x `subset` chainTargets xy
    where
      xy = append x y
      True ==> False = False
      _    ==> _     = True
      x `subset` y = x \\ y == []

newtype Mon r = Mon (Maybe (Chain r))
instance Show r => Monoid (Mon r) where
    mempty = Mon Nothing
    mappend (Mon x) (Mon y) = Mon $ (do a <- x
                                        b <- y
                                        guard (prop_append a b) `mplus` error (show (a,b))
                                        return $ append a b) `mplus` x `mplus` y
toMon = Mon . Just
fromMon (Mon x) = fromJust x

search :: [Suffix -> Maybe (Link Suffix)]
           -> [Suffix]
           -> [Chain Suffix]
search pps xs = map fromMon . runStream . execWriterT $ do 
  x <- msum $ map return xs
  tell $ toMon $ Base x x 
  return () `mplus` search' pps x
    where
      search' pps x = do
        (pp,pps) <- select pps
        l <- maybe mzero return (pp x)
        tell $ toMon $ Snoc l $ Base (linkSource l) (linkSource l)
        return () `mplus` search' pps (linkSource l)

-- invariant: results match targets order
data Action m = A { apply :: ModuleName 
                          -> Suffix -- source 
                          -> [Suffix] -- targets
                          -> m [FileR] -- results
                  }

data Pattern = Var | End | Step String Pattern deriving Show

pprint :: Pattern -> String
pprint Var = "%"
pprint End = "$"
pprint (Step s p) = s ++ "." ++ pprint p

data Binding = NoBind | BindTo Suffix

match :: Pattern -> Suffix -> Maybe Binding
match p (Suffix ss) = go p ss
    where go (Step p ps) (s:ss) | p == s = go ps ss
          go Var     ss                  = Just (BindTo (Suffix ss))
          go End     []                  = Just NoBind
          go _       _                   = Nothing

subst p = Suffix . subst' p
 where
   subst' End = const []
   subst' Var = \b -> case b of
                    NoBind -> [] -- sound?
                    BindTo (Suffix xs) ->  xs
   subst' (Step p ps) = (p:) . subst' ps

data PreProcessor m = PP { link :: Link Pattern , action :: Action m }

type Matcher f = Suffix -> Maybe (f Suffix)

toMatcher' :: Clause Pattern -> Matcher Clause
toMatcher' c = \potential -> 
                          do binding <-  msum . map (flip match potential) $ targets c
                             return $ fmap (flip subst binding) c

toMatcher :: Link Pattern -> Matcher Link
toMatcher l potential = 
    do c <- toMatcher' (clause l) potential
       return $ l { clause = c } 

                    
select :: (MonadPlus m, Functor m) => [a] -> m (a, [a])
select [x] = return (x,[])
select (x:xs) = return (x,xs) `mplus` fmap (second (x:)) (select xs)

--------------------------------------------------------------------------------

data SuffixM m = SuffixM { resolve :: ModuleName -> Suffix -> m (Maybe FileR) 
                         }

mkSuffixM :: (ModuleM RulesIO m,
              MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m) =>
             [PreProcessor m] -> [Suffix] -> SuffixM m
mkSuffixM pps bases = SuffixM { resolve = resolve' (chain' pps bases) pps }
resolve' :: (MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m) =>
            (ModuleName -> m (Chain Path))
            -> [PreProcessor m]
            -> ModuleName
            -> Suffix
            -> m (Maybe FileR)
resolve' chain pps = \module_ s -> ("resolve",module_,s) `memoPure1` do
                c <- chain module_
                case query s c of
                  Nothing -> return Nothing
                  Just (Right l) -> do Just pp <- return $ Data.List.find (\pp -> tag l == tag (link pp)) pps
                                       lookup s . zip (linkTargets l) <$> apply (action pp) module_ (linkSource l) (linkTargets l)
                  Just (Left p)  -> Just <$> readFileR p

chain' :: (ModuleM RulesIO m1,
           MonadMemo (DynamicC TargetCxt) (DynamicC Cxt) IO m1) =>
          [PreProcessor m] -> [Suffix] -> ModuleName -> m1 (Chain Path)
chain' pps bases = \module_ -> ("chain",module_) `memoPure1` do
                     dirs <- imp searchpaths
                     let paths = suffixes dirs module_ $ chains
                     mc <- findM (exist . extract) paths
                     case mc of 
                       Nothing -> fail $ "No source found for" ++ show module_
                       Just c -> return c
    where
      chains = search (map (toMatcher . link) pps) bases


toFilePath :: ModuleName -> Suffix -> FilePath
toFilePath module_ (Suffix xs) = foldr (flip (<.>)) (ModuleName.toFilePath module_) xs

suffixes :: [FilePath] -> ModuleName -> [Chain Suffix] -> [Chain Path]
suffixes sourcedirs module_ cs = [ fmap (Path d . toFilePath module_) c 
                                 | d <- sourcedirs
                                 , c <- cs ]
                                   
findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
findM _ [] = return Nothing
findM f (x:xs) = do b <- f x
                    if b then return $ Just x else findM f xs

$(liftM concat . mapM (derive makeBinary) $ [''Chain,''Link,''Clause])

-------------------------------------------------------------------------------

-- * Prettier syntax to define preprocessors

mkAction = A
base = End
(>.<) = flip Step
var = Var

(targets <~ src) c = [ PP { link = Link { clause = clause, tag = mkTag clause }, action = mkAction c } ]
    where 
      clause = Clause { targets = targets, source = src}