hercules-ci-cnix-expr 0.2.0.2 → 0.3.0.0
raw patch · 15 files changed
+1773/−91 lines, 15 filesdep +QuickCheckdep +directorydep +filepathdep ~aesondep ~basedep ~protolude
Dependencies added: QuickCheck, directory, filepath, hercules-ci-cnix-expr, hspec, scientific, temporary, unordered-containers, vector
Dependency ranges changed: aeson, base, protolude
Files
- CHANGELOG.md +22/−0
- data/vendor/flake-compat/COPYING +20/−0
- data/vendor/flake-compat/default.nix +197/−0
- hercules-ci-cnix-expr.cabal +65/−15
- src/Hercules/CNix/Expr.hs +443/−27
- src/Hercules/CNix/Expr/Context.hs +3/−0
- src/Hercules/CNix/Expr/Raw.hs +19/−48
- src/Hercules/CNix/Expr/Schema.hs +513/−0
- src/Hercules/CNix/Expr/Typed.hs +75/−1
- test/Hercules/CNix/Expr/SchemaSpec.hs +234/−0
- test/Hercules/CNix/ExprSpec.hs +122/−0
- test/Hercules/CNix/Store/TestUtil.hs +12/−0
- test/SingleState.hs +23/−0
- test/Spec.hs +1/−0
- test/TestMain.hs +24/−0
CHANGELOG.md view
@@ -5,6 +5,28 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/). +## 0.3.0.0 - 2022-03-15++### Added++ - `ToValue` and `ToRawValue` classes for converting Haskell values+ to Nix values.++ - `Hercules.CNix.Expr.Schema` module for a typed interface between+ code in the Nix language and Haskell. This also includes+ provenance tracking, improving error messages while reducing+ error handling noise in the Haskell code.++ - `addAllowedPath`, `addInternalAllowedPaths` for use with restricted mode.++### Changed++ - Flakes are enabled during `init`++### Removed++ - Nix 2.3 support+ ## 0.2.0.2 - 2022-03-09 ### Added
+ data/vendor/flake-compat/COPYING view
@@ -0,0 +1,20 @@+Copyright (c) 2020-2021 Eelco Dolstra and the flake-compat contributors++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ data/vendor/flake-compat/default.nix view
@@ -0,0 +1,197 @@+# Compatibility function to allow flakes to be used by+# non-flake-enabled Nix versions. Given a source tree containing a+# 'flake.nix' and 'flake.lock' file, it fetches the flake inputs and+# calls the flake's 'outputs' function. It then returns an attrset+# containing 'defaultNix' (to be used in 'default.nix'), 'shellNix'+# (to be used in 'shell.nix').++{ src, system ? builtins.currentSystem or "unknown-system" }:++let++ lockFilePath = src + "/flake.lock";++ lockFile = builtins.fromJSON (builtins.readFile lockFilePath);++ fetchTree =+ info:+ if info.type == "github" then+ { outPath =+ fetchTarball+ ({ url = "https://api.${info.host or "github.com"}/repos/${info.owner}/${info.repo}/tarball/${info.rev}"; }+ // (if info ? narHash then { sha256 = info.narHash; } else {})+ );+ rev = info.rev;+ shortRev = builtins.substring 0 7 info.rev;+ lastModified = info.lastModified;+ lastModifiedDate = formatSecondsSinceEpoch info.lastModified;+ narHash = info.narHash;+ }+ else if info.type == "git" then+ { outPath =+ builtins.fetchGit+ ({ url = info.url; }+ // (if info ? rev then { inherit (info) rev; } else {})+ // (if info ? ref then { inherit (info) ref; } else {})+ );+ lastModified = info.lastModified;+ lastModifiedDate = formatSecondsSinceEpoch info.lastModified;+ narHash = info.narHash;+ } // (if info ? rev then {+ rev = info.rev;+ shortRev = builtins.substring 0 7 info.rev;+ } else {+ })+ else if info.type == "path" then+ { outPath = builtins.path { path = info.path; };+ narHash = info.narHash;+ }+ else if info.type == "tarball" then+ { outPath =+ fetchTarball+ ({ inherit (info) url; }+ // (if info ? narHash then { sha256 = info.narHash; } else {})+ );+ }+ else if info.type == "gitlab" then+ { inherit (info) rev narHash lastModified;+ outPath =+ fetchTarball+ ({ url = "https://${info.host or "gitlab.com"}/api/v4/projects/${info.owner}%2F${info.repo}/repository/archive.tar.gz?sha=${info.rev}"; }+ // (if info ? narHash then { sha256 = info.narHash; } else {})+ );+ shortRev = builtins.substring 0 7 info.rev;+ }+ else+ # FIXME: add Mercurial, tarball inputs.+ throw "flake input has unsupported input type '${info.type}'";++ callFlake4 = flakeSrc: locks:+ let+ flake = import (flakeSrc + "/flake.nix");++ inputs = builtins.mapAttrs (n: v:+ if v.flake or true+ then callFlake4 (fetchTree (v.locked // v.info)) v.inputs+ else fetchTree (v.locked // v.info)) locks;++ outputs = flakeSrc // (flake.outputs (inputs // {self = outputs;}));+ in+ assert flake.edition == 201909;+ outputs;++ callLocklessFlake = flakeSrc:+ let+ flake = import (flakeSrc + "/flake.nix");+ outputs = flakeSrc // (flake.outputs ({ self = outputs; }));+ in outputs;++ rootSrc = let+ # Try to clean the source tree by using fetchGit, if this source+ # tree is a valid git repository.+ tryFetchGit = src:+ if isGit && !isShallow+ then+ let res = builtins.fetchGit src;+ in if res.rev == "0000000000000000000000000000000000000000" then removeAttrs res ["rev" "shortRev"] else res+ else { outPath = src; };+ # NB git worktrees have a file for .git, so we don't check the type of .git+ isGit = builtins.pathExists (src + "/.git");+ isShallow = builtins.pathExists (src + "/.git/shallow");++ in+ { lastModified = 0; lastModifiedDate = formatSecondsSinceEpoch 0; }+ // (if src ? outPath then src else tryFetchGit src);++ # Format number of seconds in the Unix epoch as %Y%m%d%H%M%S.+ formatSecondsSinceEpoch = t:+ let+ rem = x: y: x - x / y * y;+ days = t / 86400;+ secondsInDay = rem t 86400;+ hours = secondsInDay / 3600;+ minutes = (rem secondsInDay 3600) / 60;+ seconds = rem t 60;++ # Courtesy of https://stackoverflow.com/a/32158604.+ z = days + 719468;+ era = (if z >= 0 then z else z - 146096) / 146097;+ doe = z - era * 146097;+ yoe = (doe - doe / 1460 + doe / 36524 - doe / 146096) / 365;+ y = yoe + era * 400;+ doy = doe - (365 * yoe + yoe / 4 - yoe / 100);+ mp = (5 * doy + 2) / 153;+ d = doy - (153 * mp + 2) / 5 + 1;+ m = mp + (if mp < 10 then 3 else -9);+ y' = y + (if m <= 2 then 1 else 0);++ pad = s: if builtins.stringLength s < 2 then "0" + s else s;+ in "${toString y'}${pad (toString m)}${pad (toString d)}${pad (toString hours)}${pad (toString minutes)}${pad (toString seconds)}";++ allNodes =+ builtins.mapAttrs+ (key: node:+ let+ sourceInfo =+ if key == lockFile.root+ then rootSrc+ else fetchTree (node.info or {} // removeAttrs node.locked ["dir"]);++ subdir = if key == lockFile.root then "" else node.locked.dir or "";++ flake = import (sourceInfo + (if subdir != "" then "/" else "") + subdir + "/flake.nix");++ inputs = builtins.mapAttrs+ (inputName: inputSpec: allNodes.${resolveInput inputSpec})+ (node.inputs or {});++ # Resolve a input spec into a node name. An input spec is+ # either a node name, or a 'follows' path from the root+ # node.+ resolveInput = inputSpec:+ if builtins.isList inputSpec+ then getInputByPath lockFile.root inputSpec+ else inputSpec;++ # Follow an input path (e.g. ["dwarffs" "nixpkgs"]) from the+ # root node, returning the final node.+ getInputByPath = nodeName: path:+ if path == []+ then nodeName+ else+ getInputByPath+ # Since this could be a 'follows' input, call resolveInput.+ (resolveInput lockFile.nodes.${nodeName}.inputs.${builtins.head path})+ (builtins.tail path);++ outputs = flake.outputs (inputs // { self = result; });++ result = outputs // sourceInfo // { inherit inputs; inherit outputs; inherit sourceInfo; };+ in+ if node.flake or true then+ assert builtins.isFunction flake.outputs;+ result+ else+ sourceInfo+ )+ lockFile.nodes;++ result =+ if !(builtins.pathExists lockFilePath)+ then callLocklessFlake rootSrc+ else if lockFile.version == 4+ then callFlake4 rootSrc (lockFile.inputs)+ else if lockFile.version >= 5 && lockFile.version <= 7+ then allNodes.${lockFile.root}+ else throw "lock file '${lockFilePath}' has unsupported version ${toString lockFile.version}";++in+ rec {+ defaultNix =+ result+ // (if result ? defaultPackage.${system} then { default = result.defaultPackage.${system}; } else {});++ shellNix =+ defaultNix+ // (if result ? devShell.${system} then { default = result.devShell.${system}; } else {});+ }
hercules-ci-cnix-expr.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: hercules-ci-cnix-expr-version: 0.2.0.2+version: 0.3.0.0 synopsis: Bindings for the Nix evaluator category: Nix, CI, Testing, DevOps homepage: https://docs.hercules-ci.com@@ -14,12 +14,22 @@ extra-source-files: CHANGELOG.md +data-dir: data+data-files:+ vendor/flake-compat/*.nix+ vendor/flake-compat/COPYING+ source-repository head type: git location: https://github.com/hercules-ci/hercules-ci-agent +-- Deprecated flag nix-2_4 description: Build for Nix >=2.4pre*+ default: True++flag nix-2_5+ description: Build for Nix >=2.5pre* default: False -- match the C++ language standard Nix is using@@ -29,6 +39,12 @@ -Wall extra-libraries: stdc++ + if flag(nix-2_5)+ cxx-options:+ -DNIX_2_5+ cpp-options:+ -DNIX_2_5+ if os(darwin) -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829 ld-options: -Wl,-keep_dwarf_unwind@@ -58,24 +74,34 @@ Hercules.CNix.Expr.Context Hercules.CNix.Expr.Raw Hercules.CNix.Expr.Typed+ Hercules.CNix.Expr.Schema+ other-modules:+ Paths_hercules_ci_cnix_expr+ autogen-modules:+ Paths_hercules_ci_cnix_expr hs-source-dirs: src default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns build-depends:- aeson+ aeson >= 2 , base >=4.7 && <5 , bytestring , conduit+ , directory+ , filepath , hercules-ci-cnix-store , containers , exceptions , inline-c , inline-c-cpp , protolude >= 0.3+ , scientific , text , unliftio+ , unordered-containers+ , vector default-language: Haskell2010 include-dirs: include@@ -83,17 +109,41 @@ hercules-ci-cnix/expr.hxx extra-libraries: boost_context+ pkgconfig-depends:+ nix-store >= 2.4+ , nix-expr >= 2.4+ , nix-main >= 2.4 - if flag(nix-2_4)- cpp-options:- -DNIX_2_4- pkgconfig-depends:- nix-store >= 2.4- , nix-expr >= 2.4- , nix-main >= 2.4- else- pkgconfig-depends:- nix-store >= 2.0- , nix-expr >= 2.0- , nix-main >= 2.0- , bdw-gc++test-suite hercules-ci-cnix-expr-tests+ type: exitcode-stdio-1.0+ main-is: TestMain.hs+ other-modules:+ Hercules.CNix.ExprSpec+ Hercules.CNix.Store.TestUtil+ Hercules.CNix.Expr.SchemaSpec+ SingleState+ Spec+ hs-source-dirs:+ test+ default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+ ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+ -- trace on exception (profiling):+ -- -with-rtsopts=-xc+ build-depends:+ aeson+ , base+ , bytestring+ , containers+ , hercules-ci-cnix-expr+ , hercules-ci-cnix-store+ , hspec+ , protolude+ , QuickCheck+ , scientific+ , temporary+ , unordered-containers+ , vector+ build-tool-depends:+ hspec-discover:hspec-discover == 2.*+ default-language: Haskell2010
src/Hercules/CNix/Expr.hs view
@@ -1,7 +1,13 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} module Hercules.CNix.Expr ( module Hercules.CNix.Expr,@@ -18,7 +24,13 @@ -- TODO: Map Nix-specific C++ exceptions to a CNix exception type import Conduit+import qualified Data.Aeson as A+import Data.Coerce (coerce)+import qualified Data.HashMap.Lazy as H import qualified Data.Map as M+import qualified Data.Scientific as Sci+import Data.Vector (Vector)+import qualified Data.Vector as V import Foreign (nullPtr) import qualified Foreign.C.String import Hercules.CNix.Encapsulation (moveToForeignPtrWrapper)@@ -28,8 +40,11 @@ import Hercules.CNix.Store import Hercules.CNix.Store.Context import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C-import Protolude hiding (evalState, throwIO)+import qualified Language.C.Inline.Cpp.Exception as C+import Paths_hercules_ci_cnix_expr (getDataFileName)+import Protolude hiding (evalState)+import System.Directory (makeAbsolute)+import Data.Aeson.KeyMap (toMapText) C.context (Hercules.CNix.Store.Context.context <> Hercules.CNix.Expr.Context.evalContext) @@ -57,8 +72,10 @@ C.include "<nix/globals.hh>" -C.include "<nix-compat.hh>"+C.include "<nix/flake/flake.hh>" +C.include "<nix/flake/flakeref.hh>"+ C.include "hercules-ci-cnix/expr.hxx" C.include "<gc/gc.h>"@@ -77,6 +94,14 @@ [C.throwBlock| void { nix::initNix(); nix::initGC();+#ifdef NIX_2_5+ std::set<nix::ExperimentalFeature> features(nix::settings.experimentalFeatures.get());+ features.insert(nix::ExperimentalFeature::Flakes);+#else+ Strings features(nix::settings.experimentalFeatures.get());+ features.push_back("flakes");+#endif+ nix::settings.experimentalFeatures.assign(features); } |] setTalkative :: IO ()@@ -143,6 +168,21 @@ ) (\x -> liftIO [C.throwBlock| void { delete $(EvalState* x); } |]) +-- | Insert an allowed path. Only has an effect when in restricted or pure mode.+addAllowedPath :: Ptr EvalState -> ByteString -> IO ()+addAllowedPath evalState path =+ [C.throwBlock| void {+ std::string path = std::string($bs-ptr:path, $bs-len:path);+ EvalState &evalState = *$(EvalState *evalState);+ if (evalState.allowedPaths) {+ evalState.allowedPaths->insert(path);+ }+ }|]++addInternalAllowedPaths :: Ptr EvalState -> IO ()+addInternalAllowedPaths evalState = do+ addAllowedPath evalState . encodeUtf8 . toS =<< getDataFileName "vendor/flake-compat"+ evalFile :: Ptr EvalState -> FilePath -> IO RawValue evalFile evalState filename = do filename' <- Foreign.C.String.newCString filename@@ -180,12 +220,7 @@ throw nix::Error("Could not evaluate automatic arguments"); } Value *r = new (NoGC) Value ();-#ifdef NIX_2_4 r->mkAttrs(autoArgs);-#else- r->type = tAttrs;- r->attrs = autoArgs;-#endif return r; }|] @@ -224,7 +259,6 @@ <$> [C.throwBlock| int { Value *v = $(Value *v); EvalState &evalState = *$(EvalState *evalState);-#ifdef NIX_2_4 Bindings::iterator iter = v->attrs->find(evalState.sRecurseForDerivations); if (iter == v->attrs->end()) { return 0;@@ -235,22 +269,6 @@ // nixpkgs master 67e2de195a4aa0a50ffb1e1ba0b4fb531dca67dc return evalState.forceBool(*iter->value, *iter->pos); }-#else- Symbol rfd = evalState.symbols.create("recurseForDerivations");- Bindings::iterator iter = v->attrs->find(rfd);- if (iter == v->attrs->end()) {- return 0;- } else {- evalState.forceValue(*iter->value, nix::noPos);- if (iter->value->type == ValueType::tBool) {- return iter->value->boolean ? 1 : 0;- } else {- // They can be empty attrsets???- // Observed in nixpkgs master 67e2de195a4aa0a50ffb1e1ba0b4fb531dca67dc- return 1;- }- }-#endif } |] getAttr :: Ptr EvalState -> Value NixAttrs -> ByteString -> IO (Maybe RawValue)@@ -300,11 +318,11 @@ StorePath storePath = drvInfo->requireDrvPath(); #else std::string drvPath = drvInfo->queryDrvPath();- StorePath storePath = parseStorePath(*state.store, drvPath);+ StorePath storePath = state.store->parseStorePath(drvPath); #endif // write it (?)- auto drv = state.store->derivationFromPath(printPath23(*state.store, storePath));+ auto drv = state.store->derivationFromPath(storePath); return new StorePath(storePath); }|]@@ -341,3 +359,401 @@ pure $ Right (Just b) Right _ -> do pure $ Right Nothing++-- | Parse a string and eval it.+valueFromExpressionString ::+ Ptr EvalState ->+ -- | The string to parse+ ByteString ->+ -- | Base path for path exprs+ ByteString ->+ IO RawValue+valueFromExpressionString evalState s basePath = do+ mkRawValue+ =<< [C.throwBlock| Value *{+ EvalState &evalState = *$(EvalState *evalState);+ Expr *expr = evalState.parseExprFromString(std::string($bs-ptr:s, $bs-len:s), std::string($bs-ptr:basePath, $bs-len:basePath));+ Value *r = new (NoGC) Value();+ evalState.eval(expr, *r);+ return r;+ }|]++-- | 'apply' but strict.+callFunction :: Ptr EvalState -> RawValue -> RawValue -> IO RawValue+callFunction evalState (RawValue f) (RawValue a) = do+ mkRawValue+ =<< [C.throwBlock| Value *{+ EvalState &evalState = *$(EvalState *evalState);+ Value *r = new (NoGC) Value();+ evalState.callFunction(*$(Value *f), *$(Value *a), *r, noPos);+ return r;+ }|]++apply :: RawValue -> RawValue -> IO RawValue+apply (RawValue f) (RawValue a) = do+ mkRawValue+ =<< [C.throwBlock| Value *{+ Value *r = new (NoGC) Value();+ r->mkApp($(Value *f), $(Value *a));+ return r;+ }|]++mkPath :: ByteString -> IO (Value NixPath)+mkPath path =+ Value+ <$> ( mkRawValue+ =<< [C.throwBlock| Value *{+ Value *r = new (NoGC) Value();+ std::string s($bs-ptr:path, $bs-len:path);+ r->mkPath(s.c_str());+ return r;+ }|]+ )++getFlakeFromFlakeRef :: Ptr EvalState -> ByteString -> IO RawValue+getFlakeFromFlakeRef evalState flakeRef = do+ [C.throwBlock| Value *{+ EvalState &evalState = *$(EvalState *evalState);+ Value *r = new (NoGC) Value();+ std::string flakeRefStr($bs-ptr:flakeRef, $bs-len:flakeRef);+ auto flakeRef = nix::parseFlakeRef(flakeRefStr, {}, true);+ nix::flake::callFlake(evalState,+ nix::flake::lockFlake(evalState, flakeRef,+ nix::flake::LockFlags {+ .updateLockFile = false,+ .useRegistries = false,+ .allowMutable = false,+ }),+ *r);+ return r;+ }|]+ >>= mkRawValue++getLocalFlake :: Ptr EvalState -> Text -> IO RawValue+getLocalFlake evalState path = do+ absPath <- encodeUtf8 . toS <$> makeAbsolute (toS path)+ mkRawValue+ =<< [C.throwBlock| Value *{+ EvalState &evalState = *$(EvalState *evalState);+ Value *r = new (NoGC) Value();+ std::string path($bs-ptr:absPath, $bs-len:absPath);+ auto flakeRef = nix::parseFlakeRef(path, {}, true);+ nix::flake::callFlake(evalState,+ nix::flake::lockFlake(evalState, flakeRef,+ nix::flake::LockFlags {+ .updateLockFile = false,+ .useRegistries = false,+ .allowMutable = false,+ }),+ *r);+ return r;+ }|]++getFlakeFromGit :: Ptr EvalState -> Text -> Text -> Text -> IO RawValue+getFlakeFromGit evalState url ref rev = do+ -- TODO: use a URL library, test+ getFlakeFromFlakeRef evalState (encodeUtf8 $ "git+" <> url <> "?ref=" <> ref <> "&rev=" <> rev)++getFlakeFromArchiveUrl :: Ptr EvalState -> Text -> IO RawValue+getFlakeFromArchiveUrl evalState url = do+ srcArgs <-+ toRawValue evalState $+ ("url" :: ByteString) =: url+ fn <- valueFromExpressionString evalState "builtins.fetchTarball" "/"+ pValue <- apply fn srcArgs+ p <- assertType evalState pValue+ p' <- getStringIgnoreContext p+ getFlakeFromFlakeRef evalState p'++traverseWithKey_ :: Applicative f => (k -> a -> f ()) -> Map k a -> f ()+traverseWithKey_ f = M.foldrWithKey (\k a more -> f k a *> more) (pure ())++class ToRawValue a where+ toRawValue :: Ptr EvalState -> a -> IO RawValue+ default toRawValue :: ToValue a => Ptr EvalState -> a -> IO RawValue+ toRawValue evalState a = rtValue <$> toValue evalState a++class ToRawValue a => ToValue a where+ type NixTypeFor a :: Type+ toValue :: Ptr EvalState -> a -> IO (Value (NixTypeFor a))++-- | Marshall values from Nix into Haskell. Instances must satisfy the+-- requirements that:+--+-- - Only a single Nix value type is acceptable for the Haskell type.+-- - Marshalling does not fail, as the Nix runtime type has already been checked.+class FromValue n a | a -> n where+ fromValue :: Value n -> IO a++instance FromValue Bool Bool where+ fromValue = getBool++-- | Identity+instance ToRawValue RawValue where+ toRawValue _ = pure++-- | Upcast+instance ToRawValue (Value a)++-- | Identity+instance ToValue (Value a) where+ type NixTypeFor (Value a) = a+ toValue _ = pure++instance ToRawValue C.CBool++instance ToValue C.CBool where+ type NixTypeFor C.CBool = Bool+ toValue _ b =+ coerce+ <$> [C.block| Value *{+ Value *r = new (NoGC) Value();+ r->mkBool($(bool b));+ return r;+ }|]++instance ToRawValue Bool++instance ToValue Bool where+ type NixTypeFor Bool = Bool+ toValue es False = toValue es (0 :: C.CBool)+ toValue es True = toValue es (1 :: C.CBool)++-- | The native Nix integer type+instance ToRawValue Int64++-- | The native Nix integer type+instance ToValue Int64 where+ type NixTypeFor Int64 = NixInt+ toValue _ i =+ coerce+ <$> [C.block| Value *{+ Value *r = new (NoGC) Value();+ r->mkInt($(int64_t i));+ return r;+ }|]++instance ToRawValue Int++instance ToValue Int where+ type NixTypeFor Int = NixInt+ toValue es i = toValue es (fromIntegral i :: Int64)++instance ToRawValue C.CDouble++instance ToValue C.CDouble where+ type NixTypeFor C.CDouble = NixFloat+ toValue _ f =+ coerce+ <$> [C.block| Value *{+ Value *r = new (NoGC) Value();+ r->mkFloat($(double f));+ return r;+ }|]++instance ToRawValue Double++instance ToValue Double where+ type NixTypeFor Double = NixFloat+ toValue es f = toValue es (fromRational (toRational f) :: C.CDouble)++-- | Nix String+instance ToValue ByteString where+ type NixTypeFor ByteString = NixString+ toValue _ s =+ -- TODO simplify when r->mkString(string_view) is safe in all supported Nix versions+ coerce+ <$> [C.block| Value *{+ Value *r = new (NoGC) Value();+ std::string_view s($bs-ptr:s, $bs-len:s);+ // If empty, the pointer may be invalid; don't use it.+ if (s.size() == 0) {+ r->mkString("");+ }+ else {+ r->mkString(GC_STRNDUP(s.data(), s.size()));+ }+ return r;+ }|]++-- | Nix String+instance ToRawValue ByteString++-- | UTF-8+instance ToRawValue Text++-- | UTF-8+instance ToValue Text where+ type NixTypeFor Text = NixString+ toValue es s = toValue es (encodeUtf8 s)++instance ToRawValue a => ToRawValue (Map ByteString a)++#if NIX_IS_AT_LEAST(2,6,0)+withBindingsBuilder :: Integral n => Ptr EvalState -> n -> (Ptr BindingsBuilder' -> IO ()) -> IO (Value NixAttrs)+withBindingsBuilder evalState n f = do+ withBindingsBuilder' evalState n \bb -> do+ f bb+ v <- [C.block| Value* {+ auto v = new (NoGC) Value();+ v->mkAttrs(*$(BindingsBuilder *bb));+ return v;+ }|]+ Value <$> mkRawValue v++withBindingsBuilder' :: Integral n => Ptr EvalState -> n -> (Ptr BindingsBuilder' -> IO a) -> IO a+withBindingsBuilder' evalState n =+ let l :: C.CInt+ l = fromIntegral n+ in+ bracket+ [C.block| BindingsBuilder* {+ auto &evalState = *$(EvalState *evalState);+ return new BindingsBuilder(evalState, evalState.allocBindings($(int l)));+ }|]+ \bb -> [C.block| void { delete $(BindingsBuilder *bb); }|]+#endif++instance ToRawValue a => ToValue (Map ByteString a) where+ type NixTypeFor (Map ByteString a) = NixAttrs++#if NIX_IS_AT_LEAST(2,6,0)+ toValue evalState attrs = withBindingsBuilder evalState (length attrs) \bb -> do+ attrs & traverseWithKey_ \k a -> do+ RawValue aRaw <- toRawValue evalState a+ [C.block| void {+ EvalState &evalState = *$(EvalState *evalState);+ std::string k($bs-ptr:k, $bs-len:k);+ Value &a = *$(Value *aRaw);+ $(BindingsBuilder *bb)->alloc(evalState.symbols.create(k)) = a;+ }|]+#else+ toValue evalState attrs = do+ let l :: C.CInt+ l = fromIntegral (length attrs)+ v <-+ [C.block| Value* {+ EvalState &evalState = *$(EvalState *evalState);+ Value *v = new (NoGC) Value();+ evalState.mkAttrs(*v, $(int l));+ return v;+ }|]+ attrs & traverseWithKey_ \k a -> do+ RawValue aRaw <- toRawValue evalState a+ [C.block| void {+ EvalState &evalState = *$(EvalState *evalState);+ std::string k($bs-ptr:k, $bs-len:k);+ Value &a = *$(Value *aRaw);+ *evalState.allocAttr(*$(Value *v), evalState.symbols.create(k)) = a;+ }|]+ [C.block| void {+ $(Value *v)->attrs->sort();+ }|]+ Value <$> mkRawValue v+#endif++instance ToRawValue a => ToRawValue (Map Text a)++instance ToRawValue a => ToValue (Map Text a) where+ type NixTypeFor (Map Text a) = NixAttrs+ toValue evalState attrs = toValue evalState (M.mapKeys encodeUtf8 attrs)++mkNull :: IO RawValue+mkNull =+ coerce+ <$> [C.block| Value* {+ Value *v = new (NoGC) Value();+ v->mkNull();+ return v;+ }|]++instance ToRawValue A.Value where+ toRawValue es (A.Bool b) = toRawValue es b+ toRawValue es (A.String s) = toRawValue es s+ toRawValue es (A.Object fs) = toRawValue es $ toMapText fs+ toRawValue _es A.Null = mkNull+ toRawValue es (A.Number n) | Just i <- Sci.toBoundedInteger n = toRawValue es (i :: Int64)+ toRawValue es (A.Number f) = toRawValue es (Sci.toRealFloat f :: Double)+ toRawValue es (A.Array a) = toRawValue es a++-- | For deriving-via of 'ToRawValue' using 'ToJSON'.+newtype ViaJSON a = ViaJSON {fromViaJSON :: a}+ deriving newtype (Eq, Ord, Read, Show)++instance A.ToJSON a => ToRawValue (ViaJSON a) where+ toRawValue es (ViaJSON a) = toRawValue es (A.toJSON a)++hmTraverseWithKey_ :: Applicative f => (k -> a -> f ()) -> H.HashMap k a -> f ()+hmTraverseWithKey_ f = H.foldrWithKey (\k a more -> f k a *> more) (pure ())++instance ToRawValue a => ToRawValue (H.HashMap Text a)++instance ToRawValue a => ToValue (H.HashMap Text a) where+ type NixTypeFor (H.HashMap Text a) = NixAttrs++#if NIX_IS_AT_LEAST(2,6,0)+ toValue evalState attrs = withBindingsBuilder evalState (length attrs) \bb -> do+ attrs & hmTraverseWithKey_ \k' a -> do+ RawValue aRaw <- toRawValue evalState a+ let k = encodeUtf8 k'+ [C.block| void {+ EvalState &evalState = *$(EvalState *evalState);+ std::string k($bs-ptr:k, $bs-len:k);+ Value &a = *$(Value *aRaw);+ $(BindingsBuilder *bb)->alloc(evalState.symbols.create(k)) = a;+ }|]+#else+ toValue evalState attrs = do+ let l :: C.CInt+ l = fromIntegral (length attrs)+ v <-+ [C.block| Value* {+ EvalState &evalState = *$(EvalState *evalState);+ Value *v = new (NoGC) Value();+ evalState.mkAttrs(*v, $(int l));+ return v;+ }|]+ attrs & hmTraverseWithKey_ \k' a -> do+ RawValue aRaw <- toRawValue evalState a+ let k = encodeUtf8 k'+ [C.block| void {+ EvalState &evalState = *$(EvalState *evalState);+ std::string k($bs-ptr:k, $bs-len:k);+ Value &a = *$(Value *aRaw);+ *evalState.allocAttr(*$(Value *v), evalState.symbols.create(k)) = a;+ }|]+ [C.block| void {+ $(Value *v)->attrs->sort();+ }|]+ Value <$> mkRawValue v+#endif++instance ToRawValue a => ToRawValue (Vector a)++instance ToRawValue a => ToValue (Vector a) where+ type NixTypeFor (Vector a) = NixList+ toValue evalState vec =+ coerce <$> do+ let l :: C.CInt+ l = fromIntegral (length vec)+ v <-+ [C.block| Value* {+ EvalState &evalState = *$(EvalState *evalState);+ Value *v = new (NoGC) Value();+ evalState.mkList(*v, $(int l));+ return v;+ }|]+ vec & V.imapM_ \i a -> do+ RawValue aRaw <- toRawValue evalState a+ let ix = fromIntegral i+ [C.block| void {+ Value &v = *$(Value *v);+ v.listElems()[$(int ix)] = $(Value *aRaw);+ }|]+ Value <$> mkRawValue v++instance ToRawValue a => ToRawValue [a]++instance ToRawValue a => ToValue [a] where+ type NixTypeFor [a] = NixList+ toValue es l = toValue es (V.fromList l)
src/Hercules/CNix/Expr/Context.hs view
@@ -21,6 +21,8 @@ data Attr' +data BindingsBuilder'+ context :: C.Context context = C.cppCtx <> C.fptrCtx@@ -37,4 +39,5 @@ C.TypeName "EvalState" =: [t|EvalState|] <> C.TypeName "Value" =: [t|Value'|] <> C.TypeName "Attr" =: [t|Attr'|]+ <> C.TypeName "BindingsBuilder" =: [t|BindingsBuilder'|] }
src/Hercules/CNix/Expr/Raw.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,7 +5,7 @@ import Hercules.CNix.Expr.Context import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C+import qualified Language.C.Inline.Cpp.Exception as C import Protolude hiding (evalState) import Prelude () @@ -28,6 +27,12 @@ C.using "namespace nix" +-- | A heap object.+--+-- Nix doesn't store all its objects on the heap, but we do.+--+-- Also, Nix calls them @Value@s but it includes thunks, which are not values+-- and some may never produce values, such as @throw "msg"@. newtype RawValue = RawValue (Ptr Value') -- | Takes ownership of the value.@@ -56,7 +61,6 @@ -- | You may need to 'forceValue' first. rawValueType :: RawValue -> IO RawValueType-#ifdef NIX_2_4 rawValueType (RawValue v) = f <$> [C.block| int {@@ -88,51 +92,6 @@ f 10 = Float f 11 = Thunk f _ = Other-#else-rawValueType (RawValue v) =- f- <$> [C.block| int {- switch ($(Value* v)->type) {- case tInt: return 1;- case tBool: return 2;- case tString: return 3;- case tPath: return 4;- case tNull: return 5;- case tAttrs: return 6;- case tList1: return 7;- case tList2: return 8;- case tListN: return 9;- case tThunk: return 10;- case tApp: return 11;- case tLambda: return 12;- case tBlackhole: return 13;- case tPrimOp: return 14;- case tPrimOpApp: return 15;- case tExternal: return 16;- case tFloat: return 17;- default: return 0;- }- }|]- where- f 1 = Int- f 2 = Bool- f 3 = String- f 4 = Path- f 5 = Null- f 6 = Attrs- f 7 = List- f 8 = List- f 9 = List- f 10 = Thunk- f 11 = App- f 12 = Lambda- f 13 = Blackhole- f 14 = PrimOp- f 15 = PrimOpApp- f 16 = External- f 17 = Float- f _ = Other-#endif forceValue :: Exception a => Ptr EvalState -> RawValue -> IO (Either a ()) forceValue evalState (RawValue v) =@@ -142,3 +101,15 @@ if (v == NULL) throw std::invalid_argument("forceValue value must be non-null"); $(EvalState *evalState)->forceValue(*v, nix::noPos); }|]++-- | Brings RawValueType closer to the 2.4 ValueType.+--+-- This function won't be necessary when support for 2.3 is dropped and we+-- switch entirely to the Haskell equivalent of C++ ValueType.+canonicalRawType :: RawValueType -> RawValueType+canonicalRawType = \case+ App -> Thunk+ Blackhole -> Thunk+ PrimOp -> Lambda+ PrimOpApp -> Lambda+ x -> x
+ src/Hercules/CNix/Expr/Schema.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Types and functions to represent interfaces between Nix code and Haskell+-- code.+module Hercules.CNix.Expr.Schema+ ( -- * Core+ PSObject (..),+ MonadEval,++ -- * Error handling+ Provenance (..),+ NixException (..),+ appendProvenance,++ -- * Alternatives++ --+ -- Runtime type matching. Use of @|@ comes from the implicit sum types that+ -- constitute Nix values.+ type (|.),+ (|!),++ -- * Functions+ type (->.),+ (.$),+ (>>$.),+ type (->?),+ ($?),+ (>>$?),++ -- * Simple types+ type StringWithoutContext,++ -- * Attribute sets+ basicAttrsWithProvenance,+ --+ -- Common type that can represent both simultaneously.+ type Attrs',++ -- * Attribute sets as records+ type Attrs,+ type (::.),+ (#.),+ (>>.),+ type (::?),+ (#?),+ (>>?),+ (#?!),++ -- * Attribute sets as used as dictionaries+ type Dictionary,+ dictionaryToMap,+ lookupDict,+ lookupDictBS,+ requireDict,+ requireDictBS,++ -- * Serialization+ toPSObject,+ FromPSObject (..),+ check,+ getText_,+ getByteString_,++ -- * Parsing Nix+ exprWithBasePath,+ exprWithBasePathBS,++ -- * Utilities+ uncheckedCast,+ englishOr,+ )+where++import Data.Coerce (coerce)+import qualified Data.Map as M+import qualified Data.Text as T+import qualified GHC.TypeLits as TL+import Hercules.CNix.Expr (CheckType, EvalState, HasRawValueType, NixAttrs, NixFunction, NixPath, NixString, RawValue, Value (rtValue), apply, checkType, getAttr, getRawValueType, getStringIgnoreContext, hasContext, rawValueType, toRawValue, valueFromExpressionString)+import qualified Hercules.CNix.Expr as Expr+import Hercules.CNix.Expr.Raw (RawValueType, canonicalRawType)+import Protolude hiding (TypeError, check, evalState)++-- TODO add Pos fields+data Provenance+ = File FilePath+ | Other Text+ | Data+ | Attribute Provenance Text+ | Application Provenance Provenance+ deriving (Show, Eq, Ord)++data NixException+ = MissingAttribute Provenance Text+ | TypeError+ Provenance+ RawValueType+ -- ^ actual+ [RawValueType]+ -- ^ expected+ | InvalidText Provenance UnicodeException+ | StringContextNotAllowed Provenance+ deriving (Show, Eq)++instance Exception NixException where+ displayException (MissingAttribute p name) = "Missing attribute " <> show name <> appendProvenance p+ displayException (TypeError p actual expected) = "Expecting a value of type " <> toS (englishOr (map show expected)) <> ", but got type " <> show actual <> "." <> appendProvenance p+ displayException (InvalidText p ue) = displayException ue <> appendProvenance p+ displayException (StringContextNotAllowed p) = "This string must not have a context. It must be usable without building store paths." <> appendProvenance p++appendProvenance :: Provenance -> [Char]+appendProvenance (Attribute p name) = "\n in attribute " <> show name <> appendProvenance p+appendProvenance (Other x) = "\n in " <> toS x+appendProvenance Data = ""+appendProvenance (Application p _p) = "\n in function result" <> appendProvenance p+appendProvenance (File f) = "\n in file " <> show f++-- | Alternative schema. The value only needs to satisfy one subschema.+data a |. b++-- | Function schema.+data a ->. b++infixr 1 ->.++-- | Optional function. If the value is not a function, use it as the result.+type a ->? b = (a ->. b) |. b++infixr 1 ->?++-- | Attribute set schema with known attributes and wildcard type for remaining attributes.+data Attrs' (as :: [Attr]) w++-- | Attribute set schema with known attributes only+type Attrs as = Attrs' as Void++-- | Attribute set functioning as a "dictionary" from string keys to a certain type.+type Dictionary = Attrs' '[]++-- | A kind for attribute declarations.+data Attr+ = -- | Required attribute. Use '::.'.+ Symbol :. Type+ | -- | Optional attribute. Use ':?.'.+ Symbol :? Type++data StringWithoutContext++infix 0 :.++infix 0 :?++infix 0 ::.++infix 0 ::?++-- | Optional (@_?@) attribute name and type (@::_@)+--+-- This indicates that the attribute may be omitted in its entirety, which is+-- distinct from an attribute that may be @null@.+type a ::? b = a ':? b++-- | Required (@_.@) attribute name and type (@::_@)+--+-- Note that the type may still be nullable, but the attribute is expected to exist.+type a ::. b = a ':. b++-- | An object (thunk or value) with its 'Provenance' and an expected schema type attached as a+-- phantom type.+--+-- The phantom specifies the expactation, not a checked type.+data PSObject (a :: Type) = PSObject+ { -- | Tracks the origin of the object, which is useful informaton for error messages.+ provenance :: Provenance,+ -- | The Nix object, which may be a thunk (producing errors, non-termination, etc) or a 'Value' of any type.+ --+ -- Use 'check' and/or '|.' to evaluate it (whnf) and narrow down its runtime type to a specific 'Value'.+ value :: RawValue+ }++(.$) :: (MonadIO m) => PSObject (a ->. b) -> PSObject a -> m (PSObject b)+f .$ a = do+ v <- liftIO (value f `apply` value a)+ pure+ PSObject+ { provenance = Application (provenance f) (provenance a),+ value = v+ }++type AttrType as s = AttrType' as as s++type family AttrType' all as s where+ AttrType' all ((s ':. t) ': as) s = t+ AttrType' all ((s ':? t) ': as) s =+ TL.TypeError+ ( 'TL.Text "The attribute set field named " 'TL.:<>: 'TL.ShowType s 'TL.:<>: 'TL.Text " is optional."+ 'TL.:$$: 'TL.Text " Try the optional variation, e.g. (#?) instead of (#.)"+ )+ AttrType' all (_ ': as) s = AttrType' all as s+ AttrType' all '[] s =+ TL.TypeError+ ( 'TL.Text "Schema for attribute set does not declare a field named " 'TL.:<>: 'TL.ShowType s 'TL.:<>: 'TL.Text "."+ 'TL.:$$: 'TL.Text " Known attributes are " 'TL.:<>: 'TL.ShowType all+ )++type OptionalAttrType as s = OptionalAttrType' as as s++type family OptionalAttrType' all as s where+ OptionalAttrType' all ((s ':? t) ': as) s = t+ OptionalAttrType' all ((s ':. t) ': as) s =+ TL.TypeError+ ( 'TL.Text "The attribute set field named " 'TL.:<>: 'TL.ShowType s 'TL.:<>: 'TL.Text " is required, but you're asking for an optional field."+ 'TL.:$$: 'TL.Text " Try the required variation, e.g. (#.) instead of (#?)"+ )+ OptionalAttrType' all (_ ': as) s = OptionalAttrType' all as s+ OptionalAttrType' all '[] s =+ TL.TypeError+ ( 'TL.Text "Schema for attribute set does not declare a field named " 'TL.:<>: 'TL.ShowType s 'TL.:<>: 'TL.Text "."+ 'TL.:$$: 'TL.Text " Known attributes are " 'TL.:<>: 'TL.ShowType all+ )++-- | Like 'Proxy', but with an 'IsLabel' instance. For use with '(^#)'+data AttrLabel a = AttrLabel++instance (s ~ t) => IsLabel s (AttrLabel t) where+ fromLabel = AttrLabel++infixl 9 #.++infixl 9 >>.++type MonadEval m = (MonadIO m, MonadReader (Ptr EvalState) m)++-- | A combination of '>>=' and '#.'.+(>>.) :: (KnownSymbol s, AttrType as s ~ b, MonadEval m) => m (PSObject (Attrs' as w)) -> AttrLabel s -> m (PSObject b)+mas >>. p = mas >>= \as -> as #. p++-- | Attribute selector. @a #. #b@ is @a.b@ in Nix. Operates on attributes that are required (@_.@) in the schema, throwing an error if necessary.+(#.) :: (KnownSymbol s, AttrType as s ~ b, MonadEval m) => PSObject (Attrs' as w) -> AttrLabel s -> m (PSObject b)+as #. p = do+ evalState <- ask+ let name = T.pack (symbolVal p)+ v <- check as+ liftIO (getAttr evalState v (encodeUtf8 name)) >>= \case+ Nothing -> throwIO $ MissingAttribute (provenance as) name+ Just b -> pure PSObject {value = b, provenance = Attribute (provenance as) name}++-- | A combination of '>>=' and '#?'.+(>>?) :: (KnownSymbol s, OptionalAttrType as s ~ b, MonadEval m) => m (PSObject (Attrs' as w)) -> AttrLabel s -> m (Maybe (PSObject b))+mas >>? p = mas >>= \as -> as #? p++-- | Attribute selector. @a #? #b@ is @a.b@ in Nix, but handles the missing case without exception. Operates on attributes that are optional (@_?@) in the schema, throwing an error if necessary.+(#?) :: (KnownSymbol s, OptionalAttrType as s ~ b, MonadEval m) => PSObject (Attrs' as w) -> AttrLabel s -> m (Maybe (PSObject b))+as #? p = do+ evalState <- ask+ let name = T.pack (symbolVal p)+ v <- check as+ liftIO (getAttr evalState v (encodeUtf8 name))+ <&> fmap (\b -> PSObject {value = b, provenance = Attribute (provenance as) name})++-- | Retrieve an optional attribute but throw if it's missing.+--+-- It provides a decent error message with attrset provenance, but can't provide+-- extra context like you can when manually handling the @a '#?' b@ 'Nothing' case.+(#?!) :: (KnownSymbol s, OptionalAttrType as s ~ b, MonadEval m) => PSObject (Attrs' as w) -> AttrLabel s -> m (PSObject b)+as #?! p = do+ as #? p >>= \case+ Nothing -> throwIO $ MissingAttribute (provenance as) (T.pack (symbolVal p))+ Just x -> pure x++lookupDictBS :: MonadEval m => ByteString -> PSObject (Attrs' as w) -> m (Maybe (PSObject w))+lookupDictBS name as = do+ evalState <- ask+ v <- check as+ liftIO (getAttr evalState v name)+ <&> fmap (\b -> PSObject {value = b, provenance = Attribute (provenance as) (decodeUtf8With lenientDecode name)})++lookupDict :: MonadEval m => Text -> PSObject (Attrs' as w) -> m (Maybe (PSObject w))+lookupDict name as = do+ evalState <- ask+ v <- check as+ liftIO (getAttr evalState v (encodeUtf8 name))+ <&> fmap (\b -> PSObject {value = b, provenance = Attribute (provenance as) name})++-- | Like '#?!'. Throws an acceptable but not great error message.+requireDictBS :: MonadEval m => ByteString -> PSObject (Attrs' as w) -> m (PSObject w)+requireDictBS name as = do+ lookupDictBS name as >>= \case+ Nothing -> throwIO $ MissingAttribute (provenance as) (decodeUtf8With lenientDecode name)+ Just r -> pure r++-- | Like '#?!'. Throws an acceptable but not great error message.+requireDict :: MonadEval m => Text -> PSObject (Attrs' as w) -> m (PSObject w)+requireDict name as = do+ lookupDict name as >>= \case+ Nothing -> throwIO $ MissingAttribute (provenance as) name+ Just r -> pure r++dictionaryToMap :: MonadEval m => PSObject (Dictionary w) -> m (Map ByteString (PSObject w))+dictionaryToMap dict = do+ (liftIO . Expr.getAttrs =<< check dict)+ <&> M.mapWithKey+ ( \name b ->+ PSObject {value = b, provenance = Attribute (provenance dict) (decodeUtf8With lenientDecode name)}+ )++type family NixTypeForSchema s where+ NixTypeForSchema (Attrs' _ _) = NixAttrs+ NixTypeForSchema (_ ->. _) = NixFunction+ NixTypeForSchema NixString = NixString+ NixTypeForSchema StringWithoutContext = NixString+ NixTypeForSchema NixPath = NixPath+ NixTypeForSchema Bool = Bool+ NixTypeForSchema Int64 = Int64++class PossibleTypesForSchema s where+ typesForSchema :: Proxy s -> [RawValueType]+ default typesForSchema :: HasRawValueType (NixTypeForSchema s) => Proxy s -> [RawValueType]+ typesForSchema _ = [getRawValueType (Proxy @(NixTypeForSchema s))]++instance PossibleTypesForSchema (Attrs' as w)++instance PossibleTypesForSchema (a ->. b)++instance PossibleTypesForSchema NixString++instance PossibleTypesForSchema NixPath++instance PossibleTypesForSchema Bool++instance PossibleTypesForSchema Int64++instance+ (PossibleTypesForSchema a, PossibleTypesForSchema b) =>+ PossibleTypesForSchema (a |. b)+ where+ typesForSchema _ = typesForSchema (Proxy @a) <> typesForSchema (Proxy @b)++-- | Force and check type, then continue without backtracking+(|!) ::+ forall a b c m.+ ( CheckType (NixTypeForSchema a),+ MonadIO m,+ MonadEval m,+ PossibleTypesForSchema a,+ PossibleTypesForSchema b+ ) =>+ (PSObject a -> m c) ->+ (PSObject b -> m c) ->+ PSObject (a |. b) ->+ m c+f |! g = \ab -> do+ evalState <- ask+ t <- liftIO $ checkType @(NixTypeForSchema a) evalState (value ab)+ rawType <- liftIO $ rawValueType (value ab)+ let c = canonicalRawType rawType+ -- This call makes it O(n*n) because of the nested |! calls, but n is small.+ ts = typesForSchema (Proxy @(a |. b))+ when (c `notElem` ts) do+ throwIO $ TypeError (provenance ab) c ts+ case t of+ Just _abChecked -> f (ab {value = value ab})+ Nothing -> g (ab {value = value ab})++englishOr :: [Text] -> Text+englishOr [] = "impossible"+englishOr [a] = a+englishOr [y, z] = y <> " or " <> z+englishOr (a : as) = a <> ", " <> englishOr as++-- | Optional application.+($?) :: (MonadEval m, PossibleTypesForSchema a, PossibleTypesForSchema b) => PSObject (a ->? b) -> PSObject a -> m (PSObject b)+x $? a =+ pure x >>$? pure a++-- | Optional application. Like '$?' but takes care of monadic binding as a convenience.+(>>$?) :: (MonadEval m, PossibleTypesForSchema a, PossibleTypesForSchema b) => m (PSObject (a ->? b)) -> m (PSObject a) -> m (PSObject b)+x >>$? a =+ ( (\f -> a >>= (f .$))+ |! pure+ )+ =<< x++-- | Application. Like '$.' but takes care of monadic binding as a convenience.+(>>$.) :: (MonadEval m, PossibleTypesForSchema a, PossibleTypesForSchema b) => m (PSObject (a ->. b)) -> m (PSObject a) -> m (PSObject b)+f >>$. a = do+ f' <- f+ a' <- a+ f' .$ a'++-- | Parses an expression from string+exprWithBasePath ::+ forall schema m.+ (MonadEval m) =>+ -- | Expression text in the Nix language.+ Text ->+ -- | Base path for relative path references in the expression text.+ FilePath ->+ -- | A schema that the expression should satisfy.+ Proxy schema ->+ m (PSObject schema)+exprWithBasePath expr = exprWithBasePathBS (encodeUtf8 expr)++-- | Parses an expression from string+exprWithBasePathBS ::+ forall schema m.+ (MonadEval m) =>+ -- | Expression text in the Nix language.+ ByteString ->+ -- | Base path for relative path references in the expression text.+ FilePath ->+ -- | A schema that the expression should satisfy.+ Proxy schema ->+ m (PSObject schema)+exprWithBasePathBS expr path _ = do+ evalState <- ask+ v <- liftIO (valueFromExpressionString evalState expr (encodeUtf8 (toS path)))+ pure $ PSObject {provenance = Other "internal expression", value = v}++-- | Ignores string context.+getByteString_ ::+ (MonadEval m) =>+ PSObject NixString ->+ m ByteString+getByteString_ s = do+ check s >>= liftIO . Expr.getStringIgnoreContext++-- | Ignores string context.+getText_ ::+ (MonadEval m) =>+ PSObject NixString ->+ m Text+getText_ = validateE getByteString_ decodeUtf8' InvalidText++validate :: Monad m => (PSObject s -> m a) -> (Provenance -> a -> m b) -> PSObject s -> m b+validate basicParse validator o = do+ a <- basicParse o+ validator (provenance o) a++validateE :: MonadIO m => (PSObject s -> m a) -> (a -> Either e b) -> (Provenance -> e -> NixException) -> PSObject s -> m b+validateE basicParse validator thrower =+ validate basicParse \prov a ->+ case validator a of+ (Left e) -> throwIO (thrower prov e)+ (Right b) -> pure b++-- | Force a value and check against schema.+check ::+ forall schema m.+ ( CheckType (NixTypeForSchema schema),+ HasRawValueType (NixTypeForSchema schema),+ MonadEval m+ ) =>+ PSObject schema ->+ m (Value (NixTypeForSchema schema))+check pv = do+ evalState <- ask+ liftIO do+ checkType evalState (value pv) >>= \case+ Nothing -> do+ t <- rawValueType (value pv)+ throwIO $ TypeError (provenance pv) t [getRawValueType (Proxy @(NixTypeForSchema schema))]+ Just x -> pure x++-- TODO make this actually schema-based+toPSObject ::+ (MonadEval m, Expr.ToRawValue a) =>+ a ->+ m (PSObject (Expr.NixTypeFor a))+toPSObject a = do+ evalState <- ask+ v <- liftIO (toRawValue evalState a)+ pure (PSObject {provenance = Data, value = v})++uncheckedCast :: forall (a :: Type) (b :: Type). PSObject a -> PSObject b+uncheckedCast = coerce++-- | Schema-based parsing type class that constrains neither types nor schemas.+class FromPSObject schema a where+ -- | Parse an object assumed to be in schema @schema@ into a value of type @a@+ -- or throw a 'NixException'.+ fromPSObject :: MonadEval m => PSObject schema -> m a++instance FromPSObject StringWithoutContext ByteString where+ fromPSObject o = do+ v <- check o+ liftIO do+ c <- hasContext v+ when c do+ throwIO $ StringContextNotAllowed (provenance o)+ liftIO $ getStringIgnoreContext v++instance FromPSObject StringWithoutContext Text where+ fromPSObject = validateE fromPSObject decodeUtf8' InvalidText++instance FromPSObject StringWithoutContext [Char] where+ fromPSObject = fmap T.unpack . fromPSObject++instance FromPSObject Bool Bool where+ fromPSObject o = do+ v <- check o+ liftIO (Expr.getBool v)++basicAttrsWithProvenance :: Value NixAttrs -> Provenance -> PSObject (Attrs '[])+basicAttrsWithProvenance attrs p = PSObject {value = rtValue attrs, provenance = p}
src/Hercules/CNix/Expr/Typed.hs view
@@ -52,9 +52,12 @@ -- | Runtime-Typed Value. This implies that it has been forced, -- because otherwise the type would not be known.+--+-- This is distinct from Nix, which calls its objects @Value@ regardless if+-- they're thunks. newtype Value a = Value {rtValue :: RawValue} -data NixInt+type NixInt = Int64 data NixFloat @@ -133,3 +136,74 @@ [C.exp| const char *{ strdup($(Value *v)->string.s) }|]++hasContext :: Value NixString -> IO Bool+hasContext (Value (RawValue v)) =+ (0 /=)+ <$> [C.exp| int { $(Value *v)->string.context ? 1 : 0 }|]++class CheckType a where+ checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value a))++instance CheckType Int64 where+ checkType es v = match' es v <&> \case IsInt x -> pure x; _ -> Nothing++instance CheckType Bool where+ checkType es v = match' es v <&> \case IsBool x -> pure x; _ -> Nothing++instance CheckType NixString where+ checkType es v = match' es v <&> \case IsString x -> pure x; _ -> Nothing++instance CheckType NixPath where+ checkType es v = match' es v <&> \case IsPath x -> pure x; _ -> Nothing++instance CheckType () where+ checkType es v = match' es v <&> \case IsNull x -> pure x; _ -> Nothing++instance CheckType NixAttrs where+ checkType es v = match' es v <&> \case IsAttrs x -> pure x; _ -> Nothing++instance CheckType NixList where+ checkType es v = match' es v <&> \case IsList x -> pure x; _ -> Nothing++instance CheckType NixFunction where+ checkType es v = match' es v <&> \case IsFunction f -> pure f; _ -> Nothing++instance CheckType NixExternal where+ checkType es v = match' es v <&> \case IsExternal x -> pure x; _ -> Nothing++instance CheckType NixFloat where+ checkType es v = match' es v <&> \case IsFloat f -> pure f; _ -> Nothing++assertType :: (HasCallStack, MonadIO m, CheckType t) => Ptr EvalState -> RawValue -> m (Value t)+assertType es v = do+ liftIO (checkType es v) >>= \case+ Nothing -> withFrozenCallStack (panic "Unexpected type")+ Just x -> pure x++class HasRawValueType s where+ getRawValueType :: Proxy s -> RawValueType++instance HasRawValueType NixString where+ getRawValueType _ = String++instance HasRawValueType Int64 where+ getRawValueType _ = Int++instance HasRawValueType Bool where+ getRawValueType _ = Bool++instance HasRawValueType NixFloat where+ getRawValueType _ = Float++instance HasRawValueType NixPath where+ getRawValueType _ = Path++instance HasRawValueType NixAttrs where+ getRawValueType _ = Attrs++instance HasRawValueType NixFunction where+ getRawValueType _ = Lambda++instance HasRawValueType NixList where+ getRawValueType _ = List
+ test/Hercules/CNix/Expr/SchemaSpec.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}++module Hercules.CNix.Expr.SchemaSpec where++import Hercules.CNix.Expr (EvalState, NixPath, NixString)+import qualified Hercules.CNix.Expr as Expr+import Hercules.CNix.Expr.Raw (RawValueType (Attrs, Bool, Lambda, Null, String))+import Hercules.CNix.Expr.Schema+import Protolude hiding (TypeError, check, evalState)+import SingleState (evalState)+import Test.Hspec++runES :: ReaderT (Ptr EvalState) m a -> m a+runES m = runReaderT m evalState++displaying :: Exception e => [Char] -> e -> Bool+displaying text e = displayException e == text++spec :: Spec+spec = do+ describe "exprWithBasePath" $ do+ it "can get a byte string from an expression" \() -> do+ s <- runES do+ e <- exprWithBasePath "''hi there''" "/" (Proxy @NixString)+ getByteString_ e+ s `shouldBe` "hi there"++ describe "getText_" $ do+ it "can get text from an expression" \() -> do+ s <- runES do+ e <- exprWithBasePath "''hi there''" "/" (Proxy @NixString)+ getText_ e+ s `shouldBe` "hi there"++ it "can report invalid utf8 with provenance" \() -> do+ ( runES do+ e <- exprWithBasePathBS "''hi\xffthere''" "/" (Proxy @NixString)+ getText_ e+ )+ `shouldThrow` \case+ InvalidText p _e -> p == Other "internal expression"+ _ -> False++ describe "check" $ do+ it "reports type errors with provenance" \() -> do+ ( runES do+ e <- exprWithBasePath "true" "/" (Proxy @NixString)+ check e >>= liftIO . Expr.getStringIgnoreContext+ )+ `shouldThrow` (== TypeError (Other "internal expression") Bool [String])++ it "reports type errors with provenance in human readable format" \_ -> do+ displayException (TypeError (Other "internal expression") Bool [String])+ `shouldBe` "Expecting a value of type String, but got type Bool.\n in internal expression"++ describe "#. and >>." do+ it "report errors with attribute path in provenance" \() -> do+ ( runES do+ e <-+ exprWithBasePath+ "{ a.b.c = true; }"+ "/"+ ( Proxy+ @( Attrs+ '[ "a" ::. NixString+ ]+ )+ )+ getByteString_ =<< e #. #a+ )+ `shouldThrow` (== TypeError (Attribute (Other "internal expression") "a") Attrs [String])++ it "report errors with attribute path in provenance" \() -> do+ ( runES do+ e <-+ exprWithBasePath+ "{ a.b.c = true; }"+ "/"+ ( Proxy+ @( Attrs+ '[ "a"+ ::. Attrs+ '[ "b"+ ::. Attrs '["c" ::. NixString]+ ]+ ]+ )+ )+ getByteString_ =<< e #. #a >>. #b >>. #c+ )+ `shouldThrow` (== TypeError (Attribute (Other "internal expression") "a" `Attribute` "b" `Attribute` "c") Bool [String])++ it "is not strict in the schema" \() -> do+ r <- runES do+ e <-+ exprWithBasePath+ @( Attrs+ '[ "doesNotExistButNoProblem" ::. NixPath,+ "a" ::. NixString+ ]+ )+ "{ a = ''hello there''; }"+ "/"+ Proxy++ getByteString_ =<< e #. #a+ r `shouldBe` "hello there"++ let schema =+ Proxy+ @( Attrs+ '[ "optionallyFunction" ::. (NixString ->? NixString),+ "optionalAttr" ::? NixString+ ]+ )++ describe "$? and >>$?" do+ it "can ignore an optional function" $ \_ -> do+ r <- runES do+ e <-+ exprWithBasePath+ "{ optionallyFunction = ''simple as that''; }"+ "/"+ schema+ e #. #optionallyFunction >>$? panic "not needed" >>= getByteString_+ r `shouldBe` "simple as that"++ it "can call an optional function" $ \_ -> do+ r <- runES do+ e <-+ exprWithBasePath+ "{ optionallyFunction = what: ''simple as ${what}''; }"+ "/"+ schema+ e #. #optionallyFunction >>$? toPSObject ("a b c" :: Text) >>= getByteString_+ r `shouldBe` "simple as a b c"++ it "can throw an error message with complete info" $ \_ -> do+ -- maybe a new class that returns the allowable types for any schema?+ ( runES do+ e <-+ exprWithBasePath+ "{ optionallyFunction = true; }"+ "/"+ schema+ e #. #optionallyFunction >>$? toPSObject ("a b c" :: Text) >>= getByteString_+ )+ `shouldThrow` (== TypeError (Attribute (Other "internal expression") "optionallyFunction") Bool [Lambda, String])++ describe ".#? and >>?" do+ it "can return Nothing" \_ -> do+ r <- runES do+ e <-+ exprWithBasePath+ "{ }"+ "/"+ schema+ e #? #optionalAttr >>= traverse getByteString_+ r `shouldBe` Nothing++ it "can return Just" \_ -> do+ r <- runES do+ e <-+ exprWithBasePath+ "{ optionalAttr = ''nice''; }"+ "/"+ schema+ e #? #optionalAttr >>= traverse getByteString_+ r `shouldBe` Just "nice"++ describe "fromPSObject" do+ describe "@Bool" do+ describe "@Bool" do+ it "can return true" do+ r <- runES do+ e <- exprWithBasePath "true" "/" (Proxy @Bool)+ fromPSObject e+ r `shouldBe` True+ it "can return false" do+ r <- runES do+ e <- exprWithBasePath "false" "/" (Proxy @Bool)+ fromPSObject e+ r `shouldBe` False+ it "can throw a type error" do+ ( runES do+ e <- exprWithBasePath "null" "/" (Proxy @Bool)+ fromPSObject @_ @Bool e+ )+ `shouldThrow` (== TypeError (Other "internal expression") Null [Bool])+ it "can throw a type error with provenance" do+ ( runES do+ e <- exprWithBasePath "{ a = null; }" "/" (Proxy @(Attrs '["a" ::. Bool]))+ fromPSObject @_ @Bool =<< e #. #a+ )+ `shouldThrow` (== TypeError (Other "internal expression" `Attribute` "a") Null [Bool])++ describe "@StringWithoutContext" do+ describe "@ByteString" do+ it "can return the string" do+ r <- runES do+ e <- exprWithBasePath "''hi''" "/" (Proxy @StringWithoutContext)+ fromPSObject e+ r `shouldBe` ("hi" :: ByteString)+ describe "@ByteString" do+ it "can fail because of context" do+ ( runES do+ e <- exprWithBasePath "''hi ${derivation {name = ''pkg''; builder = ''foo''; system = ''x86_64-linux'';}}''" "/" (Proxy @StringWithoutContext)+ fromPSObject @_ @ByteString e+ )+ `shouldThrow` (== StringContextNotAllowed (Other "internal expression"))+ describe "@Text" do+ it "can return the string" do+ r <- runES do+ e <- exprWithBasePath "''hi''" "/" (Proxy @StringWithoutContext)+ fromPSObject e+ r `shouldBe` ("hi" :: Text)+ describe "@Text" do+ it "can fail because of context" do+ ( runES do+ e <- exprWithBasePath "''hi ${derivation {name = ''pkg''; builder = ''foo''; system = ''x86_64-linux'';}}''" "/" (Proxy @StringWithoutContext)+ fromPSObject @_ @Text e+ )+ `shouldThrow` (== StringContextNotAllowed (Other "internal expression"))+ describe "@Text" do+ it "can fail because of utf8" do+ ( runES do+ e <- exprWithBasePathBS "''hi\xffthere''" "/" (Proxy @StringWithoutContext)+ fromPSObject @_ @Text e+ )+ `shouldThrow` \case+ InvalidText p _e -> p == Other "internal expression"+ _ -> False
+ test/Hercules/CNix/ExprSpec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CNix.ExprSpec (spec) where++import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Hercules.CNix.Expr+import qualified Hercules.CNix.Expr.Typed as Typed+import Protolude hiding (evalState)+import qualified SingleState+import Test.Hspec++setup :: (Ptr EvalState -> IO a) -> IO a+setup f = f SingleState.evalState++-- withTempStore \store -> withEvalState store f++checkWithNix :: Ptr EvalState -> ByteString -> RawValue -> IO ()+checkWithNix evalState s a = do+ f <- valueFromExpressionString evalState s "/home/someuser/src/dummy-project"+ r <- apply f a+ match evalState r >>= \case+ Right (IsBool b) -> do+ bl <- getBool b+ if bl+ then pass+ else panic $ "Value did not satisfy <<" <> decodeUtf8With lenientDecode s <> ">>"+ Right _ -> panic "wrong type"+ Left e -> throwIO e++spec :: Spec+spec = do+ describe "getLocalFlake" $+ it "gets a trivial flake" $ do+ setup \evalState -> do+ v <- getLocalFlake evalState "test/data/simple-flake" >>= assertType evalState+ lib <- getAttr evalState v "lib"+ libAttrs <-+ for lib (Typed.match evalState) >>= \case+ Just (Right (Typed.IsAttrs as)) -> pure as+ Just (Left e) -> panic $ "lib error " <> show e+ Just _ -> panic "lib must be attrs"+ Nothing -> panic "no lib???"+ greeting <- getAttr evalState libAttrs "greeting"+ greetingBytes <-+ for greeting (Typed.match evalState) >>= \case+ Just (Right (Typed.IsString s)) -> getStringIgnoreContext s+ Just (Left e) -> panic $ "lib.greeting error " <> show e+ Just _ -> panic "lib.greeting must be string"+ Nothing -> panic "no lib.greeting???"+ greetingBytes `shouldBe` "hello flake"++ describe "valueFromExpressionString" do+ it "parses true" do+ setup \evalState -> do+ v <- valueFromExpressionString evalState "true" "/"+ match evalState v >>= \case+ Right (IsBool b) -> do+ r <- getBool b+ r `shouldBe` True+ Right _ -> panic "wrong type"+ Left e -> throwIO e+ describe "toRawValue" do+ it "converts True" $ setup \evalState -> do+ a <- toRawValue evalState True+ a & checkWithNix evalState "a: a == true"+ it "converts False" $ setup \evalState -> do+ a <- toRawValue evalState False+ a & checkWithNix evalState "a: a == false"+ it "converts 0" $ setup \evalState -> do+ a <- toRawValue evalState (0 :: Int64)+ a & checkWithNix evalState "a: a == 0"+ it "converts 1" $ setup \evalState -> do+ a <- toRawValue evalState (1 :: Int64)+ a & checkWithNix evalState "a: a == 1"+ it "converts 42" $ setup \evalState -> do+ a <- toRawValue evalState (42 :: Int64)+ a & checkWithNix evalState "a: a == 42"+ -- Oddly, Nix does not support -9223372036854775808, which would be the+ -- most negative int64+ it "converts -9223372036854775807" $ setup \evalState -> do+ a <- toRawValue evalState (-9223372036854775807 :: Int64)+ a & checkWithNix evalState "a: a == (-9223372036854775807)"+ it "converts 9223372036854775807" $ setup \evalState -> do+ a <- toRawValue evalState (9223372036854775807 :: Int64)+ a & checkWithNix evalState "a: a == 9223372036854775807"+ it "converts Map.empty" $ setup \evalState -> do+ a <- toRawValue evalState (mempty :: Map ByteString Int64)+ a & checkWithNix evalState "a: a == {}"+ it "converts Map.singleton" $ setup \evalState -> do+ a <- toRawValue evalState (M.singleton "foo" 1 :: Map ByteString Int64)+ a & checkWithNix evalState "a: a == { foo = 1; }"+ it "converts empty bytes" $ setup \evalState -> do+ a <- toRawValue evalState ("" :: ByteString)+ a & checkWithNix evalState "a: a == ''''"+ it "converts empty text" $ setup \evalState -> do+ a <- toRawValue evalState ("" :: Text)+ a & checkWithNix evalState "a: a == ''''"+ it "converts bytes" $ setup \evalState -> do+ a <- toRawValue evalState ("hi" :: ByteString)+ a & checkWithNix evalState "a: a == ''hi''"+ it "converts text" $ setup \evalState -> do+ a <- toRawValue evalState ("hi" :: Text)+ a & checkWithNix evalState "a: a == ''hi''"+ it "converts empty list" $ setup \evalState -> do+ a <- toRawValue evalState ([] :: [Int])+ a & checkWithNix evalState "a: a == []"+ it "converts singleton list" $ setup \evalState -> do+ a <- toRawValue evalState ["hi" :: Text]+ a & checkWithNix evalState "a: a == [''hi'']"+ it "converts list" $ setup \evalState -> do+ a <- toRawValue evalState =<< sequenceA [toRawValue evalState ("hi" :: Text), toRawValue evalState True, toRawValue evalState (1 :: Int), toRawValue evalState (mempty :: Map ByteString Int)]+ a & checkWithNix evalState "a: a == [''hi'' true 1 {}]"+ it "converts json" $ setup \evalState -> do+ jsonExample <- BS.readFile "test/data/sample.json"+ jsonValue <- case A.eitherDecode (BL.fromStrict jsonExample) of+ Left e -> panic (toS e)+ Right r -> pure (r :: A.Value)+ a <- toRawValue evalState jsonValue+ a & checkWithNix evalState ("a: a == builtins.fromJSON ''" <> jsonExample <> "''")
+ test/Hercules/CNix/Store/TestUtil.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CNix.Store.TestUtil where++import Hercules.CNix.Store (Store, withStoreFromURI)+import Protolude+import System.IO.Temp (withSystemTempDirectory)++withTempStore :: (Store -> IO a) -> IO a+withTempStore f =+ withSystemTempDirectory "cnix-test-store" \d ->+ withStoreFromURI (toS d) f
+ test/SingleState.hs view
@@ -0,0 +1,23 @@+-- | Work around Nix regression causing corruption when EvalState is destroyed and a new one created.+module SingleState (withGlobalState, evalState) where++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Hercules.CNix.Expr+import Hercules.CNix.Store.TestUtil (withTempStore)+import Protolude hiding (evalState, state)+import System.IO.Unsafe (unsafePerformIO)++theEvalState :: IORef (Ptr EvalState)+theEvalState = unsafePerformIO $ newIORef (panic "Store not initialized yet")+{-# NOINLINE theEvalState #-}++-- | Work around Nix regression causing corruption when EvalState is destroyed and a new one created.+withGlobalState :: IO () -> IO ()+withGlobalState io = withTempStore $ \store -> withEvalState store $ \state -> do+ writeIORef theEvalState state+ io++-- | Work around Nix regression causing corruption when EvalState is destroyed and a new one created.+evalState :: Ptr EvalState+evalState = unsafePerformIO $ readIORef theEvalState+{-# NOINLINE evalState #-}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/TestMain.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE BlockArguments #-}++import Hercules.CNix.Expr (init)+import Protolude+import SingleState+import qualified Spec+import System.Mem (performMajorGC)+import Test.Hspec.Runner++main :: IO ()+main = do+ init+ withGlobalState $ do+ -- for_ [(1 :: Int)..1000] \_ -> do+ hspecWith config {configConcurrentJobs = Just 1} Spec.spec+ -- `catch` (\e -> putErrText $ "Caught " <> show (e :: SomeException))+ putErrText "Performing Haskell GC..."+ performMajorGC+ putErrText "Haskell GC done..."+ where+ config =+ defaultConfig+ { configColorMode = ColorAlways+ }