{-# LANGUAGE RecordWildCards, TupleSections #-} module Development.Ninja.Parse(parse) where import qualified Data.ByteString.Char8 as BS import Development.Ninja.Env import Development.Ninja.Type import Development.Ninja.Lexer import Control.Applicative import Control.Monad import Prelude parse :: FilePath -> Env Str Str -> IO Ninja parse :: FilePath -> Env Str Str -> IO Ninja parse file :: FilePath file env :: Env Str Str env = FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile FilePath file Env Str Str env Ninja newNinja parseFile :: FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile :: FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile file :: FilePath file env :: Env Str Str env ninja :: Ninja ninja = do [Lexeme] lexes <- Maybe FilePath -> IO [Lexeme] lexerFile (Maybe FilePath -> IO [Lexeme]) -> Maybe FilePath -> IO [Lexeme] forall a b. (a -> b) -> a -> b $ if FilePath file FilePath -> FilePath -> Bool forall a. Eq a => a -> a -> Bool == "-" then Maybe FilePath forall a. Maybe a Nothing else FilePath -> Maybe FilePath forall a. a -> Maybe a Just FilePath file (Ninja -> (Lexeme, [(Str, Expr)]) -> IO Ninja) -> Ninja -> [(Lexeme, [(Str, Expr)])] -> IO Ninja forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM (Env Str Str -> Ninja -> (Lexeme, [(Str, Expr)]) -> IO Ninja applyStmt Env Str Str env) Ninja ninja{sources :: [FilePath] sources=FilePath fileFilePath -> [FilePath] -> [FilePath] forall a. a -> [a] -> [a] :Ninja -> [FilePath] sources Ninja ninja} ([(Lexeme, [(Str, Expr)])] -> IO Ninja) -> [(Lexeme, [(Str, Expr)])] -> IO Ninja forall a b. (a -> b) -> a -> b $ [Lexeme] -> [(Lexeme, [(Str, Expr)])] withBinds [Lexeme] lexes withBinds :: [Lexeme] -> [(Lexeme, [(Str,Expr)])] withBinds :: [Lexeme] -> [(Lexeme, [(Str, Expr)])] withBinds [] = [] withBinds (x :: Lexeme x:xs :: [Lexeme] xs) = (Lexeme x,[(Str, Expr)] a) (Lexeme, [(Str, Expr)]) -> [(Lexeme, [(Str, Expr)])] -> [(Lexeme, [(Str, Expr)])] forall a. a -> [a] -> [a] : [Lexeme] -> [(Lexeme, [(Str, Expr)])] withBinds [Lexeme] b where (a :: [(Str, Expr)] a,b :: [Lexeme] b) = [Lexeme] -> ([(Str, Expr)], [Lexeme]) f [Lexeme] xs f :: [Lexeme] -> ([(Str, Expr)], [Lexeme]) f (LexBind a :: Str a b :: Expr b : rest :: [Lexeme] rest) = let (as :: [(Str, Expr)] as,bs :: [Lexeme] bs) = [Lexeme] -> ([(Str, Expr)], [Lexeme]) f [Lexeme] rest in ((Str a,Expr b)(Str, Expr) -> [(Str, Expr)] -> [(Str, Expr)] forall a. a -> [a] -> [a] :[(Str, Expr)] as, [Lexeme] bs) f xs :: [Lexeme] xs = ([], [Lexeme] xs) applyStmt :: Env Str Str -> Ninja -> (Lexeme, [(Str,Expr)]) -> IO Ninja applyStmt :: Env Str Str -> Ninja -> (Lexeme, [(Str, Expr)]) -> IO Ninja applyStmt env :: Env Str Str env ninja :: Ninja ninja@Ninja{..} (key :: Lexeme key, binds :: [(Str, Expr)] binds) = case Lexeme key of LexBuild outputs :: [Expr] outputs rule :: Str rule deps :: [Expr] deps -> do [Str] outputs <- (Expr -> IO Str) -> [Expr] -> IO [Str] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Env Str Str -> Expr -> IO Str askExpr Env Str Str env) [Expr] outputs [Str] deps <- (Expr -> IO Str) -> [Expr] -> IO [Str] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Env Str Str -> Expr -> IO Str askExpr Env Str Str env) [Expr] deps [(Str, Str)] binds <- ((Str, Expr) -> IO (Str, Str)) -> [(Str, Expr)] -> IO [(Str, Str)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (\(a :: Str a,b :: Expr b) -> (Str a,) (Str -> (Str, Str)) -> IO Str -> IO (Str, Str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Env Str Str -> Expr -> IO Str askExpr Env Str Str env Expr b) [(Str, Expr)] binds let (normal :: [Str] normal,implicit :: [Str] implicit,orderOnly :: [Str] orderOnly) = [Str] -> ([Str], [Str], [Str]) splitDeps [Str] deps let build :: Build build = Str -> Env Str Str -> [Str] -> [Str] -> [Str] -> [(Str, Str)] -> Build Build Str rule Env Str Str env [Str] normal [Str] implicit [Str] orderOnly [(Str, Str)] binds Ninja -> IO Ninja forall (m :: * -> *) a. Monad m => a -> m a return (Ninja -> IO Ninja) -> Ninja -> IO Ninja forall a b. (a -> b) -> a -> b $ if Str rule Str -> Str -> Bool forall a. Eq a => a -> a -> Bool == FilePath -> Str BS.pack "phony" then Ninja ninja{phonys :: [(Str, [Str])] phonys = [(Str x, [Str] normal [Str] -> [Str] -> [Str] forall a. [a] -> [a] -> [a] ++ [Str] implicit [Str] -> [Str] -> [Str] forall a. [a] -> [a] -> [a] ++ [Str] orderOnly) | Str x <- [Str] outputs] [(Str, [Str])] -> [(Str, [Str])] -> [(Str, [Str])] forall a. [a] -> [a] -> [a] ++ [(Str, [Str])] phonys} else if [Str] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Str] outputs Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == 1 then Ninja ninja{singles :: [(Str, Build)] singles = ([Str] -> Str forall a. [a] -> a head [Str] outputs, Build build) (Str, Build) -> [(Str, Build)] -> [(Str, Build)] forall a. a -> [a] -> [a] : [(Str, Build)] singles} else Ninja ninja{multiples :: [([Str], Build)] multiples = ([Str] outputs, Build build) ([Str], Build) -> [([Str], Build)] -> [([Str], Build)] forall a. a -> [a] -> [a] : [([Str], Build)] multiples} LexRule name :: Str name -> Ninja -> IO Ninja forall (m :: * -> *) a. Monad m => a -> m a return Ninja ninja{rules :: [(Str, Rule)] rules = (Str name, [(Str, Expr)] -> Rule Rule [(Str, Expr)] binds) (Str, Rule) -> [(Str, Rule)] -> [(Str, Rule)] forall a. a -> [a] -> [a] : [(Str, Rule)] rules} LexDefault xs :: [Expr] xs -> do [Str] xs <- (Expr -> IO Str) -> [Expr] -> IO [Str] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Env Str Str -> Expr -> IO Str askExpr Env Str Str env) [Expr] xs Ninja -> IO Ninja forall (m :: * -> *) a. Monad m => a -> m a return Ninja ninja{defaults :: [Str] defaults = [Str] xs [Str] -> [Str] -> [Str] forall a. [a] -> [a] -> [a] ++ [Str] defaults} LexPool name :: Str name -> do Int depth <- Env Str Str -> [(Str, Expr)] -> IO Int getDepth Env Str Str env [(Str, Expr)] binds Ninja -> IO Ninja forall (m :: * -> *) a. Monad m => a -> m a return Ninja ninja{pools :: [(Str, Int)] pools = (Str name, Int depth) (Str, Int) -> [(Str, Int)] -> [(Str, Int)] forall a. a -> [a] -> [a] : [(Str, Int)] pools} LexInclude expr :: Expr expr -> do Str file <- Env Str Str -> Expr -> IO Str askExpr Env Str Str env Expr expr FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile (Str -> FilePath BS.unpack Str file) Env Str Str env Ninja ninja LexSubninja expr :: Expr expr -> do Str file <- Env Str Str -> Expr -> IO Str askExpr Env Str Str env Expr expr Env Str Str e <- Env Str Str -> IO (Env Str Str) forall k v. Env k v -> IO (Env k v) scopeEnv Env Str Str env FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile (Str -> FilePath BS.unpack Str file) Env Str Str e Ninja ninja LexDefine a :: Str a b :: Expr b -> do Env Str Str -> Str -> Expr -> IO () addBind Env Str Str env Str a Expr b Ninja -> IO Ninja forall (m :: * -> *) a. Monad m => a -> m a return Ninja ninja LexBind a :: Str a _ -> FilePath -> IO Ninja forall a. HasCallStack => FilePath -> a error (FilePath -> IO Ninja) -> FilePath -> IO Ninja forall a b. (a -> b) -> a -> b $ "Unexpected binding defining " FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ Str -> FilePath BS.unpack Str a splitDeps :: [Str] -> ([Str], [Str], [Str]) splitDeps :: [Str] -> ([Str], [Str], [Str]) splitDeps (x :: Str x:xs :: [Str] xs) | Str x Str -> Str -> Bool forall a. Eq a => a -> a -> Bool == FilePath -> Str BS.pack "|" = ([],[Str] a[Str] -> [Str] -> [Str] forall a. [a] -> [a] -> [a] ++[Str] b,[Str] c) | Str x Str -> Str -> Bool forall a. Eq a => a -> a -> Bool == FilePath -> Str BS.pack "||" = ([],[Str] b,[Str] a[Str] -> [Str] -> [Str] forall a. [a] -> [a] -> [a] ++[Str] c) | Bool otherwise = (Str xStr -> [Str] -> [Str] forall a. a -> [a] -> [a] :[Str] a,[Str] b,[Str] c) where (a :: [Str] a,b :: [Str] b,c :: [Str] c) = [Str] -> ([Str], [Str], [Str]) splitDeps [Str] xs splitDeps [] = ([], [], []) getDepth :: Env Str Str -> [(Str, Expr)] -> IO Int getDepth :: Env Str Str -> [(Str, Expr)] -> IO Int getDepth env :: Env Str Str env xs :: [(Str, Expr)] xs = case Str -> [(Str, Expr)] -> Maybe Expr forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup (FilePath -> Str BS.pack "depth") [(Str, Expr)] xs of Nothing -> Int -> IO Int forall (m :: * -> *) a. Monad m => a -> m a return 1 Just x :: Expr x -> do Str x <- Env Str Str -> Expr -> IO Str askExpr Env Str Str env Expr x case Str -> Maybe (Int, Str) BS.readInt Str x of Just (i :: Int i, n :: Str n) | Str -> Bool BS.null Str n -> Int -> IO Int forall (m :: * -> *) a. Monad m => a -> m a return Int i _ -> FilePath -> IO Int forall a. HasCallStack => FilePath -> a error (FilePath -> IO Int) -> FilePath -> IO Int forall a b. (a -> b) -> a -> b $ "Could not parse depth field in pool, got: " FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ Str -> FilePath BS.unpack Str x