diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Changelog for jsonnet + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,217 @@ +Copyright Alexandre Moreno 2020. + +Licensed under either of: + +* BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause) +* Apache License, version 2.0 (https://opensource.org/licenses/Apache-2.0) + +As a user, you may use this code under either license, at your option. + + +--------------------------------------------------------------------- +BSD 3-Clause License +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. + + +--------------------------------------------------------------------- +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). + +"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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,73 @@ +# haskell-jsonnet + +[![Actions Status](https://github.com/moleike/jsonnet-hs/workflows/build/badge.svg)](https://github.com/moleike/jsonnet-hs/actions) [![Join the chat at https://gitter.im/jsonnet-hs/community](https://badges.gitter.im/jsonnet-hs/community.svg)](https://gitter.im/jsonnet-hs/community?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) + +A full-fledged Haskell implementation of the [Jsonnet][jsonnet] spec. +For an introduction to the language itself, see the [tutorial][tutorial] or language [reference][reference]. +We are using the same test suite used in the offical [C++][cpp-jsonnet] and [Go][go-jsonnet] implementation (which is fairly comprehensive). + +## Build + +Using the [stack][stack] build tool: + +```bash +git clone github.com/moleike/jsonnet-hs.git +cd jsonnet-hs +stack build +``` + +## Progress + +Here is the implementation status of the main language features: + +- [X] array and object comprehension +- [X] array slices +- [X] Python-style string formatting +- [X] text blocks +- [X] verbatim strings +- [X] object-level locals +- [ ] object-level asserts +- [X] keyword parameters +- [X] default arguments +- [ ] top-level arguments +- [ ] external variables +- [X] hidden fields ([@CristhianMotoche](https://github.com/CristhianMotoche)) +- [X] tailstrict annotation + +OO features are implemented but need some more work: +- [X] `self` keyword +- [X] `super` keyword +- [X] outermost object reference `$` +- [X] object composition (merging objects) +- [X] field composition (`+:` field syntax) + +[//]: # "Implementation overview" + + + +## Contributing + +See [CONTRIBUTING.md][contributing]. + +## Acknowledgments + +I took inspiration from [Expresso][Expresso], [hnix][hnix], [fixplate][fixplate], and numerous other libraries. Thanks to their authors. + +## License + +See [LICENSE][license]. + +Copyright © 2020–present Alexandre Moreno + +[jsonnet]: https://jsonnet.org/ +[tutorial]: https://jsonnet.org/learning/tutorial.html +[reference]: https://jsonnet.org/ref/language.html +[stack]: https://docs.haskellstack.org/en/stable/README +[Expresso]: https://github.com/willtim/Expresso +[hnix]: https://github.com/haskell-nix/hnix +[fixplate]: https://hackage.haskell.org/package/fixplate +[contributing]: https://github.com/moleike/haskell-jsonnet/blob/master/CONTRIBUTING.md +[license]: https://github.com/moleike/haskell-jsonnet/blob/master/LICENSE +[cpp-jsonnet]: https://github.com/google/jsonnet +[go-jsonnet]: https://github.com/google/go-jsonnet + diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Monad.Except +import qualified Data.Aeson as JSON +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8 as LC (putStrLn) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8Builder) +import qualified Data.Text.IO as TIO +import Data.Version (showVersion) +import Language.Jsonnet +import Language.Jsonnet.Error +import Language.Jsonnet.Std +import Options.Applicative +import Paths_jsonnet (version) +import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty) + +main :: IO () +main = do + runProgram =<< execParser options + return () + +runProgram :: Options -> IO () +runProgram opts@Options {..} = do + src <- readSource input + conf <- mkConfig opts + outp <- interpret conf src + either printError (printResult output format) outp + +printResult :: Output -> Format -> JSON.Value -> IO () +printResult outp Json val = + writeOutput (JSON.encode val) outp +printResult outp Plaintext (JSON.String s) = + writeOutput (encodeToLazyByteString s) outp + where + encodeToLazyByteString = + toLazyByteString . encodeUtf8Builder +printResult _ Plaintext _ = + print "Runtime error: expected string result" + +writeOutput :: L.ByteString -> Output -> IO () +writeOutput bs = \case + FileOutput path -> L.writeFile path bs + Stdout -> LC.putStrLn bs + +printError :: Error -> IO () +printError = print . pretty + +readSource :: Input -> IO Text +readSource = \case + Stdin -> TIO.getContents + FileInput path -> TIO.readFile path + ExecInput str -> pure (T.pack str) + +getStdlib :: IO Value +getStdlib = + runExceptT std >>= \case + Right stdlib -> pure stdlib + Left err -> error (show $ pretty err) + +mkConfig :: Options -> IO Config +mkConfig Options {..} = do + let fname = case input of + Stdin -> "" + FileInput path -> path + ExecInput _ -> "" + stdlib <- getStdlib + pure Config {..} + +fileOutput :: Parser Output +fileOutput = + fromMaybe Stdout + <$> ( optional $ + FileOutput + <$> strOption + ( long "output-file" + <> short 'o' + <> metavar "" + <> help "Write to the output file rather than stdout" + ) + ) + +fileInput :: Parser (Maybe String) +fileInput = + optional $ + strArgument + ( metavar "" + <> help "Jsonnet source file or stdin" + ) + +parseOpts :: Parser Options +parseOpts = do + input <- mkInput <$> exec <*> fileInput + output <- fileOutput + format <- + flag + Json + Plaintext + ( long "string" + <> short 'S' + <> help "Expect a string, manifest as plain text" + ) + pure Options {..} + +mkInput :: Bool -> Maybe String -> Input +mkInput exec = \case + Nothing -> Stdin + Just e | exec -> ExecInput e + Just p | otherwise -> FileInput p + +exec :: Parser Bool +exec = + switch + ( long "exec" + <> short 'e' + <> help "Treat filename as code" + ) + +ver :: Parser (a -> a) +ver = + infoOption + verStr + ( long "version" + <> short 'v' + <> help "Print version of the program" + ) + where + verStr = "Jsonnet command line " <> showVersion version + +options :: ParserInfo Options +options = + info + (ver <*> helper <*> parseOpts) + ( fullDesc + <> noIntersperse + ) + +data Options = Options + { output :: Output, + format :: Format, + input :: Input + } + +data Input + = FileInput FilePath + | ExecInput String + | Stdin + deriving (Eq, Show) + +data Output + = FileOutput FilePath + | Stdout + deriving (Eq, Show) + +data Format = Json | Plaintext + deriving (Eq, Show) diff --git a/jsonnet.cabal b/jsonnet.cabal new file mode 100644 --- /dev/null +++ b/jsonnet.cabal @@ -0,0 +1,122 @@ +cabal-version: 2.2 +name: jsonnet +version: 0.1.0.0 +synopsis: Jsonnet implementaton in pure Haskell +description: Please see the README on GitHub at +homepage: https://github.com/moleike/haskell-jsonnet#readme +bug-reports: https://github.com/moleike/haskell-jsonnet/issues +author: Alexandre Moreno +maintainer: alexmorenocano@gmail.com +copyright: 2020 Alexandre Moreno +category: Compiler +license: BSD-3-Clause +x-license: BSD-3-Clause OR Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/moleike/haskell-jsonnet + +library + exposed-modules: + Language.Jsonnet + , Language.Jsonnet.Error + , Language.Jsonnet.Pretty + , Language.Jsonnet.Parser + , Language.Jsonnet.Parser.SrcSpan + , Language.Jsonnet.Syntax + , Language.Jsonnet.Syntax.Annotated + , Language.Jsonnet.Core + , Language.Jsonnet.Check + , Language.Jsonnet.Desugar + , Language.Jsonnet.Annotate + , Language.Jsonnet.Common + , Language.Jsonnet.Eval + , Language.Jsonnet.Eval.Monad + , Language.Jsonnet.Value + , Language.Jsonnet.Std + , Language.Jsonnet.Std.Lib + , Language.Jsonnet.Std.TH + , Language.Jsonnet.Manifest + , Language.Jsonnet.TH + , Language.Jsonnet.TH.QQ + autogen-modules: + Paths_jsonnet + other-modules: + Paths_jsonnet + + hs-source-dirs: + src + build-depends: + aeson >= 1.5.6 && < 1.6, + base >= 4.14.1 && < 4.15, + bytestring >= 0.10.12 && < 0.11, + containers >= 0.6.2 && < 0.7, + scientific >= 0.3.6 && < 0.4, + hashable >= 1.3.1 && < 1.4, + text >= 1.2.4 && < 1.3, + template-haskell >= 2.16.0 && < 2.17, + data-fix >= 0.3.1 && < 0.4, + transformers-compat >= 0.6.6 && < 0.7, + unordered-containers >= 0.2.13 && < 0.3, + mtl >= 2.2.2 && < 2.3, + vector >= 0.12.2 && < 0.13, + ansi-wl-pprint >= 0.6.9 && < 0.7, + deriving-compat >= 0.5.10 && < 0.6, + directory >= 1.3.6 && < 1.4, + filepath >= 1.4.2 && < 1.5, + exceptions >= 0.10.4 && < 0.11, + megaparsec >= 9.0.1 && < 9.1, + parser-combinators >= 1.3.0 && < 1.4, + semigroupoids >= 5.3.5 && < 5.4, + unbound-generics >= 0.4.1 && < 0.5 + default-language: Haskell2010 + default-extensions: + MultiParamTypeClasses + , FlexibleContexts + , FlexibleInstances + , DeriveGeneric + , LambdaCase + +executable jsonnet + main-is: Main.hs + other-modules: + Paths_jsonnet + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + jsonnet, + base >= 4.14.1 && < 4.15, + optparse-applicative >= 0.16.1 && < 0.17, + text >= 1.2.4 && < 1.3, + ansi-wl-pprint >= 0.6.9 && < 0.7, + mtl >= 2.2.2 && < 2.3, + bytestring >= 0.10.12 && < 0.11, + aeson >= 1.5.6 && < 1.6 + default-language: Haskell2010 + +test-suite jsonnet-test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Paths_jsonnet + hs-source-dirs: + test/golden + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , ansi-wl-pprint + , jsonnet + , mtl + , text + , filepath + , bytestring + , tasty + , tasty-golden + , tasty-hunit + default-language: Haskell2010 diff --git a/src/Language/Jsonnet.hs b/src/Language/Jsonnet.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.Jsonnet + ( JsonnetM, + interpret, + Config (..), + Value (..), + runJsonnetM, + parse, + desugar, + evaluate, + ) +where + +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Except +import Control.Monad.Reader +import qualified Data.Aeson as JSON +import Data.Functor.Identity +import Data.Functor.Sum +import Data.Map.Strict (singleton) +import Data.Text (Text) +import qualified Data.Text.IO as T (readFile) +import Debug.Trace +import Language.Jsonnet.Annotate +import qualified Language.Jsonnet.Check as Check +import Language.Jsonnet.Core +import qualified Language.Jsonnet.Desugar as Desugar +import Language.Jsonnet.Error +import Language.Jsonnet.Eval +import Language.Jsonnet.Manifest (manifest) +import qualified Language.Jsonnet.Parser as Parser +import Language.Jsonnet.Pretty () +import Language.Jsonnet.Syntax.Annotated +import Language.Jsonnet.Value + +newtype JsonnetM a = JsonnetM + { unJsonnetM :: ReaderT Config (ExceptT Error IO) a + } + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadFix, + MonadReader Config, + MonadError Error, + MonadThrow, + MonadCatch, + MonadMask, + MonadFail + ) + +data Config = Config + { fname :: FilePath, + stdlib :: Value + } + +runJsonnetM :: Config -> JsonnetM a -> IO (Either Error a) +runJsonnetM conf = runExceptT . (`runReaderT` conf) . unJsonnetM + +interpret :: Config -> Text -> IO (Either Error JSON.Value) +interpret conf = + runJsonnetM conf + . (parse >=> check >=> desugar >=> evaluate) + +parse :: Text -> JsonnetM Expr +parse inp = + asks fname >>= JsonnetM . lift . go + where + go fp = do + ast <- Parser.parse fp inp + Parser.resolveImports fp ast + +check :: Expr -> JsonnetM Expr +check expr = do + _ <- + JsonnetM $ + lift $ + Check.check expr + pure expr + +desugar :: Expr -> JsonnetM Core +desugar expr = pure (Desugar.desugar expr) + +-- evaluate a Core expression with the implicit stdlib +evaluate :: Core -> JsonnetM JSON.Value +evaluate expr = do + ctx <- singleton "std" . TV . pure <$> asks stdlib + JsonnetM $ + lift $ + runEval (emptyEnv {ctx = ctx}) ((eval >=> manifest) expr) diff --git a/src/Language/Jsonnet/Annotate.hs b/src/Language/Jsonnet/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Annotate.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Language.Jsonnet.Annotate where + +import Control.Applicative (Const (..)) +import Data.Fix +import Data.Functor.Product + +-- | Annotated trees, based on fixplate +type AnnF f a = Product (Const a) f + +type Ann f a = Fix (AnnF f a) + +pattern AnnF f a = Pair (Const a) f + +annMap :: Functor f => (a -> b) -> Ann f a -> Ann f b +annMap g = go + where + go (Fix (AnnF f a)) = Fix $ AnnF (fmap go f) (g a) + +forget :: Functor f => Ann f a -> Fix f +forget (Fix (AnnF f _)) = Fix $ fmap forget f + +attrib :: Ann f a -> a +attrib (Fix (AnnF _ a)) = a + +inherit :: Functor f => (Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b +inherit h root = go root + where + go p s@(Fix t) = + let (b, a) = + h s p + in Fix (AnnF (fmap (go a) t) b) + +annZip :: Functor f => Fix (AnnF (AnnF f a) b) -> Ann f (a, b) +annZip (Fix (AnnF (AnnF t x) y)) = Fix (AnnF (fmap annZip t) (x, y)) + +--instance (Show a, Show1 f) => Show1 (Const a :*: f) where +-- liftShowsPrec = liftShowsPrecDefault diff --git a/src/Language/Jsonnet/Check.hs b/src/Language/Jsonnet/Check.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Check.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +-- | +module Language.Jsonnet.Check where + +import Control.Monad.Except +import Data.Fix +import Data.Functor.Identity +import Data.List +import qualified Data.List.NonEmpty as NE +import Language.Jsonnet.Annotate +import Language.Jsonnet.Common hiding (span) +import Language.Jsonnet.Core +import Language.Jsonnet.Error +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Syntax +import Unbound.Generics.LocallyNameless + +type Check = ExceptT Error IO + +check :: Ann ExprF SrcSpan -> Check () +check = foldFixM alg + where + alg (AnnF f a) = withExceptT (`CheckError` (Just a)) $ case f of + ELocal bnds _ -> checkLocal (NE.toList $ fst <$> bnds) + EFun ps _ -> checkFun (fst <$> ps) + EApply _ (Args as _) -> checkApply as + _ -> pure () + checkLocal names = case dups names of + [] -> pure () + (xs : _) -> throwError $ DuplicateBinding (head xs) + checkFun names = case dups names of + [] -> pure () + (xs : _) -> throwError $ DuplicateParam (head xs) + checkApply args = case f args of + [] -> pure () + (x : _) -> throwError $ PosAfterNamedParam + where + f args = filter isPos ns + isPos = \case + Pos _ -> True + _ -> False + (ps, ns) = span isPos args + dups = filter ((> 1) . length) . group . sort diff --git a/src/Language/Jsonnet/Common.hs b/src/Language/Jsonnet/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Common.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Jsonnet.Common where + +import Data.Data (Data) +import Data.Functor.Classes +import Data.Functor.Classes.Generic +import Data.Scientific (Scientific) +import Data.String +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic, Generic1) +import Language.Jsonnet.Parser.SrcSpan +import Text.Show.Deriving +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.TH (makeClosedAlpha) + +data Literal + = Null + | Bool Bool + | String Text + | Number Scientific + deriving (Show, Eq, Ord, Generic, Typeable, Data) + +makeClosedAlpha ''Literal + +instance Subst a Literal where + subst _ _ = id + substs _ = id + +data BinOp + = Arith ArithOp + | Comp CompOp + | Bitwise BitwiseOp + | Logical LogicalOp + | In + deriving (Show, Eq, Generic, Typeable, Data) + +data UnyOp + = Compl + | LNot + | Plus + | Minus + deriving (Show, Eq, Enum, Bounded, Generic, Typeable, Data) + +data ArithOp = Add | Sub | Mul | Div | Mod + deriving (Show, Eq, Enum, Bounded, Generic, Typeable, Data) + +data CompOp = Lt | Le | Gt | Ge | Eq | Ne + deriving (Show, Eq, Enum, Bounded, Generic, Typeable, Data) + +data BitwiseOp = And | Or | Xor | ShiftL | ShiftR + deriving (Show, Eq, Enum, Bounded, Generic, Typeable, Data) + +data LogicalOp = LAnd | LOr + deriving (Show, Eq, Enum, Bounded, Generic, Typeable, Data) + +instance Alpha ArithOp + +instance Alpha BinOp + +instance Alpha CompOp + +instance Alpha BitwiseOp + +instance Alpha LogicalOp + +instance Alpha UnyOp + +data Strictness = Strict | Lazy + deriving (Eq, Read, Show, Generic, Typeable, Data) + +instance Alpha Strictness + +data Arg a = Pos a | Named String a + deriving + ( Eq, + Read, + Show, + Typeable, + Data, + Generic, + Generic1, + Functor, + Foldable, + Traversable + ) + +deriveShow1 ''Arg + +instance Alpha a => Alpha (Arg a) + +data Args a = Args + { args :: [Arg a], + strictness :: Strictness + } + deriving + ( Eq, + Read, + Show, + Typeable, + Data, + Generic, + Functor, + Foldable, + Traversable + ) + +deriveShow1 ''Args + +instance Alpha a => Alpha (Args a) + +data Assert a = Assert + { cond :: a, + msg :: Maybe a, + expr :: a + } + deriving + ( Eq, + Read, + Show, + Typeable, + Data, + Generic, + Functor, + Foldable, + Traversable + ) + +instance Alpha a => Alpha (Assert a) + +deriveShow1 ''Assert + +data CompSpec a = CompSpec + { var :: String, + forspec :: a, + ifspec :: Maybe a + } + deriving + ( Eq, + Read, + Show, + Typeable, + Data, + Generic, + Functor, + Foldable, + Traversable + ) + +deriveShow1 ''CompSpec + +instance Alpha a => Alpha (CompSpec a) + +data StackFrame a = StackFrame + { name :: Maybe (Name a), + span :: SrcSpan + } + deriving (Eq, Show) + +pushStackFrame :: + StackFrame a -> + Backtrace a -> + Backtrace a +pushStackFrame x (Backtrace xs) = Backtrace (x : xs) + +data Backtrace a = Backtrace [StackFrame a] + deriving (Eq, Show) + +data Visibility = Visible | Hidden | Forced + deriving + ( Eq, + Read, + Show, + Generic, + Typeable, + Data + ) + +instance Alpha Visibility + +class HasVisibility a where + visible :: a -> Bool + forced :: a -> Bool + hidden :: a -> Bool + +data Hideable a = Hideable a Visibility + deriving + ( Eq, + Read, + Show, + Generic, + Functor, + Typeable, + Data + ) + +instance Alpha a => Alpha (Hideable a) + +instance HasVisibility (Hideable a) where + visible (Hideable _ Visible) = True + visible _ = False + + forced (Hideable _ Forced) = True + forced _ = False + + hidden (Hideable _ Hidden) = True + hidden _ = False diff --git a/src/Language/Jsonnet/Core.hs b/src/Language/Jsonnet/Core.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Core.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Jsonnet.Core where + +import Data.Data (Data) +import Data.String +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Language.Jsonnet.Common +import Language.Jsonnet.Parser.SrcSpan +import Unbound.Generics.LocallyNameless + +type Param a = (Name a, Embed (Maybe a)) + +data KeyValue a = KeyValue a (Hideable a) + deriving (Show, Typeable, Generic) + +instance Alpha a => Alpha (KeyValue a) + +newtype Fun = Fun (Bind (Rec [Param Core]) Core) + deriving (Show, Typeable, Generic) + +instance Alpha Fun + +newtype Let + = Let (Bind (Rec [(Name Core, Embed Core)]) Core) + deriving (Show, Typeable, Generic) + +instance Alpha Let + +data Comp + = ArrC (Bind (Name Core) (Core, Maybe Core)) + | ObjC (Bind (Name Core) (KeyValue Core, Maybe Core)) + deriving (Show, Typeable, Generic) + +instance Alpha Comp + +data Core + = CLoc SrcSpan Core + | CLit Literal + | CVar (Name Core) + | CFun Fun + | CApp Core (Args Core) + | CLet Let + | CObj [KeyValue Core] + | CArr [Core] + | CBinOp BinOp Core Core + | CUnyOp UnyOp Core + | CIfElse Core Core Core + | CErr Core + | CLookup Core Core + | CComp Comp Core + deriving (Show, Typeable, Generic) + +instance Alpha Core + +--data Params +-- = EmptyPs +-- | ConsPs (Rebind (Name Core, Embed (Maybe Core)) Params) +-- deriving (Show, Typeable, Generic) +--instance Alpha Params + +instance IsString (Name Core) where + fromString = string2Name diff --git a/src/Language/Jsonnet/Desugar.hs b/src/Language/Jsonnet/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Desugar.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Language.Jsonnet.Desugar (desugar) where + +import Data.Fix as F +import Data.List.NonEmpty (NonEmpty (..), fromList, toList) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Language.Jsonnet.Annotate +import Language.Jsonnet.Common +import Language.Jsonnet.Core +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Syntax +import Unbound.Generics.LocallyNameless + +class Desugarer a where + desugar :: a -> Core + +instance Desugarer (Ann ExprF ()) where + desugar = foldFix go . zipWithOutermost + where + go (AnnF f (_, b)) = alg b f + +instance Desugarer (Ann ExprF SrcSpan) where + desugar = foldFix go . zipWithOutermost + where + go (AnnF f (a, b)) = alg b $ CLoc a <$> f + +-- annotate nodes with a boolean denoting outermost objects +zipWithOutermost :: Ann ExprF a -> Ann ExprF (a, Bool) +zipWithOutermost = annZip . inherit go False + where + go (Fix (AnnF (EObj {}) _)) False = (True, True) + go (Fix (AnnF (EObj {}) _)) True = (False, True) + go _ x = (False, x) + +alg outermost = \case + ELit l -> CLit l + EIdent i -> CVar (s2n i) + EFun ps e -> mkFun ps e + EApply e es -> CApp e es + ELocal bnds e -> mkLet bnds e + -- operator % is overloaded for both modulo and string formatting + EBinOp (Arith Mod) e1 e2 -> + stdFunc "mod" (Args [Pos e1, Pos e2] Lazy) + EBinOp (Comp Eq) e1 e2 -> + stdFunc "equals" (Args [Pos e1, Pos e2] Lazy) + EBinOp (Comp Ne) e1 e2 -> + CUnyOp LNot (stdFunc "equals" (Args [Pos e1, Pos e2] Lazy)) + EBinOp op e1 e2 -> CBinOp op e1 e2 + EUnyOp op e -> CUnyOp op e + EIfElse c t e -> CIfElse c t e + EIf c t -> CIfElse c t (CLit Null) + EArr e -> CArr e + EObj {..} -> mkObj outermost locals fields + ELookup e1 e2 -> CLookup e1 e2 + EIndex e1 e2 -> CLookup e1 e2 + EErr e -> CErr e + EAssert e -> mkAssert e + ESlice {..} -> mkSlice expr start end step + EArrComp {expr, comp} -> mkArrComp expr comp + EObjComp {field, comp, locals} -> mkObjComp field comp locals + +mkSlice expr start end step = + stdFunc + "slice" + ( Args + [ Pos expr, + Pos $ maybeNull start, + Pos $ maybeNull end, + Pos $ maybeNull step + ] + Lazy + ) + where + maybeNull = fromMaybe (CLit Null) + +mkObj outermost locals fields = + --mkLet (("self", CObj fields) :| bnds) self + case bnds of + [] -> fs + xs -> mkLet (NE.fromList xs) fs + where + bnds = + if outermost + then (("$", fs) : locals) + else locals + fs = CObj (mkKeyValue <$> fields) + +mkAssert :: Assert Core -> Core +mkAssert (Assert c m e) = + CIfElse + c + e + ( CErr $ + fromMaybe + (CLit $ String "Assertion failed") + m + ) + +mkArrComp :: Core -> NonEmpty (CompSpec Core) -> Core +mkArrComp expr comp = foldr f (CArr [expr]) comp + where + f CompSpec {..} e = + CComp (ArrC (bind (s2n var) (e, ifspec))) forspec + +mkKeyValue :: Field Core -> KeyValue Core +mkKeyValue Field {..} = KeyValue key (Hideable value' visibility) + where + value' = + if override + then + CIfElse + (CBinOp In key super) + (CBinOp (Arith Add) (CLookup super key) value) + value + else value + super = CVar $ s2n "super" + +mkObjComp (Field {..}) comp locals = + CComp (ObjC (bind (s2n "arr") (kv', Nothing))) arrComp + where + kv' = + mkKeyValue + ( Field + { key = key', + value = value', + visibility, + override + } + ) + bnds = NE.zip (fmap var comp) xs + key' = mkLet bnds key + value' = case locals of + [] -> mkLet bnds value + -- we need to nest the let bindings due to the impl. + xs -> mkLet bnds $ mkLet (NE.fromList xs) value + xs = CLookup (CVar $ s2n "arr") . CLit . Number . fromIntegral <$> [0 ..] + arrComp = mkArrComp arr comp + arr = CArr $ NE.toList $ CVar . s2n . var <$> comp + +stdFunc :: Text -> Args Core -> Core +stdFunc f = + CApp + ( CLookup + (CVar "std") + (CLit $ String f) + ) + +mkFun ps e = + CFun $ + Fun $ + bind + ( rec $ + fmap + ( \(n, a) -> + (s2n n, Embed a) + ) + ps + ) + e + +mkLet bnds e = + CLet $ + Let $ + bind + ( rec $ + toList + ( fmap + ( \(n, a) -> + (s2n n, Embed a) + ) + bnds + ) + ) + e diff --git a/src/Language/Jsonnet/Error.hs b/src/Language/Jsonnet/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Error.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +module Language.Jsonnet.Error where + +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Void (Void) +import Language.Jsonnet.Common +import Language.Jsonnet.Core +import Language.Jsonnet.Parser.SrcSpan +import Text.Megaparsec (ParseErrorBundle) +import Text.PrettyPrint.ANSI.Leijen (Doc) + +data Error + = ParserError ParserError + | CheckError CheckError (Maybe SrcSpan) + | EvalError EvalError (Backtrace Core) + deriving (Show) + +data EvalError + = TypeMismatch + { expected :: Text, + actual :: Text + } + | InvalidKey Doc + | DuplicateKey Doc + | NoSuchKey Doc + | InvalidIndex Doc + | IndexOutOfBounds Scientific + | DivByZero + | VarNotFound Doc + | AssertionFailed Doc + | TooManyArgs Int + | ParamNotBound Doc + | BadParam Doc + | StdError Doc + | RuntimeError Doc + | ManifestError Doc + deriving (Show) + +data ParserError + = ParseError (ParseErrorBundle Text Void) + | ImportError IOError (Maybe SrcSpan) + deriving (Eq, Show) + +data CheckError + = DuplicateParam String + | PosAfterNamedParam + | DuplicateBinding String + deriving (Show) diff --git a/src/Language/Jsonnet/Eval.hs b/src/Language/Jsonnet/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Eval.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Jsonnet.Eval + ( eval, + evalClos, + mergeWith, + module Language.Jsonnet.Eval.Monad, + ) +where + +import Control.Applicative +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State.Lazy +import Data.Aeson.Text +import Data.Bifunctor (second) +import Data.Bits +import Data.Foldable +import qualified Data.HashMap.Lazy as H +import Data.Int +import Data.List +import qualified Data.Map.Lazy as M +import Data.Maybe (catMaybes, isNothing) +import Data.Scientific (isInteger, toBoundedInteger) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as V +import Debug.Trace +import Language.Jsonnet.Common hiding (span) +import Language.Jsonnet.Core +import Language.Jsonnet.Error +import Language.Jsonnet.Eval.Monad +import Language.Jsonnet.Manifest +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Pretty () +import qualified Language.Jsonnet.Std.Lib as Std +import Language.Jsonnet.Value +import Text.PrettyPrint.ANSI.Leijen (pretty) +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Bind + +-- an evaluator for the core calculus, based on a +-- big-step, call-by-need operational semantics, matching +-- jsonnet specificaton + +eval :: Core -> Eval Value +eval = \case + CLoc sp e -> do + --traceShowM (spanBegin sp) + updateSpan (Just sp) >> eval e + CLit l -> evalLiteral l + CVar n -> do + env <- asks ctx + --sp <- gets currentPos + --traceShowM (spanBegin <$> sp) + v <- liftMaybe (VarNotFound (pretty n)) (M.lookup n env) + force v + CFun f -> VClos f <$> ask + CApp e es -> evalApp e =<< evalArgs es + cc@(CLet (Let bnd)) -> mdo + (r, e1) <- unbind bnd + bnds <- + mapM + ( \(v, Embed e) -> do + th <- mkThunk $ extendCtx' bnds $ eval e + pure (v, th) + ) + (unrec r) + + --traceShowM "applying the body of the local binding" + --traceShowM e1 + extendCtx' bnds (eval e1) + CObj e -> evalObj e + CArr e -> VArr . V.fromList <$> traverse thunk e + CBinOp (Logical op) e1 e2 -> do + e1' <- thunk e1 + e2' <- thunk e2 + evalLogical op e1' e2' + CBinOp op e1 e2 -> do + e1' <- eval e1 + e2' <- eval e2 + evalBinOp op e1' e2' + CUnyOp op e -> do + e' <- eval e + evalUnyOp op e' + CLookup e1 e2 -> do + v1 <- eval e1 + v2 <- eval e2 + evalLookup v1 v2 + CIfElse c e1 e2 -> do + eval c >>= \case + VBool b -> + if b + then eval e1 + else eval e2 + v -> throwTypeMismatch "bool" v + CErr e -> + ( eval + >=> toString + >=> throwE . RuntimeError . pretty + ) + e + CComp (ArrC bnd) cs -> do + evalArrComp cs bnd + CComp (ObjC bnd) cs -> do + evalObjComp cs bnd + +thunk :: Core -> Eval Thunk +thunk e = + ask >>= \rho -> + mkThunk $ withCtx (ctx rho) (eval e) + +extendCtx' :: [(Name Core, Thunk)] -> Eval a -> Eval a +extendCtx' = extendCtx . M.fromList + +evalArgs :: Args Core -> Eval [Arg Thunk] +evalArgs = \case + as@(Args _ Lazy) -> args <$> traverse thunk as + as@(Args _ Strict) -> args <$> traverse f as + where + f = eval >=> pure . mkThunk' + +evalApp :: Core -> [Arg Thunk] -> Eval Value +evalApp e vs = withStackFrame e $ do + eval e >>= \case + VClos f Env {..} -> evalClos ctx f vs + v@(VFun _) -> foldlM f v vs + where + f (VFun g) (Pos v) = g v + f v _ = throwTypeMismatch "function" v + v -> throwTypeMismatch "function" v + +withStackFrame :: Core -> Eval a -> Eval a +withStackFrame (CLoc sp (CVar n)) e = + pushScope n (pushSpan (Just sp) e) +withStackFrame (CLoc sp _) e = + pushScope (s2n "anonymous") (pushSpan (Just sp) e) +withStackFrame (CVar n) e = + pushScope n (pushSpan Nothing e) +withStackFrame _ e = + pushScope (s2n "anonymous") (pushSpan Nothing e) + +evalClos :: Ctx -> Fun -> [Arg Thunk] -> Eval Value +evalClos rho (Fun f) vs = do + (bnds, e) <- unbind f + let xs = second unembed <$> unrec bnds + withCtx rho (evalFun xs e vs) + +appDefaults :: [(Name Core, Maybe Core)] -> Core -> Eval Value +appDefaults rs e = do + case findIndex isNothing ds of + Just x -> throwE $ ParamNotBound (pretty $ ns !! x) + Nothing -> mdo + bnds <- + mapM + ( \(v, e) -> do + th <- mkThunk $ extendCtx' bnds $ eval e + pure (v, th) + ) + (zip ns $ catMaybes ds) + extendCtx' bnds (eval e) + where + (ns, ds) = unzip rs + +evalFun bnds e args = do + if length ps > length bnds + then throwE $ TooManyArgs (length bnds) + else extendCtx' (zip names ps') $ evalNamedArgs ns bnds' + where + isPos = \case + Pos _ -> True + _ -> False + (ps, ns) = span isPos args + ps' = fmap (\(Pos a) -> a) ps + (names, _) = unzip bnds + bnds' = drop (length ps) bnds + evalNamedArgs ns bnds = do + ns' <- forM ns $ \case + Named n v -> pure (n, v) + (names, vs) <- unzip <$> buildParams ns' bnds + let rs = filter ((`notElem` names) . fst) bnds + extendCtx' (zip names vs) (appDefaults rs e) + where + buildParams as bnds = traverse f as + where + ns = fst $ unzip bnds + f (a, b) = case g a of + Nothing -> throwE $ BadParam (pretty a) + Just n -> pure (n, b) + g a = find ((a ==) . name2String) ns + +-- | right-biased union of two objects, i.e. '{x : 1} + {x : 2} == {x : 2}' +mergeWith :: Object -> Object -> Object +mergeWith xs ys = + let f a b + | hidden a && visible b = a + | otherwise = b + g name xs = fmap $ + \case + TC rho e -> TC (M.insert name (mkThunk' $ VObj xs) rho) e + v@(TV {}) -> v + h name xs = fmap $ + \case + TC rho e -> TC (insert' name (mkThunk' $ VObj xs) rho) e + v@(TV {}) -> v + xs' = H.map (g "self" zs') xs + ys' = H.map (g "self" zs' . h "super" xs') ys + zs' = H.unionWith f xs' ys' + insert' = M.insertWith (const) + in zs' + +evalObj :: [KeyValue Core] -> Eval Value +evalObj xs = mdo + env <- asks ctx + fs <- + catMaybes + <$> mapM + ( \(KeyValue key value) -> do + k <- evalKey key + v <- pure $ TC (M.insert "self" (self fs) env) <$> value + case k of + Just k -> pure $ Just (k, v) + _ -> pure Nothing + ) + xs + pure $ VObj $ H.fromList $ fs + where + self = mkThunk' . VObj . H.fromList + +evalKey :: Core -> Eval (Maybe Text) +evalKey key = + eval key >>= \case + VStr k -> pure $ Just k + VNull -> pure Nothing + v -> throwInvalidKey v + +evalKeyValue :: KeyValue Core -> Eval (Maybe (Text, Hideable Thunk)) +evalKeyValue (KeyValue key value) = do + a <- evalKey key + b <- asks ctx >>= \rho -> pure (TC rho <$> value) + pure $ (,b) <$> a + +evalArrComp :: + Core -> + Bind (Name Core) (Core, Maybe Core) -> + Eval Value +evalArrComp cs bnd = do + xs <- comp + inj' flattenArrays $ VArr $ V.mapMaybe id xs + where + comp = + eval cs >>= \case + VArr xs -> forM xs $ \x -> do + (n, (e, cond)) <- unbind bnd + extendCtx' [(n, x)] $ do + b <- f cond + if b + then Just <$> thunk e + else pure Nothing + v -> throwTypeMismatch "array" v + where + f Nothing = pure True + f (Just c) = do + vb <- eval c + proj vb + +evalObjComp :: + Core -> + Bind (Name Core) (KeyValue Core, Maybe Core) -> + Eval Value +evalObjComp cs bnd = do + xs <- comp + pure $ VObj $ H.fromList $ catMaybes $ V.toList xs + where + comp = + eval cs >>= \case + VArr xs -> forM xs $ \x -> do + (n, (e, cond)) <- unbind bnd + extendCtx' [(n, x)] $ do + b <- f cond + if b + then evalKeyValue e + else pure Nothing + v -> throwTypeMismatch "array" v + f Nothing = pure True + f (Just c) = do + vb <- eval c + proj vb + +evalUnyOp :: UnyOp -> Value -> Eval Value +evalUnyOp Compl x = inj <$> fmap (complement @Int64) (proj x) +evalUnyOp LNot x = inj <$> fmap not (proj x) +evalUnyOp Minus x = inj <$> fmap (negate @Double) (proj x) +evalUnyOp Plus x = inj <$> fmap (id @Double) (proj x) + +evalBinOp :: BinOp -> Value -> Value -> Eval Value +evalBinOp In s o = evalBin (\o s -> Std.objectHasEx o s True) o s +evalBinOp (Arith Add) x@(VStr _) y = inj <$> append x y +evalBinOp (Arith Add) x y@(VStr _) = inj <$> append x y +evalBinOp (Arith Add) x@(VArr _) y@(VArr _) = evalBin ((V.++) @Thunk) x y +evalBinOp (Arith Add) (VObj x) (VObj y) = pure $ VObj (x `mergeWith` y) +evalBinOp (Arith op) x y = evalArith op x y +evalBinOp (Comp op) x y = evalComp op x y +evalBinOp (Bitwise op) x y = evalBitwise op x y + +evalArith :: ArithOp -> Value -> Value -> Eval Value +evalArith Add n1 n2 = evalBin ((+) @Double) n1 n2 +evalArith Sub n1 n2 = evalBin ((-) @Double) n1 n2 +evalArith Mul n1 n2 = evalBin ((*) @Double) n1 n2 +evalArith Div (VNum _) (VNum 0) = throwE DivByZero +evalArith Div n1 n2 = evalBin ((/) @Double) n1 n2 +evalArith Mod (VNum _) (VNum 0) = throwE DivByZero +evalArith Mod n1 n2 = evalBin (mod @Int64) n1 n2 + +evalComp :: CompOp -> Value -> Value -> Eval Value +evalComp Lt n1 n2 = evalBin ((<) @Double) n1 n2 +evalComp Gt n1 n2 = evalBin ((>) @Double) n1 n2 +evalComp Le n1 n2 = evalBin ((<=) @Double) n1 n2 +evalComp Ge n1 n2 = evalBin ((>=) @Double) n1 n2 + +evalLogical :: LogicalOp -> Thunk -> Thunk -> Eval Value +evalLogical LAnd e1 e2 = do + force e1 >>= \case + VBool True -> force e2 >>= \x -> inj <$> fmap (id @Bool) (proj x) + VBool False -> pure (VBool False) + v -> throwTypeMismatch "boolean" v +evalLogical LOr e1 e2 = do + force e1 >>= \case + VBool False -> force e2 >>= \x -> inj <$> fmap (id @Bool) (proj x) + VBool True -> pure (VBool True) + v -> throwTypeMismatch "boolean" v + +evalBitwise :: BitwiseOp -> Value -> Value -> Eval Value +evalBitwise And = evalBin ((.&.) @Int64) +evalBitwise Or = evalBin ((.|.) @Int64) +evalBitwise Xor = evalBin (xor @Int64) +evalBitwise ShiftL = evalBin (shiftL @Int64) +evalBitwise ShiftR = evalBin (shiftR @Int64) + +evalLookup :: Value -> Value -> Eval Value +evalLookup (VArr a) (VNum i) + | isInteger i = + liftMaybe (IndexOutOfBounds i) ((a !?) =<< toBoundedInteger i) >>= force +evalLookup (VArr _) _ = + throwE (InvalidIndex $ "array index was not integer") +evalLookup (VObj o) (VStr s) = + liftMaybe (NoSuchKey (pretty s)) (H.lookup s o) + >>= \(Hideable v _) -> force v +evalLookup (VStr s) (VNum i) | isInteger i = do + liftMaybe (IndexOutOfBounds i) (f =<< bounded) + where + f = pure . VStr . T.singleton . T.index s + bounded = + toBoundedInteger i >>= \i' -> + if T.length s - 1 < i' && i' < 0 + then Nothing + else Just i' +evalLookup (VStr _) _ = + throwE (InvalidIndex $ "string index was not integer") +evalLookup v _ = throwTypeMismatch "array/object/string" v + +evalLiteral :: Literal -> Eval Value +evalLiteral = \case + Null -> pure VNull + Bool b -> pure $ VBool b + String s -> pure $ VStr s + Number n -> pure $ VNum n + +evalBin :: + (HasValue a, HasValue b, HasValue c) => + (a -> b -> c) -> + Value -> + Value -> + Eval Value +evalBin = inj'' + +append :: Value -> Value -> Eval Text +append v1 v2 = T.append <$> toString v1 <*> toString v2 + +throwInvalidKey :: Value -> Eval a +throwInvalidKey = throwE . InvalidKey . pretty . valueType + +updateSpan :: Maybe SrcSpan -> Eval () +updateSpan sp = modify $ \st -> st {currentPos = sp} + +toString :: Value -> Eval Text +toString (VStr s) = pure s +toString v = toStrict . encodeToLazyText <$> manifest v + +flattenArrays :: Vector (Vector Thunk) -> Vector Thunk +flattenArrays = join + +liftMaybe :: EvalError -> Maybe a -> Eval a +liftMaybe e = + \case + Nothing -> throwE e + Just a -> pure a diff --git a/src/Language/Jsonnet/Eval.hs-boot b/src/Language/Jsonnet/Eval.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Eval.hs-boot @@ -0,0 +1,10 @@ +module Language.Jsonnet.Eval where + +import Language.Jsonnet.Common +import Language.Jsonnet.Core +import Language.Jsonnet.Eval.Monad +import {-# SOURCE #-} Language.Jsonnet.Value (Thunk, Value) + +eval :: Core -> Eval Value + +evalClos :: Ctx -> Fun -> [Arg Thunk] -> Eval Value diff --git a/src/Language/Jsonnet/Eval/Monad.hs b/src/Language/Jsonnet/Eval/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Eval/Monad.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Language.Jsonnet.Eval.Monad where + +import Control.Arrow +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Except +import Control.Monad.RWS.Strict +import Control.Monad.Reader +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as M +import Data.Maybe (listToMaybe) +import Debug.Trace +import GHC.Generics +import Language.Jsonnet.Common +import Language.Jsonnet.Core +import Language.Jsonnet.Error +import Language.Jsonnet.Parser.SrcSpan +import {-# SOURCE #-} Language.Jsonnet.Value (Thunk) +import Unbound.Generics.LocallyNameless + +instance (Monoid w, Fresh m) => Fresh (RWST r w s m) where + fresh = lift . fresh + +newtype Eval a = Eval + { unEval :: ExceptT Error (RWST Env () EvalState (FreshMT IO)) a + } + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadFix, + MonadWriter (), + MonadReader Env, + MonadError Error, + MonadState EvalState, + MonadThrow, + MonadCatch, + MonadMask, + MonadFail, + Fresh, + Generic + ) + +type Ctx = Map (Name Core) Thunk + +extendCtx :: Ctx -> Eval a -> Eval a +extendCtx ctx' = + local + ( \env@Env {ctx} -> + env {ctx = M.union ctx' ctx} + ) + +pushScope :: Name Core -> Eval a -> Eval a +pushScope name = + local + ( \env@Env {scopes} -> + env {scopes = Just name : scopes} + ) + +pushSpan :: Maybe SrcSpan -> Eval a -> Eval a +pushSpan span c = do + local + ( \env@Env {spans} -> + env {spans = span : spans} + ) + c + +withCtx :: Ctx -> Eval a -> Eval a +withCtx ctx = local (\env -> env {ctx = ctx}) + +data Env = Env + { ctx :: Ctx, + spans :: [Maybe SrcSpan], + scopes :: [Maybe (Name Core)] + } + +withEnv :: Env -> Eval a -> Eval a +withEnv rho = local (const rho) + +emptyEnv :: Env +emptyEnv = Env M.empty [] [Nothing] + +data EvalState = EvalState + { currentPos :: Maybe SrcSpan + } + +emptyState :: EvalState +emptyState = EvalState Nothing + +-- traceShowM $ "length of spans: " +-- traceShowM $ length sp +-- traceShowM $ "length of scopes: " +-- traceShowM $ length sc +getBacktrace :: Eval (Backtrace Core) +getBacktrace = do + sp <- (:) <$> gets currentPos <*> asks spans + sc <- asks scopes + pure $ + Backtrace $ + case sequence sp of + Just sp -> zipWith StackFrame sc sp + Nothing -> [] + +throwE :: EvalError -> Eval a +throwE e = throwError . EvalError e =<< getBacktrace + +runEval :: Env -> Eval a -> ExceptT Error IO a +runEval env = mapExceptT f . unEval + where + f comp = do + (a, _, _) <- runFreshMT $ runRWST comp env emptyState + pure a diff --git a/src/Language/Jsonnet/Eval/Monad.hs-boot b/src/Language/Jsonnet/Eval/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Eval/Monad.hs-boot @@ -0,0 +1,5 @@ +module Language.Jsonnet.Eval.Monad where + +data Eval a + +data EvalState diff --git a/src/Language/Jsonnet/Manifest.hs b/src/Language/Jsonnet/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Manifest.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Language.Jsonnet.Manifest where + +import Control.Monad.Except +import Data.Aeson (FromJSON (..)) +import qualified Data.Aeson as JSON +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as H +import Data.Text (Text) +import Data.Vector (Vector) +import Debug.Trace +import Language.Jsonnet.Common +import Language.Jsonnet.Error +import Language.Jsonnet.Eval.Monad +import Language.Jsonnet.Value + +manifest :: Value -> Eval JSON.Value +manifest = + \case + VNull -> pure JSON.Null + VBool b -> pure $ JSON.Bool b + VNum n -> pure $ JSON.Number n + VStr s -> pure $ JSON.String s + VArr a -> JSON.Array <$> forceArray a + VObj o -> JSON.Object <$> forceObject o + VClos {} -> throwE (ManifestError "function") + VFun _ -> throwE (ManifestError "function") + +forceArray :: Vector Thunk -> Eval (Vector JSON.Value) +forceArray = traverse (force >=> manifest) + +forceObject :: Object -> Eval (HashMap Text JSON.Value) +forceObject = traverse (force >=> manifest) . visibleKeys + +visibleKeys :: Object -> HashMap Text Thunk +visibleKeys o = + H.fromList [(k, v) | (k, vv@(Hideable v _)) <- xs, not (hidden vv)] + where + xs = H.toList o diff --git a/src/Language/Jsonnet/Parser.hs b/src/Language/Jsonnet/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Parser.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Language.Jsonnet.Parser where + +import Control.Applicative hiding (many, some) +import Control.Arrow (left) +import Control.Monad +import Control.Monad.Combinators.Expr +import qualified Control.Monad.Combinators.NonEmpty as NE +import Control.Monad.Except +import Data.Char +import Data.Either +import Data.Fix +import Data.Functor +import Data.Functor.Sum +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Void +import GHC.IO.Exception hiding (IOError) +import Language.Jsonnet.Annotate +import Language.Jsonnet.Common +import Language.Jsonnet.Error +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Syntax +import Language.Jsonnet.Syntax.Annotated +import System.Directory +import System.FilePath.Posix (takeDirectory) +import System.IO.Error (tryIOError) +import Text.Megaparsec hiding (ParseError, parse) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +type Parser = Parsec Void Text + +parse :: + MonadError Error m => + FilePath -> + Text -> + m Expr' +parse fp inp = + liftEither $ + left (ParserError . ParseError) $ + runParser (sc *> exprP <* eof) fp inp + +resolveImports :: + (MonadError Error m, MonadIO m) => + FilePath -> + Expr' -> + m Expr +resolveImports fp = foldFixM go + where + go (AnnF (InL e) a) = pure $ Fix $ AnnF e a + go (AnnF (InR (Const (Import fp'))) a) = + resolveImports fp' + =<< parse fp' + =<< readImportFile fp' a + readImportFile fp' a = do + inp <- readFile' fp' + liftEither $ left (ParserError . flip ImportError (Just a)) inp + where + readFile' = + liftIO + . tryIOError + . withCurrentDirectory (takeDirectory fp) + . T.readFile + +sc :: Parser () +sc = L.space space1 lineComment blockComment + where + lineComment = L.skipLineComment "//" <|> L.skipLineComment "#" + blockComment = L.skipBlockComment "/*" "*/" + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +comma :: Parser Text +comma = symbol "," + +colon :: Parser Text +colon = symbol ":" + +annotateLoc :: Parser (f a) -> Parser (AnnF f SrcSpan a) +annotateLoc p = do + begin <- getSourcePos + res <- p + end <- getSourcePos + pure $ AnnF res $ SrcSpan begin end + +identifier :: Parser String +identifier = do + ident <- p + when (ident `elem` reservedKeywords) $ + fail $ + "Keyword " <> ident <> " cannot be an identifier." + pure ident + where + p = + lexeme + ( (:) + <$> (letterChar <|> char '_') + <*> many (alphaNumChar <|> char '_') + ) + +keywordP :: Text -> Parser Text +keywordP keyword = lexeme (string keyword <* notFollowedBy alphaNumChar) + +-- unfinished string parser +stringLiteral :: Parser String +stringLiteral = quoted (char '\"') <|> quoted (char '\'') + where + quoted c = + c + *> manyTill + ( try escapeUnicode <|> escapeAscii + <|> anySingle + ) + c + +escapeAscii :: Parser Char +escapeAscii = do + void (char '\\') + choice + [ char '\"' $> '\"', + char '\'' $> '\'', -- this one is jsonnet specific + char '\\' $> '\\', + char '/' $> '/', + char 'n' $> '\n', + char 'r' $> '\r', + char 'f' $> '\f', + char 't' $> '\t', + char 'b' $> '\b' + ] + +escapeUnicode :: Parser Char +escapeUnicode = do + _ <- string "\\u" + hex <- ("0x" ++) <$> count 4 hexDigitChar + pure (chr $ read hex) + +verbatimString :: Parser String +verbatimString = char '@' *> (quoted (char '\'') <|> quoted (char '\"')) + where + quoted c = + c + *> manyTill + ((c *> c) <|> anySingle) + (try $ c <* notFollowedBy c) + +textBlock :: Parser String +textBlock = do + _ <- symbol "|||" <* sc' + ref <- L.indentLevel + x <- line + xs <- + manyTill + (L.indentGuard (sc'' ref) EQ ref >> line) + (try $ sc' *> symbol "|||") + pure $ concat (x : xs) + where + line :: Parser String + line = (++) <$> many (anySingleBut '\n') <*> some (char '\n') + sc' :: Parser () + sc' = L.space (void $ some (char ' ' <|> char '\t')) empty empty + sc'' :: Pos -> Parser () + sc'' x = void $ count' 0 (unPos x - 1) (oneOf [' ', '\t']) + +unquoted :: Parser Expr' +unquoted = Fix <$> annotateLoc (mkStrF <$> identifier) + +stringP :: Parser Expr' +stringP = + Fix + <$> annotateLoc + ( mkStrF + <$> ( verbatimString + <|> stringLiteral + <|> textBlock + ) + ) + +numberP :: Parser Expr' +numberP = Fix <$> annotateLoc number + where + number = mkFloatF <$> lexeme L.scientific + +identP :: Parser Expr' +identP = Fix <$> annotateLoc (mkIdentF <$> (try (T.unpack <$> symbol "$") <|> identifier)) + +booleanP :: Parser Expr' +booleanP = Fix <$> annotateLoc boolean + where + boolean = + keywordP "true" $> mkBoolF True + <|> keywordP "false" $> mkBoolF False + +nullP :: Parser Expr' +nullP = Fix <$> annotateLoc null + where + null = keywordP "null" $> mkNullF + +errorP :: Parser Expr' +errorP = Fix <$> annotateLoc error + where + error = keywordP "error" *> (mkErrorF <$> exprP) + +assertP :: Parser Expr' +assertP = Fix <$> annotateLoc assert + where + assert = do + cond <- keywordP "assert" *> exprP + msg <- optional (colon *> exprP) + _ <- symbol ";" + expr <- exprP + pure $ mkAssertF cond msg expr + +ifElseP :: Parser Expr' +ifElseP = Fix <$> annotateLoc ifElseExpr + where + ifElseExpr = do + cond <- keywordP "if" *> exprP + expr <- keywordP "then" *> exprP + option + (mkIfF cond expr) + (keywordP "else" *> (mkIfElseF cond expr <$> exprP)) + +paramsP :: Parser [Param Expr'] +paramsP = parens (param `sepEndBy` comma) + where + param = (,) <$> identifier <*> optional (symbol "=" *> exprP) + +function :: + Parser [Param Expr'] -> + Parser Expr' -> + Parser Expr' +function ps expr = Fix <$> annotateLoc (mkFunF <$> ps <*> expr) + +functionP :: Parser Expr' +functionP = keywordP "function" *> function paramsP exprP + +forspecP :: Parser (CompSpec Expr') +forspecP = do + _ <- keywordP "for" + var <- identifier + _ <- keywordP "in" + forspec <- exprP + ifspec <- optional (keywordP "if" *> exprP) + pure CompSpec {..} + +binding :: Parser (String, Expr') +binding = do + name <- identifier + _ <- symbol "=" + expr <- exprP + pure (name, expr) + +localFunc :: Parser (String, Expr') +localFunc = do + name <- identifier + ps <- paramsP + _ <- symbol "=" + expr <- function (pure ps) exprP + pure (name, expr) + +localBndsP :: Parser (NonEmpty (String, Expr')) +localBndsP = do + _ <- keywordP "local" + (try binding <|> localFunc) `NE.sepBy1` comma + +localP :: Parser Expr' +localP = Fix <$> annotateLoc localExpr + where + localExpr = do + bnds <- localBndsP + _ <- symbol ";" + expr <- exprP + pure $ mkLocalF bnds expr + +arrayP :: Parser Expr' +arrayP = Fix <$> annotateLoc (brackets (try arrayComp <|> array)) + where + array = mkArrayF <$> (exprP `sepEndBy` comma) + arrayComp = do + expr <- exprP <* optional comma + comps <- NE.some forspecP + return $ mkArrCompF expr comps + +objectP :: Parser Expr' +objectP = Fix <$> annotateLoc (braces (try objectComp <|> object)) + where + object = do + xs <- eitherP localP fieldP `sepEndBy` comma + let (ls, fs) = (lefts xs, rights xs) + pure $ mkObjectF fs ls + fieldP = try methodP <|> pairP + pairP = do + key <- keyP + (override, visibility) <- + (,) + <$> option False ((symbol "+") $> True) <*> sepP + value <- exprP + pure $ Field {..} + keyP = brackets exprP <|> unquoted <|> stringP + methodP = do + let override = False + key <- unquoted + ps <- paramsP + visibility <- sepP + value <- function (pure ps) exprP + pure $ Field {..} + sepP = + try (symbol ":::" $> Forced) + <|> try (symbol "::" $> Hidden) + <|> (symbol ":" $> Visible) + localP = do + _ <- keywordP "local" + try binding <|> localFunc + objectComp = do + locals1 <- localP `sepEndBy` comma + expr <- pairP <* optional comma + locals2 <- localP `sepEndBy` comma + comps <- NE.some forspecP + return $ mkObjCompF expr (locals1 <> locals2) comps + +importP :: Parser Expr' +importP = Fix <$> annotateLoc importDecl + where + importDecl = mkImportF <$> (keywordP "import" *> stringLiteral) + +binary :: + Text -> + (Expr' -> Expr' -> Expr') -> + Operator Parser Expr' +binary name f = InfixL (f <$ operator name) + where + operator sym = try $ symbol sym <* notFollowedBy opChar + opChar = oneOf (":~+&|^=<>*/%" :: [Char]) "operator" + +prefix :: + Text -> + (Expr' -> Expr') -> + Operator Parser Expr' +prefix name f = Prefix (f <$ symbol name) + +-- | associativity and operator precedence +-- 1. @e(...)@ @e[...]@ @e.f@ (application and indexing) +-- 2. @+@ @-@ @!@ @~@ (the unary operators) +-- 3. @*@ @/@ @%@ (these, and the remainder below, are binary operators) +-- 4. @+@ @-@ +-- 5. @<<@ @>>@ +-- 6. @<@ @>@ @<=@ @>=@ @in@ +-- 7. @==@ @!=@ +-- 8. @&@ +-- 9. @^@ +-- 10. @|@ +-- 11. @&&@ +-- 12. @||@ +-- default is associate to the left +opTable :: [[Operator Parser Expr']] +opTable = + [ [Postfix postfixOperators], + [ prefix "+" (mkUnyOp Plus), + prefix "-" (mkUnyOp Minus), + prefix "!" (mkUnyOp LNot), + prefix "~" (mkUnyOp Compl) + ], + [ binary "*" (mkBinOp (Arith Mul)), + binary "/" (mkBinOp (Arith Div)), + binary "%" (mkBinOp (Arith Mod)) + ], + [ binary "+" (mkBinOp (Arith Add)), + binary "-" (mkBinOp (Arith Sub)), + Postfix postfixObjectMerge + ], + [ binary ">>" (mkBinOp (Bitwise ShiftR)), + binary "<<" (mkBinOp (Bitwise ShiftL)) + ], + [ binary "in" (mkBinOp In), + binary ">" (mkBinOp (Comp Gt)), + binary "<=" (mkBinOp (Comp Le)), + binary ">=" (mkBinOp (Comp Ge)), + binary "<" (mkBinOp (Comp Lt)) + ], + [ binary "==" (mkBinOp (Comp Eq)), + binary "!=" (mkBinOp (Comp Ne)) + ], + [binary "&" (mkBinOp (Bitwise And))], + [binary "^" (mkBinOp (Bitwise Xor))], + [binary "|" (mkBinOp (Bitwise Or))], + [binary "&&" (mkBinOp (Logical LAnd))], + [binary "||" (mkBinOp (Logical LOr))] + ] + +-- | shorthand syntax for object composition: +-- when the right-hand side is an object literal the '+' +-- operator can be elided. +postfixObjectMerge :: Parser (Expr' -> Expr') +postfixObjectMerge = flip (mkBinOp (Arith Add)) <$> objectP + +-- | application, indexing and lookup: e(...) e[...] e.f +-- all have the same precedence (the highest) +postfixOperators :: Parser (Expr' -> Expr') +postfixOperators = + foldr1 (flip (.)) + <$> some + ( applyP + <|> try sliceP + <|> indexP + <|> lookupP + ) + +indexP :: Parser (Expr' -> Expr') +indexP = flip mkIndex <$> brackets exprP + +lookupP :: Parser (Expr' -> Expr') +lookupP = flip mkLookup <$> (symbol "." *> unquoted) + +-- arguments are many postional followed by many named +-- just like Python +applyP :: Parser (Expr' -> Expr') +applyP = flip mkApply <$> argsP + where + argsP :: Parser (Args Expr') + argsP = Args <$> parens (args `sepEndBy` comma) <*> tailstrict + where + args = try named <|> posal + posal = Pos <$> exprP + named = Named <$> identifier <*> (symbol "=" *> exprP) + tailstrict = option Lazy (keywordP "tailstrict" $> Strict) + +sliceP :: Parser (Expr' -> Expr') +sliceP = brackets $ do + start <- optional exprP <* colon + end <- optional exprP + step <- optional (colon *> optional exprP) + pure $ mkSlice start end (join step) + +primP :: Parser Expr' +primP = + lexeme $ + choice + [ try identP, + numberP, + stringP, + booleanP, + nullP, + ifElseP, + functionP, + objectP, + arrayP, + localP, + importP, + errorP, + assertP, + parens exprP + ] + +exprP :: Parser Expr' +exprP = makeExprParser primP opTable + +reservedKeywords :: [String] +reservedKeywords = + [ "assert", + "else", + "error", + "false", + "for", + "function", + "if", + "import", + "importstr", + "in", + "local", + "null", + "tailstrict", + "then", + "true" + ] diff --git a/src/Language/Jsonnet/Parser/SrcSpan.hs b/src/Language/Jsonnet/Parser/SrcSpan.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Parser/SrcSpan.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +module Language.Jsonnet.Parser.SrcSpan where + +import Data.Data +import Data.Function (on) +import GHC.Generics (Generic) +import Text.Megaparsec.Pos (SourcePos (..)) +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.TH + +data SrcSpan = SrcSpan + { spanBegin :: SourcePos, + spanEnd :: SourcePos + } + deriving + ( Ord, + Eq, + Show, + Read, + Generic, + Typeable, + Data + ) + +$(makeClosedAlpha ''SrcSpan) + +instance Subst b SrcSpan where + subst _ _ = id + substs _ = id + +instance Semigroup SrcSpan where + s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2) + +class HasSrcSpan a where + srcSpan :: a -> SrcSpan + +instance HasSrcSpan SrcSpan where + srcSpan = id diff --git a/src/Language/Jsonnet/Pretty.hs b/src/Language/Jsonnet/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Pretty.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Jsonnet.Pretty where + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Text as JSON (encodeToLazyText) +import qualified Data.HashMap.Lazy as H +import Data.List (sortOn) +import Data.Scientific (Scientific (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +import qualified Data.Vector as V +import GHC.IO.Exception (IOException (..)) +import Language.Jsonnet.Common +import Language.Jsonnet.Error +import Language.Jsonnet.Parser.SrcSpan +import Text.Megaparsec.Error (errorBundlePretty) +import Text.Megaparsec.Pos +import Text.PrettyPrint.ANSI.Leijen hiding (encloseSep, (<$>)) +import Unbound.Generics.LocallyNameless (Name, name2String) + +instance Pretty (Name a) where + pretty v = pretty (name2String v) + +instance Pretty Text where + pretty v = pretty (T.unpack v) + +ppNumber s + | e < 0 || e > 1024 = + text $ + LT.unpack $ + toLazyText $ + scientificBuilder s + | otherwise = integer (coefficient s * 10 ^ e) + where + e = base10Exponent s + +ppJson :: Int -> JSON.Value -> Doc +ppJson i = + \case + JSON.Null -> text "null" + JSON.Number n -> ppNumber n + JSON.Bool True -> text "true" + JSON.Bool False -> text "false" + JSON.String s -> ppString s + JSON.Array a -> ppArray a + JSON.Object o -> ppObject o + where + encloseSep l r s ds = case ds of + [] -> l <> r + _ -> l <$$> indent i (vcat $ punctuate s ds) <$$> r + ppObject o = encloseSep lbrace rbrace comma xs + where + prop (k, v) = ppString k <> colon <+> ppJson i v + xs = map prop (sortOn fst $ H.toList o) + ppArray a = encloseSep lbracket rbracket comma xs + where + xs = map (ppJson i) (V.toList a) + ppString = text . LT.unpack . JSON.encodeToLazyText + +instance Pretty JSON.Value where + pretty = ppJson 4 + +instance Pretty SrcSpan where + pretty SrcSpan {spanBegin, spanEnd} = + text (sourceName spanBegin) + <> colon + <> lc spanBegin spanEnd + where + lc (SourcePos _ lb cb) (SourcePos _ le ce) + | lb == le = + int (unPos lb) <> colon + <> int (unPos cb) + <> dash + <> int (unPos ce) + | otherwise = + int (unPos lb) <> colon <> int (unPos cb) <> dash + <> int (unPos le) + <> colon + <> int (unPos ce) + dash = char '-' + +instance Pretty ParserError where + pretty (ParseError e) = pretty (errorBundlePretty e) + pretty (ImportError (IOError _ _ _ desc _ f) sp) = + text "Parse error:" + <+> pretty f + <+> parens (text desc) + <$$> indent 4 (pretty sp) + +instance Pretty CheckError where + pretty = + \case + DuplicateParam e -> + text "duplicate parameter" + <+> squotes (text e) + DuplicateBinding e -> + text "duplicate local var" + <+> squotes (text e) + PosAfterNamedParam -> + text "positional after named argument" + +instance Pretty EvalError where + pretty = + \case + TypeMismatch {..} -> + text "type mismatch:" + <+> text "expected" + <+> text (T.unpack expected) + <+> text "but got" + <+> text (T.unpack actual) + InvalidKey k -> + text "invalid key:" + <+> k + InvalidIndex k -> + text "invalid index:" + <+> k + NoSuchKey k -> + text "no such key:" + <+> k + IndexOutOfBounds i -> + text "index out of bounds:" + <+> ppNumber i + DivByZero -> + text "divide by zero exception" + VarNotFound v -> + text "variable" + <+> squotes (text $ show v) + <+> text "is not defined" + AssertionFailed e -> + text "assertion failed:" <+> e + StdError e -> e + RuntimeError e -> e + ParamNotBound s -> + text "parameter not bound:" + <+> text (show s) + BadParam s -> + text "function has no parameter" + <+> squotes s + ManifestError e -> + text "manifest error:" + <+> e + TooManyArgs n -> + text "too many args, function has" + <+> int n + <+> "parameter(s)" + +instance Pretty (StackFrame a) where + pretty StackFrame {..} = + pretty span <+> pretty name' + where + name' = (<+>) (text "function") . angles . pretty <$> name + +instance Pretty (Backtrace a) where + pretty (Backtrace xs) = vcat $ pretty <$> xs + +instance Pretty Error where + pretty = + \case + EvalError e bt -> + text "Runtime error:" + <+> pretty e + <$$> indent 2 (pretty bt) + ParserError e -> pretty e + CheckError e sp -> + text "Static error:" + <+> pretty e + <$$> indent 2 (pretty sp) diff --git a/src/Language/Jsonnet/Std.hs b/src/Language/Jsonnet/Std.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Std.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Jsonnet.Std + ( std, + ) +where + +import Control.Monad.Except +import Language.Jsonnet.Annotate +import Language.Jsonnet.Desugar +import Language.Jsonnet.Error +import Language.Jsonnet.Eval +import Language.Jsonnet.Eval (mergeWith) +import Language.Jsonnet.Eval.Monad +import qualified Language.Jsonnet.Std.Lib as Lib +import Language.Jsonnet.Std.TH (mkStdlib) +import Language.Jsonnet.Value +import Prelude hiding (length) + +-- the jsonnet stdlib is written in both jsonnet and Haskell, here we merge +-- the native (small, Haskell) with the interpreted (the splice mkStdlib) +std :: ExceptT Error IO Value +std = do + ast <- pure $(mkStdlib) + core <- pure $ desugar (annMap (const ()) ast) + runEval emptyEnv (eval core >>= flip mergeObjects Lib.std) + where + mergeObjects (VObj x) (VObj y) = pure $ VObj (x `mergeWith` y) diff --git a/src/Language/Jsonnet/Std/Lib.hs b/src/Language/Jsonnet/Std/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Std/Lib.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Jsonnet.Std.Lib + ( std, + objectHasEx, + ) +where + +import Control.Monad.Except +import Control.Monad.State +import Data.Aeson (FromJSON (..)) +import qualified Data.Aeson as JSON +import qualified Data.ByteString as B +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as H +import Data.List (sort) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Word +import Language.Jsonnet.Common +import Language.Jsonnet.Core (Fun (Fun), KeyValue (..)) +import Language.Jsonnet.Error +import Language.Jsonnet.Eval.Monad +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Value +import System.FilePath.Posix (takeFileName) +import Text.Megaparsec.Pos (SourcePos (..)) +import Text.PrettyPrint.ANSI.Leijen (text) +import Unbound.Generics.LocallyNameless +import Prelude hiding (length) +import qualified Prelude as P (length) + +-- | The native subset of Jsonnet standard library +std :: Value +std = VObj $ H.fromList $ map f xs + where + f = \(k, v) -> (k, TV <$> Hideable v Hidden) + xs = + ("thisFile", inj <$> thisFile) : + map + (\(k, v) -> (k, pure v)) + [ ("type", inj valueType), + ("primitiveEquals", inj primitiveEquals), + ("length", inj length), + ("pow", inj ((^^) @Double @Int)), + ("exp", inj (exp @Double)), + ("log", inj (log @Double)), + ("exponent", inj (exponent @Double)), + ("mantissa", inj (significand @Double)), + ("floor", inj (floor @Double @Integer)), + ("ceil", inj (ceiling @Double @Integer)), + ("sqrt", inj (sqrt @Double)), + ("sin", inj (sin @Double)), + ("cos", inj (cos @Double)), + ("tan", inj (tan @Double)), + ("asin", inj (asin @Double)), + ("acos", inj (acos @Double)), + ("atan", inj (atan @Double)), + ("modulo", inj (mod @Integer)), + ("codepoint", inj (fromEnum . T.head)), + ("char", inj (T.singleton . toEnum)), + ("encodeUTF8", inj (B.unpack . T.encodeUtf8 :: Text -> [Word8])), + ("decodeUTF8", inj (T.decodeUtf8 . B.pack :: [Word8] -> Text)), + ("makeArray", inj makeArray), + ("filter", inj (filterM @Eval @Value)), + ("objectHasEx", inj objectHasEx), + ("objectFieldsEx", inj objectFieldsEx), + ("parseJson", inj (JSON.decodeStrict @Value)) + ] + +primitiveEquals :: Value -> Value -> Eval Bool +primitiveEquals VNull VNull = pure True +primitiveEquals (VBool a) (VBool b) = pure (a == b) +primitiveEquals (VStr a) (VStr b) = pure (a == b) +primitiveEquals (VNum a) (VNum b) = pure (a == b) +primitiveEquals _ _ = + throwE + ( StdError $ + text $ + T.unpack $ + "primitiveEquals operates on primitive types" + ) + +objectFieldsEx :: Object -> Bool -> [Text] +objectFieldsEx o True = sort (H.keys o) -- all fields +objectFieldsEx o False = sort $ H.keys $ H.filter (not . hidden) o -- only visible (incl. forced) + +objectHasEx :: Object -> Text -> Bool -> Bool +objectHasEx o f all = f `elem` objectFieldsEx o all + +length :: Value -> Eval Int +length = \case + VStr s -> pure $ T.length s + VArr a -> pure $ P.length a + VObj o -> pure $ P.length (H.keys o) + VClos (Fun f) _ -> do + (ps, _) <- unbind f + pure $ P.length (unrec ps) + v -> + throwE + ( StdError $ + text $ + T.unpack $ + "length operates on strings, objects, functions and arrays, got " + <> valueType v + ) + +makeArray :: Int -> (Int -> Eval Value) -> Eval [Value] +makeArray n f = traverse f [0 .. n - 1] + +-- hacky way of returning the current file +thisFile :: Eval (Maybe FilePath) +thisFile = f <$> gets currentPos + where + f = fmap (takeFileName . sourceName . spanBegin) + +instance FromJSON Value where + parseJSON = \case + JSON.Null -> pure VNull + JSON.Bool b -> pure $ VBool b + JSON.Number n -> pure $ VNum n + JSON.String s -> pure $ VStr s + JSON.Array a -> VArr <$> traverse (fmap mkThunk' . parseJSON) a + JSON.Object o -> VObj . f <$> traverse parseJSON o + where + f :: HashMap Text Value -> Object + f o = + H.fromList + [ (mkField k (mkThunk' v)) + | (k, v) <- H.toList o + ] + mkField k v = (k, Hideable v Visible) diff --git a/src/Language/Jsonnet/Std/TH.hs b/src/Language/Jsonnet/Std/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Std/TH.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Jsonnet.Std.TH where + +import qualified Data.Text.IO as TIO +import Language.Haskell.TH +import Language.Haskell.TH.Quote () +import Language.Haskell.TH.Syntax (addDependentFile) +import Language.Jsonnet.TH (parse) + +stdlibPath :: String +stdlibPath = "stdlib/std.jsonnet" + +mkStdlib :: Q Exp +mkStdlib = do + src <- runIO (TIO.readFile stdlibPath) + ast <- parse stdlibPath src + addDependentFile stdlibPath + pure ast diff --git a/src/Language/Jsonnet/Syntax.hs b/src/Language/Jsonnet/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Syntax.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Jsonnet.Syntax where + +import Control.Applicative (Const (..)) +import Data.Data (Data) +import Data.Functor.Sum +import Data.List.NonEmpty +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import GHC.Generics +import Language.Jsonnet.Common +import Text.Show.Deriving +import Unbound.Generics.LocallyNameless + +type Ident = String + +type Param a = (Ident, Maybe a) + +data Field a = Field + { key :: a, + value :: a, + visibility :: Visibility, + override :: Bool + } + deriving + ( Eq, + Read, + Show, + Typeable, + Data, + Generic, + Functor, + Foldable, + Traversable + ) + +instance Alpha a => Alpha (Field a) + +deriveShow1 ''Field + +data ExprF a + = ELit Literal + | EIdent Ident + | EFun [Param a] a + | EApply a (Args a) + | ELocal + { bnds :: NonEmpty (Ident, a), + expr :: a + } + | EObj + { locals :: [(Ident, a)], + fields :: [Field a] + --asserts :: [Assert a] + } + | EArr [a] + | EErr a + | ELookup a a + | EIndex a a + | EAssert (Assert a) + | EIf a a + | EIfElse a a a + | ESlice + { expr :: a, + start :: Maybe a, + end :: Maybe a, + step :: Maybe a + } + | EBinOp BinOp a a + | EUnyOp UnyOp a + | EArrComp + { expr :: a, + comp :: NonEmpty (CompSpec a) + } + | EObjComp + { field :: Field a, + locals :: [(Ident, a)], + comp :: NonEmpty (CompSpec a) + } + deriving + ( Show, + Functor, + Foldable, + Traversable, + Generic, + Typeable, + Data + ) + +deriveShow1 ''ExprF + +newtype Import = Import FilePath + deriving (Show, Eq) + +type ExprF' = Sum ExprF (Const Import) + +mkImportF :: String -> ExprF' a +mkImportF = InR . Const . Import + +mkNullF :: ExprF' a +mkNullF = (InL . ELit) Null + +mkIntF :: Integral b => b -> ExprF' a +mkIntF = InL . ELit . Number . fromIntegral + +mkFloatF :: Scientific -> ExprF' a +mkFloatF = InL . ELit . Number + +mkStrF :: String -> ExprF' a +mkStrF = InL . ELit . String . T.pack + +mkBoolF :: Bool -> ExprF' a +mkBoolF = InL . ELit . Bool + +mkIdentF :: Ident -> ExprF' a +mkIdentF = InL . EIdent + +mkFunF :: [Param a] -> a -> ExprF' a +mkFunF a = InL . EFun a + +mkApplyF :: a -> Args a -> ExprF' a +mkApplyF a = InL . EApply a + +mkIfF :: a -> a -> ExprF' a +mkIfF c = InL . EIf c + +mkIfElseF :: a -> a -> a -> ExprF' a +mkIfElseF c a = InL . EIfElse c a + +mkLocalF :: NonEmpty (Ident, a) -> a -> ExprF' a +mkLocalF n = InL . ELocal n + +mkLookupF :: a -> a -> ExprF' a +mkLookupF e = InL . ELookup e + +mkIndexF :: a -> a -> ExprF' a +mkIndexF e = InL . EIndex e + +mkSliceF :: a -> Maybe a -> Maybe a -> Maybe a -> ExprF' a +mkSliceF e f g = InL . ESlice e f g + +mkObjectF :: [Field a] -> [(Ident, a)] -> ExprF' a +mkObjectF fs ls = InL $ EObj ls fs + +mkArrayF :: [a] -> ExprF' a +mkArrayF = InL . EArr + +mkErrorF :: a -> ExprF' a +mkErrorF = InL . EErr + +mkAssertF :: a -> Maybe a -> a -> ExprF' a +mkAssertF e m = InL . EAssert . Assert e m + +mkArrCompF :: a -> NonEmpty (CompSpec a) -> ExprF' a +mkArrCompF e = InL . EArrComp e + +mkObjCompF :: Field a -> [(Ident, a)] -> NonEmpty (CompSpec a) -> ExprF' a +mkObjCompF f ls = InL . EObjComp f ls diff --git a/src/Language/Jsonnet/Syntax/Annotated.hs b/src/Language/Jsonnet/Syntax/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Syntax/Annotated.hs @@ -0,0 +1,45 @@ +-- | +module Language.Jsonnet.Syntax.Annotated where + +import Data.Fix +import Data.Functor.Sum +import Data.List.NonEmpty +import Data.Semigroup.Foldable +import Language.Jsonnet.Annotate +import Language.Jsonnet.Common +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Syntax + +-- annotated syntax tree with resolved imports +type Expr = Ann ExprF SrcSpan + +-- annotated syntax tree with unresolved imports +type Expr' = Ann ExprF' SrcSpan + +mkApply :: Expr' -> Args Expr' -> Expr' +mkApply a@(Fix (AnnF _ ann)) args = + Fix $ AnnF (InL $ EApply a args) ann + +--mkApply a@(Fix (AnnF _ ann)) b = +-- Fix $ AnnF (InL $ EApply a b) (fold1 (ann <| fmap attrib (fromList b))) + +mkLookup :: Expr' -> Expr' -> Expr' +mkLookup a@(Fix (AnnF _ ann1)) b@(Fix (AnnF _ ann2)) = + Fix $ AnnF (InL $ ELookup a b) (ann1 <> ann2) + +mkIndex :: Expr' -> Expr' -> Expr' +mkIndex a@(Fix (AnnF _ ann1)) b@(Fix (AnnF _ ann2)) = + Fix $ AnnF (InL $ EIndex a b) (ann1 <> ann2) + +mkSlice :: Maybe Expr' -> Maybe Expr' -> Maybe Expr' -> Expr' -> Expr' +mkSlice i n s e@(Fix (AnnF _ ann1)) = + Fix $ AnnF (InL $ ESlice e i n s) ann1 + +mkBinOp :: BinOp -> Expr' -> Expr' -> Expr' +mkBinOp op a@(Fix (AnnF _ ann1)) b@(Fix (AnnF _ ann2)) = + Fix $ AnnF (InL $ EBinOp op a b) (ann1 <> ann2) + +-- FIXME we are manually here updating the span +mkUnyOp :: UnyOp -> Expr' -> Expr' +mkUnyOp op a@(Fix (AnnF _ ann)) = + Fix $ AnnF (InL $ EUnyOp op a) ann diff --git a/src/Language/Jsonnet/TH.hs b/src/Language/Jsonnet/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/TH.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Jsonnet.TH where + +import Control.Monad.Except hiding (lift) +import Data.Data +import Data.Functor.Product +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Jsonnet.Common +import qualified Language.Jsonnet.Parser as Parser +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Pretty () +import Language.Jsonnet.Syntax +import Language.Jsonnet.Syntax.Annotated +import Text.PrettyPrint.ANSI.Leijen (pretty) + +instance Data a => Lift (Arg a) where + lift = liftData + +instance Data a => Lift (Hideable a) where + lift = liftData + +instance Lift SrcSpan where + lift = liftData + +instance Lift Visibility where + lift = liftData + +instance Data a => Lift (Args a) where + lift = liftData + +instance Lift Strictness where + lift = liftData + +instance Lift Literal where + lift = liftData + +instance Lift Scientific where + lift s = [|fromRational $(return $ LitE $ RationalL (toRational s))|] + +instance Lift BinOp where + lift = liftData + +instance Lift ArithOp where + lift = liftData + +instance Lift CompOp where + lift = liftData + +instance Lift BitwiseOp where + lift = liftData + +instance Lift LogicalOp where + lift = liftData + +instance Lift UnyOp where + lift = liftData + +instance Data a => Lift (Field a) where + lift = liftData + +instance Data a => Lift (Assert a) where + lift = liftData + +instance Data a => Lift (CompSpec a) where + lift = liftData + +instance Data a => Lift (ExprF a) where + lift = liftData + +instance + ( Typeable a, + Typeable f, + Typeable g, + Data (f a), + Data (g a) + ) => + Lift (Product f g a) + where + lift = liftData + +instance Lift Expr where + lift = liftData + +liftText :: Text -> Q Exp +liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) + +-- ouch: https://gitlab.haskell.org/ghc/ghc/-/issues/12596 +liftDataWithText :: Data a => a -> Q Exp +liftDataWithText = dataToExpQ (\a -> liftText <$> cast a) + +parse :: FilePath -> Text -> Q Exp +parse path str = do + res <- + runIO $ + parse' str >>= \case + Left err -> fail (show $ pretty err) + Right res -> pure res + liftDataWithText res + where + parse' = + runExceptT + . ( Parser.parse path + >=> Parser.resolveImports path + ) diff --git a/src/Language/Jsonnet/TH/QQ.hs b/src/Language/Jsonnet/TH/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/TH/QQ.hs @@ -0,0 +1,14 @@ +module Language.Jsonnet.TH.QQ where + +import qualified Data.Text as T +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Jsonnet.TH + +jsonnet :: QuasiQuoter +jsonnet = + QuasiQuoter + { quoteExp = \str -> parse "" (T.pack str), + quotePat = error "Usage as a pattern is not supported", + quoteType = error "Usage as a type is not supported", + quoteDec = error "Usage as a declaration is not supported" + } diff --git a/src/Language/Jsonnet/Value.hs b/src/Language/Jsonnet/Value.hs new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Value.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +module Language.Jsonnet.Value where + +import Control.Applicative +import Control.Arrow +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State.Lazy +import Data.Bits +import Data.ByteString (ByteString) +import Data.Data +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as H +import Data.Hashable (Hashable) +import Data.IORef +import Data.Int +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as M +import Data.Scientific (Scientific, fromFloatDigits, toRealFloat) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Typeable +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as V +import Debug.Trace +import GHC.Generics (Generic) +import Language.Jsonnet.Common +import Language.Jsonnet.Core +import Language.Jsonnet.Error +import {-# SOURCE #-} Language.Jsonnet.Eval (eval, evalClos) +import Language.Jsonnet.Eval.Monad +import Language.Jsonnet.Parser.SrcSpan +import Language.Jsonnet.Pretty () +import Text.PrettyPrint.ANSI.Leijen (Doc, pretty) +import Unbound.Generics.LocallyNameless + +-- jsonnet value +data Value + = VNull + | VBool !Bool + | VNum !Scientific + | VStr !Text + | VArr !Array + | VObj !(HashMap Text (Hideable Thunk)) + | VClos !Fun !Env + | VFun !(Thunk -> Eval Value) + deriving (Generic) + +type Array = Vector Thunk + +type Object = HashMap Text (Hideable Thunk) + +valueType :: Value -> Text +valueType = + \case + VNull -> "null" + VBool _ -> "boolean" + VNum _ -> "number" + VStr _ -> "string" + VArr _ -> "array" + VObj _ -> "object" + VClos _ _ -> "function" + VFun _ -> "function" + +data Thunk = TC !Ctx !Core | TV !(Eval Value) + deriving (Generic) + +force :: Thunk -> Eval Value +force = \case + TC rho expr -> withCtx rho (eval expr) + TV comp -> comp + +mkThunk' :: Value -> Thunk +mkThunk' = TV . pure + +mkThunk :: MonadIO m => Eval Value -> m Thunk +mkThunk ev = do + ref <- liftIO $ newIORef Nothing + pure $ + TV $ + liftIO (readIORef ref) >>= \case + Nothing -> do + v <- ev + liftIO $ writeIORef ref $ Just v + pure v + Just v -> pure v + +proj' :: HasValue a => Thunk -> Eval a +proj' = force >=> proj + +class HasValue a where + proj :: Value -> Eval a + inj :: a -> Value + +instance {-# OVERLAPS #-} HasValue Value where + proj = pure + inj = id + +instance HasValue Bool where + proj (VBool n) = pure n + proj v = throwTypeMismatch "bool" v + inj = VBool + +instance HasValue Text where + proj (VStr s) = pure s + proj v = throwTypeMismatch "string" v + inj = VStr + +instance {-# OVERLAPPING #-} HasValue [Char] where + proj (VStr s) = pure $ T.unpack s + proj v = throwTypeMismatch "string" v + inj = VStr . T.pack + +instance HasValue ByteString where + proj (VStr s) = pure (encodeUtf8 s) + proj v = throwTypeMismatch "string" v + inj = VStr . decodeUtf8 + +instance HasValue Scientific where + proj (VNum n) = pure n + proj v = throwTypeMismatch "number" v + inj = VNum + +instance HasValue Double where + proj (VNum n) = pure (toRealFloat n) + proj v = throwTypeMismatch "number" v + inj = VNum . fromFloatDigits + +instance {-# OVERLAPS #-} Integral a => HasValue a where + proj (VNum n) = pure (round n) + proj v = throwTypeMismatch "number" v + inj = VNum . fromIntegral + +instance HasValue a => HasValue (Maybe a) where + proj VNull = pure Nothing + proj a = Just <$> proj a + inj Nothing = VNull + inj (Just a) = inj a + +instance HasValue a => HasValue (Vector a) where + proj (VArr as) = traverse proj' as + proj v = throwTypeMismatch "array" v + inj as = VArr $ mkThunk' . inj <$> as + +instance {-# OVERLAPS #-} HasValue (Vector Thunk) where + proj (VArr as) = pure as + proj v = throwTypeMismatch "array" v + inj = VArr + +instance {-# OVERLAPPABLE #-} HasValue a => HasValue [a] where + proj = fmap V.toList . proj + inj = inj . V.fromList + +instance {-# OVERLAPS #-} HasValue Object where + proj (VObj o) = pure o + proj v = throwTypeMismatch "object" v + inj = VObj + +--instance HasValue a => HasValue (Object a) where +-- proj (VObj o) = traverse proj' o +-- proj v = throwTypeMismatch "object" v +-- inj o = VObj $ mkThunk' . inj <$> o + +instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> b) where + proj v = throwTypeMismatch "impossible" v + inj f = VFun $ \x -> force x >>= fmap (inj . f) . proj + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> c) where + proj v = throwTypeMismatch "impossible" v + inj f = inj $ \x -> inj (f x) + +instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> Eval b) where + proj (VFun f) = pure $ \x -> do + r <- f (mkThunk' $ inj x) + proj r + proj (VClos f env) = pure $ \x -> do + r <- evalClos (ctx env) f $ [Pos $ mkThunk' $ inj x] + proj r + proj v = throwTypeMismatch "function" v + inj f = VFun $ \v -> proj' v >>= fmap inj . f + +instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> Eval c) where + proj (VFun f) = pure $ \x y -> do + VFun g <- f (mkThunk' $ inj x) + r <- g (mkThunk' $ inj y) + proj r + proj (VClos f env) = pure $ \x y -> do + r <- evalClos (ctx env) f $ Pos . mkThunk' <$> [inj x, inj y] + proj r + proj v = throwTypeMismatch "function" v + inj f = inj $ \x -> inj (f x) + +throwTypeMismatch :: Text -> Value -> Eval a +throwTypeMismatch expected = + throwE + . TypeMismatch expected + . valueType + +inj' :: + (HasValue a, HasValue b) => + (a -> b) -> + (Value -> Eval Value) +inj' f v = inj . f <$> proj v + +inj'' :: + (HasValue a, HasValue b, HasValue c) => + (a -> b -> c) -> + Value -> + Value -> + Eval Value +inj'' f v1 v2 = inj <$> liftA2 f (proj v1) (proj v2) diff --git a/src/Language/Jsonnet/Value.hs-boot b/src/Language/Jsonnet/Value.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Jsonnet/Value.hs-boot @@ -0,0 +1,5 @@ +module Language.Jsonnet.Value where + +data Value + +data Thunk diff --git a/test/golden/Test.hs b/test/golden/Test.hs new file mode 100644 --- /dev/null +++ b/test/golden/Test.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Main where + +import Control.Monad +import Control.Monad.Except +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import Data.Text.Lazy +import Data.Text.Lazy.Encoding (encodeUtf8) +import Language.Jsonnet +import Language.Jsonnet.Error +import Language.Jsonnet.Pretty () +import Language.Jsonnet.Std +import System.FilePath (replaceExtension, takeBaseName) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Golden (findByExtension, goldenVsString) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) +import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty) + +main :: IO () +main = goldenTests >>= defaultMain + +render :: Pretty a => a -> LBS.ByteString +render = encodeUtf8 . pack . show . pretty + +run :: Config -> IO LBS.ByteString +run conf = do + prog <- T.readFile (fname conf) + outp <- interpret conf prog + pure (either render render outp) + +goldenTests :: IO TestTree +goldenTests = do + jsonnetFiles <- findByExtension [".jsonnet"] "./test/golden" + runExceptT std >>= \case + Left err -> error (show $ pretty err) + Right stdlib -> do + return $ + testGroup + "Jsonnet golden tests" + [ goldenVsString + (takeBaseName jsonnetFile) -- test name + goldenFile -- golden file path + (run $ Config jsonnetFile stdlib) + | jsonnetFile <- jsonnetFiles, + let goldenFile = replaceExtension jsonnetFile ".golden" + ]