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