jsonnet (empty) → 0.1.0.0
raw patch · 30 files changed
+3390/−0 lines, 30 filesdep +aesondep +ansi-wl-pprintdep +base
Dependencies added: aeson, ansi-wl-pprint, base, bytestring, containers, data-fix, deriving-compat, directory, exceptions, filepath, hashable, jsonnet, megaparsec, mtl, optparse-applicative, parser-combinators, scientific, semigroupoids, tasty, tasty-golden, tasty-hunit, template-haskell, text, transformers-compat, unbound-generics, unordered-containers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +217/−0
- README.md +73/−0
- app/Main.hs +165/−0
- jsonnet.cabal +122/−0
- src/Language/Jsonnet.hs +97/−0
- src/Language/Jsonnet/Annotate.hs +39/−0
- src/Language/Jsonnet/Check.hs +45/−0
- src/Language/Jsonnet/Common.hs +214/−0
- src/Language/Jsonnet/Core.hs +70/−0
- src/Language/Jsonnet/Desugar.hs +185/−0
- src/Language/Jsonnet/Error.hs +53/−0
- src/Language/Jsonnet/Eval.hs +407/−0
- src/Language/Jsonnet/Eval.hs-boot +10/−0
- src/Language/Jsonnet/Eval/Monad.hs +121/−0
- src/Language/Jsonnet/Eval/Monad.hs-boot +5/−0
- src/Language/Jsonnet/Manifest.hs +43/−0
- src/Language/Jsonnet/Parser.hs +495/−0
- src/Language/Jsonnet/Parser/SrcSpan.hs +44/−0
- src/Language/Jsonnet/Pretty.hs +176/−0
- src/Language/Jsonnet/Std.hs +31/−0
- src/Language/Jsonnet/Std/Lib.hs +137/−0
- src/Language/Jsonnet/Std/TH.hs +20/−0
- src/Language/Jsonnet/Syntax.hs +164/−0
- src/Language/Jsonnet/Syntax/Annotated.hs +45/−0
- src/Language/Jsonnet/TH.hs +117/−0
- src/Language/Jsonnet/TH/QQ.hs +14/−0
- src/Language/Jsonnet/Value.hs +221/−0
- src/Language/Jsonnet/Value.hs-boot +5/−0
- test/golden/Test.hs +52/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Changelog for jsonnet++## Unreleased changes
+ LICENSE view
@@ -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+<http://www.apache.org/licenses/>++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.
+ README.md view
@@ -0,0 +1,73 @@+# haskell-jsonnet++[](https://github.com/moleike/jsonnet-hs/actions) [](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+
+ app/Main.hs view
@@ -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 "<filename>"+ <> help "Write to the output file rather than stdout"+ )+ )++fileInput :: Parser (Maybe String)+fileInput =+ optional $+ strArgument+ ( metavar "<filename>"+ <> 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)
+ jsonnet.cabal view
@@ -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 <https://github.com/moleike/jsonnet-haskell#readme>+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
+ src/Language/Jsonnet.hs view
@@ -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)
+ src/Language/Jsonnet/Annotate.hs view
@@ -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
+ src/Language/Jsonnet/Check.hs view
@@ -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
+ src/Language/Jsonnet/Common.hs view
@@ -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
+ src/Language/Jsonnet/Core.hs view
@@ -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
+ src/Language/Jsonnet/Desugar.hs view
@@ -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
+ src/Language/Jsonnet/Error.hs view
@@ -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)
+ src/Language/Jsonnet/Eval.hs view
@@ -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
+ src/Language/Jsonnet/Eval.hs-boot view
@@ -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
+ src/Language/Jsonnet/Eval/Monad.hs view
@@ -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
+ src/Language/Jsonnet/Eval/Monad.hs-boot view
@@ -0,0 +1,5 @@+module Language.Jsonnet.Eval.Monad where++data Eval a++data EvalState
+ src/Language/Jsonnet/Manifest.hs view
@@ -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
+ src/Language/Jsonnet/Parser.hs view
@@ -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"+ ]
+ src/Language/Jsonnet/Parser/SrcSpan.hs view
@@ -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
+ src/Language/Jsonnet/Pretty.hs view
@@ -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)
+ src/Language/Jsonnet/Std.hs view
@@ -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)
+ src/Language/Jsonnet/Std/Lib.hs view
@@ -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)
+ src/Language/Jsonnet/Std/TH.hs view
@@ -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
+ src/Language/Jsonnet/Syntax.hs view
@@ -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
+ src/Language/Jsonnet/Syntax/Annotated.hs view
@@ -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
+ src/Language/Jsonnet/TH.hs view
@@ -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+ )
+ src/Language/Jsonnet/TH/QQ.hs view
@@ -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"+ }
+ src/Language/Jsonnet/Value.hs view
@@ -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)
+ src/Language/Jsonnet/Value.hs-boot view
@@ -0,0 +1,5 @@+module Language.Jsonnet.Value where++data Value++data Thunk
+ test/golden/Test.hs view
@@ -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"+ ]