jsonnet 0.2.0.0 → 0.3.0.0

raw patch · 24 files changed

+1158/−1056 lines, 24 filesdep +lensdep +tasty-benchdep +th-utilitiesdep ~ansi-wl-pprintdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, tasty-bench, th-utilities

Dependency ranges changed: ansi-wl-pprint, base, bytestring, hashable, optparse-applicative, scientific, text, unordered-containers, vector

API changes (from Hackage documentation)

Files

• README.md +24/−26
• app/Main.hs +5/−16
• benchmarks/Bench.hs +113/−0
• jsonnet.cabal +56/−35
• src/Language/Jsonnet.hs +22/−10
• src/Language/Jsonnet/Common.hs +37/−58
• src/Language/Jsonnet/Core.hs +32/−29
• src/Language/Jsonnet/Desugar.hs +108/−78
• src/Language/Jsonnet/Error.hs +5/−1
• src/Language/Jsonnet/Eval.hs +483/−306
• src/Language/Jsonnet/Eval.hs-boot +0/−9
• src/Language/Jsonnet/Eval/Monad.hs +69/−86
• src/Language/Jsonnet/Eval/Monad.hs-boot +0/−5
• src/Language/Jsonnet/Manifest.hs +0/−43
• src/Language/Jsonnet/Parser.hs +40/−32
• src/Language/Jsonnet/Pretty.hs +3/−2
• src/Language/Jsonnet/Std/Lib.hs +54/−93
• src/Language/Jsonnet/Std/TH.hs +3/−1
• src/Language/Jsonnet/Syntax.hs +46/−12
• src/Language/Jsonnet/Syntax/Annotated.hs +2/−2
• src/Language/Jsonnet/TH.hs +4/−19
• src/Language/Jsonnet/Value.hs +51/−177
• src/Language/Jsonnet/Value.hs-boot +0/−5
• test/golden/Test.hs +1/−11

@@ -8,6 +8,28 @@ 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). +## 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+- [X] outermost object reference `$`+- [X] mixin inheritence (operator `+` with `self` and `super`)+- [X] field composition (operator `+:`)+- [ ] multiple file output+ ## Build  Using the [stack][stack] build tool:@@ -96,32 +118,7 @@  See the Standard library [documentation][stdlib] for more details. -## 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"  ## Benchmarks@@ -135,7 +132,7 @@  ## Acknowledgments -I took inspiration from [Expresso][Expresso], [hnix][hnix], [fixplate][fixplate], +I took inspiration from [Expresso][Expresso], [hnix][hnix], [fixplate][fixplate], [Disco][disco],  and numerous other libraries. Thanks to their authors.  ## License@@ -151,6 +148,7 @@ [Expresso]: https://github.com/willtim/Expresso [hnix]: https://github.com/haskell-nix/hnix [fixplate]: https://hackage.haskell.org/package/fixplate+[disco]: https://github.com/disco-lang/disco [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

@@ -22,11 +22,7 @@ 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 Language.Jsonnet.Value import Options.Applicative import Paths_jsonnet (version) import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty)@@ -36,7 +32,10 @@   runProgram =<< execParser options   return () -runProgram :: Options -> IO ()+runProgram ::+  -- |+  Options ->+  IO () runProgram opts@Options {..} = do   src <- readSource input   conf <- mkConfig opts@@ -68,22 +67,12 @@   FileInput path -> TIO.readFile path   ExecInput str -> pure (T.pack str) --- the jsonnet stdlib is written in both jsonnet and Haskell, here we merge--- the native (a small subset) with the interpreted (the splice mkStdlib)--std :: Eval Value-std = eval core >>= flip mergeObjects Lib.std-  where-    core = desugar (annMap (const ()) $mkStdlib)-    mergeObjects (VObj x) (VObj y) = pure $ VObj (x `mergeWith` y)- mkConfig :: Options -> IO Config mkConfig Options {..} = do   let fname = case input of         Stdin -> ""         FileInput path -> path         ExecInput _ -> ""-  stdlib <- mkThunk std   pure Config {..}  fileOutput :: Parser Output

@@ -0,0 +1,113 @@+{-# LANGUAGE QuasiQuotes #-}++import qualified Data.ByteString.Lazy as LBS+import Data.Text.Lazy+import Data.Text.Lazy.Encoding (encodeUtf8)+import Language.Jsonnet+import Language.Jsonnet.Core (Core)+import Language.Jsonnet.Syntax.Annotated (Expr)+import Language.Jsonnet.TH.QQ+import Test.Tasty.Bench+import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty)++render :: Pretty a => a -> LBS.ByteString+render = encodeUtf8 . pack . show . pretty++conf = Config ""++eval :: Expr -> IO LBS.ByteString+eval expr = do+  outp <- runJsonnetM conf (desugar expr >>= evaluate)+  pure (either render render outp)++main :: IO ()+main =+  defaultMain+    [ bgroup+        "simple"+        [ bench "bench01" $ nfAppIO eval bench01,+          bench "bench02" $ nfAppIO eval bench02,+          bench "bench03" $ nfAppIO eval bench03+        ],+      bgroup+        "caching"+        [ bench "bench08" $ nfAppIO eval bench08+        ],+      bgroup+        "stdlib"+        [ bench "bench04" $ nfAppIO eval bench04+        , bench "bench06" $ nfAppIO eval bench06+        ]+    ]++bench01 =+  [jsonnet|+    local sum(x) =+      if x == 0 then+      0+      else+      x + sum(x - 1);+    sum(300)+  |]++bench02 =+  [jsonnet|+    local Fib = {+      n: 1,+      local outer = self,+      r: if self.n <= 1+           then 1+           else (Fib { n: outer.n - 1 }).r + (Fib { n: outer.n - 2 }).r,+    };++    (Fib { n: 25 }).r+  |]++bench03 =+  [jsonnet|+    local fibonacci(n) =+      if n <= 1 then+        1+      else+        fibonacci(n - 1) + fibonacci(n - 2);+    fibonacci(25)+  |]++bench04 =+  [jsonnet|+    std.foldl(function(e, res) e + res, std.makeArray(20000, function(i) 'aaaaa'), '')+  |]++bench06 =+  [jsonnet|+    // A benchmark for builtin sort++    local reverse = std.reverse;+    local sort = std.sort;++    true+    && std.assertEqual(std.range(1, 500), sort(std.range(1, 500)))+    && std.assertEqual(std.range(1, 1000), sort(std.range(1, 1000)))+    && std.assertEqual(reverse(std.range(1, 1000)), sort(std.range(1, 1000), keyF=function(x) -x))+    && std.assertEqual(std.range(1, 1000), sort(reverse(std.range(1, 1000))))+    && std.assertEqual(std.makeArray(2000, function(i) std.floor((i + 2) / 2)), sort(std.range(1, 1000) + reverse(std.range(1, 1000))))+  |]++bench08 =+  [jsonnet|+    local fib(n) =+      local fibnext = {+        a: super.a + super.b,+        b: super.a,+      };++      local go(n) =+        if n == 0 then+          { a: 1, b: 1 }+        else+          go(n - 1) + fibnext;++      go(n).b;++    fib(25)+  |]

@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           jsonnet-version:        0.2.0.0+version:        0.3.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@@ -43,7 +43,6 @@     , Language.Jsonnet.Core     , Language.Jsonnet.Check     , Language.Jsonnet.Desugar-    , Language.Jsonnet.Manifest   autogen-modules:       Paths_jsonnet   other-modules:@@ -52,29 +51,31 @@   hs-source-dirs:       src   build-depends:-    aeson                 >= 1.5.6 && < 1.6,-    base                  >= 4.15.0 && < 4.16,-    bytestring            >= 0.10.12 && < 0.11,-    containers            >= 0.6.4 && < 0.7,-    scientific            >= 0.3.6 && < 0.4,-    hashable              >= 1.3.1 && < 1.4,-    text                  >= 1.2.4 && < 1.3,-    template-haskell      >= 2.17.0 && < 2.18,-    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,-    optparse-applicative  >= 0.16.1 && < 0.17+      aeson                         >= 1.5.6 && < 1.6,+      base                          >= 4.15.0 && < 4.16,+      bytestring                    >= 0.10.12 && < 0.11,+      containers                    >= 0.6.4 && < 0.7,+      scientific                    >= 0.3.7 && < 0.4,+      hashable                      >= 1.3.2 && < 1.4,+      text                          >= 1.2.4 && < 1.3,+      template-haskell              >= 2.17.0 && < 2.18,+      data-fix                      >= 0.3.1 && < 0.4,+      transformers-compat           >= 0.6.6 && < 0.7,+      unordered-containers          >= 0.2.14 && < 0.3,+      mtl                           >= 2.2.2 && < 2.3,+      vector                        >= 0.12.3 && < 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,+      lens                          >= 5.0.1 && < 5.1,+      semigroupoids                 >= 5.3.5 && < 5.4,+      megaparsec                    >= 9.0.1 && < 9.1,+      parser-combinators            >= 1.3.0 && < 1.4,+      unbound-generics              >= 0.4.1 && < 0.5,+      th-utilities                  == 0.2.4.2+   default-language: Haskell2010   default-extensions:       MultiParamTypeClasses@@ -85,20 +86,22 @@  executable hs-jsonnet   main-is: Main.hs+  autogen-modules:+      Paths_jsonnet   other-modules:       Paths_jsonnet   hs-source-dirs:       app-  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N   build-depends:-      jsonnet-    , base-    , optparse-applicative-    , text-    , ansi-wl-pprint-    , mtl-    , bytestring-    , aeson+      jsonnet,+      aeson,+      base,+      bytestring,+      text,+      mtl,+      ansi-wl-pprint,+      optparse-applicative >= 0.16.1 && < 0.17   default-language: Haskell2010  test-suite jsonnet-test@@ -108,7 +111,7 @@       Paths_jsonnet   hs-source-dirs:       test/golden-  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N   build-depends:       base     , ansi-wl-pprint@@ -121,3 +124,21 @@     , tasty-golden     , tasty-hunit   default-language: Haskell2010++benchmark jsonnet-bench+  main-is: Bench.hs+  type: exitcode-stdio-1.0+  hs-source-dirs:+      benchmarks+  build-depends:+      base+    , tasty-bench+    , jsonnet+    , bytestring+    , text+    , ansi-wl-pprint+  default-language: Haskell2010+  if impl(ghc >= 8.10)+    ghc-options: "-with-rtsopts=-A32m --nonmoving-gc"+  else+    ghc-options: "-with-rtsopts=-A32m"

@@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}  module Language.Jsonnet   ( JsonnetM,@@ -13,6 +14,7 @@     runJsonnetM,     parse,     evaluate,+    desugar,   ) where @@ -22,19 +24,23 @@ import qualified Data.Aeson as JSON import Data.Functor.Identity import Data.Functor.Sum+import qualified Data.Map.Lazy as M 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.Common 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 Language.Jsonnet.Eval.Monad import qualified Language.Jsonnet.Parser as Parser import Language.Jsonnet.Pretty ()+import qualified Language.Jsonnet.Std.Lib as Lib+import Language.Jsonnet.Std.TH (mkStdlib) import Language.Jsonnet.Syntax.Annotated import Language.Jsonnet.Value @@ -55,9 +61,8 @@       MonadFail     ) -data Config = Config-  { fname :: FilePath,-    stdlib :: Thunk+newtype Config = Config+  { fname :: FilePath   }  runJsonnetM :: Config -> JsonnetM a -> IO (Either Error a)@@ -85,12 +90,19 @@   pure expr  desugar :: Expr -> JsonnetM Core-desugar expr = pure (Desugar.desugar expr)+desugar = pure . Desugar.desugar --- evaluate a Core expression with the implicit stdlib+-- | evaluate a Core expression with the implicit stdlib evaluate :: Core -> JsonnetM JSON.Value evaluate expr = do-  ctx <- singleton "std" <$> asks stdlib-  JsonnetM $-    lift $-      runEval (emptyEnv {ctx = ctx}) ((eval >=> manifest) expr)+  env <- singleton "std" <$> std+  JsonnetM $ lift $ ExceptT $ runEvalM env (rnf expr)++-- | the jsonnet stdlib is written in both jsonnet and Haskell, here we merge+--   the native (a small subset) with the interpreted (the splice mkStdlib)+std :: JsonnetM Value+std = JsonnetM $ lift $ ExceptT $ runEvalM M.empty stdlib+  where+    stdlib = whnf core >>= flip mergeObjects Lib.std+    core = Desugar.desugar (annMap (const ()) $mkStdlib)+    mergeObjects x y = whnfPrim (BinOp Add) [Pos x, Pos y]

@@ -1,10 +1,14 @@+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}  module Language.Jsonnet.Common where @@ -34,42 +38,46 @@   subst _ _ = id   substs _ = id +data Prim+  = UnyOp UnyOp+  | BinOp BinOp+  | Cond+  deriving (Show, Eq, Generic, Typeable, Data)++instance Alpha Prim+ data BinOp-  = Arith ArithOp-  | Comp CompOp-  | Bitwise BitwiseOp-  | Logical LogicalOp+  = Add+  | Sub+  | Mul+  | Div+  | Mod+  | Lt+  | Le+  | Gt+  | Ge+  | Eq+  | Ne+  | And+  | Or+  | Xor+  | ShiftL+  | ShiftR+  | LAnd+  | LOr   | In+  | Lookup   deriving (Show, Eq, Generic, Typeable, Data) +instance Alpha BinOp+ 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+  | Err+  deriving (Show, Eq, Generic, Typeable, Data)  instance Alpha UnyOp @@ -159,18 +167,12 @@ instance Alpha a => Alpha (CompSpec a)  data StackFrame a = StackFrame-  { name :: Maybe (Name a),+  { name :: 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]+newtype Backtrace a = Backtrace [StackFrame a]   deriving (Eq, Show)  data Visibility = Visible | Hidden | Forced@@ -189,26 +191,3 @@   visible :: a -> Bool   forced :: a -> Bool   hidden :: a -> Bool--data Hideable a = Hideable {value :: a, visiblity :: 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

@@ -1,9 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-}  module Language.Jsonnet.Core where@@ -16,46 +18,47 @@ 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)+type Param a = (Name a, Embed a) -newtype Fun = Fun (Bind (Rec [Param Core]) Core)-  deriving (Show, Typeable, Generic)+data CField = CField+  { -- |+    fieldKey :: Core,+    -- |+    fieldVal :: Core,+    -- |+    fieldVis :: Visibility+  }+  deriving (Show, Generic) -instance Alpha Fun+mkField :: Core -> Core -> Visibility -> CField+mkField = CField -newtype Let-  = Let (Bind (Rec [(Name Core, Embed Core)]) Core)-  deriving (Show, Typeable, Generic)+--pattern CField k v h <- CField_ k _ v h -instance Alpha Let+instance Alpha CField  data Comp   = ArrC (Bind (Name Core) (Core, Maybe Core))-  | ObjC (Bind (Name Core) (KeyValue Core, Maybe Core))+  | ObjC (Bind (Name Core) (CField, 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+type Lam = Bind (Rec [Param Core]) Core++type Let = Bind (Rec [(Name Core, Embed Core)]) Core++data Core where+  CLoc :: SrcSpan -> Core -> Core+  CLit :: Literal -> Core+  CVar :: Name Core -> Core+  CLam :: Lam -> Core+  CPrim :: Prim -> Core+  CApp :: Core -> Args Core -> Core+  CLet :: Let -> Core+  CObj :: [CField] -> Core+  CArr :: [Core] -> Core+  CComp :: Comp -> Core -> Core   deriving (Show, Typeable, Generic)  instance Alpha Core

@@ -10,16 +10,22 @@  module Language.Jsonnet.Desugar (desugar) where +import qualified Data.Bifunctor import Data.Fix as F-import Data.List.NonEmpty (NonEmpty (..), fromList, toList)+import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Text (Text)+import qualified Data.Text as T (pack)+import Debug.Trace import Language.Jsonnet.Annotate import Language.Jsonnet.Common import Language.Jsonnet.Core+import Language.Jsonnet.Error import Language.Jsonnet.Parser.SrcSpan+import Language.Jsonnet.Pretty () import Language.Jsonnet.Syntax+import Text.PrettyPrint.ANSI.Leijen hiding (encloseSep, (<$>)) import Unbound.Generics.LocallyNameless  class Desugarer a where@@ -33,44 +39,41 @@ instance Desugarer (Ann ExprF SrcSpan) where   desugar = foldFix go . zipWithOutermost     where-      go (AnnF f (a, b)) = alg b $ CLoc a <$> f+      go (AnnF f (a, b)) = CLoc a (alg b f) --- annotate nodes with a boolean denoting outermost objects+-- | 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 (Fix (AnnF EObj {} _)) False = (True, True)+    go (Fix (AnnF EObj {} _)) True = (False, True)     go _ x = (False, x) +alg :: Bool -> ExprF Core -> Core alg outermost = \case   ELit l -> CLit l   EIdent i -> CVar (s2n i)-  EFun ps e -> mkFun ps e+  EFun ps e -> desugarFun 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 ->+  ELocal bnds e -> desugarLet bnds e+  EBinOp Mod e1 e2 ->+    -- operator % is overloaded for both modulo and string formatting     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)+  EBinOp op e1 e2 -> desugarBinOp op e1 e2+  EUnyOp op e -> desugarUnyOp op e+  EIfElse c t e -> desugarIfElse c t e+  EIf c t -> desugarIfElse 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+  EObj {..} -> desugarObj outermost locals fields+  ELookup e1 e2 -> desugarLookup e1 e2+  EIndex e1 e2 -> desugarLookup e1 e2+  EErr e -> desugarErr e+  EAssert e -> desugarAssert e+  ESlice {..} -> desugarSlice expr start end step+  EArrComp {expr, comp} -> desugarArrComp expr comp+  EObjComp {field, comp, locals} -> desugarObjComp field comp locals -mkSlice expr start end step =+desugarSlice expr start end step =   stdFunc     "slice"     ( Args@@ -84,54 +87,75 @@   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+desugarIfElse :: Core -> Core -> Core -> Core+desugarIfElse c t e = CApp (CPrim Cond) (Args [Pos c, Pos t, Pos e] Lazy)++desugarLookup :: Core -> Core -> Core+desugarLookup e1 e2 = CApp (CPrim (BinOp Lookup)) (Args [Pos e1, Pos e2] Lazy)++desugarErr :: Core -> Core+desugarErr e = CApp (CPrim (UnyOp Err)) (Args [Pos e] Lazy)++desugarBinOp :: BinOp -> Core -> Core -> Core+desugarBinOp op e1 e2 = CApp (CPrim (BinOp op)) (Args [Pos e1, Pos e2] Lazy)++desugarUnyOp :: UnyOp -> Core -> Core+desugarUnyOp op e = CApp (CPrim (UnyOp op)) (Args [Pos e] Lazy)++desugarObj outermost locals fields = obj   where+    obj = CObj (desugarField <$> fields')+     bnds =       if outermost-        then (("$", fs) : locals)+        then ("$", CVar "self") : locals         else locals-    fs = CObj (mkKeyValue <$> fields) -mkAssert :: Assert Core -> Core-mkAssert (Assert c m e) =-  CIfElse+    f v@(CLit _) = v+    f v@(CLoc _ (CLit _)) = v+    f v = case bnds of+      [] -> v+      xs -> desugarLet (NE.fromList xs) v++    fields' =+      (\(EField key val v o) -> EField key (f val) v o) <$> fields++desugarAssert :: Assert Core -> Core+desugarAssert (Assert c m e) =+  desugarIfElse     c     e-    ( CErr $+    ( desugarErr $         fromMaybe           (CLit $ String "Assertion failed")           m     ) -mkArrComp :: Core -> NonEmpty (CompSpec Core) -> Core-mkArrComp expr comp = foldr f (CArr [expr]) comp+desugarArrComp :: Core -> NonEmpty (CompSpec Core) -> Core+desugarArrComp expr = foldr f (CArr [expr])   where     f CompSpec {..} e =       CComp (ArrC (bind (s2n var) (e, ifspec))) forspec -mkKeyValue :: Field Core -> KeyValue Core-mkKeyValue Field {..} = KeyValue key (Hideable value' visibility)+desugarField :: EField Core -> CField+desugarField EField {..} = mkField key value' visibility   where     value' =       if override         then-          CIfElse-            (CBinOp In key super)-            (CBinOp (Arith Add) (CLookup super key) value)+          desugarIfElse+            (desugarBinOp In key super)+            (desugarBinOp Add (desugarLookup super key) value)             value         else value     super = CVar $ s2n "super" -mkObjComp (Field {..}) comp locals =+desugarObjComp EField {..} comp locals =   CComp (ObjC (bind (s2n "arr") (kv', Nothing))) arrComp   where     kv' =-      mkKeyValue-        ( Field+      desugarField+        ( EField             { key = key',               value = value',               visibility,@@ -139,47 +163,53 @@             }         )     bnds = NE.zip (fmap var comp) xs-    key' = mkLet bnds key+    key' = desugarLet bnds key     value' = case locals of-      [] -> mkLet bnds value+      [] -> desugarLet 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+      xs -> desugarLet bnds $ desugarLet (NE.fromList xs) value+    xs = desugarLookup (CVar $ s2n "arr") . CLit . Number . fromIntegral <$> [0 ..]+    arrComp = desugarArrComp arr comp     arr = CArr $ NE.toList $ CVar . s2n . var <$> comp  stdFunc :: Text -> Args Core -> Core stdFunc f =   CApp-    ( CLookup+    ( desugarLookup         (CVar "std")         (CLit $ String f)     ) -mkFun ps e =-  CFun $-    Fun $-      bind-        ( rec $-            fmap-              ( \(n, a) ->-                  (s2n n, Embed a)-              )-              ps-        )-        e+desugarFun ps e =+  CLam $+    bind+      ( rec $+          fmap+            ( \(n, a) ->+                (s2n n, Embed (fromMaybe (errNotBound n) a))+            )+            ps+      )+      e+  where+    errNotBound n =+      desugarErr $+        CLit $+          String+            ( T.pack $+                show $+                  pretty $ ParamNotBound (pretty n)+            ) -mkLet bnds e =+desugarLet bnds e =   CLet $-    Let $-      bind-        ( rec $-            toList-              ( fmap-                  ( \(n, a) ->-                      (s2n n, Embed a)-                  )-                  bnds-              )-        )-        e+    bind+      ( rec $+          toList+            ( fmap+                ( Data.Bifunctor.bimap s2n Embed+                )+                bnds+            )+      )+      e

@@ -5,8 +5,10 @@  module Language.Jsonnet.Error where +import Control.Exception import Data.Scientific (Scientific) import Data.Text (Text)+import Data.Typeable (Typeable) import Data.Void (Void) import Language.Jsonnet.Common import Language.Jsonnet.Core@@ -39,7 +41,9 @@   | StdError Doc   | RuntimeError Doc   | ManifestError Doc-  deriving (Show)+  deriving (Show, Typeable)++instance Exception EvalError  data ParserError   = ParseError (ParseErrorBundle Text Void)

@@ -1,139 +1,100 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-} -module Language.Jsonnet.Eval-  ( eval,-    evalClos,-    mergeWith,-    module Language.Jsonnet.Eval.Monad,-  )-where+module Language.Jsonnet.Eval where  import Control.Applicative+import Control.Lens (locally, view) import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State.Lazy-import Data.Aeson.Text+import qualified Data.Aeson as JSON+import Data.Aeson.Text (encodeToLazyText) import Data.Bifunctor (second) import Data.Bits+import Data.ByteString (ByteString) import Data.Foldable+import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as H-import Data.Int-import Data.List+import Data.IORef+import Data.Int (Int64)+import qualified Data.List as L (sort) import qualified Data.Map.Lazy as M-import Data.Maybe (catMaybes, isNothing)-import Data.Scientific (isInteger, toBoundedInteger)+import Data.Maybe+import Data.Scientific import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Lazy (toStrict)+import Data.Traversable (for) import Data.Vector (Vector, (!?)) import qualified Data.Vector as V import Debug.Trace-import Language.Jsonnet.Common hiding (span)+import Language.Jsonnet.Common 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 Text.PrettyPrint.ANSI.Leijen hiding (equals, (<$>)) import Unbound.Generics.LocallyNameless-import Unbound.Generics.LocallyNameless.Bind+import Prelude hiding (length)+import qualified Prelude as P (length) --- an evaluator for the core calculus, based on a--- big-step, call-by-need operational semantics, matching--- jsonnet specificaton+rnf :: Core -> Eval JSON.Value+rnf = whnf >=> manifest -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)+whnfV :: Value -> Eval Value+whnfV (VIndir loc) = whnfIndir loc >>= whnfV+whnfV (VThunk c e) = withEnv e (whnf c)+whnfV v = pure v -    --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+whnf :: Core -> Eval Value+whnf (CVar n) = lookupVar n+whnf (CLoc sp c) = locally currentPos (const $ Just sp) (whnf c)+whnf (CLit l) = pure (whnfLiteral l)+whnf (CObj bnd) = whnfObj bnd+whnf (CArr cs) = VArr . V.fromList <$> mapM mkValue cs+whnf (CLet bnd) = whnfLetrec bnd+whnf (CPrim p) = pure (VPrim p)+whnf (CApp e es) = whnfApp e es+whnf (CLam f) = VClos f <$> view ctx+whnf (CComp comp e) = whnfComp comp e -thunk :: Core -> Eval Thunk-thunk e =-  ask >>= \rho ->-    mkThunk $ withCtx (ctx rho) (eval e)+mkValue :: Core -> Eval Value+mkValue c@(CLit _) = whnf c+mkValue c@(CLam _) = whnf c+mkValue c@(CPrim _) = whnf c+mkValue c = mkThunk c >>= mkIndirV -extendCtx' :: [(Name Core, Thunk)] -> Eval a -> Eval a-extendCtx' = extendCtx . M.fromList+lookupVar :: Name Core -> Eval Value+lookupVar n = do+  rho <- view ctx+  v <- liftMaybe (VarNotFound (pretty n)) (M.lookup n rho)+  whnfV v -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'+whnfLiteral :: Literal -> Value+whnfLiteral = \case+  Null -> VNull+  Bool b -> VBool b+  String s -> VStr s+  Number n -> VNum n -evalApp :: Core -> [Arg Thunk] -> Eval Value-evalApp e vs = withStackFrame e $ do-  eval e >>= \case-    VClos f Env {..} -> evalClos ctx f vs+whnfArgs :: Args Core -> Eval [Arg Value]+whnfArgs = \case+  as@(Args _ Strict) -> args <$> mapM whnf as+  as@(Args _ Lazy) -> args <$> mapM mkValue as++whnfApp :: Core -> Args Core -> Eval Value+whnfApp e es = withStackFrame e $ do+  vs <- whnfArgs es+  whnf e >>= whnfV >>= \case+    VClos f env -> whnfClos env f vs+    VPrim op -> whnfPrim op vs     v@(VFun _) -> foldlM f v vs       where         f (VFun g) (Pos v) = g v@@ -142,266 +103,482 @@  withStackFrame :: Core -> Eval a -> Eval a withStackFrame (CLoc sp (CVar n)) e =-  pushScope n (pushSpan (Just sp) e)+  pushStackFrame (n, 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)+  pushStackFrame (s2n "anonymous", Just sp) e+withStackFrame (CVar _) e = e+--pushStackFrame (n, Nothing) e+withStackFrame _ e = e -evalClos :: Ctx -> Fun -> [Arg Thunk] -> Eval Value-evalClos rho (Fun f) vs = do+--pushStackFrame (s2n "anonymous", Nothing) e++whnfClos :: Env -> Lam -> [Arg Value] -> Eval Value+whnfClos rho f args = do   (bnds, e) <- unbind f-  let xs = second unembed <$> unrec bnds-  withCtx rho (evalFun xs e vs)+  (rs, ps, ns) <- splitArgs args (second unembed <$> unrec bnds)+  withEnv rho $+    extendEnv (M.fromList ps) $+      extendEnv (M.fromList ns) $+        appDefaults rs e -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+-- all parameter names are bound in default values+appDefaults :: [(Name Core, Core)] -> Core -> Eval Value+appDefaults rs e = mdo+  bnds <-+    M.fromList+      <$> mapM+        ( \(n, e) -> do+            th <- extendEnv bnds (mkValue e)+            pure (n, th)+        )+        rs+  extendEnv bnds (whnf e) -evalFun bnds e args = do-  if length ps > length bnds-    then throwE $ TooManyArgs (length bnds)-    else extendCtx' (zip names ps') $ evalNamedArgs ns bnds'+-- returns a triple with unapplied binders, positional and named+splitArgs args bnds = do+  named <- getNamed+  pos <- getPos+  unapp <- getUnapp named+  pure (unapp, pos, named)   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)+    (bnds1, bnds2) = splitAt (length ps) bnds+    (ps, ns) = split args+    pNames = map fst bnds++    getPos =+      if length ps > length bnds+        then throwE $ TooManyArgs (length bnds)+        else pure $ zip (map fst bnds1) ps++    -- checks the provided named arguments exist+    getNamed = traverse f ns       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+        f (a, b) = case g a of+          Nothing -> throwE $ BadParam (pretty a)+          Just n -> pure (n, b)+        g a = find ((a ==) . name2String) pNames --- | 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'+    getUnapp named =+      pure $ filter ((`notElem` ns) . fst) bnds2+      where+        ns = map fst named -evalObj :: [KeyValue Core] -> Eval Value-evalObj xs = mdo-  env <- asks ctx-  fs <--    catMaybes+    split [] = ([], [])+    split (Pos p : xs) =+      let (ys, zs) = split xs in (p : ys, zs)+    split (Named n v : xs) =+      let (ys, zs) = split xs in (ys, (n, v) : zs)++whnfPrim :: Prim -> [Arg Value] -> Eval Value+whnfPrim (UnyOp op) [Pos e] = whnfV e >>= whnfUnyOp op+whnfPrim (BinOp LAnd) [Pos e1, Pos e2] = whnfLogical id e1 e2+whnfPrim (BinOp LOr) [Pos e1, Pos e2] = whnfLogical not e1 e2+whnfPrim (BinOp op) [Pos e1, Pos e2] =+  liftA2 (,) (whnfV e1) (whnfV e2) >>= uncurry (whnfBinOp op)+whnfPrim Cond [Pos c, Pos t, Pos e] = whnfCond c t e++whnfBinOp :: BinOp -> Value -> Value -> Eval Value+whnfBinOp Lookup e1 e2 = whnfLookup e1 e2+whnfBinOp Add x@(VStr _) y = inj <$> append x y+whnfBinOp Add x y@(VStr _) = inj <$> append x y+whnfBinOp Add x@(VArr _) y@(VArr _) = liftF2 ((V.++) @Value) x y+whnfBinOp Add (VObj x) (VObj y) = x `mergeWith` y+whnfBinOp Add n1 n2 = liftF2 ((+) @Double) n1 n2+whnfBinOp Sub n1 n2 = liftF2 ((-) @Double) n1 n2+whnfBinOp Mul n1 n2 = liftF2 ((*) @Double) n1 n2+whnfBinOp Div (VNum _) (VNum 0) = throwE DivByZero+whnfBinOp Div n1 n2 = liftF2 ((/) @Double) n1 n2+whnfBinOp Mod (VNum _) (VNum 0) = throwE DivByZero+whnfBinOp Mod n1 n2 = liftF2 (mod @Int64) n1 n2+whnfBinOp Eq e1 e2 = inj <$> equals e1 e2+whnfBinOp Ne e1 e2 = inj . not <$> equals e1 e2+whnfBinOp Lt e1 e2 = liftF2 ((<) @Double) e1 e2+whnfBinOp Gt e1 e2 = liftF2 ((>) @Double) e1 e2+whnfBinOp Le e1 e2 = liftF2 ((<=) @Double) e1 e2+whnfBinOp Ge e1 e2 = liftF2 ((>=) @Double) e1 e2+whnfBinOp And e1 e2 = liftF2 ((.&.) @Int64) e1 e2+whnfBinOp Or e1 e2 = liftF2 ((.|.) @Int64) e1 e2+whnfBinOp Xor e1 e2 = liftF2 (xor @Int64) e1 e2+whnfBinOp ShiftL e1 e2 = liftF2 (shiftL @Int64) e1 e2+whnfBinOp ShiftR e1 e2 = liftF2 (shiftR @Int64) e1 e2+whnfBinOp In s o = liftF2 (\o s -> objectHasEx o s True) o s++whnfLogical :: HasValue a => (a -> Bool) -> Value -> Value -> Eval Value+whnfLogical f e1 e2 = do+  x <- whnfV e1 >>= proj'+  if f x+    then inj <$> (whnfV e2 >>= proj' @Bool)+    else pure (inj x)++append :: Value -> Value -> Eval Text+append v1 v2 = T.append <$> toString v1 <*> toString v2++whnfUnyOp :: UnyOp -> Value -> Eval Value+whnfUnyOp Compl x = inj <$> fmap (complement @Int64) (proj' x)+whnfUnyOp LNot x = inj <$> fmap not (proj' x)+whnfUnyOp Minus x = inj <$> fmap (negate @Double) (proj' x)+whnfUnyOp Plus x = inj <$> fmap (id @Double) (proj' x)+whnfUnyOp Err x = (toString >=> throwE . RuntimeError . pretty) x++toString :: Value -> Eval Text+toString (VStr s) = pure s+toString v = toStrict . encodeToLazyText <$> manifest v++whnfCond :: Value -> Value -> Value -> Eval Value+whnfCond c e1 e2 = do+  c' <- proj' c+  if c'+    then whnfV e1+    else whnfV e2++whnfLookup :: Value -> Value -> Eval Value+whnfLookup (VObj o) (VStr s) =+  whnfV . fieldValWHNF =<< liftMaybe (NoSuchKey (pretty s)) (H.lookup s o)+whnfLookup (VArr a) (VNum i)+  | isInteger i =+    whnfV =<< liftMaybe (IndexOutOfBounds i) ((a !?) =<< toBoundedInteger i)+whnfLookup (VArr _) _ =+  throwE (InvalidIndex "array index was not integer")+whnfLookup (VStr s) (VNum i)+  | isInteger i =+    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'+whnfLookup (VStr _) _ =+  throwE (InvalidIndex "string index was not integer")+whnfLookup v _ = throwTypeMismatch "array/object/string" v++whnfIndir :: Ref -> Eval Value+whnfIndir ref = do+  c <- liftIO $ readIORef ref+  case c of+    Cell v True ->+      return v -- Already evaluated, just return it+    Cell v False -> do+      v' <- whnfV v -- Needs to be reduced+      liftIO $ writeIORef ref (Cell v' True)+      return v'++whnfLetrec :: Let -> Eval Value+whnfLetrec bnd = mdo+  (r, e1) <- unbind bnd+  bnds <-+    M.fromList       <$> 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+        ( \(n, Embed e) -> do+            v <- extendEnv bnds (mkValue e)+            pure (n, v)         )+        (unrec r)+  extendEnv bnds (mkValue e1)++whnfObj :: [CField] -> Eval Value+whnfObj xs = mdo+  obj <-+    mkIndirV . VObj . H.fromList . catMaybes+      =<< mapM+        ( \field ->+            let self = M.singleton (s2n "self") obj+             in whnfField self field+        )         xs-  pure $ VObj $ H.fromList $ fs-  where-    self = mkThunk' . VObj . H.fromList+  pure obj -evalKey :: Core -> Eval (Maybe Text)-evalKey key =-  eval key >>= \case-    VStr k -> pure $ Just k-    VNull -> pure Nothing-    v -> throwInvalidKey v+whnfField ::+  -- | self object+  Env ->+  -- |+  CField ->+  -- |+  Eval (Maybe (Text, VField))+whnfField self (CField k v h) = do+  let fieldVis = h+  fieldKey <- whnf k -- keys are strictly evaluated+  fieldValWHNF <- extendEnv self (mkValue v)+  fieldVal <- extendEnv self (mkThunk v)+  fmap (,VField {..}) <$> proj' fieldKey -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+flattenArrays :: Vector (Vector Value) -> Vector Value+flattenArrays = join -evalArrComp ::+whnfComp ::+  Comp ->   Core ->-  Bind (Name Core) (Core, Maybe Core) ->   Eval Value-evalArrComp cs bnd = do+whnfComp (ArrC bnd) cs = do   xs <- comp-  inj' flattenArrays $ VArr $ V.mapMaybe id xs+  liftF flattenArrays $ VArr $ V.mapMaybe id xs   where     comp =-      eval cs >>= \case+      whnf cs >>= \case         VArr xs -> forM xs $ \x -> do           (n, (e, cond)) <- unbind bnd-          extendCtx' [(n, x)] $ do+          extendEnv (M.fromList [(n, x)]) $ do             b <- f cond             if b-              then Just <$> thunk e+              then Just <$> mkValue e               else pure Nothing-        v -> throwTypeMismatch "array" v+        v -> throwTypeMismatch "" 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+        f (Just c) = proj' =<< whnf c+whnfComp (ObjC bnd) cs = do   xs <- comp   pure $ VObj $ H.fromList $ catMaybes $ V.toList xs   where     comp =-      eval cs >>= \case+      whnf cs >>= \case         VArr xs -> forM xs $ \x -> do-          (n, (e, cond)) <- unbind bnd-          extendCtx' [(n, x)] $ do+          (n, (CField k v h, cond)) <- unbind bnd+          extendEnv (M.fromList [(n, x)]) $ do             b <- f cond             if b-              then evalKeyValue e+              then do+                fieldKey <- whnf k+                fieldValWHNF <- mkValue v+                fieldVal <- mkThunk v+                let fieldVis = h+                fmap (,VField {..}) <$> proj' fieldKey               else pure Nothing         v -> throwTypeMismatch "array" v     f Nothing = pure True-    f (Just c) = do-      vb <- eval c-      proj vb+    f (Just c) = proj' =<< whnf c -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)+-- | Right-biased union of two objects, i.e. '{x : 1} + {x : 2} == {x : 2}'+--   with OO-like `self` and `super` support via value recursion (knot-tying)+mergeWith :: Object -> Object -> Eval Value+mergeWith xs ys = mdo+  zs' <- mkIndirV $ VObj (H.unionWith f xs' ys')+  xs' <- for xs (update self zs')+  ys' <- do+    xs'' <- mkIndirV (VObj xs')+    ys'' <- for ys (update self zs')+    for ys'' (update super xs'')+  pure zs'+  where+    self = s2n "self"+    super = s2n "super"+    f a b+      | hidden a && visible b = a+      | otherwise = b+    update name xs f@VField {..} = case fieldVal of+      VThunk c env -> do+        let env' = M.insert name xs env+        let fieldVal = VThunk c env'+        fieldValWHNF <- mkIndirV fieldVal+        pure VField {..}+      _ -> pure f -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+visibleKeys :: Object -> HashMap Text Value+visibleKeys = H.mapMaybe f+  where+    f v@VField {..}+      | not (hidden v) = Just fieldValWHNF+      | otherwise = Nothing -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+liftMaybe :: EvalError -> Maybe a -> Eval a+liftMaybe e =+  \case+    Nothing -> throwE e+    Just a -> pure a -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+manifest :: Value -> Eval JSON.Value+manifest = \case+  VNull -> pure JSON.Null+  VBool b -> pure (JSON.Bool b)+  VStr s -> pure (JSON.String s)+  VNum n -> pure (JSON.Number n)+  VObj vs -> JSON.Object <$> mapM manifest (visibleKeys vs)+  VArr vs -> JSON.Array <$> mapM manifest vs+  VClos {} -> throwE (ManifestError "function")+  VFun _ -> throwE (ManifestError "function")+  v@VThunk {} -> whnfV v >>= manifest+  v@VIndir {} -> whnfV v >>= manifest+  _ -> throwE (ManifestError "impossible") -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+objectFieldsEx :: Object -> Bool -> [Text]+objectFieldsEx o True = L.sort (H.keys o) -- all fields+objectFieldsEx o False = L.sort $ H.keys $ H.filter (not . hidden) o -- only visible (incl. forced) -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)+objectHasEx :: Object -> Text -> Bool -> Bool+objectHasEx o f all = f `elem` objectFieldsEx o all -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)+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 a b =+  throwE+    ( StdError $+        text $+          T.unpack $+            "primitiveEquals operates on primitive types "+            --  <> showTy a+            --  <> showTy b+    )++equals :: Value -> Value -> Eval Bool+equals e1 e2 = liftA2 (,) (whnfV e1) (whnfV e2) >>= uncurry go   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+    go as@(VArr a) bs@(VArr b)+      | P.length a == P.length b = do+        as' <- proj' as+        bs' <- proj' bs+        allM (uncurry equals) (zip as' bs')+      | P.length a /= P.length b = pure False+    go (VObj a) (VObj b) = do+      let fields = objectFieldsEx a False+      if fields /= objectFieldsEx b False+        then pure False+        else allM objectFieldEquals fields+      where+        objectFieldEquals field =+          let a' = fieldValWHNF (a H.! field)+              b' = fieldValWHNF (b H.! field)+           in equals a' b'+    go a b = do+      ta <- showTy a+      tb <- showTy b+      if ta == tb+        then primitiveEquals a b+        else pure False -evalLiteral :: Literal -> Eval Value-evalLiteral = \case-  Null -> pure VNull-  Bool b -> pure $ VBool b-  String s -> pure $ VStr s-  Number n -> pure $ VNum n+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM p = foldrM (\a b -> (&& b) <$> p a) True -evalBin ::+-- better names?+liftF ::+  (HasValue a, HasValue b) =>+  (a -> b) ->+  (Value -> Eval Value)+liftF f v = inj . f <$> proj' v+{-# INLINE liftF #-}++liftF2 ::   (HasValue a, HasValue b, HasValue c) =>   (a -> b -> c) ->   Value ->   Value ->   Eval Value-evalBin = inj''+liftF2 f v1 v2 = inj <$> liftA2 f (proj' v1) (proj' v2)+{-# INLINE liftF2 #-} -append :: Value -> Value -> Eval Text-append v1 v2 = T.append <$> toString v1 <*> toString v2+proj' :: HasValue a => Value -> Eval a+proj' = whnfV >=> proj+{-# INLINE proj' #-} -throwInvalidKey :: Value -> Eval a-throwInvalidKey = throwE . InvalidKey . pretty . valueType+throwTypeMismatch :: Text -> Value -> Eval a+throwTypeMismatch e = throwE . TypeMismatch e <=< showTy -updateSpan :: Maybe SrcSpan -> Eval ()-updateSpan sp = modify $ \st -> st {currentPos = sp}+showTy :: Value -> Eval Text+showTy = \case+  VNull -> pure "null"+  VNum _ -> pure "number"+  VBool _ -> pure "boolean"+  VStr _ -> pure "string"+  VObj _ -> pure "object"+  VArr _ -> pure "array"+  VClos {} -> pure "function"+  VFun _ -> pure "function"+  VPrim _ -> pure "function"+  VThunk {} -> pure "thunk"+  VIndir {} -> pure "pointer" -toString :: Value -> Eval Text-toString (VStr s) = pure s-toString v = toStrict . encodeToLazyText <$> manifest v+--v@VThunk {} -> whnfV v >>= showTy+--v@VIndir {} -> whnfV v >>= showTy -flattenArrays :: Vector (Vector Thunk) -> Vector Thunk-flattenArrays = join+instance HasValue Bool where+  proj (VBool n) = pure n+  proj v = throwTypeMismatch "bool" v+  inj = VBool+  {-# INLINE inj #-} -liftMaybe :: EvalError -> Maybe a -> Eval a-liftMaybe e =-  \case-    Nothing -> throwE e-    Just a -> pure a+instance HasValue Text where+  proj (VStr s) = pure s+  proj v = throwTypeMismatch "string" v+  inj = VStr+  {-# INLINE inj #-}++instance {-# OVERLAPPING #-} HasValue [Char] where+  proj (VStr s) = pure $ T.unpack s+  proj v = throwTypeMismatch "string" v+  inj = VStr . T.pack+  {-# INLINE inj #-}++instance HasValue ByteString where+  proj (VStr s) = pure (encodeUtf8 s)+  proj v = throwTypeMismatch "string" v+  inj = VStr . decodeUtf8+  {-# INLINE inj #-}++instance HasValue Scientific where+  proj (VNum n) = pure n+  proj v = throwTypeMismatch "number" v+  inj = VNum+  {-# INLINE inj #-}++instance HasValue Double where+  proj (VNum n) = pure (toRealFloat n)+  proj v = throwTypeMismatch "number" v+  inj = VNum . fromFloatDigits+  {-# INLINE inj #-}++instance {-# OVERLAPS #-} Integral a => HasValue a where+  proj (VNum n) = pure (round n)+  proj v = throwTypeMismatch "number" v+  inj = VNum . fromIntegral+  {-# INLINE inj #-}++instance HasValue a => HasValue (Maybe a) where+  proj VNull = pure Nothing+  proj a = Just <$> proj' a+  inj Nothing = VNull+  inj (Just a) = inj a+  {-# INLINE inj #-}++instance {-# OVERLAPS #-} HasValue Object where+  proj (VObj o) = pure o+  proj v = throwTypeMismatch "object" v+  inj = VObj+  {-# INLINE inj #-}++instance HasValue a => HasValue (Vector a) where+  proj (VArr as) = mapM proj' as+  proj v = throwTypeMismatch "array" v+  inj as = VArr (inj <$> as)+  {-# INLINE inj #-}++instance {-# OVERLAPPABLE #-} HasValue a => HasValue [a] where+  proj = fmap V.toList . proj'+  inj = inj . V.fromList+  {-# INLINE inj #-}++instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> b) where+  inj f = VFun $ fmap (inj . f) . proj'+  {-# INLINE inj #-}+  proj = throwTypeMismatch "impossible"++instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> c) where+  inj f = inj $ \x -> inj (f x)+  {-# INLINE inj #-}+  proj = throwTypeMismatch "impossible"++instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> Eval b) where+  inj f = VFun $ proj' >=> fmap inj . f+  {-# INLINE inj #-}+  proj (VFun f) = pure $ \x -> f (inj x) >>= proj'+  proj (VClos f e) = pure $ \x -> proj =<< whnfClos e f [Pos (inj x)]+  proj v = throwTypeMismatch "function" v++instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> Eval c) where+  inj f = inj $ \x -> inj (f x)+  {-# INLINE inj #-}+  proj (VFun f) = pure $ \x y -> f (inj x) >>= \(VFun g) -> g (inj y) >>= proj'+  proj (VClos f env) = pure $ \x y -> proj' =<< whnfClos env f [Pos (inj x), Pos (inj y)]+  proj v = throwTypeMismatch "function" v

@@ -1,9 +0,0 @@-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

@@ -1,121 +1,104 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} +-- | module Language.Jsonnet.Eval.Monad where -import Control.Arrow+import Control.Lens (locally, makeLenses, view) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Except-import Control.Monad.RWS.Strict-import Control.Monad.Reader+  ( ExceptT (..),+    MonadError (throwError),+    MonadFix,+    MonadIO,+    runExceptT,+  )+import Control.Monad.Reader (MonadReader, ReaderT (..)) 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 qualified Data.Map.Lazy as M (union)+import Language.Jsonnet.Common (Backtrace (..), StackFrame (..))+import Language.Jsonnet.Core (Core)+import Language.Jsonnet.Error (Error (EvalError), EvalError)+import Language.Jsonnet.Parser.SrcSpan (SrcSpan) import Unbound.Generics.LocallyNameless+  ( Fresh,+    FreshMT,+    Name,+    runFreshMT,+    s2n,+  ) -instance (Monoid w, Fresh m) => Fresh (RWST r w s m) where-  fresh = lift . fresh+type Ctx a = Map (Name Core) a -newtype Eval a = Eval-  { unEval :: ExceptT Error (RWST Env () EvalState (FreshMT IO)) a+-- | Simulate a call-stack to report stack traces+data CallStack = CallStack+  { -- | source location of call-sites+    _spans :: [Maybe SrcSpan],+    -- | names of called functions+    _scopes :: [Name Core]   }++makeLenses ''CallStack++emptyStack :: CallStack+emptyStack = CallStack [] [s2n "top-level"]++data EvalState a = EvalState+  { -- | binding local variables to their values+    _ctx :: Ctx a,+    -- | call-stack simulation+    _callStack :: CallStack,+    -- | source span of expression being evaluated+    _currentPos :: Maybe SrcSpan+  }++makeLenses ''EvalState++newtype EvalM a b = EvalM+  { unEval :: ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b+  }   deriving     ( Functor,       Applicative,       Monad,       MonadIO,-      MonadFix,-      MonadWriter (),-      MonadReader Env,+      MonadReader (EvalState a),       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}+      MonadFix,+      Fresh     ) -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)]-  }+runEvalM :: Ctx a -> EvalM a b -> IO (Either Error b)+runEvalM ctx e = runFreshMT (runReaderT (runExceptT (unEval e)) st)+  where+    st = EvalState ctx emptyStack Nothing -withEnv :: Env -> Eval a -> Eval a-withEnv rho = local (const rho)+throwE :: EvalError -> EvalM a b+throwE e = throwError . EvalError e =<< getBacktrace -emptyEnv :: Env-emptyEnv = Env M.empty [] [Nothing]+extendEnv :: Ctx a -> EvalM a b -> EvalM a b+extendEnv = locally ctx . M.union -data EvalState = EvalState-  { currentPos :: Maybe SrcSpan-  }+withEnv :: Ctx a -> EvalM a b -> EvalM a b+withEnv = locally ctx . const -emptyState :: EvalState-emptyState = EvalState Nothing+pushStackFrame :: (Name Core, Maybe SrcSpan) -> EvalM a b -> EvalM a b+pushStackFrame (name, span) =+  locally (callStack . scopes) (name :)+    . locally (callStack . spans) (span :) ---  traceShowM $ "length of spans: "---  traceShowM $ length sp---  traceShowM $ "length of scopes: "---  traceShowM $ length sc-getBacktrace :: Eval (Backtrace Core)+getBacktrace :: EvalM a (Backtrace Core) getBacktrace = do-  sp <- (:) <$> gets currentPos <*> asks spans-  sc <- asks scopes+  sp <- (:) <$> view currentPos <*> view (callStack . spans)+  sc <- view (callStack . 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

@@ -1,5 +0,0 @@-module Language.Jsonnet.Eval.Monad where--data Eval a--data EvalState

@@ -1,43 +0,0 @@-{-# 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

@@ -3,7 +3,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Language.Jsonnet.Parser where+-- | Parser for Jsonnet source code.+module Language.Jsonnet.Parser+  ( parse,+    resolveImports,+  )+where  import Control.Applicative hiding (many, some) import Control.Arrow (left)@@ -40,8 +45,11 @@  parse ::   MonadError Error m =>+  -- | File name (only for source location annotations)   FilePath ->+  -- | Input for parser   Text ->+  -- | AST with unresolved imports   m Expr' parse fp inp =   liftEither $@@ -50,8 +58,11 @@  resolveImports ::   (MonadError Error m, MonadIO m) =>+  -- | File path (modules are resolved relative to this path)   FilePath ->+  -- | AST with unresolved imports   Expr' ->+  -- | AST with imports resolved   m Expr resolveImports fp = foldFixM go   where@@ -101,8 +112,7 @@ annotateLoc p = do   begin <- getSourcePos   res <- p-  end <- getSourcePos-  pure $ AnnF res $ SrcSpan begin end+  AnnF res . SrcSpan begin <$> getSourcePos  identifier :: Parser String identifier = do@@ -161,7 +171,7 @@     quoted c =       c         *> manyTill-          ((c *> c) <|> anySingle)+          (c *> c <|> anySingle)           (try $ c <* notFollowedBy c)  textBlock :: Parser String@@ -228,8 +238,7 @@       cond <- keywordP "assert" *> exprP       msg <- optional (colon *> exprP)       _ <- symbol ";"-      expr <- exprP-      pure $ mkAssertF cond msg expr+      mkAssertF cond msg <$> exprP  ifElseP :: Parser Expr' ifElseP = Fix <$> annotateLoc ifElseExpr@@ -290,8 +299,7 @@     localExpr = do       bnds <- localBndsP       _ <- symbol ";"-      expr <- exprP-      pure $ mkLocalF bnds expr+      mkLocalF bnds <$> exprP  arrayP :: Parser Expr' arrayP = Fix <$> annotateLoc (brackets (try arrayComp <|> array))@@ -314,9 +322,9 @@       key <- keyP       (override, visibility) <-         (,)-          <$> option False ((symbol "+") $> True) <*> sepP+          <$> option False (symbol "+" $> True) <*> sepP       value <- exprP-      pure $ Field {..}+      pure $ EField {..}     keyP = brackets exprP <|> unquoted <|> stringP     methodP = do       let override = False@@ -324,11 +332,11 @@       ps <- paramsP       visibility <- sepP       value <- function (pure ps) exprP-      pure $ Field {..}+      pure $ EField {..}     sepP =       try (symbol ":::" $> Forced)         <|> try (symbol "::" $> Hidden)-        <|> (symbol ":" $> Visible)+        <|> symbol ":" $> Visible     localP = do       _ <- keywordP "local"       try binding <|> localFunc@@ -351,7 +359,7 @@ binary name f = InfixL (f <$ operator name)   where     operator sym = try $ symbol sym <* notFollowedBy opChar-    opChar = oneOf (":~+&|^=<>*/%" :: [Char]) <?> "operator"+    opChar = oneOf (":~+&|^=<>*/%" :: String) <?> "operator"  prefix ::   Text ->@@ -381,38 +389,38 @@       prefix "!" (mkUnyOp LNot),       prefix "~" (mkUnyOp Compl)     ],-    [ binary "*" (mkBinOp (Arith Mul)),-      binary "/" (mkBinOp (Arith Div)),-      binary "%" (mkBinOp (Arith Mod))+    [ binary "*" (mkBinOp Mul),+      binary "/" (mkBinOp Div),+      binary "%" (mkBinOp Mod)     ],-    [ binary "+" (mkBinOp (Arith Add)),-      binary "-" (mkBinOp (Arith Sub)),+    [ binary "+" (mkBinOp Add),+      binary "-" (mkBinOp Sub),       Postfix postfixObjectMerge     ],-    [ binary ">>" (mkBinOp (Bitwise ShiftR)),-      binary "<<" (mkBinOp (Bitwise ShiftL))+    [ binary ">>" (mkBinOp ShiftR),+      binary "<<" (mkBinOp ShiftL)     ],     [ binary "in" (mkBinOp In),-      binary ">" (mkBinOp (Comp Gt)),-      binary "<=" (mkBinOp (Comp Le)),-      binary ">=" (mkBinOp (Comp Ge)),-      binary "<" (mkBinOp (Comp Lt))+      binary ">" (mkBinOp Gt),+      binary "<=" (mkBinOp Le),+      binary ">=" (mkBinOp Ge),+      binary "<" (mkBinOp Lt)     ],-    [ binary "==" (mkBinOp (Comp Eq)),-      binary "!=" (mkBinOp (Comp Ne))+    [ binary "==" (mkBinOp Eq),+      binary "!=" (mkBinOp Ne)     ],-    [binary "&" (mkBinOp (Bitwise And))],-    [binary "^" (mkBinOp (Bitwise Xor))],-    [binary "|" (mkBinOp (Bitwise Or))],-    [binary "&&" (mkBinOp (Logical LAnd))],-    [binary "||" (mkBinOp (Logical LOr))]+    [binary "&" (mkBinOp And)],+    [binary "^" (mkBinOp Xor)],+    [binary "|" (mkBinOp Or)],+    [binary "&&" (mkBinOp LAnd)],+    [binary "||" (mkBinOp 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+postfixObjectMerge = flip (mkBinOp Add) <$> objectP  -- | application, indexing and lookup: e(...) e[...] e.f -- all have the same precedence (the highest)

@@ -155,9 +155,10 @@  instance Pretty (StackFrame a) where   pretty StackFrame {..} =-    pretty span <+> pretty name'+    pretty span <+> pretty (f $ name2String name)     where-      name' = (<+>) (text "function") . angles . pretty <$> name+      f "top-level" = mempty+      f x = text "function" <+> (angles $ pretty x)  instance Pretty (Backtrace a) where   pretty (Backtrace xs) = vcat $ pretty <$> xs

@@ -1,4 +1,6 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -10,6 +12,7 @@   ) where +import Control.Lens (view) import Control.Monad.Except import Control.Monad.State import Data.Aeson (FromJSON (..))@@ -18,14 +21,17 @@ import Data.Foldable (foldrM) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as H-import Data.List (sort)+import qualified Data.List as L (intercalate, sort) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.Vector (Vector)+import qualified Data.Vector as V import Data.Word import Language.Jsonnet.Common-import Language.Jsonnet.Core (Fun (Fun), KeyValue (..))+import Language.Jsonnet.Core import Language.Jsonnet.Error+import Language.Jsonnet.Eval import Language.Jsonnet.Eval.Monad import Language.Jsonnet.Parser.SrcSpan import Language.Jsonnet.Value@@ -36,94 +42,58 @@ import Prelude hiding (length) import qualified Prelude as P (length) --- | The native subset of Jsonnet standard library+-- | Jsonnet standard library built-in methods std :: Value std = VObj $ H.fromList $ map f xs   where-    f = \(k, v) -> (k, TV <$> Hideable v Hidden)+    f = \(k, v) -> (k, VField (VStr k) v v Hidden)     xs =-      ("thisFile", inj <$> thisFile) :-      map-        (\(k, v) -> (k, pure v))-        [ ("type", inj valueType),-          ("primitiveEquals", inj primitiveEquals),-          ("equals", inj equals),-          ("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 a b =-  throwE-    ( StdError $-        text $-          T.unpack $-            "primitiveEquals operates on primitive types "-              <> valueType a-              <> valueType b-    )+      [ ("type", inj showTy),+        ("primitiveEquals", inj primitiveEquals),+        ("equals", inj equals),+        ("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 @Eval)),+        ("filter", inj (filterM @Eval @Value)),+        ("join", inj intercalate),+        ("objectHasEx", inj objectHasEx),+        ("objectFieldsEx", inj objectFieldsEx),+        ("parseJson", inj (JSON.decodeStrict @Value))+      ] -equals :: Value -> Value -> Eval Bool-equals as@(VArr a) bs@(VArr b)-  | P.length a == P.length b = do-    as' <- proj as-    bs' <- proj bs-    allM (uncurry equals) (zip as' bs')-  | P.length a /= P.length b = pure False-equals (VObj a) (VObj b) = do-  let fields = objectFieldsEx a False-  if fields /= objectFieldsEx b False-    then pure False-    else allM objectFieldEquals fields+intercalate :: Value -> [Value] -> Eval Value+intercalate sep arr = go sep (filter null arr)   where-    objectFieldEquals field = do-      a' <- force (value $ a H.! field)-      b' <- force (value $ b H.! field)-      equals a' b'-equals a b-  | valueType a == valueType b = primitiveEquals a b-equals _ _ = pure False--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+    null VNull = False+    null _ = True+    go sep@(VArr _) = app (L.intercalate @Value) sep+    go sep@(VStr _) = app T.intercalate sep+    app f sep arr = inj <$> (f <$> proj sep <*> traverse proj arr)  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+  VClos f _ -> do     (ps, _) <- unbind f     pure $ P.length (unrec ps)   v ->@@ -132,20 +102,11 @@           text $             T.unpack $               "length operates on strings, objects, functions and arrays, got "-                <> valueType v+              --   <> showTy 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)--allM :: Monad m => (a -> m Bool) -> [a] -> m Bool-allM p = foldrM (\a b -> (&& b) <$> p a) True+makeArray :: Monad m => Int -> (Int -> m Value) -> m (Vector Value)+makeArray n f = traverse f (V.fromList [0 .. n - 1])  instance FromJSON Value where   parseJSON = \case@@ -153,13 +114,13 @@     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.Array a -> VArr <$> traverse parseJSON a     JSON.Object o -> VObj . f <$> traverse parseJSON o     where       f :: HashMap Text Value -> Object       f o =         H.fromList-          [ (mkField k (mkThunk' v))+          [ mkField k v             | (k, v) <- H.toList o           ]-      mkField k v = (k, Hideable v Visible)+      mkField k v = (k, VField (VStr k) v v Visible)

@@ -8,13 +8,15 @@ import Language.Haskell.TH.Quote () import Language.Haskell.TH.Syntax (addDependentFile) import Language.Jsonnet.TH (parse)+import TH.RelativePaths (pathRelativeToCabalPackage)  stdlibPath :: String stdlibPath = "stdlib/std.jsonnet"  mkStdlib :: Q Exp mkStdlib = do+  fp <- pathRelativeToCabalPackage stdlibPath+  addDependentFile fp   src <- runIO (TIO.readFile stdlibPath)   ast <- parse stdlibPath src-  addDependentFile stdlibPath   pure ast

@@ -23,7 +23,7 @@  type Param a = (Ident, Maybe a) -data Field a = Field+data EField a = EField   { key :: a,     value :: a,     visibility :: Visibility,@@ -41,9 +41,9 @@       Traversable     ) -instance Alpha a => Alpha (Field a)+instance Alpha a => Alpha (EField a) -deriveShow1 ''Field+deriveShow1 ''EField  data ExprF a   = ELit Literal@@ -51,12 +51,16 @@   | EFun [Param a] a   | EApply a (Args a)   | ELocal-      { bnds :: NonEmpty (Ident, a),+      { -- | non-empty list of recursive bindings+        bnds :: NonEmpty (Ident, a),+        -- | body expression         expr :: a       }   | EObj-      { locals :: [(Ident, a)],-        fields :: [Field a]+      { -- |+        locals :: [(Ident, a)],+        -- |+        fields :: [EField a]         --asserts :: [Assert a]       }   | EArr [a]@@ -67,20 +71,29 @@   | EIf a a   | EIfElse a a a   | ESlice-      { expr :: a,+      { -- |+        expr :: a,+        -- |         start :: Maybe a,+        -- |         end :: Maybe a,+        -- |         step :: Maybe a       }   | EBinOp BinOp a a   | EUnyOp UnyOp a   | EArrComp-      { expr :: a,+      { -- |+        expr :: a,+        -- |         comp :: NonEmpty (CompSpec a)       }   | EObjComp-      { field :: Field a,+      { -- |+        field :: EField a,+        -- |         locals :: [(Ident, a)],+        -- |         comp :: NonEmpty (CompSpec a)       }   deriving@@ -142,10 +155,24 @@ mkIndexF :: a -> a -> ExprF' a mkIndexF e = InL . EIndex e -mkSliceF :: a -> Maybe a -> Maybe a -> Maybe a -> ExprF' a+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 ::+  -- |+  [EField a] ->+  -- |+  [(Ident, a)] ->+  ExprF' a mkObjectF fs ls = InL $ EObj ls fs  mkArrayF :: [a] -> ExprF' a@@ -160,5 +187,12 @@ mkArrCompF :: a -> NonEmpty (CompSpec a) -> ExprF' a mkArrCompF e = InL . EArrComp e -mkObjCompF :: Field a -> [(Ident, a)] -> NonEmpty (CompSpec a) -> ExprF' a+mkObjCompF ::+  -- |+  EField a ->+  -- |+  [(Ident, a)] ->+  -- |+  NonEmpty (CompSpec a) ->+  ExprF' a mkObjCompF f ls = InL . EObjComp f ls

@@ -10,10 +10,10 @@ import Language.Jsonnet.Parser.SrcSpan import Language.Jsonnet.Syntax --- annotated syntax tree with resolved imports+-- | annotated syntax tree with resolved imports type Expr = Ann ExprF SrcSpan --- annotated syntax tree with unresolved imports+-- | annotated syntax tree with unresolved imports type Expr' = Ann ExprF' SrcSpan  mkApply :: Expr' -> Args Expr' -> Expr'

@@ -29,9 +29,6 @@ instance Data a => Lift (Arg a) where   lift = liftData -instance Data a => Lift (Hideable a) where-  lift = liftData- instance Lift SrcSpan where   lift = liftData @@ -47,28 +44,16 @@ 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+instance Lift Prim where   lift = liftData -instance Lift LogicalOp where+instance Lift BinOp where   lift = liftData  instance Lift UnyOp where   lift = liftData -instance Data a => Lift (Field a) where+instance Data a => Lift (EField a) where   lift = liftData  instance Data a => Lift (Assert a) where@@ -99,7 +84,7 @@  -- ouch: https://gitlab.haskell.org/ghc/ghc/-/issues/12596 liftDataWithText :: Data a => a -> Q Exp-liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)+liftDataWithText = dataToExpQ (fmap liftText . cast)  parse :: FilePath -> Text -> Q Exp parse path str = do

@@ -1,216 +1,90 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}  -- | module Language.Jsonnet.Value where -import Control.Applicative-import Control.Arrow+import Control.Lens (view) 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.Scientific 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 Data.Vector (Vector)+import GHC.Generics 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+type Eval = EvalM Value++type Env = Ctx 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)+  | VNum !Scientific+  | VObj !Object -- !Object+  | VArr !(Vector Value)+  | VThunk !Core !Env+  | VIndir !Ref+  | VPrim !Prim+  | VClos !Lam !Env+  | VFun !Fun -type Array = Vector Thunk+data VField = VField+  { -- |+    fieldKey :: Value,+    -- |+    fieldValWHNF :: Value,+    -- |+    fieldVal :: Value,+    -- |+    fieldVis :: Visibility+  }+  deriving (Generic) -type Object = HashMap Text (Hideable Thunk)+type Fun = Value -> Eval Value -valueType :: Value -> Text-valueType =-  \case-    VNull -> "null"-    VBool _ -> "boolean"-    VNum _ -> "number"-    VStr _ -> "string"-    VArr _ -> "array"-    VObj _ -> "object"-    VClos _ _ -> "function"-    VFun _ -> "function"+type Object = HashMap Text VField -data Thunk = TC !Ctx !Core | TV !(Eval Value)+data Cell = Cell {cellVal :: Value, cellIsWHNF :: Bool}   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+type Ref = IORef Cell -proj' :: HasValue a => Thunk -> Eval a-proj' = force >=> proj+instance HasVisibility VField where+  visible VField {..} = fieldVis == Visible+  forced VField {..} = fieldVis == Forced+  hidden VField {..} = fieldVis == Hidden  class HasValue a where-  proj :: Value -> Eval a   inj :: a -> Value+  proj :: Value -> Eval a -instance {-# OVERLAPS #-} HasValue Value where-  proj = pure+instance HasValue Value where   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 {-# 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+  proj = pure -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)+mkCell :: Value -> Cell+mkCell v = Cell v False -throwTypeMismatch :: Text -> Value -> Eval a-throwTypeMismatch expected =-  throwE-    . TypeMismatch expected-    . valueType+mkIndirV :: MonadIO m => Value -> m Value+mkIndirV v = VIndir <$> allocate v -inj' ::-  (HasValue a, HasValue b) =>-  (a -> b) ->-  (Value -> Eval Value)-inj' f v = inj . f <$> proj v+mkThunk :: Core -> Eval Value+mkThunk c = VThunk c <$> view ctx -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)+allocate :: MonadIO m => Value -> m (IORef Cell)+allocate = liftIO . newIORef . mkCell

@@ -1,5 +0,0 @@-module Language.Jsonnet.Value where--data Value--data Thunk

@@ -18,7 +18,6 @@ import Language.Jsonnet.Desugar import Language.Jsonnet.Error import Language.Jsonnet.Eval-import Language.Jsonnet.Eval (mergeWith) import Language.Jsonnet.Eval.Monad import Language.Jsonnet.Pretty () import qualified Language.Jsonnet.Std.Lib as Lib@@ -45,22 +44,13 @@ goldenTests :: IO TestTree goldenTests = do   jsonnetFiles <- findByExtension [".jsonnet"] "./test/golden"-  stdlib <- mkThunk std   return $     testGroup       "Jsonnet golden tests"       [ goldenVsString           (takeBaseName jsonnetFile) -- test name           goldenFile -- golden file path-          (run $ Config jsonnetFile stdlib)+          (run $ Config jsonnetFile)         | jsonnetFile <- jsonnetFiles,           let goldenFile = replaceExtension jsonnetFile ".golden"       ]---- the jsonnet stdlib is written in both jsonnet and Haskell, here we merge--- the native (small, Haskell) with the interpreted (the splice mkStdlib)-std :: Eval Value-std = eval core >>= flip mergeObjects Lib.std-  where-    core = desugar (annMap (const ()) $mkStdlib)-    mergeObjects (VObj x) (VObj y) = pure $ VObj (x `mergeWith` y)