-- -*- coding: utf-8; mode: haskell; -*- -- File: library/Language/Ninja/Parser.hs -- -- License: -- Copyright Neil Mitchell 2011-2017. -- Copyright Awake Networks 2017. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- * Redistributions in binary form must reproduce the above -- copyright notice, this list of conditions and the following -- disclaimer in the documentation and/or other materials provided -- with the distribution. -- -- * Neither the name of Neil Mitchell nor the names of other -- contributors may be used to endorse or promote products derived -- from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | -- Module : Language.Ninja.Parser -- Copyright : Copyright 2011-2017 Neil Mitchell -- License : BSD3 -- Maintainer : opensource@awakesecurity.com -- Stability : experimental -- -- Parse a Ninja file. -- -- @since 0.1.0 module Language.Ninja.Parser ( -- * @parse*IO@ parseFileIO , parseTextIO , parseBSIO , parseLexemesIO -- * @parse*@ , parseFile , parseText , parseBS , parseLexemes -- * @parse*WithEnv@ , parseFileWithEnv , parseTextWithEnv , parseBSWithEnv , parseLexemesWithEnv ) where import Control.Arrow (second) import Control.Exception (throwIO) import Control.Monad ((>=>)) import Control.Monad.Error.Class (MonadError) import Control.Monad.Trans.Except (runExceptT) import qualified Control.Lens as Lens #if __GLASGOW_HASKELL__ >= 800 import Data.Maybe (Maybe (Just, Nothing)) #endif import Data.Monoid (Endo (Endo, appEndo), (<>)) import qualified Data.ByteString.Char8 as BSC8 import Data.Text (Text) import qualified Data.Text.Encoding as Text import qualified Data.HashMap.Strict as HM import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Language.Ninja.Lexer (Ann) import qualified Language.Ninja.AST as AST import qualified Language.Ninja.Errors as Errors import qualified Language.Ninja.Lexer as Lexer import qualified Language.Ninja.Misc as Misc import qualified Language.Ninja.Mock as Mock import Flow ((.>), (|>)) -------------------------------------------------------------------------------- -- | Parse the file at the given path into a 'AST.Ninja'. -- This function may throw an exception if parsing fails. -- -- @since 0.1.0 parseFileIO :: Misc.Path -> IO (AST.Ninja Ann) parseFileIO file = forceIO (parseFile file) -- | Parse the given 'Text' into a 'AST.Ninja'. -- This function may throw an exception if parsing fails. -- -- @since 0.1.0 parseTextIO :: Text -> IO (AST.Ninja Ann) parseTextIO text = forceIO (parseText text) -- | Parse the given 'BSC8.ByteString' into a 'AST.Ninja'. -- This function may throw an exception if parsing fails. -- -- @since 0.1.0 parseBSIO :: BSC8.ByteString -> IO (AST.Ninja Ann) parseBSIO bs = forceIO (parseBS bs) -- | Parse the given list of 'Lexer.Lexeme's into a 'AST.Ninja'. -- This function may throw an exception if parsing fails. -- -- @since 0.1.0 parseLexemesIO :: [Lexer.Lexeme Ann] -> IO (AST.Ninja Ann) parseLexemesIO lexemes = forceIO (parseLexemes lexemes) -------------------------------------------------------------------------------- -- | Parse the file at the given path into a 'AST.Ninja'. -- -- @since 0.1.0 parseFile :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Misc.Path -> m (AST.Ninja Ann) parseFile file = parseFileWithEnv file AST.makeEnv -- | Parse the given 'Text' into a 'AST.Ninja'. -- -- @since 0.1.0 parseText :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Text -> m (AST.Ninja Ann) parseText text = parseTextWithEnv text AST.makeEnv -- | Parse the given 'BSC8.ByteString' into a 'AST.Ninja'. -- -- @since 0.1.0 parseBS :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => BSC8.ByteString -> m (AST.Ninja Ann) parseBS bs = parseBSWithEnv bs AST.makeEnv -- | Parse the given list of 'Lexer.Lexeme's into a 'AST.Ninja'. -- -- @since 0.1.0 parseLexemes :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => [Lexer.Lexeme Ann] -> m (AST.Ninja Ann) parseLexemes lexemes = parseLexemesWithEnv lexemes AST.makeEnv -------------------------------------------------------------------------------- -- | Parse the file at the given path using the given Ninja variable context, -- resulting in a 'AST.Ninja'. -- -- @since 0.1.0 parseFileWithEnv :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Misc.Path -> AST.Env Text Text -> m (AST.Ninja Ann) parseFileWithEnv path env = fst <$> parseFileInternal path (AST.makeNinja, env) -- | Parse the given 'Text' using the given Ninja variable context, -- resulting in a 'AST.Ninja'. -- -- @since 0.1.0 parseTextWithEnv :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Text -> AST.Env Text Text -> m (AST.Ninja Ann) parseTextWithEnv text env = fst <$> parseTextInternal text (AST.makeNinja, env) -- | Parse the given 'BSC8.ByteString' using the given Ninja variable context, -- resulting in a 'AST.Ninja'. -- -- @since 0.1.0 parseBSWithEnv :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => BSC8.ByteString -> AST.Env Text Text -> m (AST.Ninja Ann) parseBSWithEnv bs env = fst <$> parseBSInternal bs (AST.makeNinja, env) -- | Parse the given list of 'Lexer.Lexeme's into a 'AST.Ninja'. -- -- @since 0.1.0 parseLexemesWithEnv :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => [Lexer.Lexeme Ann] -> AST.Env Text Text -> m (AST.Ninja Ann) parseLexemesWithEnv lexemes env = fst <$> parseLexemesInternal lexemes (AST.makeNinja, env) -------------------------------------------------------------------------------- type NinjaWithEnv = (AST.Ninja Ann, AST.Env Text Text) -------------------------------------------------------------------------------- parseFileInternal :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Misc.Path -> NinjaWithEnv -> m NinjaWithEnv parseFileInternal path (ninja, env) = do text <- Mock.readFile path parseTextInternal text (ninja, env) parseTextInternal :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => Text -> NinjaWithEnv -> m NinjaWithEnv parseTextInternal text = parseBSInternal (Text.encodeUtf8 text) parseBSInternal :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => BSC8.ByteString -> NinjaWithEnv -> m NinjaWithEnv parseBSInternal bs (ninja, env) = do lexemes <- Lexer.lexBS bs parseLexemesInternal lexemes (ninja, env) parseLexemesInternal :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) => [Lexer.Lexeme Ann] -> NinjaWithEnv -> m NinjaWithEnv parseLexemesInternal lexemes (ninja, env) = withBinds lexemes |> map (uncurry applyStmt) |> foldr (>=>) pure |> (\f -> f (ninja, env)) |> fmap addSpecialVars -------------------------------------------------------------------------------- type MonadApplyFun m = (MonadError Errors.ParseError m, Mock.MonadReadFile m) type ApplyFun' m = [(Text, AST.Expr Ann)] -> NinjaWithEnv -> m NinjaWithEnv type ApplyFun = (forall m. (MonadApplyFun m) => ApplyFun' m) -------------------------------------------------------------------------------- forceIO :: (forall m. (MonadApplyFun m) => m a) -> IO a forceIO action = runExceptT action >>= either throwIO pure -------------------------------------------------------------------------------- addSpecialVars :: NinjaWithEnv -> NinjaWithEnv addSpecialVars (ninja, env) = (mutator ninja, env) where specialVars :: [Text] specialVars = ["ninja_required_version", "builddir"] addVar :: Text -> (AST.Ninja Ann -> AST.Ninja Ann) addVar name = case AST.askEnv env name of (Just v) -> Lens.over AST.ninjaSpecials (HM.insert name v) Nothing -> id mutator :: AST.Ninja Ann -> AST.Ninja Ann mutator = map addVar specialVars |> map Endo |> mconcat |> appEndo withBinds :: [Lexer.Lexeme Ann] -> [(Lexer.Lexeme Ann, [(Text, AST.Expr Ann)])] withBinds = \case [] -> [] (x:xs) -> let (a, b) = f xs in (x, a) : withBinds b where f :: [Lexer.Lexeme Ann] -> ([(Text, AST.Expr Ann)], [Lexer.Lexeme Ann]) f (Lexer.LexBind _ binding : rest) = let Lexer.MkLBind _ name b = binding Lexer.MkLName _ a = name (as, bs) = f rest in ((Text.decodeUtf8 a, b) : as, bs) f xs = ([], xs) -------------------------------------------------------------------------------- applyStmt :: Lexer.Lexeme Ann -> ApplyFun applyStmt lexeme binds (ninja, env) = (case lexeme of (Lexer.LexBuild _ann lbuild) -> applyBuild lbuild (Lexer.LexRule _ann lname) -> applyRule lname (Lexer.LexDefault _ann defaults) -> applyDefault defaults (Lexer.LexPool _ann lname) -> applyPool lname (Lexer.LexInclude _ann lfile) -> applyInclude lfile (Lexer.LexSubninja _ann lfile) -> applySubninja lfile (Lexer.LexDefine _ann lbind) -> applyDefine lbind (Lexer.LexBind _ann lbind) -> throwUnexpectedBinding lbind) |> (\f -> f binds (ninja, env)) where -- TODO: don't discard annotation throwUnexpectedBinding :: Lexer.LBind Ann -> ApplyFun throwUnexpectedBinding (Lexer.MkLBind _ (Lexer.MkLName _ var) _) = \_ _ -> Errors.throwParseUnexpectedBinding (Text.decodeUtf8 var) applyBuild :: Lexer.LBuild Ann -> ApplyFun applyBuild (Lexer.MkLBuild _annB loutputs lrule ldeps) lbinds (ninja, env) = do let outputs = map (AST.askExpr env) loutputs let rule = lrule |> (\(Lexer.MkLName _annN name) -> Text.decodeUtf8 name) let deps = HS.fromList (map (AST.askExpr env) ldeps) let binds = HM.fromList (map (second (AST.askExpr env)) lbinds) let (normal, implicit, orderOnly) = splitDeps deps let build = AST.makeBuild rule env |> (Lens.set (AST.buildDeps . AST.depsNormal) normal) |> (Lens.set (AST.buildDeps . AST.depsImplicit) implicit) |> (Lens.set (AST.buildDeps . AST.depsOrderOnly) orderOnly) |> (Lens.set AST.buildBind binds) let allDeps = normal <> implicit <> orderOnly let addP = \p -> [(x, allDeps) | x <- outputs] <> (HM.toList p) |> HM.fromList let addS = HM.insert (head outputs) build let addM = HM.insert (HS.fromList outputs) build let ninja' | (rule == "phony") = Lens.over AST.ninjaPhonys addP ninja | (length outputs == 1) = Lens.over AST.ninjaSingles addS ninja | otherwise = Lens.over AST.ninjaMultiples addM ninja pure (ninja', env) applyRule :: Lexer.LName Ann -> ApplyFun applyRule (Lexer.MkLName ann name) binds (ninja, env) = do let rule = AST.makeRule |> Lens.set Misc.annotation ann |> Lens.set AST.ruleBind (HM.fromList binds) let nameT = Text.decodeUtf8 name pure (ninja |> Lens.over AST.ninjaRules (HM.insert nameT rule), env) applyDefault :: [AST.Expr Ann] -> ApplyFun applyDefault ldefaults _ (ninja, env) = do let defaults = HS.fromList (map (AST.askExpr env) ldefaults) pure (ninja |> Lens.over AST.ninjaDefaults (defaults <>), env) applyPool :: Lexer.LName Ann -> ApplyFun applyPool (Lexer.MkLName _ann name) binds (ninja, env) = do depth <- getDepth env binds let nameT = Text.decodeUtf8 name pure (ninja |> Lens.over AST.ninjaPools (HM.insert nameT depth), env) applyInclude :: Lexer.LFile Ann -> ApplyFun applyInclude (Lexer.MkLFile expr) _ (ninja, env) = do let file = AST.askExpr env expr |> Lens.view (Lens.from Misc.pathText) parseFileInternal file (ninja, env) applySubninja :: Lexer.LFile Ann -> ApplyFun applySubninja (Lexer.MkLFile expr) _ (ninja, env) = do let file = AST.askExpr env expr |> Lens.view (Lens.from Misc.pathText) parseFileInternal file (ninja, AST.scopeEnv env) applyDefine :: Lexer.LBind Ann -> ApplyFun applyDefine (Lexer.MkLBind _annB (Lexer.MkLName _annN var) value) _ (ninja, env) = pure (ninja, AST.addBind (Text.decodeUtf8 var) value env) -------------------------------------------------------------------------------- splitDeps :: HashSet Text -> (HashSet Text, HashSet Text, HashSet Text) splitDeps = HS.toList .> go .> (\(a, b, c) -> (HS.fromList a, HS.fromList b, HS.fromList c)) where go :: [Text] -> ([Text], [Text], [Text]) go [] = ([], [], []) go (x:xs) | (x == "|") = ([], a <> b, c) | (x == "||") = ([], b, a <> c) | otherwise = (x:a, b, c) where (a, b, c) = go xs getDepth :: (MonadError Errors.ParseError m) => AST.Env Text Text -> [(Text, AST.Expr Ann)] -> m Int getDepth env xs = case AST.askExpr env <$> lookup "depth" xs of Nothing -> pure 1 (Just x) -> case BSC8.readInt (Text.encodeUtf8 x) of (Just (i, n)) | n == "" -> pure i _ -> Errors.throwParseBadDepthField x --------------------------------------------------------------------------------