Copyright (C) 2009 Mathieu Boespflug <mboes@tweag.net>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

> module Eval (Target(..), eval, evalNoMeta, Eval.isStale, substituteStem) where
>
> import Parse
> import Control.Hmk
> import qualified Control.Hmk.IO as IO
>
> import Data.Sequence (Seq)
> import qualified Data.Sequence as Seq
> import qualified Data.Traversable as Seq
> import qualified Data.Foldable as Seq
> import qualified Data.Map as Map
> import qualified Data.Foldable as Map
> import qualified Data.Set as Set
> import Control.Applicative
> import Control.Monad.State
> import Control.Monad.Writer
> import Data.List (intercalate)
> import Data.Maybe (isNothing)
>
> import System.IO
> import System.Directory
> import System.Exit
> import System.Process
> import System.Posix.Env
> import System.Posix.Process (getProcessID)

Default shell to pass recipes to. The shell used should understand the -e and
-x switches, which means stop executing on first non-zero exit status and
trace execution, respectively.

> defaultShell = "/bin/sh"

> instance Monad m => Applicative (StateT s m) where
>     pure = return
>     (<*>) = ap
>
> instance (Monoid w, Monad m) => Applicative (WriterT w m) where
>     pure = return
>     (<*>) = ap

Targets are either regular files, virtual or patterns. After instantiation of
meta-rules the patterns disappear, leaving only files and virtual targets. But
it cannot be known until after evaluation of all rules whether a target is
virtual or not. However, thanks to lazy evaluation, we can lookup wether a
target is virtual or not now, if we promise to build it later.

> data Target = File { name :: FilePath }
>             | Virtual { name :: String }
>             | Pattern { name :: String }
>               deriving Show

> newtype RevAppend a = RevAppend a
>
> instance Monoid a => Monoid (RevAppend a) where
>     mempty = RevAppend mempty
>     mappend (RevAppend x) (RevAppend y) = RevAppend (mappend y x)

Only the name of targets matters when comparing them, so we make equality into
an equivalence relation rather than the default structural equality.

> instance Eq Target where
>     x == y = name x == name y
>
> instance Ord Target where
>     compare x y = compare (name x) (name y)

Variable references are substituted for their values, using the environment.

A list of tokens can be spliced, appended to, etc, to form a new list of
tokens. Freezing means turning a list of tokens into a string, which cannot be
manipulated any further. This string representation is used to export values
to the outside world, such as the system environment.

> freeze :: Seq String -> String
> freeze = intercalate " " . Seq.toList

The environment is a variable store that can be updated in place. It is very
much not a persistent abstraction. We implement it using an internal map
rather than using the system environment directly because using the system
environment would require retokenizing values when we look them up. The
content of this internal map is immediately reflected into the system
environment, however, because assignments that are exported need to be
available to subprocesses forked during sourcing and piping.

Evaluation substitutes values for all variable references, using the system
environment as a variable store. Assignments are executed first, then PRule's
are evaluated to Rule's, the data structure for rules used by Control.Hmk. The
return value is a sequence of functions mapping stems to rules. This is
because stems are synthesized as a by-product of meta-rule instantiaton, but
this instantiation is performed post evaluation.

> type Stem = String
>
> addVariable attr var val = do
>   modify (Map.insert var (val :: Seq String))
>   case attr of
>     Export -> liftIO $ setEnv var (freeze val) True
>     Local -> return ()
>
> lookupVariable var = Map.findWithDefault (Seq.empty) var <$> get
>
> evalToken (Lit x) = return (Seq.singleton x)
> evalToken (Coll toks) = Seq.singleton <$> Seq.concat <$>
>                         Seq.mapM ((f <$>) . evalToken) toks
>     where f ls | Seq.length ls == 1 = Seq.index ls 0
>                | otherwise = error "Cannot collate lists."
> evalToken (Ref tok) = do
>                var <- evalToken tok
>                lookupVariable (freeze var)
>
> eval :: Mkfile -> IO (Seq (Stem -> Rule IO Target))
> eval mkfile = evalStateT (init >> go) Map.empty
>     where init = addVariable Export "MKSHELL" (Seq.singleton defaultShell)
>           go = mdo (rules, RevAppend virtuals) <- runWriterT (eval' virtuals mkfile)
>                    return rules
>
> eval' virtuals (Mkrule ts flags ps r cont) = do
>   let tag t = if t `elem` virtuals
>               then Virtual t
>               else case t of
>                      '%':_ -> Pattern t
>                      _ -> File t
>   tsv <- Seq.msum <$> Seq.mapM evalToken ts
>   psv <- fmap tag <$> Seq.msum <$> Seq.mapM evalToken ps
>   flagsv <- evalFlags flags
>   shell <- (`Seq.index` 0) <$> lookupVariable "MKSHELL"
>   let f tv stem = let t | Set.member Flag_V flagsv = Virtual tv
>                         | '%':_ <- tv              = Pattern tv
>                         | otherwise                = File tv
>                       rv = if Set.member Flag_N flagsv && isNothing r
>                            then Just $ evalRecipe tsv t flagsv psv stem shell ("touch " ++ name t)
>                            else fmap (evalRecipe tsv t flagsv psv stem shell) r
>                       cmp = Set.fold (\x cmp -> case x of
>                                                   Flag_P cmp -> evalCompare cmp
>                                                   _ -> cmp) Eval.isStale flagsv
>                   in if Set.member Flag_V flagsv
>                      then Rule t (Seq.toList psv) rv (\_ _ -> return True)
>                      else Rule t (Seq.toList psv) rv cmp
>   when (Set.member Flag_V flagsv) (Seq.mapM_ (tell . RevAppend . return) tsv)
>   (Seq.><) <$> pure (fmap f tsv) <*> eval' virtuals cont
> eval' virtuals (Mkassign attr var val cont) = do
>   -- xxx take into account attributes.
>   lits <- Seq.msum <$> Seq.mapM evalToken val
>   addVariable attr var lits
>   eval' virtuals cont
> eval' virtuals (Mkinsert file cont) = do
>   filev <- evalToken file
>   unless (Seq.length filev == 1)
>              (error "Insertion must evaluate to a unique filename.")
>   let fp = Seq.index filev 0
>   (Seq.><) <$> (eval' virtuals =<< parse fp <$> liftIO (readFile fp)) <*> eval' virtuals cont
> eval' virtuals (Mkinpipe command cont) = do
>   commandv <- Seq.msum <$> Seq.mapM evalToken command
>   when (Seq.length commandv == 0)
>              (error "Command evaluated to empty string.")
>   let (cmd:args) = Seq.toList commandv
>   (_, Just outh, _, ph) <- liftIO $ createProcess (proc cmd args) { std_out = CreatePipe }
>   result <- liftIO $ hGetContents outh
>   code <- liftIO $ waitForProcess ph
>   case code of
>     ExitSuccess ->
>         (Seq.><) <$> eval' virtuals (parse "<pipe>" result) <*> eval' virtuals cont
>     ExitFailure n ->
>         error $ "Sub-process " ++ cmd ++ " exited with error status " ++ show n ++ "."
> eval' virtuals Mkeof = return Seq.empty

A recipe is executed by supplying the recipe as standard input to the shell.
(Note that unlike make, hmk feeds the entire recipe to the shell rather than
running each line of the recipe separately.)

> substituteStem stem (Pattern ('%':suffix)) = File (stem ++ suffix)
> substituteStem stem x = x
>
> evalRecipe alltarget target flags prereq stem shell text newprereq = do
>   pid <- show <$> getProcessID
>   setEnv "alltarget" (freeze alltarget) True
>   setEnv "newprereq" (intercalate " " (map (name . substituteStem stem) newprereq)) True
>   setEnv "newmember" "" True -- xxx aggregates not supported.
>   setEnv "nproc" (show 0) True
>   setEnv "pid" pid True
>   setEnv "prereq" (freeze (fmap (name . substituteStem stem) prereq)) True
>   setEnv "stem" stem True
>   setEnv "target" (name $ substituteStem stem $ target) True
>   let p = if Set.member Flag_Q flags
>           then proc shell ["-e"]
>           else proc shell ["-ex"]
>   (Just inh, _, _, ph) <- createProcess p { std_in = CreatePipe }
>   hSetBinaryMode inh False
>   hPutStrLn inh text
>   hClose inh
>   code <- waitForProcess ph >>= IO.testExitCode
>   let final = if Set.member Flag_E flags
>               then return TaskSuccess else return code :: IO Result
>   let final' = if Set.member Flag_D flags
>               then case code of
>                        TaskFailure -> removeFile (name target) >> final
>                        TaskSuccess -> final
>               else final
>   final'

Parsing flags has to be done at evaluation time because we allow variable
references in place of flag characters, for instance to programmatically turn
on or off verbosity of rules, etc. The content of the flags field of a rule is
necessarily either a collation or a literal.

> evalFlags toks = do
>   v <- Seq.msum <$> Seq.mapM evalToken toks
>   return $ interp (freeze v)
>     where interp "" = Set.empty
>           interp ('D':xs) = Set.insert Flag_D (interp xs)
>           interp ('E':xs) = Set.insert Flag_E (interp xs)
>           interp ('N':xs) = Set.insert Flag_N (interp xs)
>           interp ('n':xs) = Set.insert Flag_n (interp xs)
>           interp ('P':xs) = Set.singleton (Flag_P xs)
>           interp ('Q':xs) = Set.insert Flag_Q (interp xs)
>           interp ('R':xs) = Set.insert Flag_R (interp xs)
>           interp ('U':xs) = Set.insert Flag_U (interp xs)
>           interp ('V':xs) = Set.insert Flag_V (interp xs)

A user supplied comparison command is wrapped into an action in the IO monad.

> evalCompare cmp (File x) (File y) = do
>   code <- rawSystem cmp [x, y]
>   case code of
>       ExitSuccess -> return False
>       ExitFailure _ -> return True

The default comparison action.

> isStale (File x) (File y) = IO.isStale x y
> isStale (File x) (Virtual y) = return True
> isStale _ _ = error "impossible."

Version of eval where stems are instantiated to the empty string.

> evalNoMeta :: Mkfile -> IO (Seq (Rule IO Target))
> evalNoMeta mkfile = fmap ($ "") <$> eval mkfile