{-# 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.Monad


parse :: FilePath -> Env Str Str -> IO Ninja
parse :: FilePath -> Env Str Str -> IO Ninja
parse FilePath
file 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 FilePath
file Env Str Str
env 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
== FilePath
"-" 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 (Lexeme
x:[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
        ([(Str, Expr)]
a,[Lexeme]
b) = [Lexeme] -> ([(Str, Expr)], [Lexeme])
f [Lexeme]
xs
        f :: [Lexeme] -> ([(Str, Expr)], [Lexeme])
f (LexBind Str
a Expr
b : [Lexeme]
rest) = let ([(Str, Expr)]
as,[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 [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 Str Str
env ninja :: Ninja
ninja@Ninja{[FilePath]
[([Str], Build)]
[(Str, Int)]
[(Str, [Str])]
[(Str, Rule)]
[(Str, Build)]
[Str]
pools :: Ninja -> [(Str, Int)]
defaults :: Ninja -> [Str]
phonys :: Ninja -> [(Str, [Str])]
multiples :: Ninja -> [([Str], Build)]
singles :: Ninja -> [(Str, Build)]
rules :: Ninja -> [(Str, Rule)]
pools :: [(Str, Int)]
defaults :: [Str]
phonys :: [(Str, [Str])]
multiples :: [([Str], Build)]
singles :: [(Str, Build)]
rules :: [(Str, Rule)]
sources :: [FilePath]
sources :: Ninja -> [FilePath]
..} (Lexeme
key, [(Str, Expr)]
binds) = case Lexeme
key of
    LexBuild [Expr]
outputs Str
rule [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 (\(Str
a,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 ([Str]
normal,[Str]
implicit,[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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 FilePath
"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
== Int
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 Str
name ->
        Ninja -> IO Ninja
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 [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 (f :: * -> *) a. Applicative f => a -> f a
pure Ninja
ninja{defaults :: [Str]
defaults = [Str]
xs [Str] -> [Str] -> [Str]
forall a. [a] -> [a] -> [a]
++ [Str]
defaults}
    LexPool Str
name -> do
        Int
depth <- Env Str Str -> [(Str, Expr)] -> IO Int
getDepth Env Str Str
env [(Str, Expr)]
binds
        Ninja -> IO Ninja
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> 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 -> 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 Str
a Expr
b -> do
        Env Str Str -> Str -> Expr -> IO ()
addBind Env Str Str
env Str
a Expr
b
        Ninja -> IO Ninja
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ninja
ninja
    LexBind Str
a Expr
_ ->
        FilePath -> IO Ninja
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO Ninja) -> FilePath -> IO Ninja
forall a b. (a -> b) -> a -> b
$ FilePath
"Ninja parsing, 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 (Str
x:[Str]
xs) | Str
x Str -> Str -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Str
BS.pack FilePath
"|" = ([],[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 FilePath
"||" = ([],[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 ([Str]
a,[Str]
b,[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 Str Str
env [(Str, Expr)]
xs = case Str -> [(Str, Expr)] -> Maybe Expr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> Str
BS.pack FilePath
"depth") [(Str, Expr)]
xs of
    Maybe Expr
Nothing -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
    Just 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 (Int
i, Str
n) | Str -> Bool
BS.null Str
n -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
            Maybe (Int, Str)
_ -> FilePath -> IO Int
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO Int) -> FilePath -> IO Int
forall a b. (a -> b) -> a -> b
$ FilePath
"Ninja parsing, could not parse depth field in pool, got: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Str -> FilePath
BS.unpack Str
x