content: {-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables, TupleSections #-}
  
  module Development.Ninja.All(runNinja) where
  
  import Development.Ninja.Env
  import Development.Ninja.Type
  import Development.Ninja.Parse
  import Development.Shake hiding (addEnv)
  import Development.Shake.Classes
  import qualified Data.ByteString as BS8
  import qualified Data.ByteString.Char8 as BS
  
  import System.Directory
  import qualified Data.HashMap.Strict as Map
  import qualified Data.HashSet as Set
  import Data.Tuple.Extra
  import Control.Exception.Extra
  import Control.Monad
  import Data.Maybe
  import Data.Char
  import Data.List.Extra
  import System.Info.Extra
  
  -- Internal imports
  import General.Extra(removeFile_, headErr)
  import General.Timing(addTiming)
  import General.Makefile(parseMakefile)
  import Development.Shake.Internal.FileName(filepathNormalise, fileNameFromString)
  import Development.Shake.Internal.FileInfo(getFileInfo)
  import Development.Shake.Internal.Errors(throwM, errorStructured)
  import Development.Shake.Internal.Rules.File(needBS, neededBS)
  import Development.Shake.Internal.Rules.OrderOnly(orderOnlyBS)
  
  
  -- | Given the Ninja source file, a list of file arguments, a tool name.
  --   Return a bool if you should restart and the rules.
  runNinja :: IO () -> FilePath -> [String] -> Maybe String -> IO (Maybe (Rules ()))
  runNinja _ file args (Just "compdb") = do
      dir <- getCurrentDirectory
      Ninja{..} <- parse file =<< newEnv
      rules<- pure $ Map.fromList [r | r <- rules, BS.unpack (fst r) `elem` args]
      -- the build items are generated in reverse order, hence the reverse
      let xs = [(a,b,file,rule) | (a,b@Build{..}) <- reverse $ multiples ++ map (first pure) singles
                                , Just rule <- [Map.lookup ruleName rules], file:_ <- [depsNormal]]
      xs <- forM xs $ \(out,Build{..},file,Rule{..}) -> do
          -- the order of adding new environment variables matters
          env <- scopeEnv env
          addEnv env (BS.pack "out") (BS.unwords $ map quote out)
          addEnv env (BS.pack "in") (BS.unwords $ map quote depsNormal)
          addEnv env (BS.pack "in_newline") (BS.unlines depsNormal)
          forM_ buildBind $ \(a,b) -> addEnv env a b
          addBinds env ruleBind
          commandline <- fmap BS.unpack $ askVar env $ BS.pack "command"
          pure $ CompDb dir commandline $ BS.unpack file
      putStr $ printCompDb xs
      pure Nothing
  
  runNinja _ _ _ (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x
  
  runNinja restart file args Nothing = do
      addTiming "Ninja parse"
      ninja@Ninja{..} <- parse file =<< newEnv
      pure $ Just $ do
          phonys<- pure $ Map.fromList phonys
          needDeps<- pure $ needDeps ninja phonys -- partial application
          singles<- pure $ Map.fromList $ map (first filepathNormalise) singles
          multiples<- pure $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map filepathNormalise) multiples, x <- xs]
          rules<- pure $ Map.fromList rules
          pools <- fmap Map.fromList $ forM ((BS.pack "console",1):pools) $ \(name,depth) ->
              (name,) <$> newResource (BS.unpack name) depth
  
          action $ do
              -- build the .ninja files, if they change, restart the build
              before <- liftIO $ mapM (getFileInfo False . fileNameFromString) sources
              need sources
              after <- liftIO $ mapM (getFileInfo False . fileNameFromString) sources
              if before /= after then
                  runAfter restart
               else
                  needBS $ concatMap (resolvePhony phonys) $
                      if not $ null args then map BS.pack args
                      else if not $ null defaults then defaults
                      else Map.keys singles ++ Map.keys multiples
  
          (\x -> map BS.unpack . fst <$> Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in
              build needDeps phonys rules pools out2 $ snd $ multiples Map.! headErr out2
  
          (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in
              build needDeps phonys rules pools [out2] $ singles Map.! out2
  
  
  resolvePhony :: Map.HashMap Str [Str] -> Str -> [Str]
  resolvePhony mp = f $ Left 100
      where
          f (Left 0) x = f (Right []) x
          f (Right xs) x | x `elem` xs = error $ "Ninja recursive phony involving " ++ BS.unpack x
          f a x = case Map.lookup x mp of
              Nothing -> [x]
              Just xs -> concatMap (f $ either (Left . subtract 1) (Right . (x:)) a) xs
  
  
  quote :: Str -> Str
  quote x | BS.any isSpace x = let q = BS.singleton '\"' in BS.concat [q,x,q]
          | otherwise = x
  
  
  build :: (Build -> [Str] -> Action ()) -> Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action ()
  build needDeps phonys rules pools out build@Build{..} = do
      needBS $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit
      orderOnlyBS $ concatMap (resolvePhony phonys) depsOrderOnly
      case Map.lookup ruleName rules of
          Nothing -> liftIO $ errorIO $ "Ninja rule named " ++ BS.unpack ruleName ++ " is missing, required to build " ++ BS.unpack (BS.unwords out)
          Just Rule{..} -> do
              env <- liftIO $ scopeEnv env
              liftIO $ do
                  -- the order of adding new environment variables matters
                  addEnv env (BS.pack "out") (BS.unwords $ map quote out)
                  addEnv env (BS.pack "in") (BS.unwords $ map quote depsNormal)
                  addEnv env (BS.pack "in_newline") (BS.unlines depsNormal)
                  forM_ buildBind $ \(a,b) -> addEnv env a b
                  addBinds env ruleBind
  
              applyRspfile env $ do
                  commandline <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "command"
                  depfile <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "depfile"
                  deps <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "deps"
                  description <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "description"
                  pool <- liftIO $ askVar env $ BS.pack "pool"
  
                  let withPool act = case Map.lookup pool pools of
                          _ | BS.null pool -> act
                          Nothing -> liftIO $ errorIO $ "Ninja pool named " ++ BS.unpack pool ++ " not found, required to build " ++ BS.unpack (BS.unwords out)
                          Just r -> withResource r 1 act
  
                  when (description /= "") $ putInfo description
                  let (cmdOpts, cmdProg, cmdArgs) = toCommand commandline
                  if deps == "msvc" then do
                      Stdout stdout <- withPool $ command cmdOpts cmdProg cmdArgs
                      prefix <- liftIO $ fmap (fromMaybe $ BS.pack "Note: including file: ") $
                                         askEnv env $ BS.pack "msvc_deps_prefix"
                      needDeps build $ parseShowIncludes prefix $ BS.pack stdout
                   else
                      withPool $ command_ cmdOpts cmdProg cmdArgs
                  when (depfile /= "") $ do
                      when (deps /= "gcc") $ need [depfile]
                      depsrc <- liftIO $ BS.readFile depfile
                      needDeps build $ concatMap snd $ parseMakefile depsrc
                      -- correct as per the Ninja spec, but breaks --skip-commands
                      -- when (deps == "gcc") $ liftIO $ removeFile depfile
  
  
  needDeps :: Ninja -> Map.HashMap Str [Str] -> Build -> [Str] -> Action ()
  needDeps Ninja{..} phonysMp = \build xs -> do -- eta reduced so 'builds' is shared
      opts <- getShakeOptions
      if isNothing $ shakeLint opts then needBS xs else do
          neededBS xs
          -- now try and statically validate needed will never fail
          -- first find which dependencies are generated files
          xs<- pure $ filter (`Map.member` builds) xs
          -- now try and find them as dependencies
          -- performance note: allDependencies generates lazily, and difference consumes lazily,
          -- with the property that in the common case it won't generate much of the list at all
          let bad = xs `difference` allDependencies build
          case bad of
              [] -> pure ()
              xs -> throwM $ errorStructured
                  ("Lint checking error - " ++
                      (if length xs == 1 then "file in deps is" else "files in deps are") ++
                      " generated and not a pre-dependency")
                  [("File", Just $ BS.unpack x) | x <- xs]
                  ""
      where
          builds :: Map.HashMap FileStr Build
          builds = Map.fromList $ singles ++ [(x,y) | (xs,y) <- multiples, x <- xs]
  
          -- do list difference, assuming a small initial set, most of which occurs early in the list
          difference :: (Eq a, Hashable a) => [a] -> [a] -> [a]
          difference [] _ = []
          difference xs ys = f (Set.fromList xs) ys
              where
                  f xs [] = Set.toList xs
                  f xs (y:ys)
                      | y `Set.member` xs = let xs2 = Set.delete y xs in if Set.null xs2 then [] else f xs2 ys
                      | otherwise = f xs ys
  
          -- find all dependencies of a rule, no duplicates, with all dependencies of this rule listed first
          allDependencies :: Build -> [FileStr]
          allDependencies rule = f Set.empty [] [rule]
              where
                  f _ [] [] = []
                  f seen [] (x:xs) = f seen (map filepathNormalise $ concatMap (resolvePhony phonysMp) $ depsNormal x ++ depsImplicit x ++ depsOrderOnly x) xs
                  f seen (x:xs) rest | x `Set.member` seen = f seen xs rest
                                     | otherwise = x : f (Set.insert x seen) xs (maybeToList (Map.lookup x builds) ++ rest)
  
  
  applyRspfile :: Env Str Str -> Action a -> Action a
  applyRspfile env act = do
      rspfile <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "rspfile"
      rspfile_content <- liftIO $ askVar env $ BS.pack "rspfile_content"
      if rspfile == "" then
          act
       else
          flip actionFinally (removeFile_ rspfile) $ do
              liftIO $ BS.writeFile rspfile rspfile_content
              act
  
  
  parseShowIncludes :: Str -> Str -> [FileStr]
  parseShowIncludes prefix out =
      [y | x <- BS.lines out, prefix `BS.isPrefixOf` x
         , let y = BS.dropWhile isSpace $ BS.drop (BS.length prefix) x
         , not $ isSystemInclude y]
  
  -- Dodgy, but ported over from the original Ninja
  isSystemInclude :: FileStr -> Bool
  isSystemInclude x = bsProgFiles `BS.isInfixOf` tx || bsVisStudio `BS.isInfixOf` tx
      where tx = BS8.map (\c -> if c >= 97 then c - 32 else c) x
                 -- optimised toUpper that only cares about letters and spaces
  
  bsProgFiles = BS.pack "PROGRAM FILES"
  bsVisStudio = BS.pack "MICROSOFT VISUAL STUDIO"
  
  
  data CompDb = CompDb
      {cdbDirectory :: String
      ,cdbCommand :: String
      ,cdbFile :: String
      }
      deriving Show
  
  printCompDb :: [CompDb] -> String
  printCompDb xs = unlines $ ["["] ++ concat (zipWithFrom f 1 xs) ++ ["]"]
      where
          n = length xs
          f i CompDb{..} =
              ["  {"
              ,"    \"directory\": " ++ g cdbDirectory ++ ","
              ,"    \"command\": " ++ g cdbCommand ++ ","
              ,"    \"file\": " ++ g cdbFile
              ,"  }" ++ (if i == n then "" else ",")]
          g = show
  
  
  toCommand :: String -> ([CmdOption], String, [String])
  toCommand s
      -- On POSIX, Ninja does a /bin/sh -c, and so does Haskell in Shell mode (easy).
      | not isWindows = ([Shell], s, [])
      -- On Windows, Ninja passes the string directly to CreateProcess,
      -- but Haskell applies some escaping first.
      -- We try and get back as close to the original as we can, but it's very hacky
      | length s < 8000 =
          -- Using the "cmd" program adds overhead (I measure 7ms), and a limit of 8191 characters,
          -- but is the most robust, requiring no additional escaping.
          ([Shell], s, [])
      | (cmd,s) <- word1 s, upper cmd `elem` ["CMD","CMD.EXE"], ("/c",s) <- word1 s =
          -- Given "cmd.exe /c <something>" we translate to Shell, which adds cmd.exe
          -- (looked up on the current path) and /c to the front. CMake uses this rule a lot.
          -- Adding quotes around pieces are /c goes very wrong.
          ([Shell], s, [])
      | otherwise =
          -- It's a long command line which doesn't call "cmd /c". We reverse the escaping
          -- Haskell applies, but each argument will still gain quotes around it.
          let xs = splitArgs s in ([], headDef "" xs, drop1 xs)
  
  
  data State
      = Gap -- ^ Current in the gap between words
      | Word -- ^ Currently inside a space-separated argument
      | Quot -- ^ Currently inside a quote-surrounded argument
  
  -- | The process package contains a translate function, reproduced below. The aim is that after command line
  --   parsing we should get out mostly the same answer.
  splitArgs :: String -> [String]
  splitArgs = f Gap
      where
          f Gap (x:xs) | isSpace x = f Gap xs
          f Gap ('\"':xs) = f Quot xs
          f Gap [] = []
          f Gap xs = f Word xs
          f Word (x:xs) | isSpace x = [] : f Gap xs
          f Quot ('\"':xs) = [] : f Gap xs
          f s ('\\':xs) | (length -> a, b) <- span (== '\\') xs = case b of
              '\"':xs | even a -> add (replicate (a `div` 2) '\\' ++ "\"") $ f s xs
                      | otherwise -> add (replicate ((a+1) `div` 2) '\\') $ f s ('\"':xs)
              xs -> add (replicate (a+1) '\\') $ f s xs
          f s (x:xs) = add [x] $ f s xs
          f _ [] = [[]]
  
          add a (b:c) = (a++b):c
          add a [] = [a]
  
  {-
  translate (cmd,args) = unwords $ f cmd : map f args
      where
          f x = '"' : snd (foldr escape (True,"\"") xs)
          escape '"'  (_,     str) = (True,  '\\' : '"'  : str)
          escape '\\' (True,  str) = (True,  '\\' : '\\' : str)
          escape c    (_,     str) = (False, c : str)
  -}
  