diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# CHANGELOG + +## Version 0.1.0 + +This is the first release of `language-ninja`! diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,194 @@ +Apache License +============== + +_Version 2.0, January 2004_ +_<>_ + +### Terms and Conditions for use, reproduction, and distribution + +#### 1. Definitions + +“License” shall mean the terms and conditions for use, reproduction, and +distribution as defined by Sections 1 through 9 of this document. + +“Licensor” shall mean the copyright owner or entity authorized by the copyright +owner that is granting the License. + +“Legal Entity” shall mean the union of the acting entity and all other entities +that control, are controlled by, or are under common control with that entity. +For the purposes of this definition, “control” means **(i)** the power, direct +or indirect, to cause the direction or management of such entity, whether by +contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of +the outstanding shares, or **(iii)** beneficial ownership of such entity. + +“You” (or “Your”) shall mean an individual or Legal Entity exercising +permissions granted by this License. + +“Source” form shall mean the preferred form for making modifications, including +but not limited to software source code, documentation source, and configuration +files. + +“Object” form shall mean any form resulting from mechanical transformation or +translation of a Source form, including but not limited to compiled object code, +generated documentation, and conversions to other media types. + +“Work” shall mean the work of authorship, whether in Source or Object form, made +available under the License, as indicated by a copyright notice that is included +in or attached to the work (an example is provided in the Appendix below). + +“Derivative Works” shall mean any work, whether in Source or Object form, that +is based on (or derived from) the Work and for which the editorial revisions, +annotations, elaborations, or other modifications represent, as a whole, an +original work of authorship. For the purposes of this License, Derivative Works +shall not include works that remain separable from, or merely link (or bind by +name) to the interfaces of, the Work and Derivative Works thereof. + +“Contribution” shall mean any work of authorship, including the original version +of the Work and any modifications or additions to that Work or Derivative Works +thereof, that is intentionally submitted to Licensor for inclusion in the Work +by the copyright owner or by an individual or Legal Entity authorized to submit +on behalf of the copyright owner. For the purposes of this definition, +“submitted” means any form of electronic, verbal, or written communication sent +to the Licensor or its representatives, including but not limited to +communication on electronic mailing lists, source code control systems, and +issue tracking systems that are managed by, or on behalf of, the Licensor for +the purpose of discussing and improving the Work, but excluding communication +that is conspicuously marked or otherwise designated in writing by the copyright +owner as “Not a Contribution.” + +“Contributor” shall mean Licensor and any individual or Legal Entity on behalf +of whom a Contribution has been received by Licensor and subsequently +incorporated within the Work. + +#### 2. Grant of Copyright License + +Subject to the terms and conditions of this License, each Contributor hereby +grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, +irrevocable copyright license to reproduce, prepare Derivative Works of, +publicly display, publicly perform, sublicense, and distribute the Work and such +Derivative Works in Source or Object form. + +#### 3. Grant of Patent License + +Subject to the terms and conditions of this License, each Contributor hereby +grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, +irrevocable (except as stated in this section) patent license to make, have +made, use, offer to sell, sell, import, and otherwise transfer the Work, where +such license applies only to those patent claims licensable by such Contributor +that are necessarily infringed by their Contribution(s) alone or by combination +of their Contribution(s) with the Work to which such Contribution(s) was +submitted. If You institute patent litigation against any entity (including a +cross-claim or counterclaim in a lawsuit) alleging that the Work or a +Contribution incorporated within the Work constitutes direct or contributory +patent infringement, then any patent licenses granted to You under this License +for that Work shall terminate as of the date such litigation is filed. + +#### 4. Redistribution + +You may reproduce and distribute copies of the Work or Derivative Works thereof +in any medium, with or without modifications, and in Source or Object form, +provided that You meet the following conditions: + +* **(a)** You must give any other recipients of the Work or Derivative Works a + copy of this License; and +* **(b)** You must cause any modified files to carry prominent notices stating + that You changed the files; and +* **(c)** You must retain, in the Source form of any Derivative Works that You + distribute, all copyright, patent, trademark, and attribution notices from the + Source form of the Work, excluding those notices that do not pertain to any + part of the Derivative Works; and +* **(d)** If the Work includes a “NOTICE” text file as part of its distribution, + then any Derivative Works that You distribute must include a readable copy of + the attribution notices contained within such NOTICE file, excluding those + notices that do not pertain to any part of the Derivative Works, in at least + one of the following places: within a NOTICE text file distributed as part of + the Derivative Works; within the Source form or documentation, if provided + along with the Derivative Works; or, within a display generated by the + Derivative Works, if and wherever such third-party notices normally appear. + The contents of the NOTICE file are for informational purposes only and do not + modify the License. You may add Your own attribution notices within Derivative + Works that You distribute, alongside or as an addendum to the NOTICE text from + the Work, provided that such additional attribution notices cannot be + construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide +additional or different license terms and conditions for use, reproduction, or +distribution of Your modifications, or for any such Derivative Works as a whole, +provided Your use, reproduction, and distribution of the Work otherwise complies +with the conditions stated in this License. + +#### 5. Submission of Contributions + +Unless You explicitly state otherwise, any Contribution intentionally submitted +for inclusion in the Work by You to the Licensor shall be under the terms and +conditions of this License, without any additional terms or conditions. +Notwithstanding the above, nothing herein shall supersede or modify the terms of +any separate license agreement you may have executed with Licensor regarding +such Contributions. + +#### 6. Trademarks + +This License does not grant permission to use the trade names, trademarks, +service marks, or product names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the NOTICE file. + +#### 7. Disclaimer of Warranty + +Unless required by applicable law or agreed to in writing, Licensor provides the +Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, +including, without limitation, any warranties or conditions of TITLE, +NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are +solely responsible for determining the appropriateness of using or +redistributing the Work and assume any risks associated with Your exercise of +permissions under this License. + +#### 8. Limitation of Liability + +In no event and under no legal theory, whether in tort (including negligence), +contract, or otherwise, unless required by applicable law (such as deliberate +and grossly negligent acts) or agreed to in writing, shall any Contributor be +liable to You for damages, including any direct, indirect, special, incidental, +or consequential damages of any character arising as a result of this License or +out of the use or inability to use the Work (including but not limited to +damages for loss of goodwill, work stoppage, computer failure or malfunction, or +any and all other commercial damages or losses), even if such Contributor has +been advised of the possibility of such damages. + +#### 9. Accepting Warranty or Additional Liability + +While redistributing the Work or Derivative Works thereof, You may choose to +offer, and charge a fee for, acceptance of support, warranty, indemnity, or +other liability obligations and/or rights consistent with this License. However, +in accepting such obligations, You may act only on Your own behalf and on Your +sole responsibility, not on behalf of any other Contributor, and only if You +agree to indemnify, defend, and hold each Contributor harmless for any liability +incurred by, or claims asserted against, such Contributor by reason of your +accepting any such warranty or additional liability. + +_END OF TERMS AND CONDITIONS_ + +### APPENDIX: How to apply the Apache License to your work + +To apply the Apache License to your work, attach the following boilerplate +notice, with the fields enclosed by brackets `[]` replaced with your own +identifying information. (Don't include the brackets!) The text should be +enclosed in the appropriate comment syntax for the file format. We also +recommend that a file or class name and description of purpose be included on +the same “printed page” as the copyright notice for easier identification within +third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +# `language-ninja` + +[![Hackage][hackage-badge]][hackage-link] +[![Stackage][stackage-badge]][stackage-link] +[![License][license-badge]][license-link] + +`language-ninja` is a Haskell library for parsing, pretty-printing, and +compiling the [Ninja build language](https://ninja-build.org). + +## Motivation + +`language-ninja` was written as a part of Awake Security's efforts in creating +incremental build infrastructure for the Nix package manager, and in particular +for Haskell packages. This library is the basis for a tool, [ninja2nix][], that, +given a Ninja file, will output a JSON file containing information that a Nix +function can use to compute a derivation representing an incremental build +using one derivation per build edge in the parsed Ninja build graph. + +In conjunction with an as-of-yet unwritten tool, [cabal2ninja][], that will +generate a Ninja file based on information from `cabal` and `ghc -M`, we will +have incremental builds for any Haskell package that uses a default `Setup.hs` +file. + +Using Ninja as an intermediate representation has advantages here, since it +means that [ninja2nix][] could be useful for building other projects that use +a build system that can output Ninja, like the Linux kernel (with `kninja`), +Chromium, any CMake project, any Bazel project, or some Make-based projects +(with `kati`). + +## Parsing + +Originally, `language-ninja` used the Ninja lexer/parser from Neil Mitchell's +`shake` project. However, we now use a `megaparsec`-based lexer and a highly +modified version of the old parser. There is still work to be done on improving +the diagnostic data and pretty-printability of the AST from this parser. +In my view, it is very important that a parser output an AST that can be +pretty-printed exactly to same sequence of bytes that were in the parsed file, +as this makes tests and diagnostics much easier to write. + +## Pretty-printing + +Currently there is a rudimentary pretty-printer in `Language.Ninja.Pretty`. +It simply outputs text such that if that text is parsed and the parsed data +is pretty-printed again, the resulting text will be identical to the original +text (this is tested on a variety of Ninja files in the test suite). + +## Compiling + +The `Ninja` type from `Language.Ninja.IR.Ninja` contains precisely the data +that must be acted on dynamically in a Ninja. In converting from the parsed +AST to the intermediate representation using `Language.Ninja.Compile.compile`, +you are eliminating all statically-dischargeable language features in Ninja, +like variables. It also "monomorphizes" Ninja `rule`s, since rule-level `$out` +references are a kind of parametric polymorphism. This IR is thus far more +suitable for processing than the original parsed AST. + +## Miscellaneous + +The `staging` branch is used for active development; i.e.: force pushes may +happen on `staging` but will not happen on `master`. + +To build this, I recommend installing the Nix package manager and running +`nix-build release.nix -A language-ninja`. + +[hackage-badge]: + https://img.shields.io/hackage/v/language-ninja.svg?label=Hackage +[hackage-link]: + https://hackage.haskell.org/package/language-ninja +[stackage-badge]: + https://www.stackage.org/package/language-ninja/badge/lts?label=Stackage +[stackage-link]: + https://www.stackage.org/package/language-ninja +[license-badge]: + https://img.shields.io/badge/License-Apache%202.0-blue.svg +[license-link]: + https://spdx.org/licenses/Apache-2.0.html +[ninja2nix]: + https://github.com/awakesecurity/ninja2nix +[cabal2ninja]: + https://github.com/awakesecurity/cabal2ninja diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE CPP #-} + +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/executables/ninja-compile/Main.hs b/executables/ninja-compile/Main.hs new file mode 100644 --- /dev/null +++ b/executables/ninja-compile/Main.hs @@ -0,0 +1,181 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: executables/ninja-compile/Main.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +module Main (main) where + +import qualified Control.Lens as Lens + +import Control.Exception (throwIO) +import Control.Monad.Except (runExcept, runExceptT) + +import Options.Generic ((:::), type ()) +import qualified Options.Generic as Opt + +import GHC.Generics (Generic) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +import Data.Version (showVersion) +import qualified Paths_language_ninja as Paths + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LText + +import qualified Language.Ninja.Compile as Compile +import qualified Language.Ninja.Errors as Errors +import Language.Ninja.Misc.Path (Path, pathFP, pathString) +import qualified Language.Ninja.Parser as Parser + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson + +import qualified System.IO as IO + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +version :: Text +version = Text.pack (showVersion Paths.version) + +-------------------------------------------------------------------------------- + +instance Opt.ParseField Path where + parseField h m = Lens.view (Lens.from pathFP) <$> Opt.parseField h m + +composeModifiers :: Opt.Modifiers -> Opt.Modifiers -> Opt.Modifiers +composeModifiers (Opt.Modifiers fnX cnX) (Opt.Modifiers fnY cnY) + = Opt.Modifiers (fnX .> fnY) (cnX .> cnY) + +removePrefixModifier :: Text -> Opt.Modifiers +removePrefixModifier prefix = Opt.Modifiers removeFN id + where + removeFN :: String -> String + removeFN str = fromMaybe str $ do + stripped <- Text.stripPrefix prefix (Text.pack str) + (c, rest) <- Text.uncons stripped + pure (toLower c : Text.unpack rest) + +-------------------------------------------------------------------------------- + +type OptionInput + = Maybe Path "Read the given FILEPATH as a Ninja file." +type OptionOutput + = Maybe Path "Output to the given FILEPATH instead of /dev/stdout." +type OptionMachineReadable + = Bool "Should the output be fully machine-readable?" + +data Options' w + = Options' + { _optionsInput :: (w ::: OptionInput) + , _optionsOutput :: (w ::: OptionOutput) + , _optionsMachineReadable :: (w ::: OptionMachineReadable) } + deriving (Generic) + +instance Opt.ParseRecord (Options' Opt.Wrapped) where + parseRecord = Opt.parseRecordWithModifiers + (composeModifiers + (removePrefixModifier "_options") + Opt.lispCaseModifiers) + +deriving instance Show (Options' Opt.Unwrapped) + +type Options = Options' Opt.Unwrapped + +parseOptions :: IO Options +parseOptions = Opt.unwrapRecord ("ninja-compile version " <> version) + +-------------------------------------------------------------------------------- + +processNinja :: Maybe Path -> (IO.Handle, IO.Handle) -> Bool -> IO () +processNinja inputPath (input, output) machineReadable = do + let encodeJ :: Aeson.Value -> Text + encodeJ = (if machineReadable then Aeson.encode else Aeson.encodePretty) + .> LText.decodeUtf8 .> LText.toStrict + + let throwMRPE :: Errors.ParseError -> IO () + throwMRPE = Aeson.toJSON .> encodeJ .> Text.hPutStrLn output + + let throwMRCE :: Errors.CompileError -> IO () + throwMRCE = Aeson.toJSON .> encodeJ .> Text.hPutStrLn output + + inputText <- Text.hGetContents input + + ast <- runExceptT $ case inputPath of + Just path -> Parser.parseFile path + Nothing -> Parser.parseText inputText + + case ast of + Left e -> if machineReadable + then throwMRPE e + else throwIO e + Right x -> case runExcept (Compile.compile x) of + Left e -> if machineReadable + then throwMRCE e + else throwIO e + Right c -> Text.hPutStr output (encodeJ (Aeson.toJSON c)) + +runOptions :: Options -> IO () +runOptions opts = do + let pathH :: IO.IOMode -> Path -> IO IO.Handle + pathH mode p = IO.openFile (Lens.view pathString p) mode + + let inputH, outputH :: Maybe Path -> IO IO.Handle + inputH = maybe (pure IO.stdin) (pathH IO.ReadMode) + outputH = maybe (pure IO.stdout) (pathH IO.WriteMode) + + let pairH :: Maybe Path -> Maybe Path -> IO (IO.Handle, IO.Handle) + pairH i o = (,) <$> inputH i <*> outputH o + + let closeH :: (IO.Handle, IO.Handle) -> IO () + closeH (i, o) = IO.hClose i >> IO.hClose o >> pure () + + case opts of + (Options' i o mr) -> pairH i o >>= \p -> processNinja i p mr >> closeH p + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + parseOptions >>= runOptions + +-------------------------------------------------------------------------------- diff --git a/executables/ninja-lex/Main.hs b/executables/ninja-lex/Main.hs new file mode 100644 --- /dev/null +++ b/executables/ninja-lex/Main.hs @@ -0,0 +1,192 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: executables/ninja-lex/Main.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +module Main (main) where + +import qualified Control.Lens as Lens + +import Control.Exception (throwIO) +import Control.Monad.Except (runExcept) + +import Options.Generic ((:::), type ()) +import qualified Options.Generic as Opt + +import GHC.Generics (Generic) + +import Data.Char (toLower) +import Data.Functor (void) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +import Data.Version (showVersion) +import qualified Paths_language_ninja as Paths + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LText +import qualified Data.Text.Lazy.IO as LText + +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.Lexer as Lexer +import Language.Ninja.Misc.Path (Path, pathFP, pathString) +import qualified Language.Ninja.Pretty as Pretty + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson + +import qualified System.IO as IO + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +version :: String +version = showVersion Paths.version + +-------------------------------------------------------------------------------- + +instance Opt.ParseField Path where + parseField h m = Lens.view (Lens.from pathFP) <$> Opt.parseField h m + +composeModifiers :: Opt.Modifiers -> Opt.Modifiers -> Opt.Modifiers +composeModifiers (Opt.Modifiers fnX cnX) (Opt.Modifiers fnY cnY) + = Opt.Modifiers (fnX .> fnY) (cnX .> cnY) + +removePrefixModifier :: Text -> Opt.Modifiers +removePrefixModifier prefix = Opt.Modifiers removeFN id + where + removeFN :: String -> String + removeFN str = fromMaybe str $ do + stripped <- Text.stripPrefix prefix (Text.pack str) + (c, rest) <- Text.uncons stripped + pure (toLower c : Text.unpack rest) + +-------------------------------------------------------------------------------- + +type OptionProcessInput + = Maybe Path "Read the given FILEPATH as a Ninja file." +type OptionProcessOutput + = Maybe Path "Output to the given FILEPATH instead of /dev/stdout." +type OptionProcessMachineReadable + = Bool "Should the output be fully machine-readable?" + +type OptionPrettyInput + = Maybe Path "Read the given FILEPATH as a Ninja file." +type OptionPrettyOutput + = Maybe Path "Output to the given FILEPATH instead of /dev/stdout." +type OptionPrettyColor + = Bool "Should the output use ANSI color?" + +data Options' w + = Process { _optionsInput :: (w ::: OptionProcessInput) + , _optionsOutput :: (w ::: OptionProcessOutput) + , _optionsMachineReadable :: (w ::: OptionProcessMachineReadable) } + | Pretty { _optionsInput :: (w ::: OptionPrettyInput) + , _optionsOutput :: (w ::: OptionPrettyOutput) + , _optionsColor :: (w ::: OptionPrettyColor) } + deriving (Generic) + +instance Opt.ParseRecord (Options' Opt.Wrapped) where + parseRecord = Opt.parseRecordWithModifiers + (composeModifiers + (removePrefixModifier "_options") + Opt.lispCaseModifiers) + +deriving instance Show (Options' Opt.Unwrapped) + +type Options = Options' Opt.Unwrapped + +parseOptions :: IO Options +parseOptions = Opt.unwrapRecord (Text.pack ("ninja-lex version " <> version)) + +-------------------------------------------------------------------------------- + +processNinja :: Maybe Path -> (IO.Handle, IO.Handle) -> Bool -> IO () +processNinja inputPath (input, output) machineReadable = do + let encodeJ :: Aeson.Value -> Text + encodeJ = (if machineReadable then Aeson.encode else Aeson.encodePretty) + .> LText.decodeUtf8 .> LText.toStrict + + let throwMR :: Errors.ParseError -> IO () + throwMR = Aeson.toJSON .> encodeJ .> Text.hPutStrLn output + + inputText <- Text.hGetContents input + + case runExcept (Lexer.lexTextWithPath inputPath inputText) of + Left e -> if machineReadable + then throwMR e + else throwIO e + Right x -> Text.hPutStr output (encodeJ (Aeson.toJSON x)) + +prettyNinja :: Maybe Path -> (IO.Handle, IO.Handle) -> Bool -> IO () +prettyNinja _inputPath (input, output) _color = do + -- TODO: add color support + inputText <- LText.hGetContents input + let parsed :: Either String [Lexer.Lexeme Lexer.Ann] + parsed = Aeson.eitherDecode (LText.encodeUtf8 inputText) + case parsed of + Left e -> IO.hPutStrLn IO.stderr e + Right x -> Text.hPutStr output (Pretty.prettyLexemes (map void x)) + +runOptions :: Options -> IO () +runOptions opts = do + let pathH :: IO.IOMode -> Path -> IO IO.Handle + pathH mode p = IO.openFile (Lens.view pathString p) mode + + let inputH, outputH :: Maybe Path -> IO IO.Handle + inputH = maybe (pure IO.stdin) (pathH IO.ReadMode) + outputH = maybe (pure IO.stdout) (pathH IO.WriteMode) + + let pairH :: Maybe Path -> Maybe Path -> IO (IO.Handle, IO.Handle) + pairH i o = (,) <$> inputH i <*> outputH o + + let closeH :: (IO.Handle, IO.Handle) -> IO () + closeH (i, o) = IO.hClose i >> IO.hClose o >> pure () + + case opts of + (Process i o mr) -> pairH i o >>= \p -> processNinja i p mr >> closeH p + (Pretty i o c) -> pairH i o >>= \p -> prettyNinja i p c >> closeH p + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + parseOptions >>= runOptions + +-------------------------------------------------------------------------------- diff --git a/executables/ninja-parse/Main.hs b/executables/ninja-parse/Main.hs new file mode 100644 --- /dev/null +++ b/executables/ninja-parse/Main.hs @@ -0,0 +1,198 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: executables/ninja-parse/Main.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +module Main (main) where + +import qualified Control.Lens as Lens + +import Control.Exception (throwIO) +import Control.Monad.Except (runExceptT) + +import Options.Generic ((:::), type ()) +import qualified Options.Generic as Opt + +import GHC.Generics (Generic) + +import Data.Char (toLower) +import Data.Functor (void) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +import Data.Version (showVersion) +import qualified Paths_language_ninja as Paths + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LText +import qualified Data.Text.Lazy.IO as LText + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.Lexer as Lexer +import Language.Ninja.Misc.Path (Path, pathFP, pathString) +import qualified Language.Ninja.Parser as Parser +import qualified Language.Ninja.Pretty as Pretty + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson + +import qualified System.IO as IO + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +version :: String +version = showVersion Paths.version + +-------------------------------------------------------------------------------- + +instance Opt.ParseField Path where + parseField h m = Lens.view (Lens.from pathFP) <$> Opt.parseField h m + +composeModifiers :: Opt.Modifiers -> Opt.Modifiers -> Opt.Modifiers +composeModifiers (Opt.Modifiers fnX cnX) (Opt.Modifiers fnY cnY) + = Opt.Modifiers (fnX .> fnY) (cnX .> cnY) + +removePrefixModifier :: Text -> Opt.Modifiers +removePrefixModifier prefix = Opt.Modifiers removeFN id + where + removeFN :: String -> String + removeFN str = fromMaybe str $ do + stripped <- Text.stripPrefix prefix (Text.pack str) + (c, rest) <- Text.uncons stripped + pure (toLower c : Text.unpack rest) + +-------------------------------------------------------------------------------- + +type OptionProcessInput + = Maybe Path "Read the given FILEPATH as a Ninja file." +type OptionProcessOutput + = Maybe Path "Output to the given FILEPATH instead of /dev/stdout." +type OptionProcessMachineReadable + = Bool "Should the output be fully machine-readable?" + +type OptionPrettyInput + = Maybe Path "Read the given FILEPATH as a Ninja file." +type OptionPrettyOutput + = Maybe Path "Output to the given FILEPATH instead of /dev/stdout." +type OptionPrettyColor + = Bool "Should the output use ANSI color?" + +data Options' w + = Process { _optionsInput :: (w ::: OptionProcessInput) + , _optionsOutput :: (w ::: OptionProcessOutput) + , _optionsMachineReadable :: (w ::: OptionProcessMachineReadable) } + | Pretty { _optionsInput :: (w ::: OptionPrettyInput) + , _optionsOutput :: (w ::: OptionPrettyOutput) + , _optionsColor :: (w ::: OptionPrettyColor) } + deriving (Generic) + +instance Opt.ParseRecord (Options' Opt.Wrapped) where + parseRecord = Opt.parseRecordWithModifiers + (composeModifiers + (removePrefixModifier "_options") + Opt.lispCaseModifiers) + +deriving instance Show (Options' Opt.Unwrapped) + +type Options = Options' Opt.Unwrapped + +parseOptions :: IO Options +parseOptions = Opt.unwrapRecord (Text.pack ("ninja-parse version " <> version)) + +-------------------------------------------------------------------------------- + +processNinja :: Maybe Path -> (IO.Handle, IO.Handle) -> Bool -> IO () +processNinja inputPath (input, output) machineReadable = do + let encodeJ :: Aeson.Value -> Text + encodeJ = (if machineReadable then Aeson.encode else Aeson.encodePretty) + .> LText.decodeUtf8 .> LText.toStrict + + let throwMR :: Errors.ParseError -> IO () + throwMR = Aeson.toJSON .> encodeJ .> Text.hPutStrLn output + + inputText <- Text.hGetContents input + + ast <- runExceptT $ case inputPath of + Just path -> Parser.parseFile path + Nothing -> Parser.parseText inputText + + case ast of + Left e -> if machineReadable + then throwMR e + else throwIO e + Right x -> Text.hPutStr output (encodeJ (Aeson.toJSON x)) + +prettyNinja :: Maybe Path -> (IO.Handle, IO.Handle) -> Bool -> IO () +prettyNinja _inputPath (input, output) _color = do + -- TODO: add color support + inputText <- LText.hGetContents input + let parsed :: Either String (AST.Ninja Lexer.Ann) + parsed = Aeson.eitherDecode (LText.encodeUtf8 inputText) + case parsed of + Left e -> IO.hPutStrLn IO.stderr e + Right x -> Text.hPutStr output (Pretty.prettyNinja (void x)) + +runOptions :: Options -> IO () +runOptions opts = do + let pathH :: IO.IOMode -> Path -> IO IO.Handle + pathH mode p = IO.openFile (Lens.view pathString p) mode + + let inputH, outputH :: Maybe Path -> IO IO.Handle + inputH = maybe (pure IO.stdin) (pathH IO.ReadMode) + outputH = maybe (pure IO.stdout) (pathH IO.WriteMode) + + let pairH :: Maybe Path -> Maybe Path -> IO (IO.Handle, IO.Handle) + pairH i o = (,) <$> inputH i <*> outputH o + + let closeH :: (IO.Handle, IO.Handle) -> IO () + closeH (i, o) = IO.hClose i >> IO.hClose o >> pure () + + case opts of + (Process i o mr) -> pairH i o >>= \p -> processNinja i p mr >> closeH p + (Pretty i o c) -> pairH i o >>= \p -> prettyNinja i p c >> closeH p + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + parseOptions >>= runOptions + +-------------------------------------------------------------------------------- diff --git a/language-ninja.cabal b/language-ninja.cabal new file mode 100644 --- /dev/null +++ b/language-ninja.cabal @@ -0,0 +1,315 @@ +-------------------------------------------------------------------------------- + +name: language-ninja +version: 0.1.0 +stability: Experimental +build-type: Custom +cabal-version: >= 1.10 +category: Language +copyright: Copyright 2017 Awake Security +author: Awake Security +maintainer: opensource@awakesecurity.com +license: Apache-2.0 +license-file: LICENSE.md +homepage: https://github.com/awakesecurity/language-ninja +bug-reports: https://github.com/awakesecurity/language-ninja/issues +category: Build, Language +synopsis: A library for dealing with the Ninja build language. +description: A Haskell library for parsing, pretty-printing, and + compiling the Ninja build language. + The best place to start reading this documentation is + the "Language.Ninja" module. +extra-source-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.0.1 + +-------------------------------------------------------------------------------- + +source-repository head + type: git + branch: master + location: https://github.com/awakesecurity/language-ninja.git + +source-repository this + type: git + tag: release-0.1.0 + location: https://github.com/awakesecurity/language-ninja.git + +-------------------------------------------------------------------------------- + +custom-setup + setup-depends: base >= 4.8 && < 5.0 + , Cabal >= 1.24 && < 1.25 + , cabal-doctest >= 1.0.2 && < 1.1 + +-------------------------------------------------------------------------------- + +library + hs-source-dirs: library + build-depends: base >= 4.8 && < 5.0 + , aeson >= 1.0 && < 1.3 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , deepseq >= 1.4 && < 1.5 + , flow >= 1.0 && < 1.1 + , hashable >= 1.2 && < 1.3 + , intern >= 0.9 && < 0.10 + , megaparsec >= 5.2 && < 5.3 + , mtl >= 2.2 && < 2.3 + , lens >= 4.15 && < 4.16 + , QuickCheck >= 2.9 && < 2.10 + , quickcheck-instances >= 0.3 && < 0.4 + , smallcheck >= 1.1 && < 1.2 + , system-filepath >= 0.4 && < 0.5 + , text >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + , unordered-containers >= 0.2 && < 0.3 + , versions >= 3.1.1 && < 3.2 + exposed-modules: Language.Ninja + , Language.Ninja.Compile + , Language.Ninja.Lexer + , Language.Ninja.Lexer.Types + , Language.Ninja.Parser + , Language.Ninja.Pretty + , Language.Ninja.Tutorial + , Language.Ninja.AST + , Language.Ninja.AST.Build + , Language.Ninja.AST.Deps + , Language.Ninja.AST.Env + , Language.Ninja.AST.Expr + , Language.Ninja.AST.Ninja + , Language.Ninja.AST.Rule + , Language.Ninja.IR + , Language.Ninja.IR.Build + , Language.Ninja.IR.Meta + , Language.Ninja.IR.Ninja + , Language.Ninja.IR.Pool + , Language.Ninja.IR.Rule + , Language.Ninja.IR.Target + , Language.Ninja.Errors + , Language.Ninja.Errors.Compile + , Language.Ninja.Errors.Parser + , Language.Ninja.Mock + , Language.Ninja.Mock.ReadFile + , Language.Ninja.Misc + , Language.Ninja.Misc.Annotated + , Language.Ninja.Misc.Command + , Language.Ninja.Misc.IText + , Language.Ninja.Misc.Located + , Language.Ninja.Misc.Path + , Language.Ninja.Misc.Positive + default-language: Haskell2010 + other-extensions: ConstraintKinds + , DeriveDataTypeable + , DeriveFoldable + , DeriveFunctor + , DeriveGeneric + , DeriveTraversable + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , InstanceSigs + , KindSignatures + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , UndecidableInstances + ghc-options: -Wcompat -Weverything + -fno-warn-unsafe + -fno-warn-safe + -fno-warn-implicit-prelude + -fno-warn-unused-do-bind + -fno-warn-missed-specialisations + -fno-warn-all-missed-specialisations + -g + +-------------------------------------------------------------------------------- + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + other-modules: Tests.Lint + , Tests.Mock + , Tests.Orphans + , Tests.ReferenceLexer + , Tests.ReferenceLexer.Str0 + build-depends: language-ninja + , base >= 4.8 && < 5.0 + , aeson >= 1.0 && < 1.3 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , flow >= 1.0 && < 1.1 + , ghc >= 7.4 && < 8.4 + , haddock-api >= 2.17 && < 2.18 + , haddock-library >= 1.4 && < 1.5 + , hashable >= 1.2 && < 1.3 + , lens >= 4.15 && < 4.16 + , monad-mock >= 0.1 && < 0.2 + , mtl >= 2.2 && < 2.3 + , QuickCheck >= 2.9 && < 2.10 + , quickcheck-instances >= 0.3 && < 0.4 + , smallcheck >= 1.1 && < 1.2 + , system-filepath >= 0.4 && < 0.5 + , tasty >= 0.11 && < 0.12 + , tasty-html >= 0.4 && < 0.5 + , tasty-hunit >= 0.9 && < 0.10 + , tasty-lens >= 0.3 && < 0.4 + , tasty-quickcheck >= 0.8 && < 0.9 + , tasty-smallcheck >= 0.8 && < 0.9 + , text >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + , turtle >= 1.3 && < 1.4 + , unordered-containers >= 0.2 && < 0.3 + , versions >= 3.1.1 && < 3.2 + default-language: Haskell2010 + other-extensions: FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PatternGuards + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , UndecidableInstances + , ViewPatterns + ghc-options: -Wcompat -Weverything + -fno-warn-unsafe + -fno-warn-safe + -fno-warn-implicit-prelude + -fno-warn-unused-do-bind + -fno-warn-missed-specialisations + -fno-warn-all-missed-specialisations + -g -threaded + +-------------------------------------------------------------------------------- + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: DocTests.hs + build-depends: base >= 4.8 && < 5.0 + , doctest >= 0.11 && < 0.12 + , QuickCheck >= 2.9 && < 2.10 + , template-haskell >= 2.11 && < 2.12 + -- TODO: this shouldn't need to be here + -- remove this once https://git.io/vQp2m is merged + , cabal-doctest >= 1.0.2 && < 1.1 + default-language: Haskell2010 + ghc-options: -Wall -threaded + +-------------------------------------------------------------------------------- + +executable ninja-lex + hs-source-dirs: executables/ninja-lex + main-is: Main.hs + build-depends: language-ninja + , base >= 4.8 && < 5.0 + , aeson >= 1.0 && < 1.3 + , aeson-pretty >= 0.8 && < 0.9 + , flow >= 1.0 && < 1.1 + , lens >= 4.15 && < 4.16 + , mtl >= 2.2 && < 2.3 + , optparse-generic >= 1.1 && < 1.2 + -- , prettyprinter >= 1.1 && < 1.2 + -- , prettyprinter-ansi-terminal >= 1.1 && < 1.2 + , text >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + default-language: Haskell2010 + other-extensions: DataKinds + , DeriveGeneric + , ExplicitNamespaces + , FlexibleInstances + , GADTSyntax + , OverloadedStrings + , StandaloneDeriving + , TypeOperators + ghc-options: -Wcompat -Weverything + -fno-warn-unsafe + -fno-warn-safe + -fno-warn-implicit-prelude + -fno-warn-unused-do-bind + -fno-warn-missed-specialisations + -fno-warn-all-missed-specialisations + -g -threaded + +-------------------------------------------------------------------------------- + +executable ninja-parse + hs-source-dirs: executables/ninja-parse + main-is: Main.hs + build-depends: language-ninja + , base >= 4.8 && < 5.0 + , aeson >= 1.0 && < 1.3 + , aeson-pretty >= 0.8 && < 0.9 + , flow >= 1.0 && < 1.1 + , lens >= 4.15 && < 4.16 + , mtl >= 2.2 && < 2.3 + , optparse-generic >= 1.1 && < 1.2 + -- , prettyprinter >= 1.1 && < 1.2 + -- , prettyprinter-ansi-terminal >= 1.1 && < 1.2 + , text >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + default-language: Haskell2010 + other-extensions: DataKinds + , DeriveGeneric + , ExplicitNamespaces + , FlexibleInstances + , GADTSyntax + , OverloadedStrings + , StandaloneDeriving + , TypeOperators + ghc-options: -Wcompat -Weverything + -fno-warn-unsafe + -fno-warn-safe + -fno-warn-implicit-prelude + -fno-warn-unused-do-bind + -fno-warn-missed-specialisations + -fno-warn-all-missed-specialisations + -g -threaded + +-------------------------------------------------------------------------------- + +executable ninja-compile + hs-source-dirs: executables/ninja-compile + main-is: Main.hs + build-depends: language-ninja + , base >= 4.8 && < 5.0 + , aeson >= 1.0 && < 1.3 + , aeson-pretty >= 0.8 && < 0.9 + , flow >= 1.0 && < 1.1 + , lens >= 4.15 && < 4.16 + , mtl >= 2.2 && < 2.3 + , optparse-generic >= 1.1 && < 1.2 + -- , prettyprinter >= 1.1 && < 1.2 + -- , prettyprinter-ansi-terminal >= 1.1 && < 1.2 + , text >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + default-language: Haskell2010 + other-extensions: DataKinds + , DeriveGeneric + , ExplicitNamespaces + , FlexibleInstances + , GADTSyntax + , OverloadedStrings + , StandaloneDeriving + , TypeOperators + ghc-options: -Wcompat -Weverything + -fno-warn-unsafe + -fno-warn-safe + -fno-warn-implicit-prelude + -fno-warn-unused-do-bind + -fno-warn-missed-specialisations + -fno-warn-all-missed-specialisations + -g -threaded + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja.hs b/library/Language/Ninja.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja.hs @@ -0,0 +1,76 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Language.Ninja +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Tools for parsing, pretty-printing, and compiling the Ninja build language. +-- +-- This module re-exports some of the modules under the "Language.Ninja" +-- namespace for convenience. +-- +-- Take a look at "Language.Ninja.Tutorial" for a tutorial on how to use this +-- library. If you just want to dive in, I recommend reading these modules +-- in the following order: +-- +-- 1. Skim "Language.Ninja.Misc", "Language.Ninja.Mock", +-- and "Language.Ninja.Errors" for familiarity with types and values +-- that are used all over this library. +-- 2. Check out "Language.Ninja.Lexer" and then "Language.Ninja.Parser" to +-- get an idea for what is possible with the lexer/parser API. +-- 3. Read "Language.Ninja.AST" to understand what the parsed AST looks like. +-- 4. Read "Language.Ninja.Compile" to see what the AST-to-IR compiler does. +-- 5. Read "Language.Ninja.IR" to understand what the compiled IR looks like. +-- 6. Read "Language.Ninja.Pretty" to see what the pretty-printer is capable +-- of (spoiler: not very much). +-- +-- If you are not already well-versed in the Ninja build language, it is also +-- probably worth reading the Ninja +-- . +-- +-- When importing from this library, I recommend the following style: +-- +-- > import qualified Language.Ninja as Ninja +-- > import qualified Language.Ninja.AST as Ninja.AST +-- > import qualified Language.Ninja.IR as Ninja.IR +-- +-- Happy hacking! +-- +-- @since 0.1.0 +module Language.Ninja + ( module Language.Ninja.Compile + , module Language.Ninja.Lexer + , module Language.Ninja.Parser + , module Language.Ninja.Pretty + , module Language.Ninja.Misc + , module Language.Ninja.Mock + ) where + +import Language.Ninja.Compile +import Language.Ninja.Lexer +import Language.Ninja.Misc +import Language.Ninja.Mock +import Language.Ninja.Parser +import Language.Ninja.Pretty diff --git a/library/Language/Ninja/AST.hs b/library/Language/Ninja/AST.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST.hs @@ -0,0 +1,80 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Language.Ninja.AST +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- The Ninja build language after parsing. +-- +-- This module re-exports all of the modules under the "Language.Ninja.AST" +-- namespace for convenience. +-- +-- It is recommended that you import it with the following style: +-- +-- > import qualified Language.Ninja.AST as AST +-- +-- @since 0.1.0 +module Language.Ninja.AST + ( -- * "Language.Ninja.AST.Ninja" + AST.Ninja, AST.makeNinja + , AST.ninjaRules + , AST.ninjaSingles + , AST.ninjaMultiples + , AST.ninjaPhonys + , AST.ninjaDefaults + , AST.ninjaPools + , AST.ninjaSpecials + + -- * "Language.Ninja.AST.Build" + , AST.Build, AST.makeBuild + , AST.buildRule, AST.buildEnv, AST.buildDeps, AST.buildBind + + -- * "Language.Ninja.AST.Deps" + , AST.Deps, AST.makeDeps + , AST.depsNormal, AST.depsImplicit, AST.depsOrderOnly + + -- * "Language.Ninja.AST.Rule" + , AST.Rule, AST.makeRule + , AST.ruleBind + + -- * "Language.Ninja.AST.Expr" + , AST.Expr (..) + , AST._Exprs, AST._Lit, AST._Var + , AST.askVar, AST.askExpr, AST.addBind, AST.addBinds + , AST.normalizeExpr + + -- * "Language.Ninja.AST.Env" + , AST.Env + , AST.makeEnv, AST.fromEnv, AST.addEnv, AST.askEnv, AST.scopeEnv + ) where + +import qualified Language.Ninja.AST.Build as AST +import qualified Language.Ninja.AST.Deps as AST +import qualified Language.Ninja.AST.Env as AST +import qualified Language.Ninja.AST.Expr as AST +import qualified Language.Ninja.AST.Ninja as AST +import qualified Language.Ninja.AST.Rule as AST + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Build.hs b/library/Language/Ninja/AST/Build.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Build.hs @@ -0,0 +1,220 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Build.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Build +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing a @build@ declaration in the +-- parsed Ninja AST, along with any supporting or related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Build + ( -- * @Build@ + Build, makeBuild + , buildRule, buildEnv, buildDeps, buildBind + , BuildConstraint + ) where + +import qualified Control.Lens as Lens + +import Flow ((.>), (|>)) + +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import qualified Language.Ninja.AST.Deps as AST +import qualified Language.Ninja.AST.Env as AST +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | A parsed Ninja @build@ declaration. +-- +-- @since 0.1.0 +data Build ann + = MkBuild + { _buildAnn :: !ann + , _buildRule :: !Text + , _buildEnv :: !(AST.Env Text Text) + , _buildDeps :: !(AST.Deps ann) + , _buildBind :: !(HashMap Text Text) + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Construct a 'Build' with all default values. +-- +-- @since 0.1.0 +{-# INLINE makeBuild #-} +makeBuild :: (Monoid ann) + => Text + -- ^ The rule name + -> AST.Env Text Text + -- ^ The environment + -> Build ann +makeBuild rule env = MkBuild + { _buildAnn = mempty + , _buildRule = rule + , _buildEnv = env + , _buildDeps = AST.makeDeps + , _buildBind = mempty + } + +-- | A lens into the rule name associated with a 'Build'. +-- +-- @since 0.1.0 +{-# INLINE buildRule #-} +buildRule :: Lens.Lens' (Build ann) Text +buildRule = Lens.lens _buildRule + $ \(MkBuild {..}) x -> MkBuild { _buildRule = x, .. } + +-- | A lens into the environment associated with a 'Build'. +-- +-- @since 0.1.0 +{-# INLINE buildEnv #-} +buildEnv :: Lens.Lens' (Build ann) (AST.Env Text Text) +buildEnv = Lens.lens _buildEnv + $ \(MkBuild {..}) x -> MkBuild { _buildEnv = x, .. } + +-- | A lens into the dependencies associated with a 'Build'. +-- +-- @since 0.1.0 +{-# INLINE buildDeps #-} +buildDeps :: Lens.Lens' (Build ann) (AST.Deps ann) +buildDeps = Lens.lens _buildDeps + $ \(MkBuild {..}) x -> MkBuild { _buildDeps = x, .. } + +-- | A lens into the bindings associated with a 'Build'. +-- +-- @since 0.1.0 +{-# INLINE buildBind #-} +buildBind :: Lens.Lens' (Build ann) (HashMap Text Text) +buildBind = Lens.lens _buildBind + $ \(MkBuild {..}) x -> MkBuild { _buildBind = x, .. } + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Build where + annotation' f = Lens.lens (helper .> fst) (helper .> snd) + where + helper (MkBuild {..}) + = ( _buildAnn + , \x -> MkBuild { _buildAnn = x, _buildDeps = f <$> _buildDeps, .. } ) + +-- | Converts to @{ann: …, rule: …, env: …, deps: …, bind: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (Build ann) where + toJSON (MkBuild {..}) + = [ "ann" .= _buildAnn + , "rule" .= _buildRule + , "env" .= _buildEnv + , "deps" .= _buildDeps + , "bind" .= _buildBind + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Build ann) where + parseJSON = (Aeson.withObject "Build" $ \o -> do + _buildAnn <- (o .: "ann") >>= pure + _buildRule <- (o .: "rule") >>= pure + _buildEnv <- (o .: "env") >>= pure + _buildDeps <- (o .: "deps") >>= pure + _buildBind <- (o .: "bind") >>= pure + pure (MkBuild {..})) + +-- | Reasonable 'QC.Arbitrary' instance for 'Build'. +-- +-- @since 0.1.0 +instance (QC.Arbitrary ann) => QC.Arbitrary (Build ann) where + arbitrary = MkBuild + <$> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Build ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Build ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, BuildConstraint (SC.Serial m) ann + ) => SC.Serial m (Build ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, BuildConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Build ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Build'. +-- +-- @since 0.1.0 +type BuildConstraint (c :: * -> Constraint) (ann :: *) + = ( AST.DepsConstraint c ann + , c Text + , c (HashMap Text Text) + , c (AST.Maps Text Text) + , c ann + ) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Deps.hs b/library/Language/Ninja/AST/Deps.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Deps.hs @@ -0,0 +1,195 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Deps.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Deps +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing the dependencies of a @build@ +-- declaration in the parsed Ninja AST, along with any supporting or +-- related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Deps + ( -- * @Deps@ + Deps, makeDeps + , depsNormal, depsImplicit, depsOrderOnly + , DepsConstraint + ) where + +import qualified Control.Lens as Lens + +import Flow ((|>)) + +import Data.HashSet (HashSet) +import Data.Text (Text) + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | A set of Ninja build dependencies. +-- +-- @since 0.1.0 +data Deps ann + = MkDeps + { _depsAnn :: !ann + , _depsNormal :: !(HashSet Text) + , _depsImplicit :: !(HashSet Text) + , _depsOrderOnly :: !(HashSet Text) + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Construct a 'Deps' with all default values +-- +-- @since 0.1.0 +{-# INLINE makeDeps #-} +makeDeps :: (Monoid ann) => Deps ann +makeDeps = MkDeps + { _depsAnn = mempty + , _depsNormal = mempty + , _depsImplicit = mempty + , _depsOrderOnly = mempty + } + +-- | A lens into the set of normal dependencies in a 'Deps'. +-- +-- @since 0.1.0 +{-# INLINE depsNormal #-} +depsNormal :: Lens.Lens' (Deps ann) (HashSet Text) +depsNormal = Lens.lens _depsNormal + $ \(MkDeps {..}) x -> MkDeps { _depsNormal = x, .. } + +-- | A lens into the set of implicit dependencies in a 'Deps'. +-- +-- @since 0.1.0 +{-# INLINE depsImplicit #-} +depsImplicit :: Lens.Lens' (Deps ann) (HashSet Text) +depsImplicit = Lens.lens _depsImplicit + $ \(MkDeps {..}) x -> MkDeps { _depsImplicit = x, .. } + +-- | A lens into the set of order-only dependencies in a 'Deps'. +-- +-- @since 0.1.0 +{-# INLINE depsOrderOnly #-} +depsOrderOnly :: Lens.Lens' (Deps ann) (HashSet Text) +depsOrderOnly = Lens.lens _depsOrderOnly + $ \(MkDeps {..}) x -> MkDeps { _depsOrderOnly = x, .. } + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Deps where + annotation' _ = Lens.lens _depsAnn + $ \(MkDeps {..}) x -> MkDeps { _depsAnn = x, .. } + +-- | Converts to @{ann: …, normal: …, implicit: …, order-only: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (Deps ann) where + toJSON (MkDeps {..}) + = [ "ann" .= _depsAnn + , "normal" .= _depsNormal + , "implicit" .= _depsImplicit + , "order-only" .= _depsOrderOnly + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Deps ann) where + parseJSON = (Aeson.withObject "Deps" $ \o -> do + _depsAnn <- (o .: "ann") >>= pure + _depsNormal <- (o .: "normal") >>= pure + _depsImplicit <- (o .: "implicit") >>= pure + _depsOrderOnly <- (o .: "order-only") >>= pure + pure (MkDeps {..})) + +-- | Reasonable 'QC.Arbitrary' instance for 'Deps'. +-- +-- @since 0.1.0 +instance (QC.Arbitrary ann) => QC.Arbitrary (Deps ann) where + arbitrary = MkDeps + <$> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Deps ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Deps ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, DepsConstraint (SC.Serial m) ann + ) => SC.Serial m (Deps ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, DepsConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Deps ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Ninja'. +-- +-- @since 0.1.0 +type DepsConstraint (c :: * -> Constraint) (ann :: *) + = ( c (HashSet Text) + , c ann + ) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Env.hs b/library/Language/Ninja/AST/Env.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Env.hs @@ -0,0 +1,224 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Env.hs +-- +-- License: +-- Copyright Neil Mitchell 2011-2017. +-- Copyright Awake Security 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 ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Env +-- Copyright : Copyright 2011-2017 Neil Mitchell +-- License : BSD3 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing a Ninja-style environment along +-- with any supporting or related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Env + ( Env, makeEnv, fromEnv, headEnv, tailEnv + , scopeEnv, addEnv, askEnv + , EnvConstraint + , Key, Maps + ) where + +import Control.Applicative ((<|>)) +import Control.Monad ((>=>)) + +import qualified Control.Lens as Lens + +import Data.Monoid (Endo (Endo, appEndo)) + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import qualified Data.Aeson as Aeson + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | A Ninja-style environment, basically a nonempty list of hash tables. +-- +-- @since 0.1.0 +newtype Env k v + = MkEnv + { _fromEnv :: Maps k v + } + deriving (Eq, Show, Generic) + +-- | Construct an empty environment. +-- +-- @since 0.1.0 +{-# INLINE makeEnv #-} +makeEnv :: Env k v +makeEnv = MkEnv (HM.empty :| []) + +-- | An isomorphism between an 'Env' and a nonempty list of 'HashMap's. +-- +-- @since 0.1.0 +{-# INLINE fromEnv #-} +fromEnv :: Lens.Iso' (Env k v) (Maps k v) +fromEnv = Lens.iso _fromEnv MkEnv + +-- | Get the first 'HashMap' in the underlying nonempty list. +-- +-- @since 0.1.0 +{-# INLINEABLE headEnv #-} +headEnv :: Env k v -> HashMap k v +headEnv (MkEnv (m :| _)) = m + +-- | If the remainder of the underlying nonempty list is nonempty, return +-- the remainder after 'Env' wrapping. Otherwise, return 'Nothing'. +-- +-- @since 0.1.0 +{-# INLINEABLE tailEnv #-} +tailEnv :: Env k v -> Maybe (Env k v) +tailEnv (MkEnv (_ :| e)) = MkEnv <$> NE.nonEmpty e + +-- | Push a new 'Env' onto the stack. +-- +-- @since 0.1.0 +{-# INLINEABLE scopeEnv #-} +scopeEnv :: Env k v -> Env k v +scopeEnv e = MkEnv (NE.cons HM.empty (_fromEnv e)) + +-- | Add the given key and value to the given 'Env'. +-- +-- @since 0.1.0 +{-# INLINEABLE addEnv #-} +addEnv :: (Key k) => k -> v -> Env k v -> Env k v +addEnv k v (MkEnv (m :| rest)) = MkEnv (HM.insert k v m :| rest) + +-- | Look up the given key in the given 'Env'. +-- +-- @since 0.1.0 +{-# INLINEABLE askEnv #-} +askEnv :: (Key k) => Env k v -> k -> Maybe v +askEnv env k = HM.lookup k (headEnv env) + <|> (tailEnv env >>= (`askEnv` k)) + +-- | Converts to a (nonempty) array of JSON objects. +-- +-- @since 0.1.0 +instance (Aeson.ToJSONKey k, Aeson.ToJSON v) => Aeson.ToJSON (Env k v) where + toJSON = _fromEnv .> NE.toList .> Aeson.toJSON + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance ( Key k, Aeson.FromJSONKey k, Aeson.FromJSON v + ) => Aeson.FromJSON (Env k v) where + parseJSON = Aeson.parseJSON + >=> NE.nonEmpty + .> maybe (fail "Env list was empty!") pure + .> fmap MkEnv + +-- | Reasonable 'QC.Arbitrary' instance for 'Env'. +-- +-- @since 0.1.0 +instance ( Key k, QC.Arbitrary k, QC.Arbitrary v + ) => QC.Arbitrary (Env k v) where + arbitrary = QC.arbitrary + |> fmap (map (uncurry addEnv .> Endo) + .> mconcat + .> (\e -> appEndo e makeEnv)) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable k, Hashable v) => Hashable (Env k v) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData k, NFData v) => NFData (Env k v) + +-- | Uses the underlying 'Maps' instance. +-- +-- @since 0.1.0 +instance ( Monad m, EnvConstraint (SC.Serial m) k v + ) => SC.Serial m (Env k v) where + series = SC.series |> fmap MkEnv + +-- | Uses the underlying 'Maps' instance. +-- +-- @since 0.1.0 +instance ( Monad m, EnvConstraint (SC.CoSerial m) k v + ) => SC.CoSerial m (Env k v) where + coseries = SC.coseries .> fmap (\f -> _fromEnv .> f) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'Env'. +-- +-- @since 0.1.0 +type EnvConstraint (c :: * -> Constraint) (k :: *) (v :: *) + = (Key k, c k, c v, c (Maps k v)) + +-------------------------------------------------------------------------------- + +-- | A constraint alias for @('Eq' k, 'Hashable' k)@. +-- +-- @since 0.1.0 +type Key k = (Eq k, Hashable k) + +-- | A 'NE.NonEmpty' list of 'HashMap's. +-- +-- @since 0.1.0 +type Maps k v = NE.NonEmpty (HashMap k v) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Expr.hs b/library/Language/Ninja/AST/Expr.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Expr.hs @@ -0,0 +1,297 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Expr.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Expr +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing a string that potentially contains +-- variable references in the parsed Ninja AST, along with any supporting or +-- related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Expr + ( -- * @Expr@ + Expr (..) + , _Exprs, _Lit, _Var + , askVar, askExpr, addBind, addBinds + , normalizeExpr + , ExprConstraint + ) where + +import Control.Arrow (second) + +import qualified Control.Lens as Lens + +import Data.Foldable (asum) +import Data.Maybe (fromMaybe) +import Data.Monoid (Endo (Endo, appEndo), (<>)) + +import Flow ((.>), (|>)) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Control.DeepSeq (NFData) +import Data.Data (Data) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import qualified Language.Ninja.AST.Env as AST +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | An expression containing variable references in the Ninja language. +-- +-- @since 0.1.0 +data Expr ann + = -- | Sequencing of expressions. + -- + -- @since 0.1.0 + Exprs !ann ![Expr ann] + | -- | A literal string. + -- + -- @since 0.1.0 + Lit !ann !Text + | -- | A variable reference. + -- + -- @since 0.1.0 + Var !ann !Text + deriving (Eq, Show, Generic, Data, Functor, Foldable, Traversable) + +-- | A prism for the 'Exprs' constructor. +-- +-- @since 0.1.0 +{-# INLINE _Exprs #-} +_Exprs :: Lens.Prism' (Expr ann) (ann, [Expr ann]) +_Exprs = Lens.prism' (uncurry Exprs) + $ \case (Exprs ann es) -> Just (ann, es) + _ -> Nothing + +-- | A prism for the 'Lit' constructor. +-- +-- @since 0.1.0 +{-# INLINE _Lit #-} +_Lit :: Lens.Prism' (Expr ann) (ann, Text) +_Lit = Lens.prism' (uncurry Lit) + $ \case (Lit ann text) -> Just (ann, text) + _ -> Nothing + +-- | A prism for the 'Var' constructor. +-- +-- @since 0.1.0 +{-# INLINE _Var #-} +_Var :: Lens.Prism' (Expr ann) (ann, Text) +_Var = Lens.prism' (uncurry Var) + $ \case (Var ann name) -> Just (ann, name) + _ -> Nothing + +-- | Evaluate the given 'Expr' in the given context (@'Env' 'Text' 'Text'@). +-- +-- @since 0.1.0 +askExpr :: AST.Env Text Text -> Expr ann -> Text +askExpr e (Exprs _ xs) = Text.concat (map (askExpr e) xs) +askExpr _ (Lit _ x) = x +askExpr e (Var _ x) = askVar e x + +-- | Look up the given variable in the given context, returning the empty string +-- if the variable was not found. +-- +-- @since 0.1.0 +askVar :: AST.Env Text Text -> Text -> Text +askVar e x = fromMaybe Text.empty (AST.askEnv e x) + +-- | Add a binding with the given name ('Text') and value ('Expr') to the +-- given context. +-- +-- @since 0.1.0 +addBind :: Text -> Expr ann -> AST.Env Text Text -> AST.Env Text Text +addBind k v e = AST.addEnv k (askExpr e v) e + +-- | Add bindings from a list. Note that this function evaluates all the +-- right-hand-sides first, and then adds them all to the environment. +-- +-- For example: +-- +-- >>> :set -XOverloadedStrings +-- >>> let binds = [("x", Lit () "5"), ("y", Var () "x")] +-- >>> AST.headEnv (addBinds binds AST.makeEnv) +-- fromList [("x","5"),("y","")] +-- +-- @since 0.1.0 +addBinds :: [(Text, Expr ann)] -> AST.Env Text Text -> AST.Env Text Text +addBinds bs e = map (second (askExpr e) .> uncurry AST.addEnv .> Endo) bs + |> mconcat + |> (\endo -> appEndo endo e) + +-- | Normalize an 'Expr' by recursively flattening any 'Exprs' nodes, removing +-- empty 'Lit' nodes, combining adjacent 'Lit' nodes, and pulling out the +-- interior of the top-level 'Exprs' node if it has only one subnode. +-- +-- The number of 'Exprs' nodes in the output is guaranteed to be 0 or 1. +-- +-- If it is 0, then there is exactly one node of any type in the output. +-- +-- The output is thus isomorphic to @(Maybe ann, [(ann, Either Text Text)])@, +-- where the @Maybe ann@ represents the annotation of the top-level 'Exprs' +-- node if it exists. +-- +-- @since 0.1.0 +normalizeExpr :: forall ann. (Monoid ann) => Expr ann -> Expr ann +normalizeExpr = flatten .> removeEmpty .> combineAdj .> listToExpr + where + flatten :: Expr ann -> [Expr ann] + flatten (Exprs _ es) = concatMap flatten es + flatten owise = [owise] + + removeEmpty :: [Expr ann] -> [Expr ann] + removeEmpty [] = [] + removeEmpty (Lit _ "" : rest) = removeEmpty rest + removeEmpty (owise : rest) = owise : removeEmpty rest + + combineAdj :: [Expr ann] -> [Expr ann] + combineAdj = (\case + [] -> [] + (Lit annX x : Lit annY y : rest) -> (Lit (annX <> annY) (x <> y)) + |> (\e -> combineAdj (e : rest)) + (owise : rest) -> owise : combineAdj rest) + + listToExpr :: [Expr ann] -> Expr ann + listToExpr [e] = e + listToExpr es = Exprs (mconcat (map (Lens.view Misc.annotation) es)) es + +-- | The usual definition for 'Lens.Plated'. +-- +-- @since 0.1.0 +instance (Data ann) => Lens.Plated (Expr ann) + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Expr where + annotation' f = Lens.lens (helper .> fst) (helper .> snd) + where + helper (Exprs ann es) = (ann, \x -> Exprs x (map (fmap f) es)) + helper (Lit ann text) = (ann, \x -> Lit x text) + helper (Var ann name) = (ann, \x -> Var x name) + +-- | Converts 'Exprs' to @{ann: …, exprs: […]}@, 'Lit' to @{ann: …, lit: […]}@, +-- and 'Var' to @{ann: …, var: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (Expr ann) where + toJSON (Exprs ann es) = Aeson.object ["ann" .= ann, "exprs" .= es] + toJSON (Lit ann text) = Aeson.object ["ann" .= ann, "lit" .= text] + toJSON (Var ann name) = Aeson.object ["ann" .= ann, "var" .= name] + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Expr ann) where + parseJSON = Aeson.withObject "Expr" $ \o -> do + ann <- o .: "ann" + asum [ Exprs ann <$> (o .: "exprs") + , Lit ann <$> (o .: "lit") + , Var ann <$> (o .: "var") + ] + +-- | Reasonable 'QC.Arbitrary' instance for 'Expr'. +-- +-- @since 0.1.0 +instance forall ann. (QC.Arbitrary ann) => QC.Arbitrary (Expr ann) where + arbitrary = QC.sized go + where + go :: Int -> QC.Gen (Expr ann) + go n | n <= 0 = [ litG (QC.resize litLength QC.arbitrary) + , varG (QC.resize varLength QC.arbitrary) + ] |> QC.oneof + go n = [ go 0 + , do width <- (`mod` maxWidth) <$> QC.arbitrary + let subtree = go (n `div` lossRate) + Exprs <$> QC.arbitrary <*> QC.vectorOf width subtree + ] |> QC.oneof + + litG, varG :: QC.Gen Text -> QC.Gen (Expr ann) + litG g = Lit <$> QC.arbitrary <*> g + varG g = Var <$> QC.arbitrary <*> g + + litLength, varLength, lossRate, maxWidth :: Int + litLength = 10 + varLength = 10 + maxWidth = 5 + lossRate = 2 + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Expr ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Expr ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, ExprConstraint (SC.Serial m) ann + ) => SC.Serial m (Expr ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, ExprConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Expr ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Expr'. +-- +-- @since 0.1.0 +type ExprConstraint (c :: * -> Constraint) (ann :: *) = (c Text, c ann) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Ninja.hs b/library/Language/Ninja/AST/Ninja.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Ninja.hs @@ -0,0 +1,309 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Ninja.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Ninja +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing a parsed Ninja file AST, along +-- with any supporting or related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Ninja + ( -- * @Ninja@ + Ninja, makeNinja + , ninjaRules + , ninjaSingles + , ninjaMultiples + , ninjaPhonys + , ninjaDefaults + , ninjaPools + , ninjaSpecials + , NinjaConstraint + , Outputs, Output + ) where + +import Control.Monad ((>=>)) + +import qualified Control.Lens as Lens + +import Flow ((.>), (|>)) + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Data.HashSet (HashSet) + +import Data.Text (Text) + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Language.Ninja.AST.Build as AST +import qualified Language.Ninja.AST.Rule as AST +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | A parsed Ninja file. +-- +-- @since 0.1.0 +data Ninja ann + = MkNinja + { _ninjaAnn :: !ann + , _ninjaRules :: !(HashMap Text (AST.Rule ann)) + , _ninjaSingles :: !(HashMap Output (AST.Build ann)) + , _ninjaMultiples :: !(HashMap Outputs (AST.Build ann)) + , _ninjaPhonys :: !(HashMap Text (HashSet Text)) + , _ninjaDefaults :: !(HashSet Text) + , _ninjaPools :: !(HashMap Text Int) + , _ninjaSpecials :: !(HashMap Text Text) + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Construct a 'Ninja' with all default values +-- +-- @since 0.1.0 +{-# INLINE makeNinja #-} +makeNinja :: (Monoid ann) => Ninja ann +makeNinja = MkNinja + { _ninjaAnn = mempty + , _ninjaRules = mempty + , _ninjaSingles = mempty + , _ninjaMultiples = mempty + , _ninjaPhonys = mempty + , _ninjaDefaults = mempty + , _ninjaPools = mempty + , _ninjaSpecials = mempty + } + +-- | The rules defined in a parsed Ninja file. +-- +-- @since 0.1.0 +{-# INLINE ninjaRules #-} +ninjaRules :: Lens.Lens' (Ninja ann) (HashMap Text (AST.Rule ann)) +ninjaRules = Lens.lens _ninjaRules + $ \(MkNinja {..}) x -> MkNinja { _ninjaRules = x, .. } + +-- | The set of @build@ declarations with precisely one output. +-- +-- @since 0.1.0 +{-# INLINE ninjaSingles #-} +ninjaSingles :: Lens.Lens' (Ninja ann) (HashMap Text (AST.Build ann)) +ninjaSingles = Lens.lens _ninjaSingles + $ \(MkNinja {..}) x -> MkNinja { _ninjaSingles = x, .. } + +-- | The set of @build@ declarations with two or more outputs. +-- +-- @since 0.1.0 +{-# INLINE ninjaMultiples #-} +ninjaMultiples :: Lens.Lens' (Ninja ann) (HashMap Outputs (AST.Build ann)) +ninjaMultiples = Lens.lens _ninjaMultiples + $ \(MkNinja {..}) x -> MkNinja { _ninjaMultiples = x, .. } + +-- | The set of phony @build@ declarations. +-- +-- @since 0.1.0 +{-# INLINE ninjaPhonys #-} +ninjaPhonys :: Lens.Lens' (Ninja ann) (HashMap Text (HashSet Text)) +ninjaPhonys = Lens.lens _ninjaPhonys + $ \(MkNinja {..}) x -> MkNinja { _ninjaPhonys = x, .. } + +-- | The set of default targets. +-- +-- @since 0.1.0 +{-# INLINE ninjaDefaults #-} +ninjaDefaults :: Lens.Lens' (Ninja ann) (HashSet Text) +ninjaDefaults = Lens.lens _ninjaDefaults + $ \(MkNinja {..}) x -> MkNinja { _ninjaDefaults = x, .. } + +-- | A mapping from pool names to pool depth integers. +-- +-- @since 0.1.0 +{-# INLINE ninjaPools #-} +ninjaPools :: Lens.Lens' (Ninja ann) (HashMap Text Int) +ninjaPools = Lens.lens _ninjaPools + $ \(MkNinja {..}) x -> MkNinja { _ninjaPools = x, .. } + +-- | A map from "special" top-level variables to their values. +-- +-- @since 0.1.0 +{-# INLINE ninjaSpecials #-} +ninjaSpecials :: Lens.Lens' (Ninja ann) (HashMap Text Text) +ninjaSpecials = Lens.lens _ninjaSpecials + $ \(MkNinja {..}) x -> MkNinja { _ninjaSpecials = x, .. } + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Ninja where + annotation' f = Lens.lens _ninjaAnn + $ \(MkNinja {..}) x -> + MkNinja + { _ninjaAnn = x + , _ninjaRules = HM.map (fmap f) _ninjaRules + , _ninjaSingles = HM.map (fmap f) _ninjaSingles + , _ninjaMultiples = HM.map (fmap f) _ninjaMultiples + , .. } + +-- | Converts to +-- @{ann: …, rules: …, singles: …, multiples: …, phonys: …, defaults: …, +-- pools: …, specials: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (Ninja ann) where + toJSON (MkNinja {..}) + = [ "ann" .= _ninjaAnn + , "rules" .= _ninjaRules + , "singles" .= _ninjaSingles + , "multiples" .= fixMultiples _ninjaMultiples + , "phonys" .= _ninjaPhonys + , "defaults" .= _ninjaDefaults + , "pools" .= _ninjaPools + , "specials" .= _ninjaSpecials + ] |> Aeson.object + where + fixMultiples :: (Aeson.ToJSON ann) + => HashMap Outputs (AST.Build ann) -> Aeson.Value + fixMultiples = HM.toList .> map (uncurry printPair) .> Aeson.toJSON + + printPair :: (Aeson.ToJSON ann) => Outputs -> AST.Build ann -> Aeson.Value + printPair outputs build + = Aeson.object ["outputs" .= outputs, "build" .= build] + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Ninja ann) where + parseJSON = (Aeson.withObject "Ninja" $ \o -> do + _ninjaAnn <- (o .: "ann") >>= pure + _ninjaRules <- (o .: "rules") >>= pure + _ninjaSingles <- (o .: "singles") >>= pure + _ninjaMultiples <- (o .: "multiples") >>= fixMultiples + _ninjaPhonys <- (o .: "phonys") >>= pure + _ninjaDefaults <- (o .: "defaults") >>= pure + _ninjaPools <- (o .: "pools") >>= pure + _ninjaSpecials <- (o .: "specials") >>= pure + pure (MkNinja {..})) + where + fixMultiples :: (Aeson.FromJSON ann) + => Aeson.Value + -> Aeson.Parser (HashMap Outputs (AST.Build ann)) + fixMultiples = Aeson.parseJSON + >=> mapM parsePair + >=> (HM.fromList .> pure) + + parsePair :: (Aeson.FromJSON ann) + => Aeson.Value + -> Aeson.Parser (Outputs, AST.Build ann) + parsePair = (Aeson.withObject "Ninja.multiples" $ \o -> do + outputs <- (o .: "outputs") >>= pure + build <- (o .: "build") >>= pure + pure (outputs, build)) + +-- | Reasonable 'QC.Arbitrary' instance for 'Ninja'. +-- +-- @since 0.1.0 +instance (QC.Arbitrary ann) => QC.Arbitrary (Ninja ann) where + arbitrary = MkNinja + <$> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Ninja ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Ninja ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, NinjaConstraint (SC.Serial m) ann + ) => SC.Serial m (Ninja ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, NinjaConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Ninja ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Ninja'. +-- +-- @since 0.1.0 +type NinjaConstraint (c :: * -> Constraint) (ann :: *) + = ( AST.BuildConstraint c ann + , c (HashMap (HashSet Text) (AST.Build ann)) + , c (HashMap Text (HashSet Text)) + , c (HashMap Text (AST.Rule ann)) + , c (HashMap Text (AST.Build ann)) + , c (HashMap Text Int) + , c ann + ) + +-- | A type representing the set of outputs for a @build@ declaration with +-- multiple outputs. +-- +-- @since 0.1.0 +type Outputs = HashSet Output + +-- | A type representing an output of a @build@ declaration. +-- +-- @since 0.1.0 +type Output = Text + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/AST/Rule.hs b/library/Language/Ninja/AST/Rule.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/AST/Rule.hs @@ -0,0 +1,171 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/AST/Rule.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.AST.Rule +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains a type representing a @rule@ declaration in the +-- parsed Ninja AST, along with any supporting or related types. +-- +-- @since 0.1.0 +module Language.Ninja.AST.Rule + ( Rule, makeRule + , ruleBind + , RuleConstraint + ) where + +import qualified Control.Lens as Lens + +import Flow ((|>)) + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Data.Text (Text) + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import qualified Language.Ninja.AST.Expr as AST +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | A parsed Ninja @rule@ declaration. +-- +-- @since 0.1.0 +data Rule ann + = MkRule + { _ruleAnn :: !ann + , _ruleBind :: !(HashMap Text (AST.Expr ann)) + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Construct a 'Rule' with all default values +-- +-- @since 0.1.0 +{-# INLINE makeRule #-} +makeRule :: (Monoid ann) => Rule ann +makeRule = MkRule + { _ruleAnn = mempty + , _ruleBind = mempty + } + +-- | The set of bindings in scope during the execution of this rule. +-- +-- @since 0.1.0 +{-# INLINE ruleBind #-} +ruleBind :: Lens.Lens' (Rule ann) (HashMap Text (AST.Expr ann)) +ruleBind = Lens.lens _ruleBind + $ \(MkRule {..}) x -> MkRule { _ruleBind = x, .. } + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Rule where + annotation' f = Lens.lens _ruleAnn + $ \(MkRule {..}) x -> + MkRule { _ruleAnn = x + , _ruleBind = HM.map (fmap f) _ruleBind + , .. } + +-- | Converts to @{ann: …, bind: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (Rule ann) where + toJSON (MkRule {..}) + = [ "ann" .= _ruleAnn + , "bind" .= _ruleBind + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Rule ann) where + parseJSON = (Aeson.withObject "Rule" $ \o -> do + _ruleAnn <- (o .: "ann") >>= pure + _ruleBind <- (o .: "bind") >>= pure + pure (MkRule {..})) + +-- | Reasonable 'QC.Arbitrary' instance for 'Rule'. +-- +-- @since 0.1.0 +instance (QC.Arbitrary ann) => QC.Arbitrary (Rule ann) where + arbitrary = MkRule <$> QC.arbitrary <*> QC.arbitrary + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Rule ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Rule ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, RuleConstraint (SC.Serial m) ann + ) => SC.Serial m (Rule ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, RuleConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Rule ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Rule'. +-- +-- @since 0.1.0 +type RuleConstraint (c :: * -> Constraint) (ann :: *) + = ( c (HashMap Text (AST.Expr ann)) + , c ann + ) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Compile.hs b/library/Language/Ninja/Compile.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Compile.hs @@ -0,0 +1,308 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Compile.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Language.Ninja.Compile +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Compile a parsed Ninja file into an intermediate representation. +-- +-- @since 0.1.0 +module Language.Ninja.Compile + ( compile + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow (first) + +import qualified Control.Lens as Lens + +import Control.Monad.Error.Class (MonadError) + +import Data.Char (isSpace) +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (Endo (Endo, appEndo), (<>)) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Flow ((.>), (|>)) + +import Data.Hashable (Hashable) + +import qualified Data.Versions as Ver + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.IR as IR +import qualified Language.Ninja.Misc as Misc + +------------------------------------------------------------------------------- + +-- | Compile an parsed Ninja file into a intermediate representation. +-- +-- @since 0.1.0 +compile :: forall m ann. (MonadError Errors.CompileError m) + => AST.Ninja ann -> m IR.Ninja +compile ast = result + where + result :: m IR.Ninja + result = do + meta <- metaM + builds <- buildsM + phonys <- phonysM + defaults <- defaultsM + pools <- poolsM + + IR.makeNinja + |> Lens.set IR.ninjaMeta meta + |> Lens.set IR.ninjaBuilds builds + |> Lens.set IR.ninjaPhonys phonys + |> Lens.set IR.ninjaDefaults defaults + |> Lens.set IR.ninjaPools pools + |> pure + + metaM :: m IR.Meta + metaM = do + let getSpecial :: Text -> Maybe Text + getSpecial name = HM.lookup name (Lens.view AST.ninjaSpecials ast) + + let parseVersion :: Text -> m Ver.Version + parseVersion = Ver.version + .> either Errors.throwVersionParseFailure pure + + reqversion <- getSpecial "ninja_required_version" + |> fmap parseVersion + |> sequenceA + builddir <- getSpecial "builddir" + |> fmap Misc.makePath + |> pure + + IR.makeMeta + |> Lens.set IR.metaReqVersion reqversion + |> Lens.set IR.metaBuildDir builddir + |> pure + + buildsM :: m (HashSet IR.Build) + buildsM = (multiplesAST <> onHM (first HS.singleton) singlesAST) + |> HM.toList |> mapM compileBuild |> fmap HS.fromList + + phonysM :: m (HashMap IR.Target (HashSet IR.Target)) + phonysM = HM.toList phonysAST |> mapM compilePhony |> fmap HM.fromList + + defaultsM :: m (HashSet IR.Target) + defaultsM = HS.toList defaultsAST |> mapM compileDefault |> fmap HS.fromList + + poolsM :: m (HashSet IR.Pool) + poolsM = HM.toList poolsAST |> mapM compilePool |> fmap HS.fromList + + compileBuild :: (HashSet Text, AST.Build ann) -> m IR.Build + compileBuild (outputs, buildAST) = do + let depsAST = Lens.view AST.buildDeps buildAST + let normalDeps = HS.toList (Lens.view AST.depsNormal depsAST) + let implicitDeps = HS.toList (Lens.view AST.depsImplicit depsAST) + let orderOnlyDeps = HS.toList (Lens.view AST.depsOrderOnly depsAST) + + outs <- HS.toList outputs |> mapM compileOutput |> fmap HS.fromList + rule <- compileRule (outs, buildAST) + deps <- let compileDep ty dep = compileDependency (dep, ty) + in (\n i o -> HS.fromList (n <> i <> o)) + <$> mapM (compileDep IR.NormalDependency) normalDeps + <*> mapM (compileDep IR.NormalDependency) implicitDeps + <*> mapM (compileDep IR.OrderOnlyDependency) orderOnlyDeps + + IR.makeBuild rule + |> Lens.set IR.buildOuts outs + |> Lens.set IR.buildDeps deps + |> pure + + compilePhony :: (Text, HashSet Text) + -> m (IR.Target, HashSet IR.Target) + compilePhony (name, deps) = do + ename <- compileTarget name + edeps <- HS.fromList <$> mapM compileTarget (HS.toList deps) + pure (ename, edeps) + + compileDefault :: Text -> m IR.Target + compileDefault = compileTarget + + compilePool :: (Text, Int) -> m IR.Pool + compilePool pair = case pair of + ("console", 1) -> pure IR.makePoolConsole + ("console", d) -> Errors.throwInvalidPoolDepth d + ("", _) -> Errors.throwEmptyPoolName + (name, d) -> do dp <- Misc.makePositive d + |> maybe (Errors.throwInvalidPoolDepth d) pure + pure (IR.makePoolCustom name dp) + + compileRule :: (HashSet IR.Output, AST.Build ann) -> m IR.Rule + compileRule (outputs, buildAST) = do + (name, ruleAST) <- lookupRule buildAST + + let orLookupError :: Text -> Maybe a -> m a + orLookupError var = maybe (Errors.throwRuleLookupFailure var) pure + + let env = computeRuleEnv (outputs, buildAST) ruleAST + + let lookupBind :: Text -> m (Maybe Text) + lookupBind = AST.askEnv env .> pure + + let lookupBind_ :: Text -> m Text + lookupBind_ var = lookupBind var >>= orLookupError var + + command <- lookupBind_ "command" >>= compileCommand + description <- lookupBind "description" + pool <- let buildBind = Lens.view AST.buildBind buildAST + in (HM.lookup "pool" buildBind <|> AST.askEnv env "pool") + |> fromMaybe "" + |> IR.parsePoolName + |> pure + depfile <- lookupBind "depfile" + |> fmap (fmap Misc.makePath) + specialDeps <- let lookupPrefix = lookupBind "msvc_deps_prefix" + in ((,) <$> lookupBind "deps" <*> lookupPrefix) + >>= compileSpecialDeps + generator <- isJust <$> lookupBind "generator" + restat <- isJust <$> lookupBind "restat" + responseFile <- do ma <- lookupBind "rspfile" + mb <- lookupBind "rspfile_content" + pure ((,) <$> ma <*> mb) + >>= fmap compileResponseFile .> sequenceA + + IR.makeRule name command + |> Lens.set IR.ruleDescription description + |> Lens.set IR.rulePool pool + |> Lens.set IR.ruleDepfile depfile + |> Lens.set IR.ruleSpecialDeps specialDeps + |> Lens.set IR.ruleGenerator generator + |> Lens.set IR.ruleRestat restat + |> Lens.set IR.ruleResponseFile responseFile + |> pure + + compileSpecialDeps :: (Maybe Text, Maybe Text) -> m (Maybe IR.SpecialDeps) + compileSpecialDeps = (\case (Nothing, _) -> pure Nothing + (Just "gcc", m) -> goGCC m + (Just "msvc", m) -> goMSVC m + (Just d, _) -> Errors.throwUnknownDeps d) + where + goGCC, goMSVC :: Maybe Text -> m (Maybe IR.SpecialDeps) + goGCC (Just _) = Errors.throwUnexpectedMSVCPrefix "gcc" + goGCC Nothing = pure (Just IR.makeSpecialDepsGCC) + goMSVC (Just m) = pure (Just (IR.makeSpecialDepsMSVC m)) + goMSVC Nothing = pure (Just (IR.makeSpecialDepsMSVC defaultPrefix)) + + defaultPrefix = "Note: including file: " :: Text + + compileResponseFile :: (Text, Text) -> m IR.ResponseFile + compileResponseFile (file, content) = do + let path = Misc.makePath file + pure (IR.makeResponseFile path content) + + compileTarget :: Text -> m IR.Target + compileTarget = IR.makeTarget .> pure + + compileOutput :: Text -> m IR.Output + compileOutput name = do + target <- compileTarget name + pure (IR.makeOutput target) + + compileDependency :: (Text, IR.DependencyType) -> m IR.Dependency + compileDependency (name, ty) = do + target <- compileTarget name + pure (IR.makeDependency target ty) + + compileCommand :: Text -> m Misc.Command + compileCommand = Misc.makeCommand .> pure + + lookupRule :: AST.Build ann -> m (Text, AST.Rule ann) + lookupRule buildAST = do + let name = Lens.view AST.buildRule buildAST + ruleAST <- HM.lookup name rulesAST + |> maybe (Errors.throwBuildRuleNotFound name) pure + pure (name, ruleAST) + + computeRuleEnv :: (HashSet IR.Output, AST.Build ann) + -> AST.Rule ann + -> AST.Env Text Text + computeRuleEnv (outs, buildAST) ruleAST = do + let depsAST = Lens.view AST.buildDeps buildAST + + -- TODO: properly handle implicit/explicit outputs here + + let isExplicitOut :: IR.Output -> Bool + isExplicitOut _ = True + + let explicitOuts = HS.toList outs + |> filter isExplicitOut + |> map (Lens.view (IR.outputTarget . IR.targetText)) + + let explicitDeps = [ Lens.view AST.depsNormal depsAST + , Lens.view AST.depsOrderOnly depsAST + ] |> mconcat |> HS.toList + + let composeList :: [a -> a] -> (a -> a) + composeList = map Endo .> mconcat .> appEndo + + let quote :: Text -> Text + quote x | Text.any isSpace x = mconcat ["\"", x, "\""] + quote x = x + + let bindings = Lens.view AST.buildBind buildAST + + -- the order of adding new environment variables matters + AST.scopeEnv (Lens.view AST.buildEnv buildAST) + |> AST.addEnv "out" (Text.unwords (map quote explicitOuts)) + |> AST.addEnv "in" (Text.unwords (map quote explicitDeps)) + |> AST.addEnv "in_newline" (Text.unlines explicitDeps) + |> composeList (map (uncurry AST.addEnv) (HM.toList bindings)) + |> AST.addBinds (HM.toList (Lens.view AST.ruleBind ruleAST)) + + rulesAST :: HashMap Text (AST.Rule ann) + singlesAST :: HashMap Text (AST.Build ann) + multiplesAST :: HashMap (HashSet Text) (AST.Build ann) + phonysAST :: HashMap Text (HashSet Text) + defaultsAST :: HashSet Text + poolsAST :: HashMap Text Int + rulesAST = Lens.view AST.ninjaRules ast + singlesAST = Lens.view AST.ninjaSingles ast + multiplesAST = Lens.view AST.ninjaMultiples ast + phonysAST = Lens.view AST.ninjaPhonys ast + defaultsAST = Lens.view AST.ninjaDefaults ast + poolsAST = Lens.view AST.ninjaPools ast + + onHM :: (Eq k', Hashable k') + => ((k, v) -> (k', v')) -> HashMap k v -> HashMap k' v' + onHM f = HM.toList .> map f .> HM.fromList + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Errors.hs b/library/Language/Ninja/Errors.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Errors.hs @@ -0,0 +1,153 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Errors.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Language.Ninja.Errors +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module re-exports all of the modules under the "Language.Ninja.Errors" +-- namespace for convenience. +-- +-- It is recommended that you import it with the following style: +-- +-- > import qualified Language.Ninja.Errors as Errors +-- +-- @since 0.1.0 +module Language.Ninja.Errors + ( -- * "Language.Ninja.Errors" + NinjaError (..) + , throwNinjaError + , throwGenericNinjaError + , throwNinjaParseError + , throwNinjaCompileError + + -- * "Language.Ninja.Errors.Compile" + , CompileError (..) + , throwCompileError + , throwGenericCompileError + + , CompileMetaError (..) + , throwCompileMetaError + , throwGenericCompileMetaError + , throwVersionParseFailure + + , CompilePhonyError (..) + , throwCompilePhonyError + , throwGenericCompilePhonyError + + , CompileDefaultError (..) + , throwCompileDefaultError + , throwGenericCompileDefaultError + + , CompileBuildError (..) + , throwCompileBuildError + , throwGenericCompileBuildError + , throwBuildRuleNotFound + + , CompileRuleError (..) + , throwCompileRuleError + , throwGenericCompileRuleError + , throwRuleLookupFailure + , throwUnknownDeps + , throwUnexpectedMSVCPrefix + + , CompilePoolError (..) + , throwCompilePoolError + , throwGenericCompilePoolError + , throwInvalidPoolDepth + , throwEmptyPoolName + + -- * "Language.Ninja.Errors.Parser" + , ParseError (..) + , throwParseError + , throwGenericParseError + , throwLexBindingFailure + , throwLexExpectedColon + , throwLexUnexpectedDollar + , throwLexUnexpectedSeparator + , throwLexParsecError + , throwParseBadDepthField + , throwParseUnexpectedBinding + ) where + +import Language.Ninja.Errors.Compile +import Language.Ninja.Errors.Parser + +import Control.Exception (Exception) +import Control.Monad.Error.Class (MonadError (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +-- | This type subsumes any error that can be thrown during execution of a +-- function defined in @language-ninja@. +-- +-- @since 0.1.0 +data NinjaError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericNinjaError !Text + | -- | Errors encountered during parsing. + -- + -- @since 0.1.0 + NinjaParseError !ParseError + | -- | Errors encountered during compilation. + -- + -- @since 0.1.0 + NinjaCompileError !CompileError + deriving (Eq, Show, Generic) + +instance Exception NinjaError + +-- | Throw a 'NinjaError'. +-- +-- @since 0.1.0 +throwNinjaError :: (MonadError NinjaError m) => NinjaError -> m a +throwNinjaError = throwError + +-- | Throw a generic catch-all 'NinjaError'. +-- +-- @since 0.1.0 +throwGenericNinjaError :: (MonadError NinjaError m) => Text -> m a +throwGenericNinjaError msg = throwNinjaError (GenericNinjaError msg) + +-- | Throw a 'ParseError'. +-- +-- @since 0.1.0 +throwNinjaParseError :: (MonadError NinjaError m) => ParseError -> m a +throwNinjaParseError e = throwNinjaError (NinjaParseError e) + +-- | Throw a 'CompileError'. +-- +-- @since 0.1.0 +throwNinjaCompileError :: (MonadError NinjaError m) => CompileError -> m a +throwNinjaCompileError e = throwNinjaError (NinjaCompileError e) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Errors/Compile.hs b/library/Language/Ninja/Errors/Compile.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Errors/Compile.hs @@ -0,0 +1,523 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Errors/Compile.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Language.Ninja.Errors.Compile +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Errors thrown during Ninja compilation. +-- +-- @since 0.1.0 +module Language.Ninja.Errors.Compile + ( -- * @CompileError@ + CompileError (..) + , throwCompileError, throwGenericCompileError + + -- * @CompileMetaError@ + , CompileMetaError (..) + , throwCompileMetaError, throwGenericCompileMetaError + , throwVersionParseFailure + + -- * @CompilePhonyError@ + , CompilePhonyError (..) + , throwCompilePhonyError, throwGenericCompilePhonyError + + -- * @CompileDefaultError@ + , CompileDefaultError (..) + , throwCompileDefaultError, throwGenericCompileDefaultError + + -- * @CompileBuildError@ + , CompileBuildError (..) + , throwCompileBuildError, throwGenericCompileBuildError + , throwBuildRuleNotFound + + -- * @CompileRuleError@ + , CompileRuleError (..) + , throwCompileRuleError, throwGenericCompileRuleError + , throwRuleLookupFailure + , throwUnknownDeps + , throwUnexpectedMSVCPrefix + + -- * @CompilePoolError@ + , CompilePoolError (..) + , throwCompilePoolError, throwGenericCompilePoolError + , throwInvalidPoolDepth + , throwEmptyPoolName + ) where + +import Control.Exception (Exception) +import Control.Monad.Error.Class (MonadError (throwError)) +import GHC.Generics (Generic) + +import Data.Text (Text) + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson + +import qualified Text.Megaparsec as M + +import qualified Data.Versions as Ver + +import Data.Foldable (toList) + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered during compilation. +-- +-- @since 0.1.0 +data CompileError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompileError !Text + | -- | Errors encountered while compiling a 'Meta'. + -- + -- @since 0.1.0 + CompileMetaError !CompileMetaError + | -- | Errors encountered while compiling a 'Build'. + -- + -- @since 0.1.0 + CompileBuildError !CompileBuildError + | -- | Errors encountered while compiling a 'Rule'. + -- + -- @since 0.1.0 + CompileRuleError !CompileRuleError + | -- | Errors encountered while compiling the phony 'HashMap'. + -- + -- @since 0.1.0 + CompilePhonyError !CompilePhonyError + | -- | Errors encountered while compiling the default target 'HashSet'. + -- + -- @since 0.1.0 + CompileDefaultError !CompileDefaultError + | -- | Errors encountered while compiling a 'Pool'. + -- + -- @since 0.1.0 + CompilePoolError !CompilePoolError + deriving (Eq, Show, Generic) + +-- | Throw a 'CompileError'. +-- +-- @since 0.1.0 +throwCompileError :: (MonadError CompileError m) => CompileError -> m a +throwCompileError = throwError + +-- | Throw a generic catch-all 'CompileError'. +-- +-- @since 0.1.0 +throwGenericCompileError :: (MonadError CompileError m) => Text -> m a +throwGenericCompileError msg = throwCompileError (GenericCompileError msg) + +-- | Default instance. +-- +-- @since 0.1.0 +instance Exception CompileError + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompileError where + toJSON = go + where + go (GenericCompileError text) = obj "generic-compile-error" text + go (CompileMetaError cme) = obj "compile-meta-error" cme + go (CompileBuildError cbe) = obj "compile-build-error" cbe + go (CompileRuleError cre) = obj "compile-rule-error" cre + go (CompilePhonyError cpe) = obj "compile-phony-error" cpe + go (CompileDefaultError cde) = obj "compile-default-error" cde + go (CompilePoolError cpe) = obj "compile-pool-error" cpe + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling Ninja metadata. +-- +-- @since 0.1.0 +data CompileMetaError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompileMetaError !Text + | -- | @Failed to parse `ninja_required_version`: …@ + -- + -- @since 0.1.0 + VersionParseFailure !Ver.ParsingError + deriving (Eq, Show, Generic) + +-- | Throw a 'CompileMetaError'. +-- +-- @since 0.1.0 +throwCompileMetaError :: (MonadError CompileError m) => CompileMetaError -> m a +throwCompileMetaError = CompileMetaError .> throwCompileError + +-- | Throw a generic catch-all 'CompileMetaError'. +-- +-- @since 0.1.0 +throwGenericCompileMetaError :: (MonadError CompileError m) => Text -> m a +throwGenericCompileMetaError = GenericCompileMetaError .> throwCompileMetaError + +-- | Throw a 'VersionParseFailure' error. +-- +-- @since 0.1.0 +throwVersionParseFailure :: (MonadError CompileError m) + => Ver.ParsingError -> m a +throwVersionParseFailure pe = throwCompileMetaError (VersionParseFailure pe) + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompileMetaError where + toJSON = go + where + go (GenericCompileMetaError t) = obj "generic-compile-meta-error" t + go (VersionParseFailure e) = obj "version-parse-failure" (peJ e) + + -- TODO: deduplicate against the implementation in Errors.Parser + + peJ :: M.ParseError Char M.Dec -> Aeson.Value + peJ (decomposePE -> (pos, custom, unexpected, expected)) + = [ "pos" .= (posJ <$> pos) + , "unexpected" .= (errItemJ <$> unexpected) + , "expected" .= (errItemJ <$> expected) + , "custom" .= (decJ <$> custom) + ] |> Aeson.object + + decomposePE :: M.ParseError Char M.Dec + -> ( [M.SourcePos], [M.Dec] + , [M.ErrorItem Char], [M.ErrorItem Char] ) + decomposePE (M.ParseError {..}) + = ( toList errorPos, toList errorCustom + , toList errorUnexpected, toList errorExpected ) + + posJ :: M.SourcePos -> Aeson.Value + posJ (M.SourcePos {..}) = [ "name" .= sourceName + , "line" .= M.unPos sourceLine + , "column" .= M.unPos sourceColumn + ] |> Aeson.object + + errItemJ :: M.ErrorItem Char -> Aeson.Value + errItemJ (M.Tokens xs) = Aeson.toJSON (toList xs) + errItemJ (M.Label xs) = Aeson.toJSON (toList xs) + errItemJ M.EndOfInput = "eof" + + decJ :: M.Dec -> Aeson.Value + decJ (M.DecFail message) = [ "message" .= message + ] |> Aeson.object |> obj "fail" + decJ (M.DecIndentation ord x y) = [ "ordering" .= ord + , "start" .= M.unPos x + , "end" .= M.unPos y + ] |> Aeson.object |> obj "indentation" + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling a Ninja phony @build@. +-- +-- @since 0.1.0 +data CompilePhonyError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompilePhonyError !Text + deriving (Eq, Show, Generic) + +-- | Throw a 'CompilePhonyError'. +-- +-- @since 0.1.0 +throwCompilePhonyError :: (MonadError CompileError m) + => CompilePhonyError -> m a +throwCompilePhonyError = CompilePhonyError .> throwCompileError + +-- | Throw a generic catch-all 'CompilePhonyError'. +-- +-- @since 0.1.0 +throwGenericCompilePhonyError :: (MonadError CompileError m) => Text -> m a +throwGenericCompilePhonyError = GenericCompilePhonyError + .> throwCompilePhonyError + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompilePhonyError where + toJSON = go + where + go (GenericCompilePhonyError t) = obj "generic-compile-phony-error" t + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling a Ninja @default@ statement. +-- +-- @since 0.1.0 +data CompileDefaultError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompileDefaultError !Text + deriving (Eq, Show, Generic) + +-- | Throw a 'CompileDefaultError'. +-- +-- @since 0.1.0 +throwCompileDefaultError :: (MonadError CompileError m) + => CompileDefaultError -> m a +throwCompileDefaultError = CompileDefaultError .> throwCompileError + +-- | Throw a generic catch-all 'CompileDefaultError'. +-- +-- @since 0.1.0 +throwGenericCompileDefaultError :: (MonadError CompileError m) => Text -> m a +throwGenericCompileDefaultError = GenericCompileDefaultError + .> throwCompileDefaultError + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompileDefaultError where + toJSON = go + where + go (GenericCompileDefaultError t) = obj "generic-compile-default-error" t + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling a Ninja @build@ statement. +-- +-- @since 0.1.0 +data CompileBuildError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompileBuildError !Text + | -- | @Rule not found: @ + -- + -- @since 0.1.0 + BuildRuleNotFound !Text + deriving (Eq, Show, Generic) + +-- | Throw a 'CompileBuildError'. +-- +-- @since 0.1.0 +throwCompileBuildError :: (MonadError CompileError m) + => CompileBuildError -> m a +throwCompileBuildError = CompileBuildError .> throwCompileError + +-- | Throw a generic catch-all 'CompileBuildError'. +-- +-- @since 0.1.0 +throwGenericCompileBuildError :: (MonadError CompileError m) => Text -> m a +throwGenericCompileBuildError = GenericCompileBuildError + .> throwCompileBuildError + +-- | Throw a 'BuildRuleNotFound' error. +-- +-- @since 0.1.0 +throwBuildRuleNotFound :: (MonadError CompileError m) => Text -> m a +throwBuildRuleNotFound name = throwCompileBuildError (BuildRuleNotFound name) + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompileBuildError where + toJSON = go + where + go (GenericCompileBuildError t) = obj "generic-compile-build-error" t + go (BuildRuleNotFound n) = obj "build-rule-not-found" n + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling a Ninja @rule@ statement. +-- +-- @since 0.1.0 +data CompileRuleError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompileRuleError !Text + | -- | @Lookup failed on rule variable: @ + -- + -- @since 0.1.0 + RuleLookupFailure !Text + | -- | @Unknown `deps` value: @ + -- + -- @since 0.1.0 + UnknownDepsValue !Text + | -- | @Unexpected `msvc_deps_prefix` for `deps = ""`@ + -- + -- @since 0.1.0 + UnexpectedMSVCPrefix !Text + deriving (Eq, Show, Generic) + +-- | Throw a 'CompileRuleError'. +-- +-- @since 0.1.0 +throwCompileRuleError :: (MonadError CompileError m) => CompileRuleError -> m a +throwCompileRuleError = CompileRuleError .> throwCompileError + +-- | Throw a generic catch-all 'CompileRuleError'. +-- +-- @since 0.1.0 +throwGenericCompileRuleError :: (MonadError CompileError m) => Text -> m a +throwGenericCompileRuleError = GenericCompileRuleError .> throwCompileRuleError + +-- | Throw a 'RuleLookupFailure' error. +-- +-- @since 0.1.0 +throwRuleLookupFailure :: (MonadError CompileError m) => Text -> m a +throwRuleLookupFailure v = throwCompileRuleError (RuleLookupFailure v) + +-- | Throw an 'UnknownDeps' error. +-- +-- @since 0.1.0 +throwUnknownDeps :: (MonadError CompileError m) => Text -> m a +throwUnknownDeps deps = throwCompileRuleError (UnknownDepsValue deps) + +-- | Throw an 'UnexpectedMSVCPrefix' error. +-- +-- @since 0.1.0 +throwUnexpectedMSVCPrefix :: (MonadError CompileError m) => Text -> m a +throwUnexpectedMSVCPrefix deps = throwCompileRuleError + (UnexpectedMSVCPrefix deps) + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompileRuleError where + toJSON = go + where + go (GenericCompileRuleError t) = obj "generic-compile-build-error" t + go (RuleLookupFailure n) = obj "rule-lookup-failure" n + go (UnknownDepsValue d) = obj "unknown-deps-value" d + go (UnexpectedMSVCPrefix d) = obj "unexpected-msvc-prefix" d + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered while compiling a Ninja @pool@ statement. +-- +-- @since 0.1.0 +data CompilePoolError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericCompilePoolError !Text + | -- | @Invalid pool depth for console: @ + -- + -- @since 0.1.0 + InvalidPoolDepth !Int + | -- | @Pool name is an empty string@ + -- + -- @since 0.1.0 + EmptyPoolName + deriving (Eq, Show, Generic) + +-- | Throw a 'CompilePoolError'. +-- +-- @since 0.1.0 +throwCompilePoolError :: (MonadError CompileError m) => CompilePoolError -> m a +throwCompilePoolError = CompilePoolError .> throwCompileError + +-- | Throw a generic catch-all 'CompilePoolError'. +-- +-- @since 0.1.0 +throwGenericCompilePoolError :: (MonadError CompileError m) => Text -> m a +throwGenericCompilePoolError = GenericCompilePoolError .> throwCompilePoolError + +-- | Throw an 'InvalidPoolDepth' error. +-- +-- @since 0.1.0 +throwInvalidPoolDepth :: (MonadError CompileError m) => Int -> m a +throwInvalidPoolDepth d = throwCompilePoolError (InvalidPoolDepth d) + +-- | Throw an 'EmptyPoolName' error. +-- +-- @since 0.1.0 +throwEmptyPoolName :: (MonadError CompileError m) => m a +throwEmptyPoolName = throwCompilePoolError EmptyPoolName + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON CompilePoolError where + toJSON = go + where + go (GenericCompilePoolError t) = obj "generic-compile-pool-error" t + go (InvalidPoolDepth d) = obj "invalid-pool-depth" d + go EmptyPoolName = obj "empty-pool-name" nullJ + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + + nullJ = Aeson.Null :: Aeson.Value + +-- TODO: add FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Errors/Parser.hs b/library/Language/Ninja/Errors/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Errors/Parser.hs @@ -0,0 +1,226 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Errors/Parser.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Language.Ninja.Errors.Parser +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Errors thrown during Ninja parsing. +-- +-- @since 0.1.0 +module Language.Ninja.Errors.Parser + ( -- * @ParseError@ + ParseError (..) + , throwParseError, throwGenericParseError + , throwLexBindingFailure + , throwLexExpectedColon + , throwLexUnexpectedDollar + , throwLexUnexpectedSeparator + , throwLexParsecError + , throwParseBadDepthField + , throwParseUnexpectedBinding + ) where + +import Control.Exception (Exception) +import Control.Monad.Error.Class (MonadError (throwError)) +import GHC.Generics (Generic) + +import Data.Text (Text) + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson + +import qualified Text.Megaparsec as M + +import Data.Foldable (toList) + +import Flow ((|>)) + +-------------------------------------------------------------------------------- + +-- | The type of errors encountered during parsing. +-- +-- @since 0.1.0 +data ParseError + = -- | Generic catch-all error constructor. Avoid using this. + -- + -- @since 0.1.0 + GenericParseError !Text + | -- | @Lexer failed at binding: @ + -- + -- @since 0.1.0 + LexBindingFailure !Text + | -- | @Expected a colon@ + -- + -- @since 0.1.0 + LexExpectedColon + | -- | @Unexpected $ followed by unexpected stuff@ + -- + -- @since 0.1.0 + LexUnexpectedDollar + | -- | Lexer expected a separator character but found something else + -- + -- @since 0.1.0 + LexUnexpectedSeparator Char + | -- | Any other lexer error. + -- + -- @since 0.1.0 + LexParsecError !(M.ParseError Char M.Dec) + | -- | @Could not parse depth field in pool, got: @ + -- + -- @since 0.1.0 + ParseBadDepthField !Text + | -- | @Unexpected binding defining @ + -- + -- @since 0.1.0 + ParseUnexpectedBinding !Text + deriving (Eq, Show, Generic) + +-- TODO: remove unused errors here + +-- | Throw a 'ParseError'. +-- +-- @since 0.1.0 +throwParseError :: (MonadError ParseError m) => ParseError -> m a +throwParseError = throwError + +-- | Throw a generic catch-all 'ParseError'. +-- +-- @since 0.1.0 +throwGenericParseError :: (MonadError ParseError m) => Text -> m a +throwGenericParseError msg = throwParseError (GenericParseError msg) + +-- | Throw a 'LexBindingFailure' error. +-- +-- @since 0.1.0 +throwLexBindingFailure :: (MonadError ParseError m) => Text -> m a +throwLexBindingFailure t = throwParseError (LexBindingFailure t) + +-- | Throw a 'LexExpectedColon' error. +-- +-- @since 0.1.0 +throwLexExpectedColon :: (MonadError ParseError m) => m a +throwLexExpectedColon = throwParseError LexExpectedColon + +-- | Throw a 'LexUnexpectedColon' error. +-- +-- @since 0.1.0 +throwLexUnexpectedDollar :: (MonadError ParseError m) => m a +throwLexUnexpectedDollar = throwParseError LexUnexpectedDollar + +-- | Throw a 'LexUnexpectedSeparator' error. +-- +-- @since 0.1.0 +throwLexUnexpectedSeparator :: (MonadError ParseError m) => Char -> m a +throwLexUnexpectedSeparator c = throwParseError (LexUnexpectedSeparator c) + +-- | Throw a 'LexParsecError' error. +-- +-- @since 0.1.0 +throwLexParsecError :: (MonadError ParseError m) + => M.ParseError Char M.Dec -> m a +throwLexParsecError pe = throwParseError (LexParsecError pe) + +-- | Throw a 'ParseBadDepthField' error. +-- +-- @since 0.1.0 +throwParseBadDepthField :: (MonadError ParseError m) => Text -> m a +throwParseBadDepthField t = throwParseError (ParseBadDepthField t) + +-- | Throw a 'ParseUnexpectedBinding' error. +-- +-- @since 0.1.0 +throwParseUnexpectedBinding :: (MonadError ParseError m) => Text -> m a +throwParseUnexpectedBinding t = throwParseError (ParseUnexpectedBinding t) + +-- | Default instance. +-- +-- @since 0.1.0 +instance Exception ParseError + +-- | Converts to @{tag: …, value: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON ParseError where + toJSON = go + where + go (GenericParseError t) = obj "generic-parse-error" t + go (LexBindingFailure t) = obj "lex-binding-failure" t + go LexExpectedColon = obj "lex-expected-colon" nullJ + go LexUnexpectedDollar = obj "lex-unexpected-dollar" nullJ + go (LexUnexpectedSeparator c) = obj "lex-unexpected-separator" c + go (LexParsecError pe) = obj "lex-parsec-error" (peJ pe) + go (ParseBadDepthField t) = obj "parse-bad-depth-field" t + go (ParseUnexpectedBinding t) = obj "parse-unexpected-binding" t + + peJ :: M.ParseError Char M.Dec -> Aeson.Value + peJ (decomposePE -> (pos, custom, unexpected, expected)) + = [ "pos" .= (posJ <$> pos) + , "unexpected" .= (errItemJ <$> unexpected) + , "expected" .= (errItemJ <$> expected) + , "custom" .= (decJ <$> custom) + ] |> Aeson.object + + decomposePE :: M.ParseError Char M.Dec + -> ( [M.SourcePos], [M.Dec] + , [M.ErrorItem Char], [M.ErrorItem Char] ) + decomposePE (M.ParseError {..}) + = ( toList errorPos, toList errorCustom + , toList errorUnexpected, toList errorExpected ) + + posJ :: M.SourcePos -> Aeson.Value + posJ (M.SourcePos {..}) = [ "name" .= sourceName + , "line" .= M.unPos sourceLine + , "column" .= M.unPos sourceColumn + ] |> Aeson.object + + errItemJ :: M.ErrorItem Char -> Aeson.Value + errItemJ (M.Tokens xs) = Aeson.toJSON (toList xs) + errItemJ (M.Label xs) = Aeson.toJSON (toList xs) + errItemJ M.EndOfInput = "eof" + + decJ :: M.Dec -> Aeson.Value + decJ (M.DecFail message) = [ "message" .= message + ] |> Aeson.object |> obj "fail" + decJ (M.DecIndentation ord x y) = [ "ordering" .= ord + , "start" .= M.unPos x + , "end" .= M.unPos y + ] |> Aeson.object |> obj "indentation" + + obj :: (Aeson.ToJSON x) => Text -> x -> Aeson.Value + obj tag value = Aeson.object ["tag" .= tag, "value" .= value] + + nullJ = Aeson.Null :: Aeson.Value + +-- TODO: add a FromJSON instance +-- TODO: add Arbitrary instance +-- TODO: add (Co)Serial instance + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR.hs b/library/Language/Ninja/IR.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR.hs @@ -0,0 +1,91 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Language.Ninja.IR +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- The Ninja build language intermediate representation after compilation. +-- +-- This module re-exports all of the modules under the "Language.Ninja.IR" +-- namespace for convenience. +-- +-- It is recommended that you import it with the following style: +-- +-- > import qualified Language.Ninja.IR as IR +-- +-- @since 0.1.0 +module Language.Ninja.IR + ( -- * "Language.Ninja.IR.Ninja" + IR.Ninja, IR.makeNinja + , IR.ninjaMeta, IR.ninjaBuilds, IR.ninjaPhonys + , IR.ninjaDefaults, IR.ninjaPools + + -- * "Language.Ninja.IR.Meta" + , IR.Meta, IR.makeMeta, IR.metaReqVersion, IR.metaBuildDir + + -- * "Language.Ninja.IR.Build" + , IR.Build, IR.makeBuild, IR.buildRule, IR.buildOuts, IR.buildDeps + + -- * "Language.Ninja.IR.Rule" + , IR.Rule, IR.makeRule + , IR.ruleName, IR.ruleCommand, IR.ruleDescription, IR.rulePool, IR.ruleDepfile + , IR.ruleSpecialDeps, IR.ruleGenerator, IR.ruleRestat, IR.ruleResponseFile + + , IR.SpecialDeps, IR.makeSpecialDepsGCC, IR.makeSpecialDepsMSVC + , IR._SpecialDepsGCC, IR._SpecialDepsMSVC + + , IR.ResponseFile, IR.makeResponseFile + , IR.responseFilePath, IR.responseFileContent + + -- * "Language.Ninja.IR.Target" + , IR.Target, IR.makeTarget + , IR.targetIText, IR.targetText + + , IR.Output, IR.makeOutput, IR.outputTarget + + , IR.Dependency, IR.makeDependency, IR.dependencyTarget, IR.dependencyType + , IR.DependencyType (..), IR._NormalDependency, IR._OrderOnlyDependency + + -- * "Language.Ninja.IR.Pool" + , IR.Pool + , IR.makePool, IR.makePoolDefault, IR.makePoolConsole, IR.makePoolCustom + , IR.poolName, IR.poolDepth + + , IR.PoolName + , IR.makePoolNameDefault, IR.makePoolNameConsole, IR.makePoolNameCustom + , IR._PoolNameDefault, IR._PoolNameConsole, IR._PoolNameCustom + , IR.poolNameText, IR.printPoolName, IR.parsePoolName + + , IR.PoolDepth + , IR.makePoolDepth, IR.makePoolInfinite + , IR.poolDepthPositive + ) where + +import Language.Ninja.IR.Build as IR +import Language.Ninja.IR.Meta as IR +import Language.Ninja.IR.Ninja as IR +import Language.Ninja.IR.Pool as IR +import Language.Ninja.IR.Rule as IR +import Language.Ninja.IR.Target as IR diff --git a/library/Language/Ninja/IR/Build.hs b/library/Language/Ninja/IR/Build.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Build.hs @@ -0,0 +1,167 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Build.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Build +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype for Ninja @build@ declarations. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Build + ( -- * @Build@ + Build, makeBuild, buildRule, buildOuts, buildDeps + , BuildConstraint + ) where + +import qualified Control.Lens as Lens + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import Data.Text (Text) + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Language.Ninja.IR.Rule (Rule) +import Language.Ninja.IR.Target (Dependency, Output) + +import Flow ((|>)) + +-------------------------------------------------------------------------------- + +-- | A Ninja @build@ declaration, as documented +-- . +-- +-- @since 0.1.0 +data Build + = MkBuild + { _buildRule :: !Rule + , _buildOuts :: !(HashSet Output) + , _buildDeps :: !(HashSet Dependency) + } + deriving (Eq, Show, Generic) + +-- | Construct a default 'Build' from the given 'Rule' +-- +-- @since 0.1.0 +{-# INLINE makeBuild #-} +makeBuild :: Rule -> Build +makeBuild rule = MkBuild + { _buildRule = rule + , _buildOuts = HS.empty + , _buildDeps = HS.empty + } + +-- | The rule to execute when building any of the outputs. +-- +-- @since 0.1.0 +{-# INLINE buildRule #-} +buildRule :: Lens.Lens' Build Rule +buildRule = Lens.lens _buildRule + $ \(MkBuild {..}) x -> MkBuild { _buildRule = x, .. } + +-- | The outputs that are built as a result of rule execution. +-- +-- @since 0.1.0 +{-# INLINE buildOuts #-} +buildOuts :: Lens.Lens' Build (HashSet Output) +buildOuts = Lens.lens _buildOuts + $ \(MkBuild {..}) x -> MkBuild { _buildOuts = x, .. } + +-- | The dependencies that must be satisfied before this can be built. +-- +-- @since 0.1.0 +{-# INLINE buildDeps #-} +buildDeps :: Lens.Lens' Build (HashSet Dependency) +buildDeps = Lens.lens _buildDeps + $ \(MkBuild {..}) x -> MkBuild { _buildDeps = x, .. } + +-- | Converts to @{rule: …, outputs: …, dependencies: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Build where + toJSON (MkBuild {..}) + = [ "rule" .= _buildRule + , "outputs" .= _buildOuts + , "dependencies" .= _buildDeps + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Build where + parseJSON = (Aeson.withObject "Build" $ \o -> do + _buildRule <- (o .: "rule") >>= pure + _buildOuts <- (o .: "outputs") >>= pure + _buildDeps <- (o .: "dependencies") >>= pure + pure (MkBuild {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Build + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Build + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, BuildConstraint (SC.Serial m)) => SC.Serial m Build + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, BuildConstraint (SC.CoSerial m)) => SC.CoSerial m Build + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Build'. +-- +-- @since 0.1.0 +type BuildConstraint (c :: * -> Constraint) + = ( c Text + , c (HashSet Output) + , c (HashSet Dependency) + ) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR/Meta.hs b/library/Language/Ninja/IR/Meta.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Meta.hs @@ -0,0 +1,168 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Meta.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Meta +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype for Ninja top-level variables and other metadata. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Meta + ( -- * @Meta@ + Meta, makeMeta, metaReqVersion, metaBuildDir + ) where + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Data.Text (Text) + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import qualified Test.SmallCheck.Series as SC + +import qualified Data.Versions as Ver + +import qualified Text.Megaparsec as Mega + +import Language.Ninja.Misc.Path (Path) + +import qualified Control.Lens as Lens + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | Ninja top-level metadata, as documented +-- . +-- +-- @since 0.1.0 +data Meta + = MkMeta + { _metaReqVersion :: !(Maybe Ver.Version) + , _metaBuildDir :: !(Maybe Path) + } + deriving (Eq, Ord, Show, Generic) + +-- | Construct a default 'Meta' value. +-- +-- @since 0.1.0 +{-# INLINE makeMeta #-} +makeMeta :: Meta +makeMeta = MkMeta + { _metaReqVersion = Nothing + , _metaBuildDir = Nothing + } + +-- | Corresponds to the @ninja_required_version@ top-level variable. +-- +-- @since 0.1.0 +{-# INLINE metaReqVersion #-} +metaReqVersion :: Lens.Lens' Meta (Maybe Ver.Version) +metaReqVersion = Lens.lens _metaReqVersion + $ \(MkMeta {..}) x -> MkMeta { _metaReqVersion = x, .. } + +-- | Corresponds to the @builddir@ top-level variable. +-- +-- @since 0.1.0 +{-# INLINE metaBuildDir #-} +metaBuildDir :: Lens.Lens' Meta (Maybe Path) +metaBuildDir = Lens.lens _metaBuildDir + $ \(MkMeta {..}) x -> MkMeta { _metaBuildDir = x, .. } + +-- | Converts to @{req-version: …, build-dir: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Meta where + toJSON (MkMeta {..}) + = [ "req-version" .= fmap versionJ _metaReqVersion + , "build-dir" .= _metaBuildDir + ] |> Aeson.object + where + versionJ :: Ver.Version -> Aeson.Value + versionJ = Ver.prettyVer .> Aeson.toJSON + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Meta where + parseJSON = (Aeson.withObject "Meta" $ \o -> do + _metaReqVersion <- (o .: "req-version") >>= maybeVersionP + _metaBuildDir <- (o .: "build-dir") >>= pure + pure (MkMeta {..})) + where + maybeVersionP :: Maybe Aeson.Value -> Aeson.Parser (Maybe Ver.Version) + maybeVersionP = fmap versionP .> sequenceA + + versionP :: Aeson.Value -> Aeson.Parser Ver.Version + versionP = Aeson.withText "Version" (megaparsecToAeson Ver.version') + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Meta + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Meta + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.Serial m Ver.Version + , SC.Serial m Text + ) => SC.Serial m Meta + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.CoSerial m Ver.Version + , SC.CoSerial m Text + ) => SC.CoSerial m Meta + +-------------------------------------------------------------------------------- + +-- This function converts a @megaparsec@ parser to an @aeson@ parser. +-- Mainly, it handles converting the error output from @megaparsec@ to a +-- string that is appropriate for 'fail'. +megaparsecToAeson :: Mega.Parsec Mega.Dec Text t + -> (Text -> Aeson.Parser t) +megaparsecToAeson parser text = case Mega.runParser parser "" text of + Left e -> fail (Mega.parseErrorPretty e) + Right x -> pure x + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR/Ninja.hs b/library/Language/Ninja/IR/Ninja.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Ninja.hs @@ -0,0 +1,205 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Ninja.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Ninja +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype representing the intermediate representation of a Ninja file +-- after compilation. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Ninja + ( -- * @Ninja@ + Ninja, makeNinja + , ninjaMeta, ninjaBuilds, ninjaPhonys, ninjaDefaults, ninjaPools + , NinjaConstraint + ) where + +import qualified Control.Lens as Lens + +import Data.Text (Text) + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import qualified Data.Versions as Ver + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import Language.Ninja.IR.Build (Build) +import Language.Ninja.IR.Meta (Meta) +import qualified Language.Ninja.IR.Meta as Ninja +import Language.Ninja.IR.Pool (Pool) +import Language.Ninja.IR.Target (Target) + +import Flow ((|>)) + +-------------------------------------------------------------------------------- + +-- | A parsed and normalized Ninja file. +-- +-- @since 0.1.0 +data Ninja + = MkNinja + { _ninjaMeta :: !Meta + , _ninjaBuilds :: !(HashSet Build) + , _ninjaPhonys :: !(HashMap Target (HashSet Target)) + , _ninjaDefaults :: !(HashSet Target) + , _ninjaPools :: !(HashSet Pool) + } + deriving (Eq, Show, Generic) + +-- | Construct a default 'Ninja' value. +-- +-- @since 0.1.0 +{-# INLINE makeNinja #-} +makeNinja :: Ninja +makeNinja = MkNinja + { _ninjaMeta = Ninja.makeMeta + , _ninjaBuilds = HS.empty + , _ninjaPhonys = HM.empty + , _ninjaDefaults = HS.empty + , _ninjaPools = HS.empty + } + +-- | Metadata, which includes top-level variables like @builddir@. +-- +-- @since 0.1.0 +{-# INLINE ninjaMeta #-} +ninjaMeta :: Lens.Lens' Ninja Meta +ninjaMeta = Lens.lens _ninjaMeta + $ \(MkNinja {..}) x -> MkNinja { _ninjaMeta = x, .. } + +-- | Compiled @build@ declarations. +-- +-- @since 0.1.0 +{-# INLINE ninjaBuilds #-} +ninjaBuilds :: Lens.Lens' Ninja (HashSet Build) +ninjaBuilds = Lens.lens _ninjaBuilds + $ \(MkNinja {..}) x -> MkNinja { _ninjaBuilds = x, .. } + +-- | Phony targets, as documented +-- . +-- +-- @since 0.1.0 +{-# INLINE ninjaPhonys #-} +ninjaPhonys :: Lens.Lens' Ninja (HashMap Target (HashSet Target)) +ninjaPhonys = Lens.lens _ninjaPhonys + $ \(MkNinja {..}) x -> MkNinja { _ninjaPhonys = x, .. } + +-- | The set of default targets, as documented +-- . +-- +-- @since 0.1.0 +{-# INLINE ninjaDefaults #-} +ninjaDefaults :: Lens.Lens' Ninja (HashSet Target) +ninjaDefaults = Lens.lens _ninjaDefaults + $ \(MkNinja {..}) x -> MkNinja { _ninjaDefaults = x, .. } + +-- | The set of pools for this Ninja file. +-- +-- @since 0.1.0 +{-# INLINE ninjaPools #-} +ninjaPools :: Lens.Lens' Ninja (HashSet Pool) +ninjaPools = Lens.lens _ninjaPools + $ \(MkNinja {..}) x -> MkNinja { _ninjaPools = x, .. } + +-- | Converts to @{meta: …, builds: …, phonys: …, defaults: …, pools: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Ninja where + toJSON (MkNinja {..}) + = [ "meta" .= _ninjaMeta + , "builds" .= _ninjaBuilds + , "phonys" .= _ninjaPhonys + , "defaults" .= _ninjaDefaults + , "pools" .= _ninjaPools + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Ninja where + parseJSON = (Aeson.withObject "Ninja" $ \o -> do + _ninjaMeta <- (o .: "meta") >>= pure + _ninjaBuilds <- (o .: "builds") >>= pure + _ninjaPhonys <- (o .: "phonys") >>= pure + _ninjaDefaults <- (o .: "defaults") >>= pure + _ninjaPools <- (o .: "pools") >>= pure + pure (MkNinja {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Ninja + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Ninja + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, NinjaConstraint (SC.Serial m)) => SC.Serial m Ninja + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, NinjaConstraint (SC.CoSerial m)) => SC.CoSerial m Ninja + +-- | The set of constraints required for a given constraint to be automatically +-- computed for a 'Ninja'. +-- +-- @since 0.1.0 +type NinjaConstraint (c :: * -> Constraint) + = ( c Text + , c Ver.Version + , c (HashMap Target (HashSet Target)) + , c (HashSet Build) + , c (HashSet Target) + , c (HashSet Pool) + ) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR/Pool.hs b/library/Language/Ninja/IR/Pool.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Pool.hs @@ -0,0 +1,442 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Pool.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Pool +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Types relating to Ninja @pool@s. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Pool + ( -- * @Pool@ + Pool, makePool, makePoolDefault, makePoolConsole, makePoolCustom + , poolName, poolDepth + + -- * @PoolName@ + , PoolName, makePoolNameDefault, makePoolNameConsole, makePoolNameCustom + , _PoolNameDefault, _PoolNameConsole, _PoolNameCustom + , poolNameText, printPoolName, parsePoolName + + -- * @PoolDepth@ + , PoolDepth + , makePoolDepth, makePoolInfinite + , poolDepthPositive + ) where + +import Control.Applicative (empty) + +import qualified Control.Lens as Lens + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Data.Text (Text) +import qualified Data.Text as Text + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) + +import Test.SmallCheck.Series ((<~>), (\/)) +import qualified Test.SmallCheck.Series as SC + +import qualified Language.Ninja.Misc.Positive as Misc + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | A Ninja @pool@ declaration, as documented +-- . +-- +-- @since 0.1.0 +data Pool + = MkPool + { _poolName :: !PoolName + , _poolDepth :: !PoolDepth + } + deriving (Eq, Ord, Show, Read, Generic) + +-- | Construct a 'Pool', given its name and depth. +-- +-- @since 0.1.0 +{-# INLINEABLE makePool #-} +makePool :: PoolName -> PoolDepth -> Maybe Pool +makePool PoolNameDefault PoolInfinite = Just makePoolDefault +makePool PoolNameConsole (PoolDepth 1) = Just makePoolConsole +makePool (PoolNameCustom t) (PoolDepth d) = if d >= 1 + then Just (makePoolCustom t d) + else Nothing +makePool _ _ = Nothing + +-- | The default pool, i.e.: the one whose name is the empty string. +-- +-- @since 0.1.0 +{-# INLINE makePoolDefault #-} +makePoolDefault :: Pool +makePoolDefault = MkPool makePoolNameDefault PoolInfinite + +-- | The @console@ pool. +-- +-- @since 0.1.0 +{-# INLINE makePoolConsole #-} +makePoolConsole :: Pool +makePoolConsole = MkPool makePoolNameConsole (PoolDepth 1) + +-- | Create a pool with the given name and depth. +-- +-- @since 0.1.0 +{-# INLINE makePoolCustom #-} +makePoolCustom :: Text -- ^ The pool name. + -> Misc.Positive -- ^ The pool depth. + -> Pool +makePoolCustom name depth = MkPool (makePoolNameCustom name) (PoolDepth depth) + +-- | A 'Getter' that gives the name of a pool. +-- +-- @since 0.1.0 +{-# INLINE poolName #-} +poolName :: Lens.Getter Pool PoolName +poolName = Lens.to _poolName + +-- | A 'Getter' that gives the depth of a pool. +-- +-- @since 0.1.0 +{-# INLINE poolDepth #-} +poolDepth :: Lens.Getter Pool PoolDepth +poolDepth = Lens.to _poolDepth + +-- | Converts to @{name: …, depth: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Pool where + toJSON (MkPool {..}) + = [ "name" .= _poolName + , "depth" .= _poolDepth + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Pool where + parseJSON = (Aeson.withObject "Pool" $ \o -> do + _poolName <- (o .: "name") >>= pure + _poolDepth <- (o .: "depth") >>= pure + pure (MkPool {..})) + +-- | Uses the underlying instances. +-- +-- @since 0.1.0 +instance forall m. (Monad m, SC.Serial m Text) => SC.Serial m Pool where + series = pure makePoolDefault + \/ pure makePoolConsole + \/ (let nameSeries :: SC.Series m Text + nameSeries = SC.series >>= (\case "" -> empty + "console" -> empty + x -> pure x) + in makePoolCustom <$> nameSeries <~> SC.series) + +-- | Uses the underlying instances. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Pool where + coseries = SC.coseries .> fmap (\f -> convert .> f) + where + convert :: Pool -> (PoolName, PoolDepth) + convert pool = (Lens.view poolName pool, Lens.view poolDepth pool) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Pool + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Pool + +-------------------------------------------------------------------------------- + +-- | The name of a Ninja pool. +-- +-- More information is available +-- . +-- +-- @since 0.1.0 +data PoolName + = PoolNameDefault + | PoolNameConsole + | PoolNameCustom !Text + deriving (Eq, Ord, Show, Read, Generic) + +-- | Create a 'PoolName' corresponding to the built-in default pool, i.e.: the +-- pool that is selected if the @pool@ attribute is set to the empty string. +-- +-- @since 0.1.0 +{-# INLINE makePoolNameDefault #-} +makePoolNameDefault :: PoolName +makePoolNameDefault = PoolNameDefault + +-- | Create a 'PoolName' corresponding to the built-in @console@ pool. +-- +-- @since 0.1.0 +{-# INLINE makePoolNameConsole #-} +makePoolNameConsole :: PoolName +makePoolNameConsole = PoolNameConsole + +-- | Create a 'PoolName' corresponding to a custom pool. +-- Note: this can fail at runtime if given the empty string or @"console"@, +-- so you should consider 'parsePoolName' as a safer alternative. +-- +-- @since 0.1.0 +{-# INLINEABLE makePoolNameCustom #-} +makePoolNameCustom :: Text -> PoolName +makePoolNameCustom "" = error "Invalid pool name: \"\"" +makePoolNameCustom "console" = error "Invalid pool name: \"console\"" +makePoolNameCustom text = PoolNameCustom text + +-- | A one-way prism corresponding to the 'poolNameDefault' constructor. +-- +-- @since 0.1.0 +{-# INLINE _PoolNameDefault #-} +_PoolNameDefault :: Lens.Getter PoolName (Maybe ()) +_PoolNameDefault = Lens.to (\case PoolNameDefault -> Just () + _ -> Nothing) + +-- | A one-way prism corresponding to the 'poolNameConsole' constructor. +-- +-- @since 0.1.0 +{-# INLINE _PoolNameConsole #-} +_PoolNameConsole :: Lens.Getter PoolName (Maybe ()) +_PoolNameConsole = Lens.to (\case PoolNameConsole -> Just () + _ -> Nothing) + +-- | A one-way prism corresponding to the 'poolNameConsole' constructor. +-- +-- @since 0.1.0 +{-# INLINE _PoolNameCustom #-} +_PoolNameCustom :: Lens.Getter PoolName (Maybe Text) +_PoolNameCustom = Lens.to (\case (PoolNameCustom t) -> Just t + _ -> Nothing) + +-- | An isomorphism between a 'PoolName' and the corresponding 'Text'. +-- Equivalent to @'Lens.iso' 'printPoolName' 'parsePoolName'@. +-- +-- @since 0.1.0 +{-# INLINE poolNameText #-} +poolNameText :: Lens.Iso' PoolName Text +poolNameText = Lens.iso printPoolName parsePoolName + +-- | Convert a 'PoolName' to the string that, if the @pool@ attribute is set to +-- it, will cause the given 'PoolName' to be parsed. +-- +-- >>> printPoolName makePoolNameDefault +-- "" +-- +-- >>> printPoolName makePoolNameConsole +-- "console" +-- +-- >>> printPoolName (makePoolNameCustom "foobar") +-- "foobar" +-- +-- @since 0.1.0 +{-# INLINEABLE printPoolName #-} +printPoolName :: PoolName -> Text +printPoolName PoolNameDefault = "" +printPoolName PoolNameConsole = "console" +printPoolName (PoolNameCustom t) = t + +-- | Inverse of 'printPoolName'. +-- +-- >>> parsePoolName "" +-- PoolNameDefault +-- +-- >>> parsePoolName "console" +-- PoolNameConsole +-- +-- >>> parsePoolName "foobar" +-- PoolNameCustom "foobar" +-- +-- @since 0.1.0 +{-# INLINEABLE parsePoolName #-} +parsePoolName :: Text -> PoolName +parsePoolName "" = makePoolNameDefault +parsePoolName "console" = makePoolNameConsole +parsePoolName t = makePoolNameCustom t + +-- | Converts from string via 'parsePoolName'. +-- +-- @since 0.1.0 +instance IsString PoolName where + fromString = Text.pack .> parsePoolName + +-- | Converts to JSON string via 'printPoolName'. +-- +-- @since 0.1.0 +instance Aeson.ToJSON PoolName where + toJSON = printPoolName .> Aeson.String + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON PoolName where + parseJSON = Aeson.withText "PoolName" (parsePoolName .> pure) + +-- | Converts to JSON string via 'printPoolName'. +-- +-- @since 0.1.0 +instance Aeson.ToJSONKey PoolName where + toJSONKey = Aeson.toJSONKeyText printPoolName + +-- | Inverse of the 'Aeson.ToJSONKey' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSONKey PoolName where + fromJSONKey = Aeson.mapFromJSONKeyFunction parsePoolName Aeson.fromJSONKey + +-- | Uses the underlying 'Text' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m PoolName where + series = parsePoolName <$> (pure "" \/ pure "console" \/ SC.series) + +-- | Uses the underlying 'Text' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m PoolName where + coseries = SC.coseries + .> fmap (\f -> printPoolName .> f) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable PoolName + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData PoolName + +-------------------------------------------------------------------------------- + +-- | The depth of a Ninja pool. +-- +-- More information is available +-- . +-- +-- @since 0.1.0 +data PoolDepth + = PoolDepth !Misc.Positive + | PoolInfinite + deriving (Eq, Ord, Show, Read, Generic) + +-- | Construct a finite 'PoolDepth' from an integer, which should be a number +-- greater than or equal to 1. +-- +-- @since 0.1.0 +{-# INLINE makePoolDepth #-} +makePoolDepth :: Misc.Positive -> PoolDepth +makePoolDepth = PoolDepth + +-- | Construct an infinite 'PoolDepth'. This constructor is needed for the +-- default pool (@pool = ""@), which has an infinite depth. +-- +-- @since 0.1.0 +{-# INLINE makePoolInfinite #-} +makePoolInfinite :: PoolDepth +makePoolInfinite = PoolInfinite + +-- | An isomorphism between a 'PoolDepth' and a @'Maybe' 'Misc.Positive'@; +-- the 'Nothing' case maps to 'makePoolInfinite' and the 'Just' case +-- maps to 'makePoolDepth'. +-- +-- @since 0.1.0 +{-# INLINE poolDepthPositive #-} +poolDepthPositive :: Lens.Iso' PoolDepth (Maybe Misc.Positive) +poolDepthPositive = Lens.iso fromPD toPD + where + {-# INLINE fromPD #-} + fromPD :: PoolDepth -> Maybe Misc.Positive + fromPD (PoolDepth p) = Just p + fromPD PoolInfinite = Nothing + + {-# INLINE toPD #-} + toPD :: Maybe Misc.Positive -> PoolDepth + toPD (Just p) = PoolDepth p + toPD Nothing = PoolInfinite + +-- | Converts 'makePoolInfinite' to @"infinite"@ and 'makePoolDepth' to the +-- corresponding JSON number. +-- +-- @since 0.1.0 +instance Aeson.ToJSON PoolDepth where + toJSON (PoolDepth i) = Aeson.toJSON i + toJSON PoolInfinite = "infinite" + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON PoolDepth where + parseJSON (v@(Aeson.Number _)) = PoolDepth <$> Aeson.parseJSON v + parseJSON (Aeson.String "infinite") = pure PoolInfinite + parseJSON owise = Aeson.typeMismatch "PoolDepth" owise + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m) => SC.Serial m PoolDepth where + series = pure PoolInfinite + \/ (SC.series |> fmap PoolDepth) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m) => SC.CoSerial m PoolDepth where + coseries = SC.coseries + .> fmap (\f -> \case (PoolDepth i) -> f (Just i) + PoolInfinite -> f Nothing) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable PoolDepth + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData PoolDepth + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR/Rule.hs b/library/Language/Ninja/IR/Rule.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Rule.hs @@ -0,0 +1,447 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Rule.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Rule +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype for Ninja @rule@ declarations. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Rule + ( -- * @Rule@ + Rule, makeRule + , ruleName, ruleCommand, ruleDescription, rulePool, ruleDepfile + , ruleSpecialDeps, ruleGenerator, ruleRestat, ruleResponseFile + + -- * @SpecialDeps@ + , SpecialDeps, makeSpecialDepsGCC, makeSpecialDepsMSVC + , _SpecialDepsGCC, _SpecialDepsMSVC + + -- * @ResponseFile@ + , ResponseFile, makeResponseFile, responseFilePath, responseFileContent + ) where + +import qualified Control.Lens as Lens + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import qualified Test.SmallCheck.Series as SC + +import Language.Ninja.IR.Pool (PoolName, makePoolNameDefault) +import Language.Ninja.Misc.Command (Command) +import Language.Ninja.Misc.Path (Path) + +import Flow ((|>)) + +-------------------------------------------------------------------------------- + +-- | A Ninja @rule@ declaration, as documented +-- . +-- +-- @since 0.1.0 +data Rule + = MkRule + { _ruleName :: !Text + , _ruleCommand :: !Command + , _ruleDescription :: !(Maybe Text) + , _rulePool :: !PoolName + , _ruleDepfile :: !(Maybe Path) + , _ruleSpecialDeps :: !(Maybe SpecialDeps) + , _ruleGenerator :: !Bool + , _ruleRestat :: !Bool + , _ruleResponseFile :: !(Maybe ResponseFile) + } + deriving (Eq, Ord, Show, Generic) + +-- | Construct an 'Rule' with the given name and command, with default values +-- for all other attributes (e.g.: 'False', 'Nothing', 'poolDefault'). +-- +-- @since 0.1.0 +{-# INLINE makeRule #-} +makeRule :: Text + -- ^ The rule name. + -> Command + -- ^ The command to run. + -> Rule + -- ^ A rule that runs this command. +makeRule name cmd + = MkRule + { _ruleName = name + , _ruleCommand = cmd + , _ruleDescription = Nothing + , _rulePool = makePoolNameDefault + , _ruleDepfile = Nothing + , _ruleSpecialDeps = Nothing + , _ruleGenerator = False + , _ruleRestat = False + , _ruleResponseFile = Nothing + } + +-- | The name of the rule. +-- +-- @since 0.1.0 +{-# INLINE ruleName #-} +ruleName :: Lens.Lens' Rule Text +ruleName = Lens.lens _ruleName + $ \(MkRule {..}) x -> MkRule { _ruleName = x, .. } + +-- | The command that this rule will run. +-- +-- @since 0.1.0 +{-# INLINE ruleCommand #-} +ruleCommand :: Lens.Lens' Rule Command +ruleCommand = Lens.lens _ruleCommand + $ \(MkRule {..}) x -> MkRule { _ruleCommand = x, .. } + +-- | A short description of the command, used to pretty-print the command +-- as it's running. The @ninja -v@ flag controls whether to print the +-- full command or its description; if a command fails, the full command +-- line will always be printed before the command's output. +-- +-- @since 0.1.0 +{-# INLINE ruleDescription #-} +ruleDescription :: Lens.Lens' Rule (Maybe Text) +ruleDescription = Lens.lens _ruleDescription + $ \(MkRule {..}) x -> MkRule { _ruleDescription = x, .. } + +-- | The process pool in which this rule will be executed. +-- +-- @since 0.1.0 +{-# INLINE rulePool #-} +rulePool :: Lens.Lens' Rule PoolName +rulePool = Lens.lens _rulePool + $ \(MkRule {..}) x -> MkRule { _rulePool = x, .. } + +-- | If set, this should be a path to an optional Makefile that contains +-- extra implicit dependencies. This is used to support C/C++ header +-- dependencies. For more information, read the Ninja documentation +-- . +-- +-- @since 0.1.0 +{-# INLINE ruleDepfile #-} +ruleDepfile :: Lens.Lens' Rule (Maybe Path) +ruleDepfile = Lens.lens _ruleDepfile + $ \(MkRule {..}) x -> MkRule { _ruleDepfile = x, .. } + +-- | If set, enables special dependency processing used in C/C++ header +-- dependencies. For more information, read the Ninja documentation +-- . +-- +-- @since 0.1.0 +{-# INLINE ruleSpecialDeps #-} +ruleSpecialDeps :: Lens.Lens' Rule (Maybe SpecialDeps) +ruleSpecialDeps = Lens.lens _ruleSpecialDeps + $ \(MkRule {..}) x -> MkRule { _ruleSpecialDeps = x, .. } + +-- | If this is true, specifies that this rule is used to re-invoke the +-- generator program. Files built using generator rules are treated +-- specially in two ways: firstly, they will not be rebuilt if the +-- command line changes; and secondly, they are not cleaned by default. +-- +-- @since 0.1.0 +{-# INLINE ruleGenerator #-} +ruleGenerator :: Lens.Lens' Rule Bool +ruleGenerator = Lens.lens _ruleGenerator + $ \(MkRule {..}) x -> MkRule { _ruleGenerator = x, .. } + +-- | If true, causes Ninja to re-stat the command's outputs after +-- execution of the command. Each output whose modification time the +-- command did not change will be treated as though it had never needed +-- to be built. This may cause the output's reverse dependencies to be +-- removed from the list of pending build actions. +-- +-- @since 0.1.0 +{-# INLINE ruleRestat #-} +ruleRestat :: Lens.Lens' Rule Bool +ruleRestat = Lens.lens _ruleRestat + $ \(MkRule {..}) x -> MkRule { _ruleRestat = x, .. } + +-- | If present, Ninja will use a response file for the given command, +-- i.e. write the selected string to the given file before calling the +-- command and delete the file after the command is done. +-- +-- This is particularly useful on Windows OS, where the maximal length +-- of a command line is limited and response files must be used instead. +-- +-- @since 0.1.0 +{-# INLINE ruleResponseFile #-} +ruleResponseFile :: Lens.Lens' Rule (Maybe ResponseFile) +ruleResponseFile = Lens.lens _ruleResponseFile + $ \(MkRule {..}) x -> MkRule { _ruleResponseFile = x, .. } + +-- | Converts to +-- @{name: …, command: …, desc: …, pool: …, depfile: …, +-- deps: …, generator: …, restat: …, rsp: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Rule where + toJSON (MkRule {..}) + = [ "name" .= _ruleName + , "command" .= _ruleCommand + , "desc" .= _ruleDescription + , "pool" .= _rulePool + , "depfile" .= _ruleDepfile + , "deps" .= _ruleSpecialDeps + , "generator" .= _ruleGenerator + , "restat" .= _ruleRestat + , "rsp" .= _ruleResponseFile + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Rule where + parseJSON = (Aeson.withObject "Rule" $ \o -> do + _ruleName <- (o .: "name") >>= pure + _ruleCommand <- (o .: "command") >>= pure + _ruleDescription <- (o .: "desc") >>= pure + _rulePool <- (o .: "pool") >>= pure + _ruleDepfile <- (o .: "depfile") >>= pure + _ruleSpecialDeps <- (o .: "deps") >>= pure + _ruleGenerator <- (o .: "generator") >>= pure + _ruleRestat <- (o .: "restat") >>= pure + _ruleResponseFile <- (o .: "rsp") >>= pure + pure (MkRule {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Rule + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Rule + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.Serial m Text + ) => SC.Serial m Rule + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.CoSerial m Text + ) => SC.CoSerial m Rule + +-------------------------------------------------------------------------------- + +-- | Special dependency information, as described +-- . +-- +-- @since 0.1.0 +data SpecialDeps + = SpecialDepsGCC + | SpecialDepsMSVC !Text + deriving (Eq, Ord, Show, Read, Generic) + +-- | Construct a 'SpecialDeps' corresponding to the case in which @deps = gcc@ +-- is set in a Ninja build rule. +-- +-- @since 0.1.0 +{-# INLINE makeSpecialDepsGCC #-} +makeSpecialDepsGCC :: SpecialDeps +makeSpecialDepsGCC = SpecialDepsGCC + +-- | Construct a 'SpecialDeps' corresponding to the case in which @deps = msvc@ +-- is set and @msvc_deps_prefix = …@. +-- +-- The @msvc_deps_prefix@ field defines the string which should be stripped +-- from @msvc@'s @/showIncludes@ output. It is only needed if the version of +-- Visual Studio being used is not English. The value of @msvc_deps_prefix@ +-- is @"Note: including file: "@ by default. +-- +-- @since 0.1.0 +{-# INLINE makeSpecialDepsMSVC #-} +makeSpecialDepsMSVC :: Text + -> SpecialDeps +makeSpecialDepsMSVC = SpecialDepsMSVC + +-- | A prism for the @deps = gcc@ case. +-- +-- @since 0.1.0 +{-# INLINE _SpecialDepsGCC #-} +_SpecialDepsGCC :: Lens.Prism' SpecialDeps () +_SpecialDepsGCC = Lens.prism (const makeSpecialDepsGCC) + $ \case SpecialDepsGCC -> Right () + owise -> Left owise + +-- | A prism for the @deps = msvc@ / @msvc_deps_prefix = …@ case. +-- +-- @since 0.1.0 +{-# INLINE _SpecialDepsMSVC #-} +_SpecialDepsMSVC :: Lens.Prism' SpecialDeps Text +_SpecialDepsMSVC = Lens.prism makeSpecialDepsMSVC + $ \case (SpecialDepsMSVC prefix) -> Right prefix + owise -> Left owise + +-- | Converts to @{deps: "gcc"}@ or @{deps: "msvc", prefix: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON SpecialDeps where + toJSON = go + where + go SpecialDepsGCC = Aeson.object ["deps" .= gcc] + go (SpecialDepsMSVC p) = Aeson.object ["deps" .= msvc, "prefix" .= p] + + (gcc, msvc) = ("gcc", "msvc") :: (Aeson.Value, Aeson.Value) + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON SpecialDeps where + parseJSON = Aeson.withObject "SpecialDeps" $ \o -> do + deps <- o .: "deps" + case Text.pack deps of + "gcc" -> pure SpecialDepsGCC + "msvc" -> SpecialDepsMSVC <$> (o .: "prefix") + owise -> [ "Invalid deps type ", "\"", owise, "\"; " + , "should be one of [\"gcc\", \"msvc\"]." + ] |> mconcat |> Text.unpack |> fail + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable SpecialDeps + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData SpecialDeps + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.Serial m Text + ) => SC.Serial m SpecialDeps + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.CoSerial m Text + ) => SC.CoSerial m SpecialDeps + +-------------------------------------------------------------------------------- + +-- | A response file to use during rule execution, as documented +-- . +-- +-- @since 0.1.0 +data ResponseFile + = MkResponseFile + { _responseFilePath :: !Path + , _responseFileContent :: !Text + } + deriving (Eq, Ord, Show, Generic) + +-- | Construct a 'ResponseFile' with the given 'Path' and content 'Text'. +-- +-- @since 0.1.0 +{-# INLINE makeResponseFile #-} +makeResponseFile :: Path + -- ^ Corresponds to @rspfile@. + -> Text + -- ^ Corresponds to @rspfile_content@. + -> ResponseFile +makeResponseFile = MkResponseFile + +-- | A lens for the @rspfile@ field. +-- +-- @since 0.1.0 +{-# INLINE responseFilePath #-} +responseFilePath :: Lens.Lens' ResponseFile Path +responseFilePath = Lens.lens _responseFilePath + $ \(MkResponseFile {..}) x -> + MkResponseFile { _responseFilePath = x, .. } + +-- | A lens for the @rspfile_content@ field. +-- +-- @since 0.1.0 +{-# INLINE responseFileContent #-} +responseFileContent :: Lens.Lens' ResponseFile Text +responseFileContent = Lens.lens _responseFileContent + $ \(MkResponseFile {..}) x -> + MkResponseFile { _responseFileContent = x, .. } + +-- | Converts to @{path: …, content: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON ResponseFile where + toJSON (MkResponseFile {..}) + = [ "path" .= _responseFilePath + , "content" .= _responseFileContent + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON ResponseFile where + parseJSON = Aeson.withObject "ResponseFile" + $ \o -> MkResponseFile <$> (o .: "path") <*> (o .: "content") + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable ResponseFile + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData ResponseFile + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.Serial m Text + ) => SC.Serial m ResponseFile + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.CoSerial m Text + ) => SC.CoSerial m ResponseFile + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/IR/Target.hs b/library/Language/Ninja/IR/Target.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/IR/Target.hs @@ -0,0 +1,347 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/IR/Target.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.IR.Target +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Types relating to Ninja build targets, outputs, and dependencies. +-- +-- @since 0.1.0 +module Language.Ninja.IR.Target + ( -- * @Target@ + Target, makeTarget, targetIText, targetText + + -- * @Output@ + , Output, makeOutput, outputTarget + + -- * @Dependency@ + , Dependency, makeDependency, dependencyTarget, dependencyType + , DependencyType (..), _NormalDependency, _OrderOnlyDependency + ) where + +import qualified Control.Lens as Lens + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Data.String (IsString) +import GHC.Generics (Generic) + +import Test.SmallCheck.Series ((>>-)) +import qualified Test.SmallCheck.Series as SC + +import qualified Language.Ninja.Misc.IText as Misc + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | This type represents a Ninja target name. +-- +-- @since 0.1.0 +newtype Target + = MkTarget + { _targetIText :: Misc.IText + } + deriving ( Eq, Ord, Show, Read, IsString, Generic, Hashable, NFData + , Aeson.ToJSON, Aeson.FromJSON, Aeson.ToJSONKey, Aeson.FromJSONKey ) + +-- | Construct a 'Target' from some 'Text'. +-- +-- @since 0.1.0 +{-# INLINE makeTarget #-} +makeTarget :: Text -> Target +makeTarget = Lens.view Misc.itext .> MkTarget + +-- | An isomorphism between a 'Target' and its underlying 'IText'. +-- +-- @since 0.1.0 +{-# INLINE targetIText #-} +targetIText :: Lens.Iso' Target Misc.IText +targetIText = Lens.iso _targetIText MkTarget + +-- | An isomorphism that gives access to a 'Text'-typed view of a 'Target', +-- even though the underlying data has type 'IText'. +-- +-- This is equivalent to @targetIText . from itext@. +-- +-- @since 0.1.0 +{-# INLINE targetText #-} +targetText :: Lens.Iso' Target Text +targetText = targetIText . Lens.from Misc.itext + +-- | Uses the underlying 'IText' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Target where + series = SC.newtypeCons MkTarget + +-- | Uses the underlying 'IText' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Target where + coseries rs = SC.newtypeAlts rs + >>- \f -> pure (_targetIText .> f) + +-------------------------------------------------------------------------------- + +-- | A Ninja build output. +-- +-- More information is available +-- . +-- +-- @since 0.1.0 +newtype Output + = MkOutput + { _outputTarget :: Target + } + deriving (Eq, Ord, Show, Read, Generic) + +-- | Construct an 'Output'. +-- +-- @since 0.1.0 +{-# INLINE makeOutput #-} +makeOutput :: Target + -- ^ The underlying target. + -> Output +makeOutput = MkOutput + +-- | A lens for the 'Target' of an 'Output'. +-- +-- @since 0.1.0 +{-# INLINE outputTarget #-} +outputTarget :: Lens.Lens' Output Target +outputTarget = Lens.lens _outputTarget + $ \(MkOutput {..}) new -> MkOutput { _outputTarget = new, .. } + +-- | Converts to @{target: …, type: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Output where + toJSON (MkOutput {..}) + = [ "target" .= _outputTarget + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Output where + parseJSON = (Aeson.withObject "Output" $ \o -> do + _outputTarget <- (o .: "target") >>= pure + pure (MkOutput {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Output + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Output + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Output + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Output + +-------------------------------------------------------------------------------- + +-- | A build dependency. +-- +-- More information is available +-- . +-- +-- @since 0.1.0 +data Dependency + = MkDependency + { _dependencyTarget :: !Target + , _dependencyType :: !DependencyType + } + deriving (Eq, Ord, Show, Read, Generic) + +-- | Construct a 'Dependency'. +-- +-- @since 0.1.0 +{-# INLINE makeDependency #-} +makeDependency :: Target + -- ^ The underlying target. + -> DependencyType + -- ^ The dependency type (normal, implicit, or order-only). + -> Dependency +makeDependency = MkDependency + +-- | A lens for the 'Target' of a 'Dependency'. +-- +-- @since 0.1.0 +{-# INLINE dependencyTarget #-} +dependencyTarget :: Lens.Lens' Dependency Target +dependencyTarget + = Lens.lens _dependencyTarget + $ \(MkDependency {..}) new -> MkDependency { _dependencyTarget = new, .. } + +-- | A lens for the 'DependencyType' of a 'Dependency'. +-- +-- @since 0.1.0 +{-# INLINE dependencyType #-} +dependencyType :: Lens.Lens' Dependency DependencyType +dependencyType + = Lens.lens _dependencyType + $ \(MkDependency {..}) new -> MkDependency { _dependencyType = new, .. } + +-- | Converts to @{target: …, type: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Dependency where + toJSON (MkDependency {..}) + = [ "target" .= _dependencyTarget + , "type" .= _dependencyType + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Dependency where + parseJSON = (Aeson.withObject "Dependency" $ \o -> do + _dependencyTarget <- (o .: "target") >>= pure + _dependencyType <- (o .: "type") >>= pure + pure (MkDependency {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Dependency + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Dependency + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Dependency + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Dependency + +-------------------------------------------------------------------------------- + +-- | The type of a 'Dependency': normal, implicit, or order-only. +-- +-- @since 0.1.0 +data DependencyType + = -- | A normal dependency. + -- + -- @since 0.1.0 + NormalDependency + | -- | An order-only dependency. These are only rebuilt if there is at least + -- one non-order-only dependency that is out of date. + -- + -- Section 4.3 "Types of Prerequisites" in the GNU Make manual has a good + -- explanation of this concept. + -- + -- @since 0.1.0 + OrderOnlyDependency + deriving (Eq, Ord, Show, Read, Generic) + +-- | A prism for the 'NormalDependency' constructor. +-- +-- @since 0.1.0 +{-# INLINE _NormalDependency #-} +_NormalDependency :: Lens.Prism' DependencyType () +_NormalDependency = Lens.prism' (const NormalDependency) + $ \case NormalDependency -> Just () + _ -> Nothing + +-- | A prism for the 'OrderOnlyDependency' constructor. +-- +-- @since 0.1.0 +{-# INLINE _OrderOnlyDependency #-} +_OrderOnlyDependency :: Lens.Prism' DependencyType () +_OrderOnlyDependency = Lens.prism' (const OrderOnlyDependency) + $ \case OrderOnlyDependency -> Just () + _ -> Nothing + +-- | Converts to @"normal"@, @"implicit"@, and @"order-only"@ respectively. +-- +-- @since 0.1.0 +instance Aeson.ToJSON DependencyType where + toJSON NormalDependency = "normal" + toJSON OrderOnlyDependency = "order-only" + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON DependencyType where + parseJSON = (Aeson.withText "DependencyType" $ \case + "normal" -> pure NormalDependency + "order-only" -> pure OrderOnlyDependency + owise -> [ "Invalid dependency type " + , "\"", owise, "\"; should be one of " + , "[\"normal\", \"order-only\"]" + ] |> mconcat |> Text.unpack |> fail) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable DependencyType + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData DependencyType + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m) => SC.Serial m DependencyType + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m) => SC.CoSerial m DependencyType + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Lexer.hs b/library/Language/Ninja/Lexer.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Lexer.hs @@ -0,0 +1,405 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Lexer.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. + +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Language.Ninja.Lexer +-- Copyright : Copyright 2011-2017 Neil Mitchell +-- License : BSD3 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Lexing is a slow point, the code below is optimised. +-- +-- @since 0.1.0 +module Language.Ninja.Lexer + ( -- * @lex*IO@ + lexFileIO + , lexTextIO + , lexBSIO + + -- * @lex*@ + , lexFile + , lexText + , lexBS + + -- * @lex*WithPath@ + , lexTextWithPath + , lexBSWithPath + + -- * Other ways of running the lexer + , lexemesP + + -- * Type aliases + , Lexer.Parser + , Lexer.Ann + + -- * @Lexeme@ and friends + , Lexer.Lexeme (..) + , Lexer.LName (..) + , Lexer.LFile (..) + , Lexer.LBind (..) + , Lexer.LBuild (..), Lexer.makeLBuild + + -- * Classes + , Lexer.PositionParsing (..) + ) where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (second) +import Control.Exception (throwIO) +import Control.Monad (unless, void, (>=>)) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Trans.Except (runExceptT) + +import qualified Control.Lens as Lens + +import Data.ByteString (ByteString) + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Data.Char (isSpace) +import Data.Foldable (asum) +import Data.Functor ((<$)) +import Data.Maybe (catMaybes, fromMaybe) + +import Flow ((.>), (|>)) + +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Lexer as M.Lexer + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.Lexer.Types as Lexer +import qualified Language.Ninja.Misc as Misc +import qualified Language.Ninja.Mock as Mock + +-------------------------------------------------------------------------------- + +-- | Lex the file at the given path. +-- This function may throw an exception if parsing fails. +-- +-- @since 0.1.0 +lexFileIO :: Misc.Path -> IO [Lexer.Lexeme Lexer.Ann] +lexFileIO = (lexFile .> runExceptT) >=> either throwIO pure + +-- | Lex the given 'Text'. +-- This function may throw an exception if parsing fails. +-- +-- @since 0.1.0 +lexTextIO :: Text -> IO [Lexer.Lexeme Lexer.Ann] +lexTextIO = (lexText .> runExceptT) >=> either throwIO pure + +-- | Lex the given 'ByteString'. +-- This function may throw an exception if parsing fails. +-- +-- @since 0.1.0 +lexBSIO :: ByteString -> IO [Lexer.Lexeme Lexer.Ann] +lexBSIO = (lexBS .> runExceptT) >=> either throwIO pure + +-------------------------------------------------------------------------------- + +-- | Lex the given file. +-- +-- @since 0.1.0 +lexFile :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) + => Misc.Path -> m [Lexer.Lexeme Lexer.Ann] +lexFile file = Mock.readFile file >>= lexTextWithPath (Just file) + +-- | Lex the given 'Text'. +-- +-- @since 0.1.0 +lexText :: (MonadError Errors.ParseError m) + => Text -> m [Lexer.Lexeme Lexer.Ann] +lexText = lexTextWithPath Nothing + +-- | Lex the given 'BSC8.ByteString'. +-- +-- @since 0.1.0 +lexBS :: (MonadError Errors.ParseError m) + => ByteString -> m [Lexer.Lexeme Lexer.Ann] +lexBS = lexBSWithPath Nothing + +-------------------------------------------------------------------------------- + +-- | Lex the given 'Text' that comes from the given 'Misc.Path', if provided. +-- +-- @since 0.1.0 +lexTextWithPath :: (MonadError Errors.ParseError m) + => Maybe Misc.Path -> Text -> m [Lexer.Lexeme Lexer.Ann] +lexTextWithPath mp x = M.runParserT lexemesP file x + >>= either Errors.throwLexParsecError pure + where + file = fromMaybe "" (Lens.view Misc.pathString <$> mp) + +-- | Lex the given 'ByteString' that comes from the given 'Misc.Path', if it is +-- provided. The 'Misc.Path' is only used for error messages. +-- +-- @since 0.1.0 +lexBSWithPath :: (MonadError Errors.ParseError m) + => Maybe Misc.Path -> ByteString -> m [Lexer.Lexeme Lexer.Ann] +lexBSWithPath mpath = Text.decodeUtf8 .> lexTextWithPath mpath + +-------------------------------------------------------------------------------- + +-- | The @megaparsec@ parser for a Ninja file. +-- +-- @since 0.1.0 +lexemesP :: Lexer.Parser m [Lexer.Lexeme Lexer.Ann] +lexemesP = do + maybes <- [ Nothing <$ lineCommentP + , Nothing <$ M.separatorChar + , Nothing <$ M.eol + , Just <$> (lexemeP <* lineEndP) + ] |> asum |> M.many + M.eof + pure (catMaybes maybes) + +-------------------------------------------------------------------------------- + +lexemeP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +lexemeP = [ includeP, subninjaP, buildP, ruleP, poolP, defaultP, bindP, defineP + ] |> map M.try |> asum + +defineP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +defineP = Lexer.spanned equationP + |> fmap (uncurry Lexer.LexDefine) + |> debugP "defineP" + +bindP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +bindP = Lexer.spanned (indented f) + |> fmap (uncurry Lexer.LexBind) + |> debugP "bindP" + where + f :: Misc.Column -> Lexer.Parser m (Lexer.LBind Lexer.Ann) + f x | x < 2 = fail "bindP: not indented" + f _ = equationP + +includeP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +includeP = debugP "includeP" $ do + (ann, file) <- Lexer.spanned $ do + beginningOfLine + symbolP "include" + M.Lexer.lexeme spaceP fileP + pure (Lexer.LexInclude ann file) + +subninjaP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +subninjaP = debugP "subninjaP" $ do + (ann, file) <- Lexer.spanned $ do + beginningOfLine + symbolP "subninja" + M.Lexer.lexeme spaceP fileP + pure (Lexer.LexSubninja ann file) + +buildP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +buildP = debugP "buildP" $ do + let isExprEmpty :: AST.Expr Lexer.Ann -> Bool + isExprEmpty (AST.Lit _ "") = True + isExprEmpty (AST.Exprs _ []) = True + isExprEmpty _ = False + + let cleanExprs :: [AST.Expr Lexer.Ann] -> [AST.Expr Lexer.Ann] + cleanExprs = map AST.normalizeExpr .> filter (isExprEmpty .> not) + + (ann, (outs, rule, deps)) <- Lexer.spanned $ do + beginningOfLine + symbolP "build" + outs <- cleanExprs <$> M.some outputP + symbolP ":" + rule <- nameP + deps <- cleanExprs <$> M.many (M.Lexer.lexeme spaceP exprP) + pure (outs, rule, deps) + + pure (Lexer.LexBuild ann (Lexer.MkLBuild ann outs rule deps)) + +ruleP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +ruleP = debugP "ruleP" $ do + (ann, ruleName) <- Lexer.spanned $ do + beginningOfLine + symbolP "rule" + nameP + pure (Lexer.LexRule ann ruleName) + +poolP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +poolP = debugP "poolP" $ do + (ann, poolName) <- Lexer.spanned $ do + beginningOfLine + symbolP "pool" + nameP + pure (Lexer.LexPool ann poolName) + +defaultP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann) +defaultP = debugP "defaultP" $ do + (ann, defaults) <- Lexer.spanned $ do + beginningOfLine + symbolP "default" + M.many (M.Lexer.lexeme spaceP exprP) + pure (Lexer.LexDefault ann defaults) + +lineEndP :: Lexer.Parser m () +lineEndP = do + M.many M.separatorChar + lineCommentP <|> pure () + void M.eol + +equationP :: Lexer.Parser m (Lexer.LBind Lexer.Ann) +equationP = debugP "equationP" $ do + (ann, (name, value)) <- Lexer.spanned $ do + name <- nameP + symbolP "=" + value <- exprsP + pure (name, value) + + pure (Lexer.MkLBind ann name value) + +nameP :: Lexer.Parser m (Lexer.LName Lexer.Ann) +nameP = Lexer.spanned varDotP + |> fmap (second (Text.pack .> Text.encodeUtf8)) + |> fmap (uncurry Lexer.MkLName) + |> M.Lexer.lexeme spaceP + |> debugP "nameP" + +fileP :: Lexer.Parser m (Lexer.LFile Lexer.Ann) +fileP = Lexer.MkLFile <$> exprP + |> M.Lexer.lexeme spaceP + |> debugP "fileP" + +outputP :: Lexer.Parser m (AST.Expr Lexer.Ann) +outputP = Lexer.spanned (M.some (dollarP <|> litP)) + |> fmap (uncurry AST.Exprs .> AST.normalizeExpr) + |> M.Lexer.lexeme spaceP + where + litP :: Lexer.Parser m (AST.Expr Lexer.Ann) + litP = Lexer.spanned (M.some (M.satisfy isOutputChar)) + |> fmap (second Text.pack .> uncurry AST.Lit) + + isOutputChar :: Char -> Bool + isOutputChar '$' = False + isOutputChar ':' = False + isOutputChar '\n' = False + isOutputChar '\r' = False + isOutputChar c | isSpace c = False + isOutputChar _ = True + +exprsP :: Lexer.Parser m (AST.Expr Lexer.Ann) +exprsP = asum [exprP, separatorP] + |> M.many + |> Lexer.spanned + |> fmap (uncurry AST.Exprs .> AST.normalizeExpr) + where + separatorP :: Lexer.Parser m (AST.Expr Lexer.Ann) + separatorP = Lexer.spanned (M.some M.separatorChar) + |> fmap (second Text.pack .> uncurry AST.Lit) + +exprP :: Lexer.Parser m (AST.Expr Lexer.Ann) +exprP = Lexer.spanned (M.some (dollarP <|> litP)) + |> fmap (uncurry AST.Exprs .> AST.normalizeExpr) + where + litP :: Lexer.Parser m (AST.Expr Lexer.Ann) + litP = Lexer.spanned (M.some (M.satisfy isExprChar)) + |> fmap (second Text.pack .> uncurry AST.Lit) + + isExprChar :: Char -> Bool + isExprChar '$' = False + isExprChar '\n' = False + isExprChar '\r' = False + isExprChar c | isSpace c = False + isExprChar _ = True + +dollarP :: Lexer.Parser m (AST.Expr Lexer.Ann) +dollarP = debugP "dollarP" + (M.char '$' + *> ([ makeLit (M.string "$") + , makeLit (M.string " ") + , makeLit (M.string ":") + , makeLit ((M.eol *> M.many M.separatorChar *> pure "")) + , makeVar ((M.char '{' *> varDotP <* M.char '}')) + , makeVar varP + ] |> asum)) + where + makeLit :: Lexer.Parser m String -> Lexer.Parser m (AST.Expr Lexer.Ann) + makeLit p = Lexer.spanned p |> fmap (second Text.pack .> uncurry AST.Lit) + + makeVar :: Lexer.Parser m String -> Lexer.Parser m (AST.Expr Lexer.Ann) + makeVar p = Lexer.spanned p |> fmap (second Text.pack .> uncurry AST.Var) + +varDotP :: Lexer.Parser m String +varDotP = M.some (M.alphaNumChar <|> M.oneOf ['/', '-', '_', '.']) + |> debugP "varDotP" + +varP :: Lexer.Parser m String +varP = M.some (M.alphaNumChar <|> M.oneOf ['/', '-', '_']) + |> debugP "varP" + +symbolP :: String -> Lexer.Parser m String +symbolP = M.Lexer.symbol spaceP + +spaceP :: Lexer.Parser m () +spaceP = M.Lexer.space (void M.separatorChar) lineCommentP blockCommentP + +lineCommentP :: Lexer.Parser m () +lineCommentP = M.Lexer.skipLineComment "#" + +blockCommentP :: Lexer.Parser m () +blockCommentP = fail "always" + +indented :: (Misc.Column -> Lexer.Parser m a) -> Lexer.Parser m a +indented f = do + M.many M.separatorChar + Lexer.getPosition >>= Lens.view Misc.positionCol .> f + +beginningOfLine :: Lexer.Parser m () +beginningOfLine = do + col <- Lens.view Misc.positionCol <$> Lexer.getPosition + unless (col == 1) (fail "beginningOfLine failed") + +debugP :: (Show a) => String -> Lexer.Parser m a -> Lexer.Parser m a +debugP str p = M.label str p -- M.dbg str p + where + -- this shuts up the compiler wrt the Show constraint + _ = show <$> p + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Lexer/Types.hs b/library/Language/Ninja/Lexer/Types.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Lexer/Types.hs @@ -0,0 +1,585 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Lexer/Types.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 ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Lexer +-- Copyright : Copyright 2011-2017 Neil Mitchell +-- License : BSD3 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Lexing is a slow point, the code below is optimised. +-- +-- @since 0.1.0 +module Language.Ninja.Lexer.Types + ( -- * Type aliases + Parser, Ann + + -- * @Lexeme@ and friends + , Lexeme (..) + , LName (..) + , LFile (..) + , LBind (..) + , LBuild (..), makeLBuild + + , LexemeConstraint + , LNameConstraint + , LFileConstraint + , LBindConstraint + , LBuildConstraint + + -- * @PositionParsing@ + , PositionParsing (..) + , spanned + ) where + +import Control.Arrow (second) +import Control.Monad (when) + +import qualified Control.Lens as Lens + +import Data.ByteString (ByteString) + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Flow ((.>), (|>)) + +import qualified Text.Megaparsec as M + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import Test.SmallCheck.Series ((<~>)) +import qualified Test.SmallCheck.Series as SC + +import GHC.Exts (Constraint) + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Misc as Misc + +-------------------------------------------------------------------------------- + +-- | A @megaparsec@ parser. +-- +-- @since 0.1.0 +type Parser m a = M.ParsecT M.Dec Text m a + +-- | The type of annotations returned by the lexer. +-- +-- @since 0.1.0 +type Ann = Misc.Spans + +-------------------------------------------------------------------------------- + +-- | This class is kind of like 'DeltaParsing' from @trifecta@. +-- +-- @since 0.1.0 +class (Monad m) => PositionParsing m where + getPosition :: m Misc.Position + +-- | Instance for 'M.ParsecT' from @megaparsec@. +-- +-- @since 0.1.0 +instance PositionParsing (M.ParsecT M.Dec Text m) where + getPosition = convert <$> M.getPosition + where + convert :: M.SourcePos -> Misc.Position + convert (M.SourcePos fp line column) + = let path = Lens.view (Lens.from Misc.pathString) fp + in Misc.makePosition (Just path) (toLine line, toColumn column) + + toLine :: M.Pos -> Misc.Line + toColumn :: M.Pos -> Misc.Column + toLine = M.unPos .> fromIntegral + toColumn = M.unPos .> fromIntegral + +-- | Surround a section of parsers in 'getPosition' calls and return the +-- associated 'Misc.Spans'. Note that if a call of this function wraps over +-- a parser that somehow goes over multiple files, it will 'fail'. +-- +-- @since 0.1.0 +spanned :: (PositionParsing m) => m a -> m (Misc.Spans, a) +spanned p = do + start <- getPosition + result <- p + end <- getPosition + let getPosFile :: Misc.Position -> Maybe Misc.Path + getPosFile = Lens.view Misc.positionFile + let (sfile, efile) = (getPosFile start, getPosFile end) + when (sfile /= efile) $ fail "spanned: somehow went over multiple files!" + let file = sfile + let offS = Lens.view Misc.positionOffset start + let offE = Lens.view Misc.positionOffset end + pure (Misc.makeSpans [Misc.makeSpan file offS offE], result) + +-------------------------------------------------------------------------------- + +-- | Lex each line separately, rather than each lexeme. +-- +-- @since 0.1.0 +data Lexeme ann + = -- | @foo = bar@ + -- + -- @since 0.1.0 + LexDefine !ann !(LBind ann) + | -- | @[indent]foo = bar@ + -- + -- @since 0.1.0 + LexBind !ann !(LBind ann) + | -- | @include file@ + -- + -- @since 0.1.0 + LexInclude !ann !(LFile ann) + | -- | @subninja file@ + -- + -- @since 0.1.0 + LexSubninja !ann !(LFile ann) + | -- | @build foo: bar | baz || qux@ + -- + -- @since 0.1.0 + LexBuild !ann !(LBuild ann) + | -- | @rule name@ + -- + -- @since 0.1.0 + LexRule !ann !(LName ann) + | -- | @pool name@ + -- + -- @since 0.1.0 + LexPool !ann !(LName ann) + | -- | @default foo bar@ + -- + -- @since 0.1.0 + LexDefault !ann ![AST.Expr ann] + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated Lexeme where + annotation' f = Lens.lens (helper .> fst) (helper .> snd) + where + helper (LexDefine ann v) = (ann, \x -> LexDefine x (f <$> v)) + helper (LexBind ann v) = (ann, \x -> LexBind x (f <$> v)) + helper (LexInclude ann v) = (ann, \x -> LexInclude x (f <$> v)) + helper (LexSubninja ann v) = (ann, \x -> LexSubninja x (f <$> v)) + helper (LexBuild ann v) = (ann, \x -> LexBuild x (f <$> v)) + helper (LexRule ann v) = (ann, \x -> LexRule x (f <$> v)) + helper (LexPool ann v) = (ann, \x -> LexPool x (f <$> v)) + helper (LexDefault ann v) = (ann, \x -> LexDefault x (map (fmap f) v)) + +-- | Converts to @{ann: …, tag: …, value: …}@. +-- +-- @since 0.1.0 +instance forall ann. (Aeson.ToJSON ann) => Aeson.ToJSON (Lexeme ann) where + toJSON = (\case (LexDefine ann value) -> obj ann "define" value + (LexBind ann value) -> obj ann "bind" value + (LexInclude ann value) -> obj ann "include" value + (LexSubninja ann value) -> obj ann "subninja" value + (LexBuild ann value) -> obj ann "build" value + (LexRule ann value) -> obj ann "rule" value + (LexPool ann value) -> obj ann "pool" value + (LexDefault ann value) -> obj ann "default" value) + where + obj :: forall x. (Aeson.ToJSON x) => ann -> Text -> x -> Aeson.Value + obj ann tag value = [ "ann" .= ann, "tag" .= tag, "value" .= value + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (Lexeme ann) where + parseJSON = (Aeson.withObject "Lexeme" $ \o -> do + ann <- o .: "ann" + tag <- o .: "tag" + case (tag :: Text) of + "define" -> LexDefine ann <$> (o .: "value") + "bind" -> LexBind ann <$> (o .: "value") + "include" -> LexInclude ann <$> (o .: "value") + "subninja" -> LexSubninja ann <$> (o .: "value") + "build" -> LexBuild ann <$> (o .: "value") + "rule" -> LexRule ann <$> (o .: "value") + "pool" -> LexPool ann <$> (o .: "value") + "default" -> LexDefault ann <$> (o .: "value") + owise -> invalidTagError (Text.unpack owise)) + where + invalidTagError :: String -> Aeson.Parser a + invalidTagError x = [ "Invalid tag: ", x, "; expected one of: " + , show validTags + ] |> mconcat |> fail + + validTags :: [Text] + validTags = [ "define", "bind", "include", "subninja" + , "build", "rule", "pool", "default" ] + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (Lexeme ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (Lexeme ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LexemeConstraint (SC.Serial m) ann + ) => SC.Serial m (Lexeme ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LexemeConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (Lexeme ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'Lexeme'. +-- +-- @since 0.1.0 +type LexemeConstraint (c :: * -> Constraint) (ann :: *) + = ( LBindConstraint c ann + , LFileConstraint c ann + , LBuildConstraint c ann + , LNameConstraint c ann + , c [AST.Expr ann] + , c ann + ) + +-------------------------------------------------------------------------------- + +-- | The name of a Ninja rule or pool. +-- +-- @since 0.1.0 +data LName ann + = MkLName + { _lnameAnn :: !ann + , _lnameBS :: !ByteString + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated LName where + annotation' _ = Lens.lens _lnameAnn + $ \(MkLName {..}) x -> MkLName { _lnameAnn = x, .. } + +-- | Converts to @{ann: …, name: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (LName ann) where + toJSON (MkLName {..}) + = [ "ann" .= _lnameAnn + , "name" .= Text.decodeUtf8 _lnameBS + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (LName ann) where + parseJSON = (Aeson.withObject "LName" $ \o -> do + _lnameAnn <- (o .: "ann") >>= pure + _lnameBS <- (o .: "name") >>= Text.encodeUtf8 .> pure + pure (MkLName {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (LName ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (LName ann) + +-- | Uses the underlying 'SC.Serial' instances. +-- +-- @since 0.1.0 +instance ( Monad m, LNameConstraint (SC.Serial m) ann + ) => SC.Serial m (LName ann) where + series = SC.series |> fmap (second Text.encodeUtf8 .> uncurry MkLName) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LNameConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (LName ann) where + coseries = SC.coseries .> fmap (\f -> _lnameBS .> Text.decodeUtf8 .> f) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'LName'. +-- +-- @since 0.1.0 +type LNameConstraint (c :: * -> Constraint) (ann :: *) = (c Text, c ann) + +-------------------------------------------------------------------------------- + +-- | A reference to a file in an @include@ or @subninja@ declaration. +-- +-- @since 0.1.0 +newtype LFile ann + = MkLFile + { _lfileExpr :: AST.Expr ann + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Converts to @{file: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (LFile ann) where + toJSON (MkLFile {..}) + = [ "file" .= _lfileExpr + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (LFile ann) where + parseJSON = (Aeson.withObject "LFile" $ \o -> do + _lfileExpr <- (o .: "file") >>= pure + pure (MkLFile {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (LFile ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (LFile ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LFileConstraint (SC.Serial m) ann + ) => SC.Serial m (LFile ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LFileConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (LFile ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'LFile'. +-- +-- @since 0.1.0 +type LFileConstraint (c :: * -> Constraint) (ann :: *) = (c Text, c ann) + +-------------------------------------------------------------------------------- + +-- | A Ninja variable binding, top-level or otherwise. +-- +-- @since 0.1.0 +data LBind ann + = MkLBind + { _lbindAnn :: !ann + , _lbindName :: !(LName ann) + , _lbindValue :: !(AST.Expr ann) + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Converts to @{ann: …, name: …, value: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (LBind ann) where + toJSON (MkLBind {..}) + = [ "ann" .= _lbindAnn + , "name" .= _lbindName + , "value" .= _lbindValue + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (LBind ann) where + parseJSON = (Aeson.withObject "LBind" $ \o -> do + _lbindAnn <- (o .: "ann") >>= pure + _lbindName <- (o .: "name") >>= pure + _lbindValue <- (o .: "value") >>= pure + pure (MkLBind {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (LBind ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (LBind ann) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LBindConstraint (SC.Serial m) ann + ) => SC.Serial m (LBind ann) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LBindConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (LBind ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'LBind'. +-- +-- @since 0.1.0 +type LBindConstraint (c :: * -> Constraint) (ann :: *) = (c Text, c ann) + +-------------------------------------------------------------------------------- + +-- | The data contained within a Ninja @build@ declaration. +-- +-- @since 0.1.0 +data LBuild ann + = MkLBuild + { _lbuildAnn :: !ann + , _lbuildOuts :: ![AST.Expr ann] + , _lbuildRule :: !(LName ann) + , _lbuildDeps :: ![AST.Expr ann] + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Constructor for an 'LBuild'. +-- +-- @since 0.1.0 +makeLBuild :: forall ann. + ann + -- ^ The build annotation + -> [AST.Expr ann] + -- ^ The build outputs + -> LName ann + -- ^ The rule name + -> [AST.Expr ann] + -- ^ The build dependencies + -> LBuild ann +makeLBuild ann outs rule deps + = let filterExprs :: [AST.Expr ann] -> [AST.Expr ann] + filterExprs = filter (\case (AST.Lit _ "") -> False + (AST.Exprs _ []) -> False + _ -> True) + in MkLBuild ann (filterExprs outs) rule (filterExprs deps) + +-- | The usual definition for 'Misc.Annotated'. +-- +-- @since 0.1.0 +instance Misc.Annotated LBuild where + annotation' f = Lens.lens _lbuildAnn + $ \(MkLBuild {..}) x -> + MkLBuild { _lbuildAnn = x + , _lbuildOuts = map (fmap f) _lbuildOuts + , _lbuildRule = f <$> _lbuildRule + , _lbuildDeps = map (fmap f) _lbuildOuts + , .. } + +-- | Converts to @{ann: …, outs: …, rule: …, deps: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON ann) => Aeson.ToJSON (LBuild ann) where + toJSON (MkLBuild {..}) + = [ "ann" .= _lbuildAnn + , "outs" .= _lbuildOuts + , "rule" .= _lbuildRule + , "deps" .= _lbuildDeps + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON ann) => Aeson.FromJSON (LBuild ann) where + parseJSON = (Aeson.withObject "LBuild" $ \o -> do + _lbuildAnn <- (o .: "ann") >>= pure + _lbuildOuts <- (o .: "outs") >>= pure + _lbuildRule <- (o .: "rule") >>= pure + _lbuildDeps <- (o .: "deps") >>= pure + pure (MkLBuild {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable ann) => Hashable (LBuild ann) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData ann) => NFData (LBuild ann) + +-- | Uses the underlying 'SC.Serial' instances. +-- +-- @since 0.1.0 +instance ( Monad m, LBuildConstraint (SC.Serial m) ann + ) => SC.Serial m (LBuild ann) where + series = makeLBuild <$> SC.series <~> SC.series <~> SC.series <~> SC.series + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, LBuildConstraint (SC.CoSerial m) ann + ) => SC.CoSerial m (LBuild ann) + +-- | The set of constraints required for a given constraint to be automatically +-- computed for an 'LBuild'. +-- +-- @since 0.1.0 +type LBuildConstraint (c :: * -> Constraint) (ann :: *) = (c Text, c ann) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc.hs b/library/Language/Ninja/Misc.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc.hs @@ -0,0 +1,81 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Language.Ninja.Misc +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Utility types and functions for the rest of @language-ninja@. +-- +-- This module re-exports all of the modules under the "Language.Ninja.Misc" +-- namespace for convenience. +-- +-- It is recommended that you import it with the following style: +-- +-- > import qualified Language.Ninja.Misc as Misc +-- +-- @since 0.1.0 +module Language.Ninja.Misc + ( -- * "Language.Ninja.Misc.Command" + Misc.Command, Misc.makeCommand + , Misc.commandText + + -- * "Language.Ninja.Misc.Path" + , Misc.Path, Misc.makePath + , Misc.pathIText, Misc.pathText, Misc.pathString, Misc.pathFP + + -- * "Language.Ninja.Misc.IText" + , Misc.IText, Misc.uninternText, Misc.internText, Misc.itext + + -- * "Language.Ninja.Misc.Positive" + , Misc.Positive, Misc.makePositive, Misc.fromPositive + + -- * "Language.Ninja.Misc.Annotated" + , Misc.Annotated (..), Misc.annotation + + -- * "Language.Ninja.Misc.Located" + , Misc.Located, Misc.tokenize, Misc.tokenizeFile, Misc.tokenizeText + , Misc.locatedPos, Misc.locatedVal + + , Misc.Spans, Misc.makeSpans + , Misc.spansSet + + , Misc.Span, Misc.makeSpan + , Misc.spanPath, Misc.spanRange, Misc.spanStart, Misc.spanEnd + + , Misc.Position, Misc.makePosition + , Misc.positionFile, Misc.positionOffset, Misc.positionLine, Misc.positionCol + , Misc.comparePosition + + , Misc.Offset + , Misc.compareOffset, Misc.offsetLine, Misc.offsetColumn + , Misc.Line, Misc.Column + ) where + +import qualified Language.Ninja.Misc.Annotated as Misc +import qualified Language.Ninja.Misc.Command as Misc +import qualified Language.Ninja.Misc.IText as Misc +import qualified Language.Ninja.Misc.Located as Misc +import qualified Language.Ninja.Misc.Path as Misc +import qualified Language.Ninja.Misc.Positive as Misc diff --git a/library/Language/Ninja/Misc/Annotated.hs b/library/Language/Ninja/Misc/Annotated.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/Annotated.hs @@ -0,0 +1,94 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/Annotated.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Language.Ninja.Misc.Annotated +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A typeclass for AST nodes that are annotated with a polymorphic field, +-- which provides a canonical lens into that field. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.Annotated + ( Annotated (..), annotation + ) where + +import qualified Control.Lens as Lens + +-------------------------------------------------------------------------------- + +-- | If you have some type that represents an AST node, it is often useful to +-- add a polymorphic "annotation field" to it, which is used for things like +-- source positions. +-- +-- Specifically, suppose we have the following AST node type: +-- +-- @data Foo = Foo { _fooBar :: !Bar, _fooBaz :: !Baz } deriving (…)@ +-- +-- Then an annotation field is added by the following process: +-- +-- 1. Add an extra (final) type parameter @ann@ to the type. +-- 2. Add an extra field @_fooAnn :: !ann@. +-- 3. Derive instances of 'Functor', 'Foldable', and 'Traversable'. +-- 4. If the type is recursive, add a 'Lens.Plated' instance. +-- See "Language.Ninja.AST.Expr" for a complete example of this. +-- 5. Write an 'Annotated' instance with the canonical lens given by the +-- @_fooAnn@ field. There are plenty of examples around this library. +-- +-- The end result then looks like: +-- +-- > data Foo ann +-- > = Foo +-- > { _fooAnn :: !ann +-- > , _fooBar :: !Bar +-- > , _fooBaz :: !Baz +-- > } +-- > deriving (…, Functor, Foldable, Traversable) +-- > +-- > instance Annotated Foo where +-- > annotation' = … +-- +-- @since 0.1.0 +class (Functor ty) => Annotated (ty :: * -> *) where + -- | Given a function that is used when 'fmap'ing any subterms, return a lens + -- into the "annotation" field. + -- + -- When writing an instance, keep in mind that @'annotation'' id@ should + -- just be the typical definition for a lens into the annotation field. + -- + -- It should also be true that for any @f :: B -> C@ and @g :: A -> B@, + -- + -- > annotation' (f . g) == annotation' f . annotation' g + -- + -- @since 0.1.0 + annotation' :: (ann -> ann') -> Lens.Lens (ty ann) (ty ann') ann ann' + +-- | This is just shorthand for @'annotation'' id@. +-- +-- @since 0.1.0 +annotation :: (Annotated ty) => Lens.Lens' (ty ann) ann +annotation = annotation' id + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc/Command.hs b/library/Language/Ninja/Misc/Command.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/Command.hs @@ -0,0 +1,99 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/Command.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Misc.Command +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype representing a POSIX @sh@ command line. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.Command + ( Command, makeCommand, commandText + ) where + +import Data.Text (Text) + +import qualified Data.Aeson as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import Test.SmallCheck.Series ((>>-)) +import qualified Test.SmallCheck.Series as SC + +import qualified Control.Lens as Lens + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +-- | This type represents a POSIX @sh@ command line. +-- +-- @since 0.1.0 +newtype Command + = MkCommand + { _commandText :: Text + } + deriving ( Eq, Ord, Show, Read, Generic, Hashable, NFData + , Aeson.ToJSON, Aeson.FromJSON ) + +-- | Constructor for a 'Command'. +-- +-- @since 0.1.0 +{-# INLINE makeCommand #-} +makeCommand :: Text -> Command +makeCommand = MkCommand + +-- | An isomorphism between a 'Command' and its underlying 'Text'. +-- +-- @since 0.1.0 +{-# INLINE commandText #-} +commandText :: Lens.Iso' Command Text +commandText = Lens.iso _commandText MkCommand + +-- | Uses the underlying 'Text' instance. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.Serial m Text + ) => SC.Serial m Command where + series = SC.newtypeCons MkCommand + +-- | Uses the underlying 'Text' instance. +-- +-- @since 0.1.0 +instance ( Monad m + , SC.CoSerial m Text + ) => SC.CoSerial m Command where + coseries rs = SC.newtypeAlts rs + >>- \f -> pure (_commandText .> f) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc/IText.hs b/library/Language/Ninja/Misc/IText.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/IText.hs @@ -0,0 +1,181 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/IText.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Misc.IText +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- An interned text type. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.IText + ( IText, uninternText, internText, itext + ) where + +import qualified Control.Lens as Lens + +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Data.Interned as Interned +import qualified Data.Interned.Text as Interned (InternedText) + +import Control.DeepSeq (NFData (rnf)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) + +import qualified Test.SmallCheck.Series as SC + +import Control.Arrow (first) +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | An interned (hash-consed) text type. +-- This is a newtype over 'Interned.InternedText' from the @intern@ package. +-- +-- @since 0.1.0 +newtype IText + = MkIText Interned.InternedText + deriving (Eq, IsString, Generic) + +-- | Get the 'Text' corresponding to the given 'IText' value. +-- +-- >>> uninternText ("foobar" :: IText) +-- "foobar" +-- +-- @since 0.1.0 +{-# INLINE uninternText #-} +uninternText :: IText -> Text +uninternText (MkIText i) = Interned.unintern i + +-- | Intern a 'Text' value, resulting in an 'IText' value. +-- +-- prop> uninternText (internText (Text.pack x)) == Text.pack x +-- +-- >>> internText ("foobar" :: Text) +-- "foobar" +-- +-- @since 0.1.0 +{-# INLINE internText #-} +internText :: Text -> IText +internText = Interned.intern .> MkIText + +-- | An 'Lens.Iso'' between 'Text' and 'IText'. +-- +-- prop> (Lens.view itext (fromString x)) == fromString x +-- +-- prop> (Lens.view (Lens.from itext) (fromString x)) == fromString x +-- +-- >>> (Lens.view itext ("foobar" :: Text)) :: IText +-- "foobar" +-- +-- >>> (Lens.view (Lens.from itext) ("foobar" :: IText)) :: Text +-- "foobar" +-- +-- @since 0.1.0 +{-# INLINE itext #-} +itext :: Lens.Iso' Text IText +itext = Lens.iso internText uninternText + +-- | The 'Ord' instance in @intern@ compares hashes rather than values. +-- +-- @since 0.1.0 +instance Ord IText where + compare itA itB = compare (uninternText itA) (uninternText itB) + +-- | Displays an 'IText' such that 'fromString' is inverse to 'show'. +-- +-- @since 0.1.0 +instance Show IText where + show (MkIText i) = show i + +-- | Inverse of the 'Show' instance. +-- +-- @since 0.1.0 +instance Read IText where + readsPrec i = readsPrec i .> map (first (fromString .> MkIText)) + +-- | Uses the 'Hashable' instance for 'Text'. Not very efficient. +-- +-- TODO: perhaps switch to hashing the identifier, since this is likely +-- pretty hot code given all the @HashMap Target …@ types all over the place. +-- +-- @since 0.1.0 +instance Hashable IText where + hashWithSalt n = uninternText .> hashWithSalt n + +-- | Defined by @rnf a = seq a ()@, since 'IText' is a newtype of strict types. +-- +-- @since 0.1.0 +instance NFData IText where + rnf a = seq a () + +-- | Converts to JSON string via 'uninternText'. +-- +-- @since 0.1.0 +instance Aeson.ToJSON IText where + toJSON = uninternText .> Aeson.toJSON + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON IText where + parseJSON = Aeson.withText "IText" (internText .> pure) + +-- | Converts to JSON string via 'uninternText'. +-- +-- @since 0.1.0 +instance Aeson.ToJSONKey IText where + toJSONKey = Aeson.toJSONKeyText uninternText + +-- | Inverse of the 'Aeson.ToJSONKey' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSONKey IText where + fromJSONKey = Aeson.mapFromJSONKeyFunction internText Aeson.fromJSONKey + +-- | Uses the 'Text' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m IText where + series = SC.series |> fmap (Text.unpack .> Text.pack .> internText) + +-- | Uses the 'Text' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m IText where + coseries = SC.coseries .> fmap (\f int -> f (uninternText int)) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc/Located.hs b/library/Language/Ninja/Misc/Located.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/Located.hs @@ -0,0 +1,590 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/Located.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Misc.Located +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Tokenize text into a list of non-whitespace chunks, each of which is +-- annotated with its source location. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.Located + ( -- * @Located@ + Located + , tokenize, tokenizeFile, tokenizeText + -- , untokenize + , locatedPos, locatedVal + + -- * @Spans@ + , Spans, makeSpans, spansSet + + -- * @Span@ + , Span, makeSpan, spanPath, spanRange + , spanStart, spanEnd, spanStartPos, spanEndPos + + -- * @Position@ + , Position, makePosition + , positionFile, positionOffset, positionLine, positionCol + , comparePosition + + -- * @Offset@ + , Offset, compareOffset, offsetLine, offsetColumn + + -- * Miscellaneous + , Line, Column + ) where + +import Control.Arrow (second, (&&&), (***)) + +import qualified Control.Lens as Lens + +import Control.Monad.ST (ST) +import qualified Control.Monad.ST as ST +import Data.STRef (STRef) +import qualified Data.STRef as ST + +import Data.Char (isSpace) +import qualified Data.Maybe +import Data.Semigroup (Semigroup ((<>))) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.SmallCheck.Series as SC + +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Flow ((.>), (|>)) + +import qualified Language.Ninja.Misc.Path as Misc +import qualified Language.Ninja.Mock as Mock + +-------------------------------------------------------------------------------- + +-- | This datatype represents a value annotated with a source location. +-- +-- @since 0.1.0 +data Located t + = MkLocated + { _locatedPos :: {-# UNPACK #-} !Position + , _locatedVal :: !t + } + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +-- | Construct a 'Located' value directly. +-- +-- @since 0.1.0 +{-# INLINE makeLocated #-} +makeLocated :: Position -> t -> Located t +makeLocated = MkLocated + +-- | Given @path :: 'Maybe' 'Misc.Path'@ and a @text :: 'Text'@, do the +-- following: +-- +-- * Remove all @'\r'@ characters from the @text@. +-- * Split the @text@ into chunks that are guaranteed not to contain newlines +-- or whitespace, and which are annotated with their location. +-- +-- @since 0.1.0 +tokenize :: Maybe Misc.Path -> Text -> [Located Text] +tokenize mpath = removeWhitespace (mpath, 0, 0) + +-- | Read the file at the given 'Misc.Path' and then run 'tokenize' on the +-- resulting 'Text'. +-- +-- @since 0.1.0 +tokenizeFile :: (Mock.MonadReadFile m) => Misc.Path -> m [Located Text] +tokenizeFile path = tokenize (Just path) <$> Mock.readFile path + +-- | This function is equivalent to @tokenize Nothing@. +-- +-- @since 0.1.0 +tokenizeText :: Text -> [Located Text] +tokenizeText = tokenize Nothing + +-- TODO: uncomment this and implement it +-- +-- -- | This function takes the output of 'tokenize' and returns a map from +-- -- paths to the contents of the associated files. +-- -- +-- -- prop> untokenize [] == mempty +-- -- prop> untokenize (xs <> ys) == untokenize xs <> untokenize ys +-- -- prop> untokenize (tokenize (Just path) t) == Map.singleton path t +-- -- +-- -- @since 0.1.0 +-- untokenize :: [Located Text] -> Map Misc.Path Text +-- untokenize = error "untokenize is not yet written" + +-- | The position of this located value. +-- +-- @since 0.1.0 +{-# INLINE locatedPos #-} +locatedPos :: Lens.Lens' (Located t) Position +locatedPos = Lens.lens _locatedPos + $ \(MkLocated {..}) x -> MkLocated { _locatedPos = x, .. } + +-- | The value underlying this located value. +-- +-- @since 0.1.0 +{-# INLINE locatedVal #-} +locatedVal :: Lens.Lens' (Located t) t +locatedVal = Lens.lens _locatedVal + $ \(MkLocated {..}) x -> MkLocated { _locatedVal = x, .. } + +-- | Converts to @{position: …, value: …}@. +-- +-- @since 0.1.0 +instance (Aeson.ToJSON t) => Aeson.ToJSON (Located t) where + toJSON (MkLocated {..}) + = [ "pos" .= _locatedPos + , "val" .= _locatedVal + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance (Aeson.FromJSON t) => Aeson.FromJSON (Located t) where + parseJSON = (Aeson.withObject "Located" $ \o -> do + _locatedPos <- (o .: "pos") >>= pure + _locatedVal <- (o .: "val") >>= pure + pure (MkLocated {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Hashable t) => Hashable (Located t) + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (NFData t) => NFData (Located t) + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, SC.Serial m Text, SC.Serial m t + ) => SC.Serial m (Located t) + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance ( Monad m, SC.CoSerial m Text, SC.CoSerial m t + ) => SC.CoSerial m (Located t) + +-------------------------------------------------------------------------------- + +-- | A type representing a set of source spans. +-- +-- @since 0.1.0 +newtype Spans + = MkSpans (HashSet Span) + deriving ( Eq, Show, Semigroup, Monoid + , Generic, Aeson.ToJSON, Aeson.FromJSON + , Hashable, NFData ) + +-- | Construct a 'Spans' from a list of 'Span's. +-- +-- @since 0.1.0 +{-# INLINE makeSpans #-} +makeSpans :: [Span] -> Spans +makeSpans = HS.fromList .> MkSpans + +-- | A lens into the @'HashSet' 'Span'@ underlying a value of type 'Spans'. +-- +-- @since 0.1.0 +{-# INLINE spansSet #-} +spansSet :: Lens.Iso' Spans (HashSet Span) +spansSet = Lens.iso (\(MkSpans s) -> s) MkSpans + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m (HashSet Span)) => SC.Serial m Spans + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m (HashSet Span)) => SC.CoSerial m Spans + +-------------------------------------------------------------------------------- + +-- | Represents a span of source code. +-- +-- @since 0.1.0 +data Span + = MkSpan !(Maybe Misc.Path) !Offset !Offset + deriving (Eq, Show, Generic) + +-- | Construct a 'Span' from a given start position to a given end position. +-- +-- @since 0.1.0 +{-# INLINE makeSpan #-} +makeSpan :: Maybe Misc.Path + -- ^ The file in which this span resides, if any. + -> Offset + -- ^ The start offset. + -> Offset + -- ^ The end offset. + -> Span +makeSpan mpath start end = case compareOffset start end of + GT -> makeSpan mpath end start + _ -> MkSpan mpath start end + +-- | A lens into the (nullable) path associated with a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanPath #-} +spanPath :: Lens.Lens' Span (Maybe Misc.Path) +spanPath = let helper (MkSpan p s e) = (p, \x -> MkSpan x s e) + in Lens.lens (helper .> fst) (helper .> snd) + +-- | A lens giving the start and end 'Offset's associated with a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanRange #-} +spanRange :: Lens.Lens' Span (Offset, Offset) +spanRange = let helper (MkSpan p s e) = ((s, e), \(s', e') -> MkSpan p s' e') + in Lens.lens (helper .> fst) (helper .> snd) + +-- | A lens into the 'Offset' associated with the start of a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanStart #-} +spanStart :: Lens.Lens' Span Offset +spanStart = spanRange . Lens._1 + +-- | A lens into the 'Offset' associated with the end of a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanEnd #-} +spanEnd :: Lens.Lens' Span Offset +spanEnd = spanRange . Lens._2 + +-- | A getter for the 'Position' associated with the start of a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanStartPos #-} +spanStartPos :: Lens.Getter Span Position +spanStartPos = Lens.to (\(MkSpan p s _) -> makePosition p s) + +-- | A getter for the 'Position' associated with the end of a 'Span'. +-- +-- @since 0.1.0 +{-# INLINE spanEndPos #-} +spanEndPos :: Lens.Getter Span Position +spanEndPos = Lens.to (\(MkSpan p _ e) -> makePosition p e) + +-- | Converts to @{file: …, start: …, end: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Span where + toJSON (MkSpan file start end) + = [ "file" .= maybe Aeson.Null Aeson.toJSON file + , "start" .= offsetJ start + , "end" .= offsetJ end + ] |> Aeson.object + where + offsetJ :: (Line, Column) -> Aeson.Value + offsetJ (line, col) = Aeson.object ["line" .= line, "col" .= col] + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Span where + parseJSON = (Aeson.withObject "Span" $ \o -> do + file <- (o .: "file") >>= pure + start <- (o .: "start") >>= offsetP + end <- (o .: "end") >>= offsetP + pure (MkSpan file start end)) + where + offsetP :: Aeson.Value -> Aeson.Parser Offset + offsetP = (Aeson.withObject "Offset" $ \o -> do + line <- (o .: "line") >>= pure + col <- (o .: "col") >>= pure + pure (line, col)) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Span + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Span + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Span + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Span + +-------------------------------------------------------------------------------- + +-- | This datatype represents the position of a cursor in a text file. +-- +-- @since 0.1.0 +data Position + = MkPosition + { _positionFile :: !(Maybe Misc.Path) + , _positionLine :: {-# UNPACK #-} !Line + , _positionCol :: {-# UNPACK #-} !Column + } + deriving (Eq, Show, Generic) + +-- | Construct a 'Position' from a (nullable) path and a @(line, column)@ pair. +-- +-- @since 0.1.0 +{-# INLINE makePosition #-} +makePosition :: Maybe Misc.Path -> Offset -> Position +makePosition file (line, column) = MkPosition file line column + +-- | The path of the file pointed to by this position, if any. +-- +-- @since 0.1.0 +{-# INLINE positionFile #-} +positionFile :: Lens.Lens' Position (Maybe Misc.Path) +positionFile = Lens.lens _positionFile + $ \(MkPosition {..}) x -> MkPosition { _positionFile = x, .. } + +-- | The offset in the file pointed to by this position. +-- +-- @since 0.1.0 +{-# INLINE positionOffset #-} +positionOffset :: Lens.Lens' Position Offset +positionOffset + = Lens.lens (_positionLine &&& _positionCol) + $ \(MkPosition {..}) (line, col) -> + MkPosition { _positionLine = line, _positionCol = col, .. } + +-- | The line number in the file pointed to by this position. +-- +-- @since 0.1.0 +{-# INLINE positionLine #-} +positionLine :: Lens.Lens' Position Line +positionLine = positionOffset . Lens._1 + +-- | The column number in the line pointed to by this position. +-- +-- @since 0.1.0 +{-# INLINE positionCol #-} +positionCol :: Lens.Lens' Position Column +positionCol = positionOffset . Lens._2 + +-- | If two 'Position's are comparable (i.e.: if they are in the same file), +-- this function will return an 'Ordering' giving their relative positions. +-- Otherwise, it will of course return 'Nothing'. +-- +-- @since 0.1.0 +comparePosition :: Position -> Position -> Maybe Ordering +comparePosition = go + where + go (MkPosition fileX lineX colX) (MkPosition fileY lineY colY) + = compareTriple (fileX, (lineX, colX)) (fileY, (lineY, colY)) + + compareTriple :: (Maybe Misc.Path, Offset) -> (Maybe Misc.Path, Offset) + -> Maybe Ordering + compareTriple (mfileX, offX) (mfileY, offY) + | (mfileX == mfileY) = Just (compareOffset offX offY) + | otherwise = Nothing + +-- | Converts to @{file: …, line: …, col: …}@. +-- +-- @since 0.1.0 +instance Aeson.ToJSON Position where + toJSON (MkPosition {..}) + = [ "file" .= _positionFile + , "line" .= _positionLine + , "col" .= _positionCol + ] |> Aeson.object + +-- | Inverse of the 'Aeson.ToJSON' instance. +-- +-- @since 0.1.0 +instance Aeson.FromJSON Position where + parseJSON = (Aeson.withObject "Position" $ \o -> do + _positionFile <- (o .: "file") >>= pure + _positionLine <- (o .: "line") >>= pure + _positionCol <- (o .: "col") >>= pure + pure (MkPosition {..})) + +-- | Default 'Hashable' instance via 'Generic'. +-- +-- @since 0.1.0 +instance Hashable Position + +-- | Default 'NFData' instance via 'Generic'. +-- +-- @since 0.1.0 +instance NFData Position + +-- | Default 'SC.Serial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Position + +-- | Default 'SC.CoSerial' instance via 'Generic'. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Position + +-------------------------------------------------------------------------------- + +-- | A line/column offset into a file. +-- +-- @since 0.1.0 +type Offset = (Line, Column) + +-- | Compare two 'Offset's in lexicographic order (i.e.: the 'Column' is +-- ignored unless they are on the same 'Line'). +-- +-- @since 0.1.0 +compareOffset :: Offset -> Offset -> Ordering +compareOffset (lineX, colX) (lineY, colY) + | (lineX < lineY) = LT + | (lineX > lineY) = GT + | otherwise = compare colX colY + +-- | A lens into the 'Line' associated with an 'Offset'. +-- +-- For now, this is simply defined as @offsetLine = 'Lens._1'@, +-- but if 'Offset' is later refactored to be an abstract data type, using +-- this lens instead of 'Lens._1' will decrease the amount of code that +-- breaks. +-- +-- @since 0.1.0 +{-# INLINE offsetLine #-} +offsetLine :: Lens.Lens' Offset Line +offsetLine = Lens._1 + +-- | A lens into the 'Line' associated with an 'Offset'. +-- +-- Read the description of 'offsetLine' for an understanding of why this +-- exists and why you should use it instead of 'Lens._2'. +-- +-- @since 0.1.0 +{-# INLINE offsetColumn #-} +offsetColumn :: Lens.Lens' Offset Column +offsetColumn = Lens._2 + +-------------------------------------------------------------------------------- + +-- | A line number. +-- +-- @since 0.1.0 +type Line = Int + +-- | A column number. +-- +-- @since 0.1.0 +type Column = Int + +-------------------------------------------------------------------------------- + +data Chunk + = ChunkText !Text + | ChunkSpace {-# UNPACK #-} !Int + | ChunkLine {-# UNPACK #-} !Int + deriving (Eq, Show) + +-------------------------------------------------------------------------------- + +newtype Chunks + = MkChunks { fromChunks :: [Chunk] } + deriving (Eq, Show) + +{-# INLINE chunksNil #-} +chunksNil :: Chunks +chunksNil = MkChunks [] + +chunksCons :: Chunk -> Chunks -> Chunks +chunksCons = \chunk (MkChunks list) -> MkChunks (go chunk list) + where + {-# INLINE go #-} + go (ChunkSpace m) (ChunkSpace n : rest) = ChunkSpace (m + n) : rest + go (ChunkLine m) (ChunkLine n : rest) = ChunkLine (m + n) : rest + go (ChunkText a) (ChunkText b : rest) = ChunkText (a <> b) : rest + go other list = other : list + +{-# INLINE chunksAddChar #-} +chunksAddChar :: Char -> Chunks -> Chunks +chunksAddChar '\n' = chunksCons (ChunkLine 1) +chunksAddChar '\r' = id +chunksAddChar c | isSpace c = chunksCons (ChunkSpace 1) +chunksAddChar c = chunksCons (ChunkText (Text.singleton c)) + +-------------------------------------------------------------------------------- + +removeWhitespace :: (Maybe Misc.Path, Line, Column) -> Text -> [Located Text] +removeWhitespace (file, initLine, initCol) = + go .> Data.Maybe.catMaybes .> map makeLoc + where + go :: Text -> [Maybe (Line, Column, Text)] + go text = ST.runST $ do + ref <- ST.newSTRef (initLine, initCol) + Text.foldr chunksAddChar chunksNil text + |> fromChunks + |> mapM (applyChunk ref) + + applyChunk :: STRef s (Line, Column) + -> Chunk -> ST s (Maybe (Line, Column, Text)) + applyChunk ref = \case + ChunkLine n -> do ST.modifySTRef' ref ((+ n) *** const 0) + pure Nothing + ChunkSpace n -> do ST.modifySTRef' ref (second (+ n)) + pure Nothing + ChunkText t -> do (line, column) <- ST.readSTRef ref + ST.modifySTRef' ref (second (+ Text.length t)) + pure (Just (line, column, t)) + + {-# INLINE makeLoc #-} + makeLoc :: (Line, Column, Text) -> Located Text + makeLoc (line, col, text) = makeLocated (MkPosition file line col) text + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc/Path.hs b/library/Language/Ninja/Misc/Path.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/Path.hs @@ -0,0 +1,127 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/Path.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Misc.Path +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A datatype for Unix path strings. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.Path + ( Path, makePath, pathIText, pathText, pathString, pathFP + ) where + +import Language.Ninja.Misc.IText (IText) +import qualified Language.Ninja.Misc.IText as Ninja + +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Filesystem.Path.CurrentOS as FP + +import qualified Data.Aeson as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Data.String (IsString) +import GHC.Generics (Generic) +import Test.SmallCheck.Series ((>>-)) +import qualified Test.SmallCheck.Series as SC + +import qualified Control.Lens as Lens + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +-- | This type represents a Unix path string. +-- +-- @since 0.1.0 +newtype Path + = MkPath + { _pathIText :: IText + } + deriving ( Eq, Ord, Show, Read, IsString, Generic, Hashable, NFData + , Aeson.ToJSON, Aeson.FromJSON, Aeson.ToJSONKey, Aeson.FromJSONKey ) + +-- | Construct a 'Path' from some 'Text'. +-- +-- @since 0.1.0 +{-# INLINE makePath #-} +makePath :: Text -> Path +makePath = Lens.view Ninja.itext .> MkPath + +-- | An isomorphism between a 'Path' and its underlying 'IText'. +-- +-- @since 0.1.0 +{-# INLINE pathIText #-} +pathIText :: Lens.Iso' Path IText +pathIText = Lens.iso _pathIText MkPath + +-- | An isomorphism that gives access to a 'Text'-typed view of a 'Path', +-- even though the underlying data has type 'IText'. +-- +-- This is equivalent to @pathIText . from Ninja.itext@. +-- +-- @since 0.1.0 +{-# INLINE pathText #-} +pathText :: Lens.Iso' Path Text +pathText = pathIText . Lens.from Ninja.itext + +-- | An isomorphism that gives access to a 'String'-typed view of a 'Path'. +-- +-- @since 0.1.0 +{-# INLINE pathString #-} +pathString :: Lens.Iso' Path String +pathString = pathText . Lens.iso Text.unpack Text.pack + +-- | An isomorphism between a 'Path' and a 'FP.FilePath' from @system-filepath@. +-- This uses 'FP.decodeString' and 'FP.encodeString', so all the caveats on +-- those functions apply here. +-- +-- @since 0.1.0 +{-# INLINE pathFP #-} +pathFP :: Lens.Iso' Path FP.FilePath +pathFP = pathString . Lens.iso FP.decodeString FP.encodeString + +-- | Uses the underlying 'IText' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.Serial m Text) => SC.Serial m Path where + series = SC.newtypeCons MkPath + +-- | Uses the underlying 'IText' instance. +-- +-- @since 0.1.0 +instance (Monad m, SC.CoSerial m Text) => SC.CoSerial m Path where + coseries rs = SC.newtypeAlts rs + >>- \f -> pure (_pathIText .> f) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Misc/Positive.hs b/library/Language/Ninja/Misc/Positive.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Misc/Positive.hs @@ -0,0 +1,113 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Misc/Positive.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Misc.Positive +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A data type for integers greater than zero. +-- +-- @since 0.1.0 +module Language.Ninja.Misc.Positive + ( Positive, makePositive, fromPositive + ) where + +import Control.Applicative (empty) + +import qualified Control.Lens.Getter as Lens + +import qualified Data.Aeson as Aeson + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import qualified Test.SmallCheck.Series as SC + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | This type represents a positive number; i.e.: an integer greater than zero. +-- +-- @since 0.1.0 +newtype Positive + = MkPositive + { _fromPositive :: Int + } + deriving ( Eq, Ord, Real, Integral, Enum, Show, Read, Generic + , Hashable, NFData + , Aeson.ToJSON, Aeson.FromJSON ) + +-- | This instance uses 'error' to preserve the 'Positive' invariant. +-- +-- @since 0.1.0 +instance Num Positive where + (MkPositive a) + (MkPositive b) = MkPositive (a + b) + (MkPositive a) * (MkPositive b) = MkPositive (a * b) + abs = id + signum = const 1 + negate = ["Prelude.negate: Positive cannot be negated"] + |> mconcat |> error + fromInteger i | i > 0 = MkPositive (fromIntegral i) + | otherwise = [ "Prelude.fromInteger: " + , "Positive invariant violated" + ] |> mconcat |> error + +-- | Constructor for a 'Positive'. +-- +-- @since 0.1.0 +{-# INLINEABLE makePositive #-} +makePositive :: Int -> Maybe Positive +makePositive i | i > 0 = Just (MkPositive i) + | otherwise = Nothing + +-- | A 'Lens.Getter' for the 'Int' underlying a 'Positive'. +-- +-- @since 0.1.0 +{-# INLINE fromPositive #-} +fromPositive :: Lens.Getter Positive Int +fromPositive = Lens.to _fromPositive + +-- | Uses the underlying 'Int' instance. +-- +-- @since 0.1.0 +instance (Monad m) => SC.Serial m Positive where + series = MkPositive <$> (SC.series `suchThat` (> 0)) + where + suchThat :: SC.Series m a -> (a -> Bool) -> SC.Series m a + suchThat s p = s >>= \x -> if p x then pure x else empty + +-- | Uses the underlying 'Int' instance. +-- +-- @since 0.1.0 +instance (Monad m) => SC.CoSerial m Positive where + coseries = SC.coseries .> fmap (\f -> _fromPositive .> f) + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Mock.hs b/library/Language/Ninja/Mock.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Mock.hs @@ -0,0 +1,45 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Mock.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Language.Ninja.Mock +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Typeclasses that allow mocking via dependency injection (i.e.: free monads +-- or similar techniques) in @language-ninja@. +-- +-- This module re-exports all of the modules under the "Language.Ninja.Mock" +-- namespace for convenience. +-- +-- It is recommended that you import it with the following style: +-- +-- > import qualified Language.Ninja.Mock as Mock +-- +-- @since 0.1.0 +module Language.Ninja.Mock + ( -- * "Language.Ninja.Mock.ReadFile" + Mock.MonadReadFile (..) + ) where + +import Language.Ninja.Mock.ReadFile as Mock diff --git a/library/Language/Ninja/Mock/ReadFile.hs b/library/Language/Ninja/Mock/ReadFile.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Mock/ReadFile.hs @@ -0,0 +1,85 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Mock/ReadFile.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Language.Ninja.Mock.ReadFile +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A typeclass exposing an interface that allows reading a file from a +-- filesystem (virtual or otherwise). +-- +-- @since 0.1.0 +module Language.Ninja.Mock.ReadFile + ( MonadReadFile (..) + ) where + +import Prelude (IO, Monad) + +import Control.Monad.Trans.Class (MonadTrans (lift)) + +import qualified Control.Lens as Lens + +import Data.Text (Text) +import qualified Data.Text.IO as Text + +import Language.Ninja.Misc.Path (Path, pathString) + +import Flow ((.>)) + +-------------------------------------------------------------------------------- + +-- Remember: we have imported Prelude hiding 'readFile'. + +-- | This typeclass allows you to write code that reads files from the +-- filesystem and then later run that code purely against a virtual filesystem +-- of some description. +-- +-- @since 0.1.0 +class (Monad m) => MonadReadFile m where + {-# MINIMAL readFile #-} + + -- | Read the file located at the given path and decode it into 'Text'. + -- + -- TODO: some notion of error handling should be encoded into the type + -- + -- @since 0.1.0 + readFile :: Path -> m Text + +-- | The obvious instance for 'IO'. +-- +-- @since 0.1.0 +instance MonadReadFile IO where + readFile = Lens.view pathString .> Text.readFile + +-- | A placeholder (undecidable) instance that allows this constraint to +-- propagate through monad transformers without needing to 'lift' manually. +-- +-- @since 0.1.0 +instance ( MonadTrans t, Monad (t m), MonadReadFile m + ) => MonadReadFile (t m) where + readFile = readFile .> lift + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Parser.hs b/library/Language/Ninja/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Parser.hs @@ -0,0 +1,372 @@ +-- -*- 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 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 + +import Data.Maybe (Maybe (Just, Nothing)) +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 + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Pretty.hs b/library/Language/Ninja/Pretty.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Pretty.hs @@ -0,0 +1,218 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Pretty.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Language.Ninja.Pretty +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Rudimentary pretty-printers for various types in @language-ninja@. +-- +-- @since 0.1.0 +module Language.Ninja.Pretty + ( -- * Pretty-printer for 'Lexer.Lexeme' + prettyLexemes + , prettyLexeme + -- * Pretty-printer for @AST.'AST.Ninja'@ + , prettyNinja + , prettyExpr + , prettyRule + , prettySingle + , prettyMultiple + , prettyPhony + , prettyDefault + , prettyPool + , prettyBind + ) where + +import Control.Arrow (second) + +import qualified Control.Lens as Lens + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Lexer as Lexer + +import qualified Data.HashMap.Strict as HM + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Data.Char (isSpace) +import Data.Monoid ((<>)) + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +-- | Pretty-print a list of Ninja lexemes. +-- +-- @since 0.1.0 +prettyLexemes :: [Lexer.Lexeme ()] -> Text +prettyLexemes = map prettyLexeme .> mconcat + +-- | Pretty-print a Ninja lexeme. +-- +-- @since 0.1.0 +prettyLexeme :: Lexer.Lexeme () -> Text +prettyLexeme = go + where + go :: Lexer.Lexeme () -> Text + go (Lexer.LexDefine _ bind) = ppBind bind <> "\n" + go (Lexer.LexBind _ bind) = " " <> ppBind bind <> "\n" + go (Lexer.LexInclude _ file) = "include " <> ppFile file <> "\n" + go (Lexer.LexSubninja _ file) = "subninja " <> ppFile file <> "\n" + go (Lexer.LexBuild _ build) = "build " <> ppBuild build <> "\n" + go (Lexer.LexRule _ name) = "rule " <> ppName name <> "\n" + go (Lexer.LexPool _ name) = "pool " <> ppName name <> "\n" + go (Lexer.LexDefault _ exprs) = mconcat (map ppDefault exprs) + + + ppBind :: Lexer.LBind () -> Text + ppBind (Lexer.MkLBind _ name value) + = ppName name <> " = " <> prettyExpr value + + ppFile :: Lexer.LFile () -> Text + ppFile (Lexer.MkLFile expr) = prettyExpr expr + + ppName :: Lexer.LName () -> Text + ppName (Lexer.MkLName _ bs) = Text.decodeUtf8 bs + + ppBuild :: Lexer.LBuild () -> Text + ppBuild (Lexer.MkLBuild _ outs rule deps) + = [ Text.intercalate " " (map prettyExpr outs) + , " : ", ppName rule, " " + , Text.intercalate " " (map prettyExpr deps) + ] |> mconcat + + ppDefault :: AST.Expr () -> Text + ppDefault expr = "default " <> prettyExpr expr <> "\n" + +-------------------------------------------------------------------------------- + +-- | Pretty-print a 'AST.Ninja'. +-- +-- @since 0.1.0 +prettyNinja :: AST.Ninja () -> Text +prettyNinja ninja + = [ map prettyRule (HM.toList (Lens.view AST.ninjaRules ninja)) + , map prettySingle (HM.toList (Lens.view AST.ninjaSingles ninja)) + , map prettyMultiple (HM.toList (Lens.view AST.ninjaMultiples ninja)) + , map prettyPhony (HM.toList (Lens.view AST.ninjaPhonys ninja)) + , map prettyDefault (HS.toList (Lens.view AST.ninjaDefaults ninja)) + , map prettyPool (HM.toList (Lens.view AST.ninjaPools ninja)) + ] |> mconcat |> mconcat + +-- | Pretty-print an 'AST.Expr' +-- +-- @since 0.1.0 +prettyExpr :: AST.Expr () -> Text +prettyExpr = go .> mconcat + where + go (AST.Exprs _ es) = map prettyExpr es + go (AST.Lit _ text) = [text] + go (AST.Var _ name) = ["${", name, "}"] + +-- | Pretty-print a Ninja @rule@ declaration. +-- +-- @since 0.1.0 +prettyRule :: (Text, AST.Rule ()) -> Text +prettyRule (name, rule) = do + let binds = Lens.view AST.ruleBind rule + |> HM.toList + |> map (second prettyExpr .> prettyBind) + |> mconcat + mconcat ["rule ", name, "\n", binds] + +-- | Pretty-print a Ninja @build@ declaration with one output. +-- +-- @since 0.1.0 +prettySingle :: (Text, AST.Build ()) -> Text +prettySingle (output, build) = prettyMultiple (HS.singleton output, build) + +-- | Pretty-print a Ninja @build@ declaration with multiple outputs. +-- +-- @since 0.1.0 +prettyMultiple :: (HashSet Text, AST.Build ()) -> Text +prettyMultiple (outputs, build) = do + let prefixIfThere :: Text -> Text -> Text + prefixIfThere pfx rest = if Text.all isSpace rest then "" else pfx <> rest + + let unwordsSet :: HashSet Text -> Text + unwordsSet = HS.toList .> Text.unwords + + let ruleName = Lens.view AST.buildRule build + let deps = Lens.view AST.buildDeps build + let binds = Lens.view AST.buildBind build + let normal = Lens.view AST.depsNormal deps + let implicit = Lens.view AST.depsImplicit deps + let orderOnly = Lens.view AST.depsOrderOnly deps + + mconcat + [ "build ", Text.unwords (HS.toList outputs), ": " + , ruleName, " ", unwordsSet normal + , prefixIfThere " | " (unwordsSet implicit) + , prefixIfThere " || " (unwordsSet orderOnly), "\n" + , HM.toList binds |> map prettyBind |> mconcat + ] + +-- | Pretty-print a Ninja phony @build@ declaration. +-- +-- @since 0.1.0 +prettyPhony :: (Text, HashSet Text) -> Text +prettyPhony (name, inputs) + = [ ["build ", name, ": phony ", Text.unwords (HS.toList inputs)] + ] |> map mconcat |> Text.unlines + +-- | Pretty-print a Ninja @default@ declaration. +-- +-- @since 0.1.0 +prettyDefault :: Text -> Text +prettyDefault target + = [ ["default ", target] + ] |> map mconcat |> Text.unlines + +-- | Pretty-print a Ninja @pool@ declaration. +-- +-- @since 0.1.0 +prettyPool :: (Text, Int) -> Text +prettyPool (name, depth) + = [ ["pool ", name] + , [" depth = ", tshow depth] + ] |> map mconcat |> Text.unlines + +-- | Pretty-print a Ninja indented binding. +-- +-- @since 0.1.0 +prettyBind :: (Text, Text) -> Text +prettyBind (name, value) = mconcat [" ", name, " = ", value, "\n"] + +-------------------------------------------------------------------------------- + +tshow :: (Show s) => s -> Text +tshow = show .> Text.pack + +-------------------------------------------------------------------------------- diff --git a/library/Language/Ninja/Tutorial.hs b/library/Language/Ninja/Tutorial.hs new file mode 100644 --- /dev/null +++ b/library/Language/Ninja/Tutorial.hs @@ -0,0 +1,459 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: library/Language/Ninja/Tutorial.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : Language.Ninja.Tutorial +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +module Language.Ninja.Tutorial + ( -- * Introduction + -- $introduction + + -- * Lexing + -- $lexing + + -- * Parsing + -- $parsing + + -- * Abstract Syntax Tree + -- $ast + + -- * Compiling + -- $compiling + + -- * Intermediate Representation + -- $ir + + -- * Printing + -- $printing + + -- * Executables + -- $executables + + -- * Conclusion + -- $conclusion + ) where + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Compile as Compile +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.IR as IR +import qualified Language.Ninja.Lexer as Lexer +import qualified Language.Ninja.Misc as Misc +import qualified Language.Ninja.Mock as Mock +import qualified Language.Ninja.Parser as Parser +import qualified Language.Ninja.Pretty as Pretty + +import Data.Either (either) + +import Control.Lens (Iso', Lens', Prism') +import qualified Control.Lens as Lens + +import Control.Monad.Error.Class (MonadError) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +import Data.Versions (Version) + +-------------------------------------------------------------------------------- + +-- $introduction +-- +-- This library contains most of the utilities you would ever want for working +-- with the build language. +-- +-- In general, when using @language-ninja@, you'll want the following imports: +-- +-- @ +-- import qualified "Language.Ninja.AST" as AST +-- import qualified "Language.Ninja.IR" as IR +-- import qualified "Language.Ninja.Errors" as Errors +-- import qualified "Language.Ninja.Misc" as Misc +-- import qualified "Language.Ninja.Mock" as Mock +-- import qualified "Language.Ninja.Lexer" as Lexer +-- import qualified "Language.Ninja.Parser" as Parser +-- import qualified "Language.Ninja.Pretty" as Pretty +-- import qualified "Language.Ninja.Compile" as Compile +-- @ +-- +-- For this tutorial, we will also use some other imports: +-- +-- @ +-- import "Control.Lens" ('Iso'', 'Lens'', 'Prism'') +-- import qualified "Control.Lens" as Lens +-- +-- import "Control.Monad.Error.Class" ('MonadError') +-- +-- import "Data.Either" ('either') +-- +-- import "Data.Text" ('Text') +-- import qualified "Data.Text" as Text +-- +-- import "Data.HashSet" ('HashSet') +-- import qualified "Data.HashSet" as HS +-- +-- import "Data.HashMap.Strict" ('HashMap') +-- import qualified "Data.HashMap.Strict" as HM +-- +-- import "Data.Versions" ('Version') +-- @ + +-------------------------------------------------------------------------------- + +-- $lexing +-- +-- To lex a Ninja file, we use the "Language.Ninja.Lexer" module. +-- This results in a list of _annotated_ lexemes: +-- +-- @lexFileIO "./build.ninja" :: IO (Lexer.'Lexer.Lexeme' Lexer.'Lexer.Ann')@ +-- +-- For more specialized use cases, consult the module documentation. + +-------------------------------------------------------------------------------- + +-- $parsing +-- +-- To parse a Ninja file, we use the "Language.Ninja.Parse" module. +-- In the simplest case, this amounts to parsing a file: +-- +-- @ast <- (Parser.'Parser.parseFileIO' "./build.ninja") :: IO AST.'AST.Ninja'@ +-- +-- For more specialized use cases, consult the module documentation. + +-------------------------------------------------------------------------------- + +-- $ast +-- +-- Now that we have parsed the Ninja file, we can take a look at the AST: +-- +-- @ +-- let look lens = Lens.'Lens.view' lens ast +-- look AST.'AST.ninjaRules' :: 'HashMap' 'Text' AST.'AST.Rule' +-- look AST.'AST.ninjaSingles' :: 'HashMap' 'Text' AST.'AST.Build' +-- look AST.'AST.ninjaMultiples' :: 'HashMap' ('HashSet' 'Text') AST.'AST.Build' +-- look AST.'AST.ninjaPhonys' :: 'HashMap' 'Text' ('HashSet' 'Text') +-- look AST.'AST.ninjaDefaults' :: 'HashSet' 'Text' +-- look AST.'AST.ninjaPools' :: 'HashMap' 'Text' 'Int' +-- look AST.'AST.ninjaSpecials' :: 'HashMap' 'Text' 'Text' +-- @ +-- +-- [@AST.'AST.ninjaRules'@] +-- This field corresponds to the @rule@ declarations in the parsed Ninja file. +-- Specifically, it is a map from rule names (as 'Text') to @AST.'AST.Rule'@s. +-- +-- [@AST.'AST.ninjaSingles'@] +-- This field contains the set of all non-phony @build@ declarations with +-- exactly one output. Specifically, it is a map from the build output name +-- to an @AST.'AST.Build'@. +-- +-- [@AST.'AST.ninjaMultiples'@] +-- This field contains the set of all non-phony @build@ declarations with +-- two or more outputs. Specifically, it is a map from the set of outputs to +-- the corresponding @AST.'AST.Build'@. +-- +-- [@AST.'AST.ninjaPhonys'@] +-- This field contains the set of all phony @build@ declarations, as a map +-- from the output name to the set of dependencies. If a phony @build@ has +-- multiple outputs, it will naturally be expanded to multiple entries in +-- this hash map. +-- +-- [@AST.'AST.ninjaDefaults'@] +-- This field contains the set of all targets referenced in @default@ +-- declarations. +-- +-- [@AST.'AST.ninjaPools'@] +-- This field contains the set of all pools defined in the Ninja file, +-- represented as a mapping from the pool name to the pool depth. +-- +-- [@AST.'AST.ninjaSpecials'@] +-- This field contains the set of all "special" top-level variables defined +-- in the Ninja file, as a mapping from the variable name to the variable +-- value. As it stands, this map will only ever have at most two keys: +-- @ninja_required_version@ and @builddir@. For more on these variables, look +-- at the manual . +-- +-- == @AST.'AST.Rule'@ +-- +-- A value of type @AST.'AST.Rule'@ is essentially the set of variables that +-- are bound in a @rule@ body, represented as a map from the variable ('Text') +-- to its unevaluated definition (@AST.'AST.Expr'@). The underlying 'HashMap' +-- can be extracted with @AST.'AST.ruleBind'@. +-- +-- == @AST.'AST.Build'@ +-- +-- A value of type @AST.'AST.Build'@ contains four pieces of information: +-- +-- [@AST.'AST.buildRule' :: 'Lens'' AST.'AST.Build' 'Text'@] +-- The name of the @rule@ associated with this @build@ declaration. +-- [@AST.'AST.buildDeps' :: 'Lens'' AST.'AST.Build' AST.'AST.Deps'@] +-- The set of dependencies for this @build@ declaration. +-- [@AST.'AST.buildEnv' :: 'Lens'' AST.'AST.Build' (AST.'AST.Env' 'Text' 'Text')@] +-- The set of file-level variables in scope when the @build@ declaration +-- was parsed. +-- [@AST.'AST.buildBind' :: 'Lens'' AST.'AST.Build' ('HashMap' 'Text' 'Text')@] +-- The set of bindings (indented @key = value@ pairs) for this @build@ +-- declaration. +-- +-- == @AST.'AST.Deps'@ +-- +-- A value of type @AST.'AST.Deps'@ contains three pieces of information: +-- +-- [@AST.'AST.depsNormal' :: 'Lens'' AST.'AST.Deps' ('HashSet' 'Text')@] +-- The set of "normal" (explicit) dependencies for a @build@ declaration. +-- [@AST.'AST.depsImplicit' :: 'Lens'' AST.'AST.Deps' ('HashSet' 'Text')@] +-- The set of "implicit" dependencies for a @build@ declaration. +-- [@AST.'AST.depsOrderOnly' :: 'Lens'' AST.'AST.Deps' ('HashSet' 'Text')@] +-- The set of "order-only" dependencies for a @build@ declaration. +-- +-- section of the +-- Ninja manual describes in detail the differences between explicit, implicit, +-- and order-only dependencies. + +-------------------------------------------------------------------------------- + +-- $compiling +-- +-- To compile a Ninja AST (@AST.'AST.Ninja'@) to the Ninja intermediate +-- representation, we use @compile@ from the "Language.Ninja.Compile" module. +-- In the simplest case, this looks like: +-- +-- @ +-- let handleError :: Either Errors.'Errors.CompileError' a -> IO a +-- handleError = 'either' ('fail' . 'show') 'pure' +-- ir <- handleError (Compile.'Compile.compile' ast) +-- @ +-- +-- Since @Compile.'Compile.compile'@ returns in any monad with an instance +-- of @'MonadError' Errors.'Errors.CompileError'@, it is quite flexible. +-- +-- For simplicity in this case, however, we use +-- @Either Errors.'Errors.CompileError' AST.'AST.Ninja'@ +-- and convert to @IO@ by calling 'fail' when it fails. + +-------------------------------------------------------------------------------- + +-- $ir +-- +-- The @language-ninja@ intermediate representation, as defined in the +-- "Language.Ninja.IR" module, is a reduced form of the Ninja AST that handles +-- as much of the static semantics of Ninja as possible. +-- +-- The Ninja IR does not have any notion of variables/scoping, does not contain +-- unrestricted hash maps or environments, and has the @rule@ declarations +-- inlined into the @build@ nodes, thus eliminating the "polymorphism" +-- associated with the @$in@ and @$out@ Ninja variables. +-- +-- Since we have now compiled the Ninja AST, we can take a look at the IR: +-- +-- @ +-- let look lens = Lens.'Lens.view' lens ir +-- look IR.'IR.ninjaMeta' :: IR.'IR.Meta' +-- look IR.'IR.ninjaBuilds' :: 'HashSet' IR.'IR.Build' +-- look IR.'IR.ninjaPhonys' :: 'HashMap' IR.'IR.Target' ('HashSet' IR.'IR.Target') +-- look IR.'IR.ninjaDefaults' :: 'HashSet' IR.'IR.Target' +-- look IR.'IR.ninjaPools' :: 'HashSet' IR.'IR.Pool' +-- @ +-- +-- These fields correspond to more well-typed versions of their counterparts +-- in the AST. The main differences to note are: +-- +-- 1. @AST.'AST.ninjaSpecials'@ is used to compute @IR.'IR.ninjaMeta'@. +-- 2. 'Text' has mostly been replaced with @IR.'IR.Target'@ where relevant. +-- 3. @AST.'AST.ninjaSingles'@ and @AST.'AST.ninjaMultiples'@ have been merged +-- into a single field: @IR.'IR.ninjaBuilds'@. +-- 4. @AST.'AST.ninjaRules'@ is gone; the @rule@s are now inlined into the +-- @build@s that use them. +-- +-- == @IR.'IR.Meta'@ +-- +-- A value of type @IR.'IR.Meta'@ contains two pieces of information: +-- +-- [@IR.'IR.metaReqVersion' :: 'Lens'' IR.'IR.Meta' (Maybe 'Version')@] +-- The parsed Ninja version required to build this file. +-- This corresponds to the @ninja_required_version@ top-level variable. +-- [@IR.'IR.metaBuildDir' :: 'Lens'' IR.'IR.Meta' (Maybe Misc.'Misc.Path')@] +-- This corresponds to the @builddir@ top-level variable. +-- +-- == @IR.'IR.Build'@ +-- +-- A value of type @IR.'IR.Build'@ contains three pieces of information: +-- +-- [@IR.'IR.buildRule' :: 'Lens'' IR.'IR.Build' IR.'IR.Rule'@] +-- The @rule@ associated with this @build@ declaration. +-- [@IR.'IR.buildOuts' :: 'Lens'' IR.'IR.Build' ('HashSet' IR.'IR.Output')@] +-- The set of outputs for this @build@ declaration. +-- [@IR.'IR.buildDeps' :: 'Lens'' IR.'IR.Build' ('HashSet' IR.'IR.Dependency')@] +-- The set of dependencies for this @build@ declaration. +-- +-- == @IR.'IR.Rule'@ +-- +-- A value of type @IR.'IR.Rule'@ contains a lot of information. For brevity, +-- we will simply list the lens names and types; refer to the module +-- documentation ("Language.Ninja.IR.Rule") for more information. +-- +-- @ +-- IR.'IR.ruleName' :: 'Lens'' IR.'IR.Rule' 'Text' +-- IR.'IR.ruleCommand' :: 'Lens'' IR.'IR.Rule' Misc.'Misc.Command' +-- IR.'IR.ruleDescription' :: 'Lens'' IR.'IR.Rule' (Maybe 'Text') +-- IR.'IR.rulePool' :: 'Lens'' IR.'IR.Rule' IR.'IR.PoolName' +-- IR.'IR.ruleDepfile' :: 'Lens'' IR.'IR.Rule' (Maybe Misc.'Misc.Path') +-- IR.'IR.ruleSpecialDeps' :: 'Lens'' IR.'IR.Rule' (Maybe IR.'IR.SpecialDeps') +-- IR.'IR.ruleGenerator' :: 'Lens'' IR.'IR.Rule' Bool +-- IR.'IR.ruleRestat' :: 'Lens'' IR.'IR.Rule' Bool +-- IR.'IR.ruleResponseFile' :: 'Lens'' IR.'IR.Rule' (Maybe IR.'IR.ResponseFile') +-- @ +-- +-- == @IR.'IR.Pool'@ +-- +-- A value of type @IR.'IR.Pool'@ has a name (@IR.'IR.poolName'@) and a +-- depth (@IR.'IR.poolDepth'@). This type is correct-by-construction; it should +-- not be possible to construct a @'IR.Pool'@ that does not correspond to a +-- valid pool definition or reference. + +-------------------------------------------------------------------------------- + +-- $printing +-- +-- Currently there is a rudimentary pretty-printer for the lexemes and the AST +-- in the "Language.Ninja.Pretty" module. It simply returns 'Text' such that if +-- +-- @ +-- let pretty = 'pure' . Pretty.'Pretty.prettyNinja' +-- let parse = Parser.'Parser.parseTextIO' +-- @ +-- +-- then @pretty >=> parse >=> pretty >=> parse@ should be the same as @pure@, +-- modulo read-only side effects and annotations. +-- +-- There are plans to write a pretty-printer for the IR. This would be very +-- useful for generating Ninja. + +-------------------------------------------------------------------------------- + +-- $executables +-- +-- In addition to the library described above, this package also ships with +-- three executables: @ninja-lex@, @ninja-parse@, and @ninja-compile@. +-- These expose the corresponding module by using the Aeson instances to render +-- the lexed\/parsed\/compiled source. +-- +-- == @ninja-lex@ +-- +-- The command-line interface for @ninja-lex@ looks like this: +-- +-- > $ ninja-lex --help +-- > ninja-lex version 0.1.0 +-- > +-- > Usage: ninja-lex (process | pretty) +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > +-- > Available commands: +-- > process +-- > pretty +-- +-- > $ ninja-lex process --help +-- > Usage: ninja-lex process [--input FILEPATH] [--output FILEPATH] +-- > [--machine-readable] +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > --input FILEPATH Read the given FILEPATH as a Ninja file. +-- > --output FILEPATH Output to the given FILEPATH instead of /dev/stdout. +-- > --machine-readable Should the output be fully machine-readable? +-- +-- > $ ninja-lex pretty --help +-- > Usage: ninja-lex pretty [--input FILEPATH] [--output FILEPATH] [--color] +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > --input FILEPATH Read the given FILEPATH as a Ninja file. +-- > --output FILEPATH Output to the given FILEPATH instead of /dev/stdout. +-- > --color Should the output use ANSI color? +-- +-- == @ninja-parse@ +-- +-- The command-line interface for @ninja-parse@ looks like this: +-- +-- > $ ninja-parse --help +-- > ninja-parse version 0.1.0 +-- > +-- > Usage: ninja-parse (process | pretty) +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > +-- > Available commands: +-- > process +-- > pretty +-- +-- > $ ninja-parse process --help +-- > Usage: ninja-parse process [--input FILEPATH] [--output FILEPATH] +-- > [--machine-readable] +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > --input FILEPATH Read the given FILEPATH as a Ninja file. +-- > --output FILEPATH Output to the given FILEPATH instead of /dev/stdout. +-- > --machine-readable Should the output be fully machine-readable? +-- +-- > $ ninja-parse pretty --help +-- > Usage: ninja-parse pretty [--input FILEPATH] [--output FILEPATH] [--color] +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > --input FILEPATH Read the given FILEPATH as a Ninja file. +-- > --output FILEPATH Output to the given FILEPATH instead of /dev/stdout. +-- > --color Should the output use ANSI color? +-- +-- == @ninja-compile@ +-- +-- The command-line interface for @ninja-compile@ looks like this: +-- +-- > $ ninja-compile --help +-- > ninja-compile version 0.1.0 +-- > +-- > Usage: ninja-compile [--input FILEPATH] [--output FILEPATH] [--machine-readable] +-- > +-- > Available options: +-- > -h,--help Show this help text +-- > --input FILEPATH Read the given FILEPATH as a Ninja file. +-- > --output FILEPATH Output to the given FILEPATH instead of /dev/stdout. +-- > --machine-readable Should the output be fully machine-readable? + +-------------------------------------------------------------------------------- + +-- $conclusion +-- +-- I hope these tools will be useful to you for whatever task you want to do +-- with the Ninja language. Happy hacking! + +-------------------------------------------------------------------------------- diff --git a/tests/DocTests.hs b/tests/DocTests.hs new file mode 100644 --- /dev/null +++ b/tests/DocTests.hs @@ -0,0 +1,40 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- The @language-ninja@ documentation tests. +module Main (main) where + +import qualified Build_doctests as DC +import Data.Foldable (traverse_) +import Test.DocTest (doctest) + +-------------------------------------------------------------------------------- + +main :: IO () +main = let args = DC.flags ++ DC.pkgs ++ DC.module_sources + in traverse_ putStrLn args >> doctest args + +-------------------------------------------------------------------------------- diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,554 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- The @language-ninja@ test suite. +module Main (main) where + +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) + +import qualified Data.Typeable as Ty + +import Data.Text (Text) + +import Control.Exception (displayException) +import Control.Monad (forM, unless, void) +import Control.Monad.Identity (Identity) +import Control.Monad.Trans.Except (ExceptT, runExceptT) + +import qualified Control.Lens as Lens + +import qualified Language.Ninja.AST.Env as AST (Maps) + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Compile as Compile +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.IR as IR +import qualified Language.Ninja.Lexer as Lexer +import qualified Language.Ninja.Misc as Misc +import qualified Language.Ninja.Parser as Parser +import qualified Language.Ninja.Pretty as Pretty + +import Test.Tasty (TestName, TestTree) + +import qualified Test.Tasty as Test +import qualified Test.Tasty.HUnit as Test +import qualified Test.Tasty.Ingredients as Test +import qualified Test.Tasty.Options as Test +import qualified Test.Tasty.Runners.Html as Test + +import qualified Test.Tasty.QuickCheck as Test.QC +import qualified Test.Tasty.SmallCheck as Test.SC + +import qualified Test.Tasty.Lens.Iso as Test.Iso +import qualified Test.Tasty.Lens.Lens as Test.Lens +import qualified Test.Tasty.Lens.Prism as Test.Prism + +import Test.QuickCheck ((===)) +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Instances () + +import qualified Test.SmallCheck.Series as SC + +import Filesystem.Path.CurrentOS (()) +import qualified Filesystem.Path.CurrentOS as FP + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Turtle + +import Flow ((.>), (|>)) + +import qualified Tests.Lint as Lint +import Tests.Orphans () +import qualified Tests.ReferenceLexer as RefLex + +-------------------------------------------------------------------------------- + +dataPrefix :: String +dataPrefix = "./tests/data/" + +testFiles :: [String] +testFiles = [ "buildseparate" + , "compdb" + , "lexical" + , "lint" + , "nocreate" + , "outputtouch" + , "phonyorder" + , "redefine" + , "test1" + , "test2" + , "test3" + , "test4" + , "test5" + , "test6" + ] + +aesonSC' :: (Eq x, Show x) + => SC.Series IO x + -> (x -> Aeson.Value) + -> (Aeson.Value -> Aeson.Parser x) + -> TestTree +aesonSC' s toJ fromJ + = Test.SC.testProperty "parseJSON . toJSON ≡ₛ pure" + (Test.SC.over s (\x -> Aeson.parseEither fromJ (toJ x) == Right x)) + +aesonSC :: forall x. + ( Eq x, Show x, SC.Serial IO x, Aeson.ToJSON x, Aeson.FromJSON x + ) => Ty.Proxy x -> TestTree +aesonSC _ = aesonSC' @x SC.series Aeson.toJSON Aeson.parseJSON + +aesonQC' :: (Eq x, Show x) + => (QC.Gen x, x -> [x]) + -> (x -> Aeson.Value) + -> (Aeson.Value -> Aeson.Parser x) + -> TestTree +aesonQC' (gen, shrink) toJ fromJ + = Test.QC.testProperty "parseJSON . toJSON ≡ₐ pure" + (Test.QC.forAllShrink gen shrink + (\x -> Aeson.parseEither fromJ (toJ x) === Right x)) + +aesonQC :: forall x. + ( Eq x, Show x, QC.Arbitrary x, Aeson.ToJSON x, Aeson.FromJSON x + ) => Ty.Proxy x -> TestTree +aesonQC _ = aesonQC' @x (QC.arbitrary, QC.shrink) Aeson.toJSON Aeson.parseJSON + +parseTestNinja :: String -> IO (AST.Ninja ()) +parseTestNinja name = do + old <- Turtle.pwd + Turtle.cd (FP.decodeString dataPrefix) + let file = Lens.view (Lens.from Misc.pathString) (name <> ".ninja") + result <- Parser.parseFileIO file >>= void .> pure + Turtle.cd old + pure result + +lexerEquivalentTest :: String -> IO () +lexerEquivalentTest name = do + let file = dataPrefix <> name <> ".ninja" + |> Lens.view (Lens.from Misc.pathString) + + let oldLexer :: Misc.Path -> ExceptT Errors.ParseError IO [Lexer.Lexeme ()] + oldLexer = RefLex.lexFile + + let newLexer :: Misc.Path -> ExceptT Errors.ParseError IO [Lexer.Lexeme ()] + newLexer = Lexer.lexFile .> fmap (map void) + + expected <- runExceptT (oldLexer file) + actual <- runExceptT (newLexer file) + + unless (expected == actual) $ do + Test.assertEqual "prefix" expected actual + +roundtripTest :: AST.Ninja () -> IO () +roundtripTest ninja = do + let withTempDir :: (FP.FilePath -> IO a) -> IO a + withTempDir = Turtle.with (Turtle.mktempdir "." "test") + + (expected, actual) <- withTempDir $ \tmpdir -> do + let prettyInput = Pretty.prettyNinja ninja + let tmpfile = tmpdir "generated.ninja" + Turtle.writeTextFile tmpfile prettyInput + output <- Parser.parseFileIO (Lens.view (Lens.from Misc.pathFP) tmpfile) + >>= void .> pure + let prettyOutput = Pretty.prettyNinja output + pure (prettyInput, prettyOutput) + + unless (expected == actual) $ do + -- let actualJ = Aeson.toJSON actual + -- let expectedJ = Aeson.toJSON expected + -- -- LBSC8.putStrLn (Aeson.encodePretty (Aeson.diff actualJ expectedJ)) + -- LBSC8.putStrLn (Aeson.encodePretty expectedJ) + -- LBSC8.putStrLn (Aeson.encodePretty actualJ) + -- Aeson.encode actualJ `H.shouldBe` Aeson.encode expectedJ + Test.assertEqual "prefix" expected actual + +compileTest :: AST.Ninja () -> IO () +compileTest ninja = void $ do + either (displayException .> fail) pure (Compile.compile ninja) + +ninjaTests :: String -> AST.Ninja () -> TestTree +ninjaTests name ninja + = Test.testGroup (name <> ".ninja") + [ Test.testCase "compare lexer against reference implementation" $ do + lexerEquivalentTest name + , Test.testCase "roundtrip through parser and pretty-printer" $ do + roundtripTest ninja + , Test.testCase "compile to Ninja" $ do + compileTest ninja + ] + +aesonTests :: TestTree +aesonTests + = Test.testGroup "aeson" + [ testModule "Language.Ninja.Lexer" + [ testAesonSC 2 (Ty.Proxy @(Lexer.Lexeme Bool)) + , testAesonSC 4 (Ty.Proxy @(Lexer.LName Bool)) + , testAesonSC 4 (Ty.Proxy @(Lexer.LFile Bool)) + , testAesonSC 4 (Ty.Proxy @(Lexer.LBind Bool)) + , testAesonSC 2 (Ty.Proxy @(Lexer.LBuild Bool)) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Build" + [ testAesonSC 2 (Ty.Proxy @IR.Build) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Meta" + [ testAesonSC def (Ty.Proxy @IR.Meta) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Ninja" + [ testAesonSC 2 (Ty.Proxy @IR.Ninja) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Pool" + [ testAesonSC def (Ty.Proxy @IR.Pool) + , testAesonSC def (Ty.Proxy @IR.PoolName) + , testAesonSC def (Ty.Proxy @IR.PoolDepth) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Rule" + [ testAesonSC 1 (Ty.Proxy @IR.Rule) + , testAesonSC def (Ty.Proxy @IR.SpecialDeps) + , testAesonSC def (Ty.Proxy @IR.ResponseFile) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.IR.Target" + [ testAesonSC def (Ty.Proxy @IR.Target) + , testAesonSC def (Ty.Proxy @IR.Output) + , testAesonSC def (Ty.Proxy @IR.Dependency) + , testAesonSC def (Ty.Proxy @IR.DependencyType) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.AST.Env" + [ testAesonSC def (Ty.Proxy @(AST.Env Text Text)) + , testAesonQC (Ty.Proxy @(AST.Env Text Text)) + ] + , testModule "Language.Ninja.AST.Expr" + [ testAesonSC def (Ty.Proxy @(AST.Expr Bool)) + , testAesonQC (Ty.Proxy @(AST.Expr Bool)) + ] + , testModule "Language.Ninja.AST.Rule" + [ testAesonSC def (Ty.Proxy @(AST.Rule Bool)) + , testAesonQC (Ty.Proxy @(AST.Rule Bool)) + ] + , testModule "Language.Ninja.AST.Ninja" + [ -- TODO: combinatorial explosion + testAesonSC 0 (Ty.Proxy @(AST.Ninja Bool)) + -- , testAesonQC (Ty.Proxy @(AST.Ninja Bool)) + ] + , testModule "Language.Ninja.AST.Build" + [ -- TODO: combinatorial explosion + testAesonSC 1 (Ty.Proxy @(AST.Build Bool)) + -- , testAesonQC (Ty.Proxy @(AST.Build Bool)) + ] + , testModule "Language.Ninja.AST.Deps" + [ testAesonSC def (Ty.Proxy @(AST.Deps Bool)) + , testAesonQC (Ty.Proxy @(AST.Deps Bool)) + ] + , testModule "Language.Ninja.Misc.Command" + [ testAesonSC def (Ty.Proxy @Misc.Command) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.Misc.Path" + [ testAesonSC def (Ty.Proxy @Misc.Path) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.Misc.Located" + [ testAesonSC def (Ty.Proxy @(Misc.Located Bool)) + , testAesonSC def (Ty.Proxy @Misc.Position) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + , testModule "Language.Ninja.Misc.IText" + [ testAesonSC def (Ty.Proxy @Misc.IText) + -- TODO: add Arbitrary instances so we can testAesonQC + ] + ] + where + testAesonSC :: forall x. + ( Eq x, Show x, Ty.Typeable x, SC.Serial IO x + , Aeson.ToJSON x, Aeson.FromJSON x + ) => Int -> Ty.Proxy x -> Maybe TestTree + testAesonSC d p = withDepth d + (testType p + [Test.testGroup "ToJSON/FromJSON Laws" [aesonSC p]]) + + testAesonQC :: forall x. + ( Eq x, Show x, Ty.Typeable x, QC.Arbitrary x + , Aeson.ToJSON x, Aeson.FromJSON x + ) => Ty.Proxy x -> Maybe TestTree + testAesonQC p = Just (testType p + [Test.testGroup "ToJSON/FromJSON Laws" [aesonQC p]]) + + withDepth :: Int -> (TestTree -> Maybe TestTree) + withDepth 0 = const Nothing + withDepth depth = Test.localOption (Test.SC.SmallCheckDepth depth) .> Just + + testModule :: TestName -> [Maybe TestTree] -> TestTree + testModule name subtrees = Test.testGroup name (catMaybes subtrees) + + testType :: forall x. (Ty.Typeable x) + => Ty.Proxy x -> [TestTree] -> TestTree + testType p subtrees = Test.localOption typeTimeout + $ Test.testGroup (printProxy p) subtrees + + printProxy :: forall x. (Ty.Typeable x) => Ty.Proxy x -> String + printProxy p = Ty.showsTypeRep (Ty.typeRep p) "" + + def :: Int + def = (Test.defaultValue :: Test.SC.SmallCheckDepth) + |> toInteger |> fromIntegral + + typeTimeout :: Test.Timeout + typeTimeout = Test.mkTimeout 20000000 -- 20 seconds + +opticsTests :: TestTree +opticsTests + = Test.testGroup "optics" + [ testModule "Language.Ninja.IR.Build" + [ testType "Build" [] -- TODO: combinatorial explosion + -- [ testLens 1 "buildRule" IR.buildRule + -- , testLens 1 "buildOuts" IR.buildOuts + -- , testLens 1 "buildDeps" IR.buildDeps + -- ] + ] + , testModule "Language.Ninja.IR.Meta" + [ testType "Meta" + [ testLens def "metaReqVersion" IR.metaReqVersion + , testLens def "metaBuildDir" IR.metaBuildDir + ] + ] + , testModule "Language.Ninja.IR.Ninja" + [ testType "Ninja" [] -- TODO: combinatorial explosion + -- [ testLens 1 "ninjaMeta" IR.ninjaMeta + -- , testLens 1 "ninjaBuilds" IR.ninjaBuilds + -- , testLens 1 "ninjaPhonys" IR.ninjaPhonys + -- , testLens 1 "ninjaDefaults" IR.ninjaDefaults + -- , testLens 1 "ninjaPools" IR.ninjaPools + -- ] + ] + , testModule "Language.Ninja.IR.Pool" + [ testType "Pool" + [ + ] + , testType "PoolName" + [ testIso def "poolNameText" IR.poolNameText + ] + , testType "PoolDepth" + [ testIso def "poolDepthPositive" IR.poolDepthPositive + ] + ] + , testModule "Language.Ninja.IR.Rule" + [ testType "Rule" [] -- TODO: combinatorial explosion + -- [ testLens 1 "ruleName" IR.ruleName + -- , testLens 1 "ruleCommand" IR.ruleCommand + -- , testLens 1 "ruleDescription" IR.ruleDescription + -- , testLens 1 "rulePool" IR.rulePool + -- , testLens 1 "ruleDepfile" IR.ruleDepfile + -- , testLens 1 "ruleSpecialDeps" IR.ruleSpecialDeps + -- , testLens 1 "ruleGenerator" IR.ruleGenerator + -- , testLens 1 "ruleRestat" IR.ruleRestat + -- , testLens 1 "ruleResponseFile" IR.ruleResponseFile + -- ] + , testType "SpecialDeps" + [ testPrism def "_SpecialDepsGCC" IR._SpecialDepsGCC + , testPrism def "_SpecialDepsMSVC" IR._SpecialDepsMSVC + ] + , testType "ResponseFile" + [ testLens def "responseFilePath" IR.responseFilePath + , testLens def "responseFileContent" IR.responseFileContent + ] + ] + , testModule "Language.Ninja.IR.Target" + [ testType "Target" + [ testIso def "targetIText" IR.targetIText + , testIso def "targetText" IR.targetText + ] + , testType "Output" + [ testLens def "outputTarget" IR.outputTarget + ] + , testType "Dependency" + [ testLens def "dependencyTarget" IR.dependencyTarget + , testLens def "dependencyType" IR.dependencyType + ] + , testType "DependencyType" + [ testPrism def "_NormalDependency" IR._NormalDependency + , testPrism def "_OrderOnlyDependency" IR._OrderOnlyDependency + ] + ] + , testModule "Language.Ninja.AST.Env" + [ testType "Env" + [ testIso 1 "fromEnv" + (AST.fromEnv :: Lens.Iso' (AST.Env Text Int) (AST.Maps Text Int)) + ] + ] + , testModule "Language.Ninja.AST.Expr" + [ testType "Expr" + [ testPrism 4 "_Exprs" (AST._Exprs @Bool) + , testPrism 4 "_Lit" (AST._Lit @Bool) + , testPrism 4 "_Var" (AST._Var @Bool) + ] + ] + , testModule "Language.Ninja.AST.Rule" + [ testType "Rule" + [ testLens 4 "ruleBind" (AST.ruleBind @Bool) + ] + ] + , testModule "Language.Ninja.AST.Ninja" + [ testType "Ninja" [] -- TODO: combinatorial explosion + -- [ testLens 1 "ninjaRules" (AST.ninjaRules @Bool) + -- , testLens 1 "ninjaSingles" (AST.ninjaSingles @Bool) + -- , testLens 1 "ninjaMultiples" (AST.ninjaMultiples @Bool) + -- , testLens 1 "ninjaPhonys" (AST.ninjaPhonys @Bool) + -- , testLens 1 "ninjaDefaults" (AST.ninjaDefaults @Bool) + -- , testLens 1 "ninjaSpecials" (AST.ninjaSpecials @Bool) + -- ] + ] + , testModule "Language.Ninja.AST.Build" + [ testType "Build" [] -- TODO: combinatorial explosion + -- [ testLens 1 "buildRule" (AST.buildRule @Bool) + -- , testLens 1 "buildEnv" (AST.buildEnv @Bool) + -- , testLens 1 "buildDeps" (AST.buildDeps @Bool) + -- , testLens 1 "buildBind" (AST.buildBind @Bool) + -- ] + ] + , testModule "Language.Ninja.AST.Deps" + [ testType "Deps" + [ testLens def "depsNormal" (AST.depsNormal @Bool) + , testLens def "depsImplicit" (AST.depsImplicit @Bool) + , testLens def "depsOrderOnly" (AST.depsOrderOnly @Bool) + ] + ] + , testModule "Language.Ninja.Misc.Command" + [ testType "Command" + [ testIso def "commandText" Misc.commandText + ] + ] + , testModule "Language.Ninja.Misc.Path" + [ testType "Path" + [ testIso def "pathIText" Misc.pathIText + , testIso def "pathText" Misc.pathText + , testIso def "pathString" Misc.pathString + , testIso def "pathFP" Misc.pathFP + ] + ] + , testModule "Language.Ninja.Misc.Located" + [ testType "Located" + [ testLens 4 "locatedPos" + (Misc.locatedPos :: Lens.Lens' (Misc.Located Bool) Misc.Position) + , testLens 4 "locatedVal" + (Misc.locatedVal :: Lens.Lens' (Misc.Located Bool) Bool) + ] + , testType "Position" + [ testLens 4 "positionFile" Misc.positionFile + , testLens 4 "positionLine" Misc.positionLine + , testLens 4 "positionCol" Misc.positionCol + ] + ] + , testModule "Language.Ninja.Misc.IText" + [ testType "IText" + [ testIso def "itext" Misc.itext + ] + ] + ] + where + testIso :: ( Eq s, Eq a, Show s, Show a + , SC.Serial Identity s, SC.Serial IO s, SC.CoSerial IO s + , SC.Serial Identity a, SC.Serial IO a, SC.CoSerial IO a + ) => Int -> TestName -> Lens.Iso' s a -> TestTree + testLens :: ( Eq s, Eq a, Show s, Show a + , SC.Serial IO s, SC.Serial IO a + , SC.Serial Identity a, SC.CoSerial IO a + ) => Int -> TestName -> Lens.Lens' s a -> TestTree + testPrism :: ( Eq s, Eq a, Show s, Show a + , SC.Serial IO s, SC.Serial IO a + , SC.Serial Identity a, SC.CoSerial IO a + ) => Int -> TestName -> Lens.Prism' s a -> TestTree + testIso d name i = withDepth d $ Test.testGroup name [Test.Iso.test i] + testLens d name l = withDepth d $ Test.testGroup name [Test.Lens.test l] + testPrism d name p = withDepth d $ Test.testGroup name [Test.Prism.test p] + + withDepth :: Int -> (TestTree -> TestTree) + withDepth depth = Test.localOption (Test.SC.SmallCheckDepth depth) + + testModule :: TestName -> [TestTree] -> TestTree + testModule = Test.testGroup + + testType :: TestName -> [TestTree] -> TestTree + testType name subtrees = Test.localOption typeTimeout + $ Test.testGroup name subtrees + + def :: Int + def = (Test.defaultValue :: Test.SC.SmallCheckDepth) + |> toInteger |> fromIntegral + + typeTimeout :: Test.Timeout + typeTimeout = Test.mkTimeout 20000000 -- 20 seconds + +ingredients :: IO [Test.Ingredient] +ingredients = [ [Test.htmlRunner] + , Test.defaultIngredients + ] |> mconcat |> pure + +testTree :: IO TestTree +testTree = do + ninjas <- forM testFiles parseTestNinja + + haddockTests <- Lint.emptyLintHaddockOptions + |> Lint.addComponentName "language-ninja" + |> Lint.lintHaddock + + let tests = Test.testGroup "language-ninja" + [ Test.testGroup "golden" + (fmap (uncurry ninjaTests) (zip testFiles ninjas)) + , aesonTests + , opticsTests + , haddockTests + ] + pure tests + +test :: IO () +test = do + is <- ingredients + tree <- testTree + Test.defaultMainWithIngredients is tree + +main :: IO () +main = do + test + +-------------------------------------------------------------------------------- diff --git a/tests/Tests/Lint.hs b/tests/Tests/Lint.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Lint.hs @@ -0,0 +1,240 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests/Lint.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Tests.Lint +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Tests that involve linting the project. +-- In particular, Haddock linting is currently supported. +module Tests.Lint + ( lintHaddock + + , LintHaddockOptions + , emptyLintHaddockOptions + , addComponentName, addSinceException, addHaddockArgument + , modifyComponentNames, modifySinceExceptions, modifyHaddockArguments + + , ComponentName, SinceException + ) where + +import Control.Applicative (empty) +import Control.Arrow ((&&&)) +import Control.Monad (forM) + +import Data.Functor.Identity (runIdentity) +import Data.Maybe (catMaybes, isJust) +import Data.Monoid ((<>)) + +import Flow ((.>), (|>)) + +import qualified GHC +import qualified Outputable as GHC + +import qualified Data.Map.Lazy as LMap + +import qualified Data.Text as Text + +import qualified Documentation.Haddock as H +import qualified Documentation.Haddock.Types as H + +-- import qualified Documentation.Haddock.Doc as H.Doc +-- import qualified Documentation.Haddock.Parser as H.Parser +-- import qualified Documentation.Haddock.Parser.Monad as H.Parser + +import qualified Test.Tasty as Test +import qualified Test.Tasty.HUnit as Test + +import qualified Turtle + +-------------------------------------------------------------------------------- + +-- | Generate and lint the Haddock documentation for this project. +lintHaddock :: LintHaddockOptions -> IO Test.TestTree +lintHaddock options = do + _ <- H.withGhc [] GHC.getSessionDynFlags + buildHaddock + mapM (lintInterfaceFile options) (componentNames options) + |> fmap (Test.testGroup "Haddock linting") + +-------------------------------------------------------------------------------- + +-- | A type for options provided to 'lintHaddock'. +data LintHaddockOptions + = MkLintHaddockOptions + { componentNames :: [ComponentName] + , sinceExceptions :: [SinceException] + , haddockArguments :: [String] + } + deriving (Eq, Show) + +-- | An empty 'LintHaddockOptions'. +emptyLintHaddockOptions :: LintHaddockOptions +emptyLintHaddockOptions = MkLintHaddockOptions [] [] [] + +-- | Add the given 'ComponentName' to the given 'LintHaddockOptions'. +addComponentName :: ComponentName + -> (LintHaddockOptions -> LintHaddockOptions) +addComponentName cn = modifyComponentNames (cn :) + +-- | Add the given 'SinceException' to the given 'LintHaddockOptions'. +addSinceException :: SinceException + -> (LintHaddockOptions -> LintHaddockOptions) +addSinceException se = modifySinceExceptions (se :) + +-- | Add the given Haddock argument to the given 'LintHaddockOptions'. +addHaddockArgument :: String + -> (LintHaddockOptions -> LintHaddockOptions) +addHaddockArgument arg = modifyHaddockArguments (arg :) + +-- | Modify the list of 'ComponentName's with the given function. +modifyComponentNames :: ([ComponentName] -> [ComponentName]) + -> (LintHaddockOptions -> LintHaddockOptions) +modifyComponentNames f (MkLintHaddockOptions {..}) + = MkLintHaddockOptions { componentNames = f componentNames, .. } + +-- | Modify the list of 'SinceException's with the given function. +modifySinceExceptions :: ([SinceException] -> [SinceException]) + -> (LintHaddockOptions -> LintHaddockOptions) +modifySinceExceptions f (MkLintHaddockOptions {..}) + = MkLintHaddockOptions { sinceExceptions = f sinceExceptions, .. } + +-- | Modify the list of Haddock arguments with the given function. +modifyHaddockArguments :: ([String] -> [String]) + -> (LintHaddockOptions -> LintHaddockOptions) +modifyHaddockArguments f (MkLintHaddockOptions {..}) + = MkLintHaddockOptions { haddockArguments = f haddockArguments, .. } + +-------------------------------------------------------------------------------- + +-- | The name of a Cabal component for which the Haddock documentation should +-- be linted. +type ComponentName = String + +-- | An exception to the checker that ensures that every top-level exposed +-- declaration has an @\@since@ attribute; this takes the form of a +-- fully-qualified Haskell name, e.g.: @Control.Monad.unless@. +type SinceException = String + +-------------------------------------------------------------------------------- + +lintInterfaceFile :: LintHaddockOptions -> ComponentName -> IO Test.TestTree +lintInterfaceFile options cn + = readInterface ifaceFP + >>= snd + .> map ((id &&& deconstruct) .> uncurry helper) + .> Test.testGroup cn + .> pure + where + ifaceFP :: FilePath + ifaceFP = "./dist/doc/html/" <> cn <> "/" <> cn <> ".haddock" + + helper :: H.InstalledInterface -> [(Ident, H.MDoc Ident)] -> Test.TestTree + helper iface xs = do + let ifaceName = H.instMod iface + |> GHC.moduleName + |> GHC.moduleNameString + Test.testGroup ifaceName (map (checkSince options) xs) + +checkSince :: LintHaddockOptions -> (Ident, H.MDoc Ident) -> Test.TestTree +checkSince options (ident, mdoc) + = if qname `elem` sinceExceptions options + then (Test.testCaseInfo name (pure (qname <> " is in exceptions list"))) + else (Test.testCase name + (Test.assertBool message (hasSince mdoc))) + where + name = printIdentName ident + qname = printIdent ident + message = qname <> " does not have @since" + +readInterface :: FilePath -> IO (H.LinkEnv, [H.InstalledInterface]) +readInterface fp = H.readInterfaceFile H.freshNameCache fp + >>= either fail (decomposeIF .> pure) + where + decomposeIF = H.ifLinkEnv &&& H.ifInstalledIfaces + +buildHaddock :: IO () +buildHaddock = runHaddock [] + where + runHaddock :: [String] -> IO () + runHaddock extraArgs = Turtle.sh $ do + let args = ["./Setup.hs", "haddock"] ++ map Text.pack extraArgs + Turtle.inprocWithErr "runhaskell" args empty + +deconstruct :: H.InstalledInterface -> [(Ident, H.MDoc Ident)] +deconstruct iface + = (catMaybes $ runIdentity $ forM exports + $ \name -> do let ident = toIdent name + LMap.lookup name docmap + |> fmap (\doc -> (ident, toIdent <$> doc)) + |> pure) + -- maybe (fail ("could not find: " <> printIdent ident)) pure + -- pure (ident, toIdent <$> doc) + where + exports = H.instVisibleExports iface + docmap = H.instDocMap iface + toIdent = MkIdent (H.instMod iface) + +-------------------------------------------------------------------------------- + +data Ident + = MkIdent + { _identModule :: !GHC.Module + , _identName :: !GHC.Name + } + deriving () + +printIdentModule :: Ident -> String +printIdentModule (MkIdent {..}) + = GHC.moduleNameString (GHC.moduleName _identModule) + +-- NOTE: this fails if the GHC dynflags have not been set up +printIdentName :: Ident -> String +printIdentName (MkIdent {..}) + = GHC.showSDocUnsafe (GHC.ppr _identName) + +printIdent :: Ident -> String +printIdent ident = printIdentModule ident <> "." <> printIdentName ident + +instance Show Ident where + show = printIdent + +-------------------------------------------------------------------------------- + +class HasSince t where + hasSince :: t -> Bool + +instance HasSince (H.MDoc name) where + hasSince = H._meta .> H._version .> isJust + +instance HasSince (H.Documentation name) where + hasSince = H.documentationDoc .> maybe False hasSince + +-------------------------------------------------------------------------------- diff --git a/tests/Tests/Mock.hs b/tests/Tests/Mock.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Mock.hs @@ -0,0 +1,66 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests/Mock.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | +-- Module : Tests.Mock +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains concrete types that are used when mocking interfaces +-- defined in "Language.Ninja.Mock". +module Tests.Mock + ( FSAction (..) + ) where + +import Data.Text (Text) + +import Language.Ninja.Misc.Path (Path) +import Language.Ninja.Mock.ReadFile (MonadReadFile (..)) + +import qualified Control.Monad.Mock as Mock +import Data.Type.Equality ((:~:) (Refl)) + +-------------------------------------------------------------------------------- + +data FSAction r where + ReadFile :: !Path -> FSAction Text + WriteFile :: !Path -> !Text -> FSAction () + +deriving instance Eq (FSAction r) +deriving instance Show (FSAction r) + +instance Mock.Action FSAction where + eqAction (a@(ReadFile {})) (b@(ReadFile {})) | (a == b) = Just Refl + eqAction (a@(WriteFile {})) (b@(WriteFile {})) | (a == b) = Just Refl + eqAction _ _ = Nothing + +instance (Monad m) => MonadReadFile (Mock.MockT FSAction m) where + readFile path = Mock.mockAction "readFile" (ReadFile path) + +-------------------------------------------------------------------------------- diff --git a/tests/Tests/Orphans.hs b/tests/Tests/Orphans.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Orphans.hs @@ -0,0 +1,184 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests.hs +-- +-- License: +-- Copyright 2017 Awake Security +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Main +-- Copyright : Copyright 2017 Awake Security +-- License : Apache-2.0 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- This module contains orphan instances used in testing. +module Tests.Orphans + ( -- No exports other than instances. + ) where + +import Data.Hashable (Hashable) + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as Text +import qualified Data.Versions as Ver +import qualified Filesystem.Path.CurrentOS as FP + +import Test.SmallCheck.Series ((<~>), (>>-), (\/)) +import qualified Test.SmallCheck.Series as SC + +import Flow ((.>), (|>)) + +-------------------------------------------------------------------------------- + +instance ( Monad m, SC.Serial m k, SC.Serial m v, Hashable k + ) => SC.Serial m (HM.HashMap k v) where + series = pure HM.empty + \/ (HM.singleton <$> SC.series <~> SC.series) + -- \/ (HM.union <$> SC.series <~> SC.series) + +instance ( Monad m, SC.CoSerial m k, SC.CoSerial m v + ) => SC.CoSerial m (HM.HashMap k v) where + coseries = SC.coseries .> fmap (\f -> HM.toList .> f) + +-------------------------------------------------------------------------------- + +instance ( Monad m, SC.Serial m a, Hashable a + ) => SC.Serial m (HS.HashSet a) where + series = pure HS.empty + \/ (HS.singleton <$> SC.series) + -- \/ (HS.union <$> SC.series <~> SC.series) + +instance (Monad m, SC.CoSerial m a) => SC.CoSerial m (HS.HashSet a) where + coseries = SC.coseries .> fmap (\f -> HS.toList .> f) + +-------------------------------------------------------------------------------- + +instance (Monad m, SC.Serial m a) => SC.Serial m (NE.NonEmpty a) where + series = SC.series |> fmap (pure .> NE.fromList) + -- series = SC.series |> fmap (SC.getNonEmpty .> NE.fromList) + +instance (Monad m, SC.CoSerial m a) => SC.CoSerial m (NE.NonEmpty a) where + coseries = SC.coseries .> fmap (\f -> NE.toList .> f) + +-------------------------------------------------------------------------------- + +instance (Monad m) => SC.Serial m Text.Text where + series = foldr1 (\/) (map pure testText) + +instance (Monad m) => SC.CoSerial m Text.Text where + coseries rs = SC.alts0 rs >>- \y -> SC.alts2 rs >>- \f -> do + pure (Text.uncons .> (\case Nothing -> y + (Just (b, bs)) -> f (Text.singleton b) bs)) + +-------------------------------------------------------------------------------- + +instance (Monad m) => SC.Serial m FP.FilePath where + series = foldr1 (\/) (map pure testFP) + +instance (Monad m) => SC.CoSerial m FP.FilePath where + coseries = SC.coseries .> (fmap (\f -> FP.encodeString .> Text.pack .> f)) + +-------------------------------------------------------------------------------- + +instance (Monad m) => SC.Serial m Ver.Version where + series = foldr1 (\/) (map pure testVersions) + +instance (Monad m, SC.CoSerial m Ver.VUnit) => SC.CoSerial m Ver.Version where + coseries = SC.coseries .> fmap (\f -> toTuple .> f) + where + toTuple (Ver.Version {..}) = (_vEpoch, _vChunks, _vRel) + +instance (Monad m) => SC.CoSerial m Ver.VUnit where + coseries = SC.coseries + .> fmap (\f -> \case (Ver.Digits i) -> f (Right i) + (Ver.Str s) -> f (Left s)) + +-------------------------------------------------------------------------------- + +testText :: [Text.Text] +testText = ["", "foo", "42", " "] + +testFP :: [FP.FilePath] +testFP = ["/foo/bar", ".", "..", "foo", "foo/", "/foo/", "/foo//bar"] + +testVersions :: [Ver.Version] +testVersions = [ "0.1.0" + , "0.2" + , "0.2.0" + , "0.2.0.0" + , "0.25-2" + , "0.9.9.9" + , "1" + , "1.0" + , "1.0.0" + , "1.0.0.0" + , "1.0.0.1" + , "1.0.0-alpha" + , "1.0.0-alpha.1" + , "1.0.0-alpha.beta" + , "1.0.0-beta" + , "1.0.0-beta.11" + , "1.0.0-beta.2" + , "1.0.0-rc.1" + , "1:0.10.16-3" + , "1.0rc0" + , "1.0rc1" + , "1.1" + , "1:1.0" + , "1:1.1" + , "1:1.2.3-1" + , "1.1rc1" + , "1.2" + , "1.2.2r1-1" + , "1.2.3" + , "1.2.3-1" + , "1.2.3-alpha" + , "1.2.3-alpha.2" + , "1.2.3r1" + , "1.2.3r1-1" + , "1.2.4" + , "1.2.4r1-1" + , "1.2-5" + , "1.58.0-3" + , "2" + , "20150826-1" + , "21-2" + , "2.3.4" + , "3.4.5" + , "44.0.2403.157-1" + , "7.1p1-1" + , "8.u51-1" + ] |> map (Ver.version .> fromRight) + where + fromRight :: (Show a, Show b) => Either a b -> b + fromRight (Left a) = error ("fromRight: " ++ show a) + fromRight (Right b) = b + +-------------------------------------------------------------------------------- diff --git a/tests/Tests/ReferenceLexer.hs b/tests/Tests/ReferenceLexer.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/ReferenceLexer.hs @@ -0,0 +1,304 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests/ReferenceLexer.hs +-- +-- License: +-- Copyright Neil Mitchell 2011-2017. +-- Copyright Awake Security 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 FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Tests.ReferenceLexer +-- Copyright : Copyright 2011-2017 Neil Mitchell +-- License : BSD3 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- Lexing is a slow point, the code below is optimised. +module Tests.ReferenceLexer + ( -- * Lexing + lexFile, lexText, lexBS + + -- * Types + , Lexer.Lexeme (..) + , Lexer.LName (..) + , Lexer.LFile (..) + , Lexer.LBind (..) + , Lexer.LBuild (..) + ) where + +import Control.Arrow (first) +import Control.Monad.Error.Class (MonadError) + +import qualified Data.ByteString.Char8 as BSC8 + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) + +import Flow ((.>), (|>)) + +import qualified Language.Ninja.AST as AST +import qualified Language.Ninja.Errors as Errors +import qualified Language.Ninja.Misc as Misc +import qualified Language.Ninja.Mock as Mock + +import qualified Language.Ninja.Lexer as Lexer + +import Tests.ReferenceLexer.Str0 (Str0 (MkStr0)) +import qualified Tests.ReferenceLexer.Str0 as Str0 + +-------------------------------------------------------------------------------- + +type Str = BSC8.ByteString + +-- | Lex the given file. +lexFile :: (MonadError Errors.ParseError m, Mock.MonadReadFile m) + => Misc.Path -> m [Lexer.Lexeme ()] +lexFile file = Mock.readFile file >>= lexText + +-- | Lex the given 'Text'. +lexText :: (MonadError Errors.ParseError m) + => Text -> m [Lexer.Lexeme ()] +lexText = Text.encodeUtf8 .> lexBS + +-- | Lex the given 'BSC8.ByteString'. +lexBS :: (MonadError Errors.ParseError m) + => BSC8.ByteString -> m [Lexer.Lexeme ()] +lexBS x = lexerLoop (MkStr0 (BSC8.append x "\n\n\0")) + +-------------------------------------------------------------------------------- + +lexerLoop :: (MonadError Errors.ParseError m) => Str0 -> m [Lexer.Lexeme ()] +lexerLoop c_x + = case c of + '\r' -> lexerLoop x0 + '\n' -> lexerLoop x0 + '#' -> lexerLoop $ removeComment x0 + ' ' -> lexBind $ dropSpace x0 + 'b' | Just x1 <- strip "uild " x0 -> lexBuild $ dropSpace x1 + 'r' | Just x1 <- strip "ule " x0 -> lexRule $ dropSpace x1 + 'd' | Just x1 <- strip "efault " x0 -> lexDefault $ dropSpace x1 + 'p' | Just x1 <- strip "ool " x0 -> lexPool $ dropSpace x1 + 'i' | Just x1 <- strip "nclude " x0 -> lexInclude $ dropSpace x1 + 's' | Just x1 <- strip "ubninja " x0 -> lexSubninja $ dropSpace x1 + '\0' -> pure [] + _ -> lexDefine c_x + where + removeComment = Str0.dropWhile0 (/= '\n') + + (c, x0) = Str0.list0 c_x + + strip str (MkStr0 x) = let b = BSC8.pack str + in if b `BSC8.isPrefixOf` x + then Just $ MkStr0 $ BSC8.drop (BSC8.length b) x + else Nothing + +lexBind :: (MonadError Errors.ParseError m) => Str0 -> m [Lexer.Lexeme ()] +lexBind c_x | (c, x) <- Str0.list0 c_x + = case c of + '\r' -> lexerLoop x + '\n' -> lexerLoop x + '#' -> lexerLoop $ Str0.dropWhile0 (/= '\n') x + '\0' -> pure [] + _ -> lexxBind (Lexer.LexBind ()) c_x + +lexBuild :: (MonadError Errors.ParseError m) => Str0 -> m [Lexer.Lexeme ()] +lexBuild x0 = do + (outputs, x1) <- lexxExprs True x0 + let (rule, x2) = Str0.span0 isVarDot $ dropSpace x1 + (deps, x3) <- lexxExprs False $ dropSpace x2 + x4 <- lexerLoop x3 + let name = Lexer.MkLName () rule + pure (Lexer.LexBuild () (Lexer.makeLBuild () outputs name deps) : x4) + +lexDefault :: (MonadError Errors.ParseError m) => Str0 -> m [Lexer.Lexeme ()] +lexDefault str0 = do + (files, str1) <- lexxExprs False str0 + str2 <- lexerLoop str1 + pure (Lexer.LexDefault () files : str2) + +lexRule, lexPool, lexInclude, lexSubninja, lexDefine + :: (MonadError Errors.ParseError m) => Str0 -> m [Lexer.Lexeme ()] +lexRule = lexxName (Lexer.LexRule ()) +lexPool = lexxName (Lexer.LexPool ()) +lexInclude = lexxFile (Lexer.LexInclude ()) +lexSubninja = lexxFile (Lexer.LexSubninja ()) +lexDefine = lexxBind (Lexer.LexDefine ()) + +lexxBind :: (MonadError Errors.ParseError m) + => (Lexer.LBind () -> Lexer.Lexeme ()) -> Str0 -> m [Lexer.Lexeme ()] +lexxBind ctor x0 = do + let (var, x1) = Str0.span0 isVarDot x0 + let (eq, x2) = Str0.list0 $ dropSpace x1 + (expr, x3) <- lexxExpr False False $ dropSpace x2 + x4 <- lexerLoop x3 + if (eq == '=') + then pure (ctor (Lexer.MkLBind () (Lexer.MkLName () var) expr) : x4) + else Errors.throwLexBindingFailure (Text.pack (show (Str0.take0 100 x0))) + +lexxFile :: (MonadError Errors.ParseError m) + => (Lexer.LFile () -> Lexer.Lexeme ()) -> Str0 -> m [Lexer.Lexeme ()] +lexxFile ctor str0 = do + (expr, str1) <- lexxExpr False False (dropSpace str0) + str2 <- lexerLoop str1 + pure (ctor (Lexer.MkLFile expr) : str2) + +lexxName :: (MonadError Errors.ParseError m) + => (Lexer.LName () -> Lexer.Lexeme ()) -> Str0 -> m [Lexer.Lexeme ()] +lexxName ctor x = do + let (name, rest) = splitLineCont x + lexemes <- lexerLoop rest + pure (ctor (Lexer.MkLName () name) : lexemes) + +lexxExprs :: (MonadError Errors.ParseError m) + => Bool -> Str0 -> m ([AST.Expr ()], Str0) +lexxExprs sColon x0 = do + (a, c_x) <- lexxExpr sColon True x0 + let c = Str0.head0 c_x + let x1 = Str0.tail0 c_x + case c of + ' ' -> do (exprs, x2) <- lexxExprs sColon $ dropSpace x1 + pure (a:exprs, x2) + ':' | sColon -> pure ([a], x1) + _ | sColon -> Errors.throwLexExpectedColon + '\r' -> pure (a $: dropN x1) + '\n' -> pure (a $: x1) + '\0' -> pure (a $: c_x) + _ -> Errors.throwLexUnexpectedSeparator c + where + ($:) :: AST.Expr () -> Str0 -> ([AST.Expr ()], Str0) + (AST.Exprs () []) $: s = ([], s) + expr $: s = ([expr], s) + +{-# NOINLINE lexxExpr #-} +lexxExpr :: (MonadError Errors.ParseError m) + => Bool + -- ^ @stopColon@ + -> Bool + -- ^ @stopSpace@ + -> Str0 + -- ^ The input bytestring + -> m (AST.Expr (), Str0) + -- ^ The second field will start with one of @" :\n\r"@ or be empty +lexxExpr stopColon stopSpace str0 = first exprs <$> f str0 + where + exprs :: [AST.Expr ()] -> AST.Expr () + exprs [x] = AST.normalizeExpr x + exprs xs = AST.normalizeExpr (AST.Exprs () xs) + + special :: Char -> Bool + special x = let b = x `elem` ['$', '\r', '\n', '\0'] + in case (stopColon, stopSpace) of + (True , True ) -> (x <= ':') && or [x == ':', x == ' ', b] + (True , False) -> (x <= ':') && or [x == ':', b] + (False, True ) -> (x <= '$') && or [ x == ' ', b] + (False, False) -> (x <= '$') && or [ b] + + f :: (MonadError Errors.ParseError m) => Str0 -> m ([AST.Expr ()], Str0) + f (Str0.break00 special -> (a, x)) + = if BSC8.null a + then g x + else g x >>= \y -> pure (AST.Lit () (Text.decodeUtf8 a) $: y) + + g :: (MonadError Errors.ParseError m) => Str0 -> m ([AST.Expr ()], Str0) + g x0 | (Str0.head0 x0 /= '$') = pure ([], x0) + g (Str0.tail0 -> c_x) = + let (c, x0) = Str0.list0 c_x + in case c of + '$' -> f x0 >>= (AST.Lit () "$" $:) .> pure + ' ' -> f x0 >>= (AST.Lit () " " $:) .> pure + ':' -> f x0 >>= (AST.Lit () ":" $:) .> pure + '\n' -> f (dropSpace x0) + '\r' -> f (dropSpace (dropN x0)) + '{' | (name, x1) <- Str0.span0 isVarDot x0 + , ('}', x2) <- Str0.list0 x1 + , not (BSC8.null name) + -> f x2 >>= (AST.Var () (Text.decodeUtf8 name) $:) .> pure + _ | (name, x1) <- Str0.span0 isVar c_x + , not $ BSC8.null name + -> f x1 >>= (AST.Var () (Text.decodeUtf8 name) $:) .> pure + _ -> Errors.throwLexUnexpectedDollar + + ($:) :: a -> ([a], b) -> ([a], b) + x $: (xs, y) = (x:xs, y) + +splitLineCont :: Str0 -> (Str, Str0) +splitLineCont = go .> first BSC8.concat + where + go = splitLineCR .> go' + + go' (a, b) | not (endsDollar a) = ([a], b) + | otherwise = let (c, d) = go (dropSpace b) + in (BSC8.init a : c, d) + +splitLineCR :: Str0 -> (Str, Str0) +splitLineCR x = if BSC8.isSuffixOf (BSC8.singleton '\r') a + then (BSC8.init a, dropN b) + else (a, dropN b) + where + (a, b) = Str0.break0 (== '\n') x + +isVar :: Char -> Bool +isVar x = [ (x == '-') + , (x == '_') + , isAsciiLower x + , isAsciiUpper x + , isDigit x + ] |> or + +isVarDot :: Char -> Bool +isVarDot x = [ x == '.' + , isVar x + ] |> or + +endsDollar :: Str -> Bool +endsDollar = BSC8.isSuffixOf (BSC8.singleton '$') + +dropN :: Str0 -> Str0 +dropN x = if (Str0.head0 x == '\n') + then Str0.tail0 x + else x + +dropSpace :: Str0 -> Str0 +dropSpace = Str0.dropWhile0 (== ' ') + +-------------------------------------------------------------------------------- diff --git a/tests/Tests/ReferenceLexer/Str0.hs b/tests/Tests/ReferenceLexer/Str0.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/ReferenceLexer/Str0.hs @@ -0,0 +1,127 @@ +-- -*- coding: utf-8; mode: haskell; -*- + +-- File: tests/Tests/ReferenceLexer/Str0.hs +-- +-- License: +-- Copyright Neil Mitchell 2011-2017. +-- Copyright Awake Security 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. + +-- | +-- Module : Tests.ReferenceLexer.Str0 +-- Copyright : Copyright 2011-2017 Neil Mitchell +-- License : BSD3 +-- Maintainer : opensource@awakesecurity.com +-- Stability : experimental +-- +-- A NUL-terminated bytestring type used in the reference lexer. +module Tests.ReferenceLexer.Str0 + ( Str0 (..) + , break0, break00, dropWhile0, head0, list0, span0, tail0, take0 + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Internal as BS.Internal +import qualified Data.ByteString.Unsafe as BS.Unsafe + +import Data.Word (Word8) +import qualified Foreign.Ptr +import qualified Foreign.Storable +import GHC.Exts (Ptr (Ptr)) +import System.IO.Unsafe (unsafePerformIO) + +-------------------------------------------------------------------------------- + +-- | A null-terminated strict bytestring. +newtype Str0 + = MkStr0 ByteString + +-- | Convert a pointer to a 'Word8' to a 'Char'. +-- +-- TODO: uses unsafePerformIO +char :: Ptr Word8 -> Char +char x = BS.Internal.w2c $ unsafePerformIO $ Foreign.Storable.peek x + +-- | Increment a pointer by one byte. +next :: Ptr Word8 -> Ptr Word8 +next x = x `Foreign.Ptr.plusPtr` 1 + +-- | Similar to 'BSC8.dropWhile', but for null-terminated bytestrings. +{-# INLINE dropWhile0 #-} +dropWhile0 :: (Char -> Bool) -> Str0 -> Str0 +dropWhile0 f x = snd $ span0 f x + +-- | Similar to 'BSC8.span', but for null-terminated bytestrings. +{-# INLINE span0 #-} +span0 :: (Char -> Bool) -> Str0 -> (ByteString, Str0) +span0 f = break0 (not . f) + +-- | Similar to 'BSC8.break', but for null-terminated bytestrings. +{-# INLINE break0 #-} +break0 :: (Char -> Bool) -> Str0 -> (ByteString, Str0) +break0 f = break00 (\c -> (c == '\0') || f c) + +-- | Similar to 'break0', but it assumes that the given predicate will return +-- true for @'\0'@, allowing it to be slightly faster. +{-# INLINE break00 #-} +break00 :: (Char -> Bool) -> Str0 -> (ByteString, Str0) +break00 f (MkStr0 bs) = (initial, rest) + where + initial = BS.Unsafe.unsafeTake i bs + rest = MkStr0 $ BS.Unsafe.unsafeDrop i bs + + i = System.IO.Unsafe.unsafePerformIO $ + BS.Unsafe.unsafeUseAsCString bs $ \ptr -> do + let start = Foreign.Ptr.castPtr ptr :: Ptr Word8 + let end = go start + pure $! Ptr end `Foreign.Ptr.minusPtr` start + + go s@(Ptr a) | f (char s) = a + | otherwise = go (next s) + +-- | Similar to 'BSC8.head', but for null-terminated bytestrings. +head0 :: Str0 -> Char +head0 (MkStr0 x) = BS.Internal.w2c $ BS.Unsafe.unsafeHead x + +-- | Similar to 'BSC8.tail', but for null-terminated bytestrings. +tail0 :: Str0 -> Str0 +tail0 (MkStr0 x) = MkStr0 $ BS.Unsafe.unsafeTail x + +-- | Similar to 'BSC8.uncons', but for null-terminated bytestrings. +list0 :: Str0 -> (Char, Str0) +list0 x = (head0 x, tail0 x) + +-- | Similar to 'BSC8.take', but for null-terminated bytestrings. +take0 :: Int -> Str0 -> ByteString +take0 i (MkStr0 x) = BSC8.takeWhile (/= '\0') $ BSC8.take i x + +--------------------------------------------------------------------------------