diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,129 +0,0 @@ - -# Changelog - -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.12.0...master#files_bucket) Progress - - -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.11.1...0.12.0#files_bucket) 0.12.0 (2021-01-05) - -* *Disclaimer*: Current `derivationStrict` primOp implementation and so every evaluation of a derivation into a store path currently relies on the `hnix-store-remote`, which for those operations relies on the running `nix-daemon`, and so operations use/produce effects into the `/nix/store`. Be cautious - it is effectful. - -* Introduction: - * New module `Nix.Effects.Derivation`. - * Operations on derivations: - * old got principled implementations. - * also new operations got introduced. - * Implementation of the `derivationStrict` primOp. - -* Breaking: - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: **class** `MonadStore` got principled implementation. - * `addPath'` got principled into `addToStore`. - * `toFile_` got principled into `addTextToStore'`. - * For help & easy migration you may use `addPath` & `toFile_` `addTextToStore` standalone functions in the module. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects.Basic`: `defaultDerivationStrict` got reimplemented & moved into `Nix.Effects.Derivation`. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Standard`: instance for `MonadStore (Fix1T t m)` got principled accoding to class `MonadStore` changes. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Fresh.Basic`: instance for `MonadStore (StdIdT m)` got principled. - -* Additional: - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) **New module `Nix.Effects.Derivation`**: [HNix(0.12.0):Nix.Effects.Derivation documentation](https://hackage.haskell.org/package/hnix-0.12.0/docs/Nix-Effects-Derivation.html). - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/9bcfbbe88ff0bd8d803296193ee1d8603dc5289e) `Nix.Convert`: Principled `NVPath -> NixString` coercion. - * In a form of principled `instance FromValue NixString m (NValue' t f m (NValue t f m))`. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/a8e6d28fdb98a1c34f425c8395338fdabe96becc) `Nix.String`: Allow custom computations inside string contexts. - * By providing `runWithStringContext{T,}'` methods into the API. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/e45f7632c51a9657f6e8d54c39fd4d21c466d85f) Includded support for new `base16-bytestring`, which advertices 2x-4x speed increase of its operations. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: `addPath` & `toFile_` standalone functions got principled implementation through the internal use of the new `MonadStore` type class implementation. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: added `addTextToStore`, `parseStoreResult` implementations. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: added type synonyms `{RecursiveFlag, RepairFlag, StorePathName, FilePathFilter, StorePathSet}`. - * [(link)](https://github.com/haskell-nix/hnix/pull/760) `Nix.Exec`: Fixed the rendering of internal `Frames`. - * Which is an internal mechanism of a project to passing around messages with their context, still to be used internally). - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `HNix / Nix`: The library now also uses `hnix-store-remote`. - * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/06b0fca9fd607eb2e995f003424e797a41ffa5b7) `cabal.project`: project uses `cryptohash-sha512` override, the `hnix-store-core` requires it from `hnix` and uses that override also. [Detailed info](https://github.com/haskell-hvr/cryptohash-sha512/pull/5#issuecomment-752796913). We promise to attend to this issue, probably by migrating to `cryptonite` in the nearest releases. - -Future note: The HNix is a big project. During the initial development and currently the API for simplicity exposes allmost all functions, types, etc. Big open API means a big effort to create/maintain a quite noisy changelog and you parsing through it, and also creates a frequent requirements to mark releases as major and bother you due to some type changes in some parts that may not be used or applicable to be public API. - -This year the most gracious API clean-up would happen, we would check and keep open what Hackage projects are using from the API, and the other parts would be open on the request by a way of rapid minor releases. That clean-up is also a work toward splitting the project into several packages some time in the future (split would be into something like Expressions, Evaluation, Executable, Extra), which migration also would be done most thoughful and graceful as possible, with as much easiness and automation provided for migration downstream as possible. If all goes as planned - all downstream would need to do is to get and run our script that would migrate our old map of module imports to new ones, and maybe manually add those newly formed packages into `.cabal` description. - -If it is possible, please, try to switch & use the higher-level API functions where it is applicable. Thank you. - - -### [(diff)](https://github.com/haskell-nix/hnix/compare/0.11.0...0.11.1#files_bucket) 0.11.1 (2020-12-09) - -* Additional: - * [(link)](https://github.com/haskell-nix/hnix/commit/d32a6fbaf3df1c8879d1b19a18f21c031a73e56c) `Nix.Builtins`: `isString` fixed - It used to return `True` for values coercible to string like derivations and paths. It only accepts string values now. - * [(link)](https://github.com/haskell-nix/hnix/commit/53b4db2525a8f074d8c262fa7b66ce97e5820890) `Nix.Builtins`: `substring` fixed - Negative lengths used to capture an empty string. Now they capture the whole rmeainder of the string. - * [(link)](https://github.com/haskell-nix/hnix/commit/dc31c5e64f8c7aaaea14cac0134bd47544533e67) `Nix.Effects`: `pathExists` fixed - Now also works with directories. - * [(link)](https://github.com/haskell-nix/hnix/commit/e2ad934492eeac9881527610e4a1c1cf31ea1115) `Nix.Parser`: `->` is now properly right-associative (was non-associative). - * [(link)](https://github.com/haskell-nix/hnix/commit/50baea5e1e482be3c4fcc13c9a45b1083243f681) `Nix.Parser`: Nix `assert` parser (`nixAssert` function) now accepts top-level Nix format also (which means also accepts all kinds of statements), before that it accepted only regular Nix expressions. - * [(link)](https://github.com/haskell-nix/hnix/commit/59698de7185dfae508e5ccea4377a82023c4a0d5) `Nix.Render`: `renderLocation` now also shows/handles location of errors in raw strings. - - -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.10.1...0.11.0#files_bucket) 0.11.0 (2020-11-02) - -* Breaking: - * [(link)](https://github.com/haskell-nix/hnix/pull/740) Deleted incorrect `instance Generic1 NKeyName` from `module Nix.Expr.Types`. - * [(link)](https://github.com/haskell-nix/hnix/pull/739) Parentheses now are properly included in the location annotation for Nix expressions, change of `nixParens` in `module Nix.Parser` essentially results in the change of all module `nix*` function results, essentially making results of the whole module more proper. - -* Additional: - * [(link)](https://github.com/haskell-nix/hnix/pull/741) Fix QQ Text lifting error: work around of [GHC#12596 "can't find interface-file declaration"](https://gitlab.haskell.org/ghc/ghc/-/issues/12596). - * [(link)](https://github.com/haskell-nix/hnix/pull/744) Fix comments inclusion into location annotations, by using pre-whitespace position for source end locations. - - -### [(diff)](https://github.com/haskell-nix/hnix/compare/0.10.0...0.10.1#files_bucket) 0.10.1 (2020-09-13) - -* Additional: - * [(link)](https://github.com/haskell-nix/hnix/pull/715) `{Binding, NExpr, NExprF, NKeyName}` gained `Ord1` instances. - * These instances were required by downstream projects to be able to use newer HNix. - * [(link)](https://github.com/haskell-nix/hnix/pull/712) CLI gained `--long-version` option for gathering a detailed debug information. - * Currently, reports Git commit and its date. - * [(link)](https://github.com/haskell-nix/hnix/issues/718) Currently does not work in case of use of the `nix-build`, in which case simply returns `UNKNOWN` placeholder. - - -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.9.1...0.10.0#files_bucket) 0.10.0 (2020-09-12) - -* Breaking: - * [(link)](https://github.com/haskell-nix/hnix/pull/699) Removed `NExpr` `{FromJSON, ToJSON}` instances. - * This also removed the JSON output feature for unevaluated expression trees. - -* Additional: - * [(link)](https://github.com/haskell-nix/hnix/pull/703) CLI gained `--version` option. - * Dependencies: - * [(link)](https://github.com/haskell-nix/hnix/pull/686) Requires last major `data-fix` (`0.3`). - * [(link)](https://github.com/haskell-nix/hnix/pull/679) Requires last major `prettyprinter` (`1.7`). - - -### [(diff)](https://github.com/haskell-nix/hnix/compare/0.9.0...0.9.1#files_bucket) 0.9.1 (2020-07-13) - -* Additional: - * REPL: - * Better tab completion. - * Accepting multi-line input. - * Support for passing evaluated expression result of `hnix --eval -E`. - to REPL as an `input` variable. - * Support for loading `.hnixrc` from the current directory. - * Reporting of `builtins.nixVersion` bumped from 2.0 to 2.3. - * Dependencies: - * Freed from: `{interpolate, contravariant, semigroups, generic-random, tasty-quickcheck}`. - * Requires last major `repline` (`0.4`). - - -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.8.0...0.9.0#files_bucket) 0.9.0 (2020-06-15) - -* Breaking: - * Removed instances due to migration to `haskeline 0.8`: - * `instance MonadException m => MonadException(StateT(HashMap FilePath NExprLoc) m)`. - * `instance MonadException m => MonadException(Fix1T StandardTF m)`. - * Dependencies: - * Requires last major `haskeline` (`0.8`). - -* Additional: - * Library: Official support for `GHC 8.4 - 8.10`. - * Executable complies only under `GHC 8.10`. - -* Changelog started. Previous release was `0.8.0`. - - ---- - -HNix uses [PVP Versioning][1]. - -[1]: https://pvp.haskell.org diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,309 @@ + +# ChangeLog + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.12.0...0.13.0#files_bucket) 0.13.0 (2021-05-10) + +* Breaking: + + * [(link)](https://github.com/haskell-nix/hnix/pull/859/files) [(link)](https://github.com/haskell-nix/hnix/pull/863/files) [(link)](https://github.com/haskell-nix/hnix/pull/866/files) `Nix.Thunk`: `class MonadThunk t m a | t -> m, t -> a`. Class was initially designed with Kleisli arrows (`v -> m a`) in mind, which where put to have the design open and inviting customization & integration. Those functional arguments are for custom implementation, so which in reality of the project were never used and HNax just "essentially" (simplifying, because `pure` was mixed with monadic binds to `f`) was passing `pure` into them (actually, `f <=< pure`). These Kliesli functors got arguments sorted properly and were moved to a `MonadThunkF` class and names gained `*F`. And `MonadThunk` now does only what is needed, for example `force` gets the thunk and computes it. All `MonadThunk{,F}` functions become with a classic Haskell arguments order, specialized, and got more straigh-forward to understand and use, and so now they tail recurse also. + + Now, for example, instead of `force t f` use it as `v <- force t` `f =<< force t`, or `f <=< force`. + + tl;dr: results: + + ```haskell + class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where + + thunkId :: t -> ThunkId m + + thunk :: m a -> m t + + queryM :: m a -> t -> m a + -- old became `queryMF` + + force :: t -> m a + -- old became `forceF` + + forceEff :: t -> m a + -- old became `forceEffF` + + further :: t -> m t + -- old became `furtherF` + + + -- | Class of Kleisli functors for easiness of customized implementation developlemnt. + class MonadThunkF t m a | t -> m, t -> a where + + queryMF :: (a -> m r) -> m r -> t -> m r + -- was :: t -> m r -> (a -> m r) -> m r + + forceF :: (a -> m r) -> t -> m r + -- was :: t -> (a -> m r) -> m r + + forceEffF :: (a -> m r) -> t -> m r + -- was :: t -> (a -> m r) -> m r + + furtherF :: (m a -> m a) -> t -> m t + -- was :: t -> (m a -> m a) -> m t + + ``` + + * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) [(link)](https://github.com/haskell-nix/hnix/pull/870/files) [(link)](https://github.com/haskell-nix/hnix/pull/871/files) [(link)](https://github.com/haskell-nix/hnix/pull/872/files) [(link)](https://github.com/haskell-nix/hnix/pull/873/files) `Nix.Value.Monad`: `class MonadValue v m`: instances became specialized, Kleisli versions unflipped the arguments of methods into a classical order and moved to the `class MonadValueF`. As a result, `demand` now gets optimized by GHC and also tail recurse. Please, use `f =<< demand t`, or just use `demandF`, while `demandF` in fact just `kleisli =<< demand t`. + + ```haskell + class MonadValue v m where + + demand :: v -> m v + -- old became `demandF` + + inform :: v -> m v + -- old became `informF` + + + class MonadValueF v m where + + demandF :: (v -> m r) -> v -> m r + -- was :: v -> (v -> m r) -> m r + + informF :: (m v -> m v) -> v -> m v + -- was :: v -> (m v -> m v) -> m v + ``` + + * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Normal`: `normalizeValue` removed first functional argument that was passing the function that did the thunk forcing. Now function provides the thunk forcing. Now to normalize simply use `normalizeValue v`. Old implementation now is `normalizeValueF`. + + * [(link)](https://github.com/haskell-nix/hnix/pull/859/commits/8e043bcbda13ea4fd66d3eefd6da690bb3923edd) `Nix.Value.Equal`: `valueEqM`: freed from `RankNTypes: forall t f m .`. + + * [(link)](https://github.com/haskell-nix/hnix/pull/802/commits/529095deaf6bc6b102fe5a3ac7baccfbb8852e49#) `Nix.Strings`: all `hacky*` functions replaced with lawful implemetations, because of that all functions become lawful - dropped the `principled` suffix from functions: + * `Nix.String`: + ```haskell + hackyGetStringNoContext -> + getStringNoContext + hackyStringIgnoreContext -> + stringIgnoreContext + hackyMakeNixStringWithoutContext -> + makeNixStringWithoutContext + + principledMempty -> mempty + principledStringMempty -> mempty + principledStringMConcat -> mconcat + principledStringMappend -> mappend + + principledGetContext -> + getContext + principledMakeNixString -> + makeNixString + principledIntercalateNixStrin -> + intercalateNixString + principledGetStringNoContext -> + getStringNoContext + principledStringIgnoreContext -> + stringIgnoreContext + principledMakeNixStringWithoutContext -> + makeNixStringWithoutContext + principledMakeNixStringWithSingletonContext -> + makeNixStringWithSingletonContext + principledModifyNixContents -> + modifyNixContents + ``` + + * [(link)](https://github.com/haskell-nix/hnix/pull/805/files): + * Data type: `MonadFix1T t m`: `Nix.Standard` -> `Nix.Utils.Fix1` + * Children found their parents: + + ```haskell + Binary NAtom :: Nix.Expr.Types -> Nix.Atoms + FromJSON NAtom :: Nix.Expr.Types -> Nix.Atoms + ToJSON NAtom :: Nix.Expr.Types -> Nix.Atoms + + Eq1 (NValueF p m) :: Nix.Value.Equal -> Nix.Value + + Eq1 (NValue' t f m a) :: Nix.Value.Equal -> Nix.Value + + HasCitations m v (NValue' t f m a) :: Nix.Pretty -> Nix.Cited + HasCitations m v (NValue t f m) :: Nix.Pretty -> Nix.Cited + + when + (package hashable >= 1.3.1) -- gained instance + $ Hashable1 NonEmpty:: Nix.Expr.Types -> Void -- please use upstreamed instance + + -- | Was upstreamed, released in `ref-tf >= 0.5`. + MonadAtomicRef (Fix1T t m) :: Nix.Standard -> Void + + MonadRef (Fix1T t m) :: Nix.Standard -> Nix.Utils.Fix1 + MonadEnv (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadExec (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadHttp (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadInstantiate (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadIntrospect (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadPaths (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadPutStr (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadStore (Fix1T t m) :: Nix.Standard -> Nix.Effects + MonadFile (Fix1T t m) :: Nix.Standard -> Nix.Render + + MonadEnv (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadExec (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadHttp (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadInstantiate (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadIntrospect (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadPaths (Fix1 t) :: Nix.Standard -> Nix.Effects + MonadPutStr (Fix1 t) :: Nix.Standard -> Nix.Effects + ``` + * [(link)](https://github.com/haskell-nix/hnix/pull/878/files) `Nix.Value`: `nvSet{,',P}`: got unflipped, now accept source position argument before the value. + + * [(link)](https://github.com/haskell-nix/hnix/pull/878/files) `Nix.Pretty`: `mkNixDoc`: got unflipped. + + * [(link)](https://github.com/haskell-nix/hnix/pull/886/commits/381b0e5df9cc620a25533ff1c84045a4ea37a833) `Nix.Value`: Data constructor for `NValue' t f m a` changed (`NValue -> NValue'`). + + * [(link)](https://github.com/haskell-nix/hnix/pull/884/files) `Nix.Parser`: `Parser`: Data type was equivalent to `Either`, so became a type synonim for `Either`. + + * [(link)](https://github.com/haskell-nix/hnix/pull/884/files) `Nix.Thunk.Basic`: `instance MonadThunk (NThunkF m v) m v`: `queryM`: implementation no longer blocks the thunk resource it only reads from. + + * [(link)](https://github.com/haskell-nix/hnix/pull/908/files): Migrated `(String -> Text)`: + * `Nix.Value`: `{NValueF, nvBuiltin{,'}, builtin{,2,3}, describeValue}` + * `Nix.Eval`: `MonadNixEval` + * `Nix.Render.Frame`: `render{Expr,Value}` + * `Nix.Type`: `TVar` + * `Nix.Thunk`: `ThunkLoop` + * `Nix.Exec`: `{nvBuiltinP, nixInstantiateExpr, exec}` + * `Nix.Effects`: + * `class`: + * `MonadExec: exec'` + * `MonadEnv: getEnvVar` + * `MonadInstantiate: instatiateExpr` + * `parseStoreResult` + * `Nix.Effects.Derivation`: `renderSymbolic` + * `Nix.Lint`: `{NTypeF, symerr}` + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/commit/7e6cd97bf3288cb584241611fdb25bf85d7e0ba7) `cabal.project`: freed from the `cryptohash-sha512` override, Hackage trustees made a revision. + * [(link)](https://github.com/haskell-nix/hnix/pull/824/commits/4422eb10959115f21045f39e302314a77df4b775) To be more approachable for user understanding, the thunk representation in outputs changed from `"" -> ""`. + * [(link)](https://github.com/haskell-nix/hnix/pull/925/commits/37e81c96996b07cbbdf9fa4bf380265e8c008482) The Nix evaluation cycle representation changed `"" -> ""`. + * [(link)](https://github.com/haskell-nix/hnix/commit/51a3ff9e0065d50e5c625738696526c4a232b0cf) `Nix.Expr.Types`: added hacky implementation of `liftTyped` for `instance Lift (Fix NExprF)`. + * [(link)](https://github.com/haskell-nix/hnix/commit/51a3ff9e0065d50e5c625738696526c4a232b0cf) `Nix.Builtins`: `derivation` primOp internal code always fully evaluated, so GHC now always ships only fully compiled version in the bytecode. + * [(link)](https://github.com/haskell-nix/hnix/pull/890): Project switched to prelude `relude`. + * A bunch of other stuff that is not user-facing. + + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.11.1...0.12.0#files_bucket) 0.12.0 (2021-01-05) + +* *Disclaimer*: Current `derivationStrict` primOp implementation and so every evaluation of a derivation into a store path currently relies on the `hnix-store-remote`, which for those operations relies on the running `nix-daemon`, and so operations use/produce effects into the `/nix/store`. Be cautious - it is effectful. + +* Introduction: + * New module `Nix.Effects.Derivation`. + * Operations on derivations: + * old got principled implementations. + * also new operations got introduced. + * Implementation of the `derivationStrict` primOp. + +* Breaking: + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: **class** `MonadStore` got principled implementation. + * `addPath'` got principled into `addToStore`. + * `toFile_` got principled into `addTextToStore'`. + * For help & easy migration you may use `addPath` & `toFile_` `addTextToStore` standalone functions in the module. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects.Basic`: `defaultDerivationStrict` got reimplemented & moved into `Nix.Effects.Derivation`. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Standard`: instance for `MonadStore (Fix1T t m)` got principled accoding to class `MonadStore` changes. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Fresh.Basic`: instance for `MonadStore (StdIdT m)` got principled. + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) **New module `Nix.Effects.Derivation`**: [HNix(0.12.0):Nix.Effects.Derivation documentation](https://hackage.haskell.org/package/hnix-0.12.0/docs/Nix-Effects-Derivation.html). + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/9bcfbbe88ff0bd8d803296193ee1d8603dc5289e) `Nix.Convert`: Principled `NVPath -> NixString` coercion. + * In a form of principled `instance FromValue NixString m (NValue' t f m (NValue t f m))`. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/a8e6d28fdb98a1c34f425c8395338fdabe96becc) `Nix.String`: Allow custom computations inside string contexts. + * By providing `runWithStringContext{T,}'` methods into the API. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/e45f7632c51a9657f6e8d54c39fd4d21c466d85f) Includded support for new `base16-bytestring`, which advertices 2x-4x speed increase of its operations. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: `addPath` & `toFile_` standalone functions got principled implementation through the internal use of the new `MonadStore` type class implementation. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: added `addTextToStore`, `parseStoreResult` implementations. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `Nix.Effects`: added type synonyms `{RecursiveFlag, RepairFlag, StorePathName, FilePathFilter, StorePathSet}`. + * [(link)](https://github.com/haskell-nix/hnix/pull/760) `Nix.Exec`: Fixed the rendering of internal `Frames`. + * Which is an internal mechanism of a project to passing around messages with their context, still to be used internally). + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/3bba5549273c892c60aad5dd6d5058a8db40efbf) `HNix / Nix`: The library now also uses `hnix-store-remote`. + * [(link)](https://github.com/haskell-nix/hnix/pull/554/commits/06b0fca9fd607eb2e995f003424e797a41ffa5b7) `cabal.project`: project uses `cryptohash-sha512` override, the `hnix-store-core` requires it from `hnix` and uses that override also. [Detailed info](https://github.com/haskell-hvr/cryptohash-sha512/pull/5#issuecomment-752796913). We promise to attend to this issue, probably by migrating to `cryptonite` in the nearest releases. + +Future note: The HNix is a big project. During the initial development and currently the API for simplicity exposes allmost all functions, types, etc. Big open API means a big effort to create/maintain a quite noisy changelog and you parsing through it, and also creates a frequent requirements to mark releases as major and bother you due to some type changes in some parts that may not be used or applicable to be public API. + +This year the most gracious API clean-up would happen, we would check and keep open what Hackage projects are using from the API, and the other parts would be open on the request by a way of rapid minor releases. That clean-up is also a work toward splitting the project into several packages some time in the future (split would be into something like Expressions, Evaluation, Executable, Extra), which migration also would be done most thoughful and graceful as possible, with as much easiness and automation provided for migration downstream as possible. If all goes as planned - all downstream would need to do is to get and run our script that would migrate our old map of module imports to new ones, and maybe manually add those newly formed packages into `.cabal` description. + +If it is possible, please, try to switch & use the higher-level API functions where it is applicable. Thank you. + + +### [(diff)](https://github.com/haskell-nix/hnix/compare/0.11.0...0.11.1#files_bucket) 0.11.1 (2020-12-09) + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/commit/d32a6fbaf3df1c8879d1b19a18f21c031a73e56c) `Nix.Builtins`: `isString` fixed - It used to return `True` for values coercible to string like derivations and paths. It only accepts string values now. + * [(link)](https://github.com/haskell-nix/hnix/commit/53b4db2525a8f074d8c262fa7b66ce97e5820890) `Nix.Builtins`: `substring` fixed - Negative lengths used to capture an empty string. Now they capture the whole rmeainder of the string. + * [(link)](https://github.com/haskell-nix/hnix/commit/dc31c5e64f8c7aaaea14cac0134bd47544533e67) `Nix.Effects`: `pathExists` fixed - Now also works with directories. + * [(link)](https://github.com/haskell-nix/hnix/commit/e2ad934492eeac9881527610e4a1c1cf31ea1115) `Nix.Parser`: `->` is now properly right-associative (was non-associative). + * [(link)](https://github.com/haskell-nix/hnix/commit/50baea5e1e482be3c4fcc13c9a45b1083243f681) `Nix.Parser`: Nix `assert` parser (`nixAssert` function) now accepts top-level Nix format also (which means also accepts all kinds of statements), before that it accepted only regular Nix expressions. + * [(link)](https://github.com/haskell-nix/hnix/commit/59698de7185dfae508e5ccea4377a82023c4a0d5) `Nix.Render`: `renderLocation` now also shows/handles location of errors in raw strings. + + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.10.1...0.11.0#files_bucket) 0.11.0 (2020-11-02) + +* Breaking: + * [(link)](https://github.com/haskell-nix/hnix/pull/740) Deleted incorrect `instance Generic1 NKeyName` from `module Nix.Expr.Types`. + * [(link)](https://github.com/haskell-nix/hnix/pull/739) Parentheses now are properly included in the location annotation for Nix expressions, change of `nixParens` in `module Nix.Parser` essentially results in the change of all module `nix*` function results, essentially making results of the whole module more proper. + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/pull/741) Fix QQ Text lifting error: work around of [GHC#12596 "can't find interface-file declaration"](https://gitlab.haskell.org/ghc/ghc/-/issues/12596). + * [(link)](https://github.com/haskell-nix/hnix/pull/744) Fix comments inclusion into location annotations, by using pre-whitespace position for source end locations. + + +### [(diff)](https://github.com/haskell-nix/hnix/compare/0.10.0...0.10.1#files_bucket) 0.10.1 (2020-09-13) + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/pull/715) `{Binding, NExpr, NExprF, NKeyName}` gained `Ord1` instances. + * These instances were required by downstream projects to be able to use newer HNix. + * [(link)](https://github.com/haskell-nix/hnix/pull/712) CLI gained `--long-version` option for gathering a detailed debug information. + * Currently, reports Git commit and its date. + * [(link)](https://github.com/haskell-nix/hnix/issues/718) Currently does not work in case of use of the `nix-build`, in which case simply returns `UNKNOWN` placeholder. + + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.9.1...0.10.0#files_bucket) 0.10.0 (2020-09-12) + +* Breaking: + * [(link)](https://github.com/haskell-nix/hnix/pull/699) Removed `NExpr` `{FromJSON, ToJSON}` instances. + * This also removed the JSON output feature for unevaluated expression trees. + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/pull/703) CLI gained `--version` option. + * Dependencies: + * [(link)](https://github.com/haskell-nix/hnix/pull/686) Requires last major `data-fix` (`0.3`). + * [(link)](https://github.com/haskell-nix/hnix/pull/679) Requires last major `prettyprinter` (`1.7`). + + +### [(diff)](https://github.com/haskell-nix/hnix/compare/0.9.0...0.9.1#files_bucket) 0.9.1 (2020-07-13) + +* Additional: + * REPL: + * Better tab completion. + * Accepting multi-line input. + * Support for passing evaluated expression result of `hnix --eval -E`. + to REPL as an `input` variable. + * Support for loading `.hnixrc` from the current directory. + * Reporting of `builtins.nixVersion` bumped from 2.0 to 2.3. + * Dependencies: + * Freed from: `{interpolate, contravariant, semigroups, generic-random, tasty-quickcheck}`. + * Requires last major `repline` (`0.4`). + + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.8.0...0.9.0#files_bucket) 0.9.0 (2020-06-15) + +* Breaking: + * Removed instances due to migration to `haskeline 0.8`: + * `instance MonadException m => MonadException(StateT(HashMap FilePath NExprLoc) m)`. + * `instance MonadException m => MonadException(Fix1T StandardTF m)`. + * Dependencies: + * Requires last major `haskeline` (`0.8`). + +* Additional: + * Library: Official support for `GHC 8.4 - 8.10`. + * Executable complies only under `GHC 8.10`. + +* Changelog started. Previous release was `0.8.0`. + + +--- + +HNix uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,26 +0,0 @@ -Copyright (c) 2014, John Wiegley All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -3. Neither the name of the copyright holder nor the names of its contributors -may be used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/License b/License new file mode 100644 --- /dev/null +++ b/License @@ -0,0 +1,26 @@ +Copyright (c) 2014, John Wiegley All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,263 +0,0 @@ -[![Chatroom Gitter](https://img.shields.io/badge/Chatroom-Gitter-%23753a88)](https://gitter.im/haskell-nix/Lobby) -[![Hackage](https://img.shields.io/hackage/v/hnix?color=%235e5086&label=Latest%20release%20on%20Hackage)](https://hackage.haskell.org/package/hnix) -[![Hackage Matrix Builder](https://img.shields.io/badge/Hackage%20Matrix-Builder-%235e5086)](https://matrix.hackage.haskell.org/package/hnix) -[![Bounds](https://img.shields.io/hackage-deps/v/hnix?label=Released%20dep%20bounds)](https://packdeps.haskellers.com/feed?needle=hnix) -[![Hydra CI](https://img.shields.io/badge/Nixpkgs%20Hydra-CI-%234f72bb)](https://hydra.nixos.org/job/nixpkgs/trunk/haskellPackages.hnix.x86_64-linux#tabs-status) -[![Repology page](https://img.shields.io/badge/Repology-page-%23005500)](https://repology.org/project/haskell:hnix/versions) - - -# hnix - -Parser, evaluator and type checker for the Nix language written in Haskell. - - -## Contents - - - - - -- [Prerequisites](#prerequisites) -- [Getting Started](#getting-started) - - [Cachix prebuild binary caches](#cachix-prebuild-binary-caches) - - [Development using Cabal](#development-using-cabal) - - [Building the project](#building-the-project) - - [With benchmarks](#with-benchmarks) - - [With profiling](#with-profiling) - - [With full debug info](#with-full-debug-info) - - [Run HNix](#run-hnix) - - [Use of the Nix-build](#use-of-the-nix-build) - - [Run benchmarks](#run-benchmarks) - - [With profiling](#with-profiling-1) - - [With full debug info](#with-full-debug-info-1) - - [Run the result](#run-the-result) -- [Development status loop with amazing `ghcid`](#development-status-loop-with-amazing-ghcid) -- [Using the HNix REPL](#using-the-hnix-repl) -- [Nix laziness](#nix-laziness) -- [Contributing](#contributing) -- [Evaluating Nixpkgs with HNix](#evaluating-nixpkgs-with-hnix) - - - - -## Prerequisites -Tooling is WIP, `nix-shell` and `nix-store` are still used for their purpose, so, to access them Nix is required to be installed. - -*Disclaimer*: Current `derivationStrict` primOp implementation and so every evaluation of a derivation into a store path currently relies on the `hnix-store-remote`, which for those operations relies on the running `nix-daemon`, and so operations use/produce effects into the `/nix/store`. Be cautious - it is effectful. - -## Getting Started - -```shell -# Note: --recursive -git clone --recursive 'https://github.com/haskell-nix/hnix.git' -cd hnix -``` - - -### Cachix prebuild binary caches - -If you opt in to use of Nix environment, please enable the official HNix Cachix binary cache: - -1. Go through https://cachix.org/ and set it up. - -2. Run: `cachix use hnix` - - -### Development using Cabal - -Cabal [Quickstart](https://cabal.readthedocs.io/en/3.4/nix-local-build.html). - -1. (Optional), to enter the projects reproducible Nix environment: -```shell -nix-shell -``` - -2. Building: -```shell -cabal v2-configure -cabal v2-build -``` - -3. Loading the project into `ghci` REPL: -```shell -cabal v2-repl -``` - -4. Testing: - -* Default suite: -```shell -cabal v2-test -``` - -* All available tests: -```shell -env ALL_TESTS=yes cabal v2-test -``` - -* Selected (list of tests is in `tests/Main.hs`): -```shell -env NIXPKGS_TESTS=yes PRETTY_TESTS=1 cabal v2-test -``` - -#### Building the project - -##### With benchmarks - -To run benchmarks: - -```shell -cabal v2-bench -``` - -##### With profiling - -To build `hnix` with profiling enabled: - -```shell -cabal v2-configure --enable-tests --enable-profiling --flags=profiling -cabal v2-run hnix -- +RTS -p -``` - -##### With full debug info - -To build `hnix` for debugging, with full tracing output and stack traces: - -```shell -cabal v2-configure --enable-tests --enable-profiling --flags=profiling --flags=tracing -cabal v2-run hnix -- -v5 --trace +RTS -xc -``` - -Note that this going to run quite slowly, but would give the most information as to what happens during parsing & evaluation. - - -#### Run HNix -```shell -cabal v2-run hnix -- --help -``` -(`--` is for separation between `cabal` & `hnix` args) - - -### Use of the Nix-build - -There is a number of build options to use with `nix-build`, documentation of them is in: `./default.nix`, keys essentially pass-through the [Nixpkgs Haskell Lib API](https://github.com/NixOS/nixpkgs/blob/master/pkgs/development/haskell-modules/lib.nix). - -Options can be used as: -```shell -nix-build \ - --arg \ - --arg \ - --argstr "" -``` - -#### Run benchmarks - -```shell -nix-build \ - --arg disableOptimization false \ - --arg enableDeadCodeElimination true \ - --arg doStrip true \ - --arg doBenchmark true -``` - -#### With profiling - -```shell -nix-build \ - --arg disableOptimization false \ - --arg enableDeadCodeElimination true \ - --arg enableLibraryProfiling true \ - --arg enableExecutableProfiling true -``` - -#### With full debug info - -```shell -nix-build \ - --arg disableOptimization false \ - --arg enableDeadCodeElimination true \ - --arg doBenchmark true \ - --arg doStrip false \ - --arg enableLibraryProfiling true \ - --arg enableExecutableProfiling true - --arg doTracing true \ - --arg enableDWARFDebugging true -``` - -#### Run the result - -```shell -./result/bin/hnix -``` - -## Development status loop with amazing [`ghcid`](https://github.com/ndmitchell/ghcid) - -```shell -ghcid --command="cabal v2-repl --repl-options=-fno-code --repl-options=-fno-break-on-exception --repl-options=-fno-break-on-error --repl-options=-v1 --repl-options=-ferror-spans --repl-options=-j" -``` -(optional) To use projects reproducible environment, wrap `ghcid ...` command into a `nix-shell --command ' '`. - -For simplicity `alias` the command in your shell. - - -## Using the HNix REPL - -Enter in: -```shell -hnix --repl -``` - -Evaluate an expression: -```shell -hnix --eval -E '(import {}).pkgs.hello' --repl -``` -This also binds the evaluated expression result to the `input` variable, so that variable can be inspected. - -Use the `:help` command for a list of all available REPL commands. - -## Nix laziness - -Nix is a lazy language with the ability of recursion, so by default REPL and eval prints are lazy: - -```shell -hnix \ - --eval \ - --expr '{ x = true; }' - -{ x = ""; } -``` - -To disable laziness add the `--strict` to commands or `:set strict` in the REPL. - -```shell -hnix \ - --eval \ - # Strictly \ - --strict \ - --expr '{ x = true; }' - -{ x = true; } -``` - -## Contributing - -1. If something in the [quests](https://github.com/haskell-nix/hnix/issues?q=is%3Aissue+is%3Aopen+label%3A%22help+wanted%22+no%3Aassignee) looks interesting, look through the thread and leave a comment taking it, to let others know you're working on it. - -2. You are free to chat with everyone on [Gitter](https://gitter.im/haskell-nix/Lobby). - -3. When the pull request is ready to be submitted, to save time - please, test it with: - -```shell -git submodule update --init --recursive -nix-shell --run "LANGUAGE_TESTS=yes cabal v2-test" -``` - -Please, check that all tests that were passing prior (most probably all tests mentioned in the command) are still passing for the PR, it is faster to check that locally than through CI. It's OK if no new tests are passing. - -## Evaluating Nixpkgs with HNix - -Currently, the main high-level goal is to be able to evaluate all of Nixpkgs: - -```shell -hnix --eval -E "import {}" --find -``` diff --git a/ReadMe.md b/ReadMe.md new file mode 100644 --- /dev/null +++ b/ReadMe.md @@ -0,0 +1,330 @@ +[![Chatroom Gitter](https://img.shields.io/badge/Chatroom-Gitter-%23753a88)](https://gitter.im/haskell-nix/Lobby) +[![Hackage](https://img.shields.io/hackage/v/hnix?color=%235e5086&label=Latest%20release%20on%20Hackage)](https://hackage.haskell.org/package/hnix) +[![Hackage Matrix Builder](https://img.shields.io/badge/Hackage%20Matrix-Builder-%235e5086)](https://matrix.hackage.haskell.org/package/hnix) +[![Bounds](https://img.shields.io/hackage-deps/v/hnix?label=Released%20dep%20bounds)](https://packdeps.haskellers.com/feed?needle=hnix) +[![Hydra CI](https://img.shields.io/badge/Nixpkgs%20Hydra-CI-%234f72bb)](https://hydra.nixos.org/job/nixpkgs/trunk/haskellPackages.hnix.x86_64-linux#tabs-status) +[![Repology page](https://img.shields.io/badge/Repology-page-%23005500)](https://repology.org/project/haskell:hnix/versions) + + +# HNix + +Parser, evaluator and type checker for the Nix language written in Haskell. + + +## Prerequisites +Tooling is WIP, `nix-shell` and `nix-store` are still used for their purpose, so, to access them Nix is required to be installed. + +*Disclaimer*: Since still using Nix for some operations, current `derivationStrict` primOp implementation and so evaluations of a derivation into a store path currently rely on the `hnix-store-remote`, which for those operations relies on the running `nix-daemon`, and so operations use/produce effects into the `/nix/store`. Be cautious - it is effectful (produces `/nix/store` entries). + +## Building the project + +### Git clone + +```shell +git clone --recursive 'https://github.com/haskell-nix/hnix.git' && cd hnix +``` + + +### (optional) Cachix prebuild binary caches + +If you would use our Nix-shell environment for development, you can connect to our Cachix HNix build caches: + +1. Run: + ```shell + nix-env -iA cachix -f https://cachix.org/api/v1/install + ``` + + +2. Run: `cachix use hnix` + + +### Building with Cabal + +Cabal [Quickstart](https://cabal.readthedocs.io/en/3.4/nix-local-build.html). + +1. (Optional), to enter the projects reproducible Nix environment: + ```shell + nix-shell + ``` + +2. Building: + ```shell + cabal v2-configure + cabal v2-build + ``` + +3. Loading the project into `ghci` REPL: + ```shell + cabal v2-repl + ``` + +4. Testing: + + * Default suite: + ```shell + cabal v2-test + ``` + + * All available tests: + ```shell + env ALL_TESTS=yes cabal v2-test + ``` + + * Selected (list of tests is in `tests/Main.hs`): + ```shell + env NIXPKGS_TESTS=yes PRETTY_TESTS=1 cabal v2-test + ``` + +#### Checking the project + +##### Benchmarks + +To run benchmarks: + +```shell +cabal v2-bench +``` + +##### Profiling + +GHC User Manual has a full ["Profiling"](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/profiling.html) section of relevant info. + +To build `hnix` with profiling enabled: + +```shell +cabal v2-run hnix --enable-profiling --flags=profiling -- +RTS -p +``` + +Or to put simply: +```shell +# Run profiling for evaluation of a Firefox package. +# Generate: +# * for all functions +# * time profiling data +# * memory allocation profiling data +# * in the JSON profiling format +cabal v2-run --enable-profiling --flags=profiling --enable-library-profiling --profiling-detail='all-functions' hnix -- --eval --expr '(import {}).firefox.outPath' +RTS -Pj + +# Then, upload the `hnix.prof` to the https://www.speedscope.app/ to analyze it. +``` + +"RTS" stands for "RunTime System" and has a lot of options, GHC User Manual has ["Running a compiled program"/"Setting RTS options"](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/runtime_control.html) sections describing them. + +##### Full debug info + +To run stack traces & full tracing output on `hnix`: + +```shell +cabal v2-configure --enable-tests --enable-profiling --flags=profiling --flags=tracing +cabal v2-run hnix -- -v5 --trace +RTS -xc +``` + +This would give the most information as to what happens during parsing & evaluation. + + +#### Runing executable + +```shell +cabal v2-run hnix -- --help +``` +(`--` is for separation between `cabal` & `hnix` args) + + +### Building with Nix-build + +There is a number of build options to use with `nix-build`, documentation of them is in: `./default.nix`, keys essentially pass-through the [Nixpkgs Haskell Lib API](https://github.com/NixOS/nixpkgs/blob/master/pkgs/development/haskell-modules/lib.nix). + +Options can be used as: +```shell +nix-build \ + --arg \ + --arg \ + --argstr "" +``` + +#### Checking the project +##### Benchmarks + +```shell +nix-build \ + --arg disableOptimization false \ + --arg enableDeadCodeElimination true \ + --arg doStrip true \ + --arg doBenchmark true +``` + +##### Profiling + +```shell +nix-build \ + --arg disableOptimization false \ + --arg enableDeadCodeElimination true \ + --arg enableLibraryProfiling true \ + --arg enableExecutableProfiling true + +./result/bin/hnix +RTS -p +``` + +##### Full debug info + +```shell +nix-build \ + --arg disableOptimization false \ + --arg enableDeadCodeElimination true \ + --arg doBenchmark true \ + --arg doStrip false \ + --arg enableLibraryProfiling true \ + --arg enableExecutableProfiling true \ + --arg doTracing true \ + --arg enableDWARFDebugging true + +./result/bin/hnix -v5 --trace +RTS -xc +``` + +#### Runing executable + +```shell +./result/bin/hnix +``` + +## Using HNix + +See: +``` +hnix --help +``` + +It has a pretty full/good description of the current options. + + +### Parse & print + +To parse a file with `hnix` and pretty print the result: + +```shell +hnix file.nix +``` + +### Evaluating and printing the resulting value + +Expression from a file: + +```shell +hnix --eval file.nix +``` + +Expression: + +```shell +hnix --eval --expr 'import {}' +``` + +### Evaluating Nixpkgs + +Currently, the main high-level goal is to be able to evaluate all of Nixpkgs: + +```shell +hnix --eval --expr "import {}" --find +``` + +### Options supported only by HNix + +To see value provenance and thunk context: + +```shell +hnix -v2 --values --thunk --eval --expr 'import {}' +``` + +To see tracing as the evaluator runs (note that building with `cabal configure --flags=tracing` will produce much more output than this): + +```shell +hnix --trace --eval --expr 'import {}' +``` + +To attempt to generate a reduced test case demonstrating an error: + +```shell +hnix --reduce bug.nix --eval --expr 'import {}' +``` + +### REPL + +To enter REPL: +```shell +hnix --repl +``` + +Evaluate an expression and load it into REPL: +```shell +hnix --eval --expr '(import {}).pkgs.hello' --repl +``` +This binds the evaluated expression result to the `input` variable, so that variable can be inspected. + +Use the `:help` command for a list of all available REPL commands. + +#### Language laziness + +Nix is a lazy language with the ability of recursion, so by default REPL and eval prints are lazy: + +```shell +hnix \ + --eval \ + --expr '{ x = true; }' + +{ x = ""; } +``` + +To disable laziness add the `--strict` to commands or `:set strict` in the REPL. + +```shell +hnix \ + --eval \ + --strict \ + --expr '{ x = true; }' + +{ x = true; } +``` + + +## Contributing + +* The Haskell Language Server (HLS) works great with our project. + +* [Design of the HNix code base Wiki article](https://github.com/haskell-nix/hnix/wiki/Design-of-the-HNix-code-base). + +1. If something in the [quests](https://github.com/haskell-nix/hnix/issues?q=is%3Aissue+is%3Aopen+label%3A%22help+wanted%22+no%3Aassignee) looks interesting, look through the thread and leave a comment taking it, to let others know you're working on it. + +2. You are free to chat with everyone on [Gitter](https://gitter.im/haskell-nix/Lobby). + +3. When the pull request is ready to be submitted, to save time - please, test it with: + + ```shell + cabal v2-test + + # If forgot to clone recursively, run: + # git submodule update --init --recursive + ``` + + Please, check that all default tests that were passing prior are still passing. It's OK if no new tests are passing. + + +### (optional) Minimalistic development status loop with amazing [`ghcid`](https://github.com/ndmitchell/ghcid) + +If HLS is not your cup of yea: + +```shell +ghcid --command="cabal v2-repl --repl-options=-fno-code --repl-options=-fno-break-on-exception --repl-options=-fno-break-on-error --repl-options=-v1 --repl-options=-ferror-spans --repl-options=-j" +``` +(optional) To use projects reproducible environment, wrap `ghcid ...` command into a `nix-shell --command ' '`. + +For simplicity `alias` the command in your shell. + + +## Current status + +To understand the project implementation state see: + * [ChangeLog](https://github.com/haskell-nix/hnix/blob/master/ChangeLog.md) + * [Opened reports](https://github.com/haskell-nix/hnix/issues) + * [Project status](https://github.com/haskell-nix/hnix/wiki/Project-status) + * [Design of the HNix code base](https://github.com/haskell-nix/hnix/wiki/Design-of-the-HNix-code-base) + diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/benchmarks/ParserBench.hs b/benchmarks/ParserBench.hs --- a/benchmarks/ParserBench.hs +++ b/benchmarks/ParserBench.hs @@ -2,20 +2,20 @@ import Nix.Parser -import Control.Applicative import Criterion benchFile :: FilePath -> Benchmark -benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++) +benchFile = bench <*> whnfIO . parseNixFile . ("data/" <>) benchmarks :: Benchmark benchmarks = bgroup - "Parser" - [ benchFile "nixpkgs-all-packages.nix" - , benchFile "nixpkgs-all-packages-pretty.nix" - , benchFile "let-comments.nix" - , benchFile "let-comments-multiline.nix" - , benchFile "let.nix" - , benchFile "simple.nix" - , benchFile "simple-pretty.nix" - ] + "Parser" $ + fmap benchFile + [ "nixpkgs-all-packages.nix" + , "nixpkgs-all-packages-pretty.nix" + , "let-comments.nix" + , "let-comments-multiline.nix" + , "let.nix" + , "simple.nix" + , "simple-pretty.nix" + ] diff --git a/hnix.cabal b/hnix.cabal --- a/hnix.cabal +++ b/hnix.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: hnix -version: 0.12.0.1 +version: 0.13.0 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix @@ -7,323 +8,322 @@ bug-reports: https://github.com/haskell-nix/hnix/issues author: John Wiegley maintainer: johnw@newartisans.com -license: BSD3 -license-file: LICENSE +license: BSD-3-Clause +license-file: License build-type: Simple -cabal-version: >= 1.10 data-dir: data/ data-files: - nix/corepkgs/buildenv.nix - nix/corepkgs/unpack-channel.nix - nix/corepkgs/derivation.nix - nix/corepkgs/fetchurl.nix - nix/corepkgs/imported-drv-to-derivation.nix + nix/corepkgs/buildenv.nix + nix/corepkgs/unpack-channel.nix + nix/corepkgs/derivation.nix + nix/corepkgs/fetchurl.nix + nix/corepkgs/imported-drv-to-derivation.nix extra-source-files: - data/nix/corepkgs/buildenv.nix - data/nix/corepkgs/unpack-channel.nix - data/nix/corepkgs/derivation.nix - data/nix/corepkgs/fetchurl.nix - data/nix/corepkgs/imported-drv-to-derivation.nix - data/nix/tests/lang/binary-data - data/nix/tests/lang/data - data/nix/tests/lang/dir1/a.nix - data/nix/tests/lang/dir2/a.nix - data/nix/tests/lang/dir2/b.nix - data/nix/tests/lang/dir3/a.nix - data/nix/tests/lang/dir3/b.nix - data/nix/tests/lang/dir3/c.nix - data/nix/tests/lang/dir4/a.nix - data/nix/tests/lang/dir4/c.nix - data/nix/tests/lang/eval-fail-abort.nix - data/nix/tests/lang/eval-fail-antiquoted-path.nix - data/nix/tests/lang/eval-fail-assert.nix - data/nix/tests/lang/eval-fail-bad-antiquote-1.nix - data/nix/tests/lang/eval-fail-bad-antiquote-2.nix - data/nix/tests/lang/eval-fail-bad-antiquote-3.nix - data/nix/tests/lang/eval-fail-blackhole.nix - data/nix/tests/lang/eval-fail-deepseq.nix - data/nix/tests/lang/eval-fail-hashfile-missing.nix - data/nix/tests/lang/eval-fail-missing-arg.nix - data/nix/tests/lang/eval-fail-path-slash.nix - data/nix/tests/lang/eval-fail-remove.nix - data/nix/tests/lang/eval-fail-scope-5.nix - data/nix/tests/lang/eval-fail-seq.nix - data/nix/tests/lang/eval-fail-substring.nix - data/nix/tests/lang/eval-fail-to-path.nix - data/nix/tests/lang/eval-fail-undeclared-arg.nix - data/nix/tests/lang/eval-okay-any-all.exp - data/nix/tests/lang/eval-okay-any-all.nix - data/nix/tests/lang/eval-okay-arithmetic.exp - data/nix/tests/lang/eval-okay-arithmetic.nix - data/nix/tests/lang/eval-okay-attrnames.exp - data/nix/tests/lang/eval-okay-attrnames.nix - data/nix/tests/lang/eval-okay-attrs2.exp - data/nix/tests/lang/eval-okay-attrs2.nix - data/nix/tests/lang/eval-okay-attrs3.exp - data/nix/tests/lang/eval-okay-attrs3.nix - data/nix/tests/lang/eval-okay-attrs4.exp - data/nix/tests/lang/eval-okay-attrs4.nix - data/nix/tests/lang/eval-okay-attrs5.exp - data/nix/tests/lang/eval-okay-attrs5.nix - data/nix/tests/lang/eval-okay-attrs.exp - data/nix/tests/lang/eval-okay-attrs.nix - data/nix/tests/lang/eval-okay-autoargs.exp - data/nix/tests/lang/eval-okay-autoargs.flags - data/nix/tests/lang/eval-okay-autoargs.nix - data/nix/tests/lang/eval-okay-backslash-newline-1.exp - data/nix/tests/lang/eval-okay-backslash-newline-1.nix - data/nix/tests/lang/eval-okay-backslash-newline-2.exp - data/nix/tests/lang/eval-okay-backslash-newline-2.nix - data/nix/tests/lang/eval-okay-builtins-add.exp - data/nix/tests/lang/eval-okay-builtins-add.nix - data/nix/tests/lang/eval-okay-builtins.exp - data/nix/tests/lang/eval-okay-builtins.nix - data/nix/tests/lang/eval-okay-callable-attrs.exp - data/nix/tests/lang/eval-okay-callable-attrs.nix - data/nix/tests/lang/eval-okay-catattrs.exp - data/nix/tests/lang/eval-okay-catattrs.nix - data/nix/tests/lang/eval-okay-closure.exp.xml - data/nix/tests/lang/eval-okay-closure.nix - data/nix/tests/lang/eval-okay-comments.exp - data/nix/tests/lang/eval-okay-comments.nix - data/nix/tests/lang/eval-okay-concat.exp - data/nix/tests/lang/eval-okay-concatmap.exp - data/nix/tests/lang/eval-okay-concatmap.nix - data/nix/tests/lang/eval-okay-concat.nix - data/nix/tests/lang/eval-okay-concatstringssep.exp - data/nix/tests/lang/eval-okay-concatstringssep.nix - data/nix/tests/lang/eval-okay-context.exp - data/nix/tests/lang/eval-okay-context-introspection.exp - data/nix/tests/lang/eval-okay-context-introspection.nix - data/nix/tests/lang/eval-okay-context.nix - data/nix/tests/lang/eval-okay-curpos.exp - data/nix/tests/lang/eval-okay-curpos.nix - data/nix/tests/lang/eval-okay-deepseq.exp - data/nix/tests/lang/eval-okay-deepseq.nix - data/nix/tests/lang/eval-okay-delayed-with.exp - data/nix/tests/lang/eval-okay-delayed-with-inherit.exp - data/nix/tests/lang/eval-okay-delayed-with-inherit.nix - data/nix/tests/lang/eval-okay-delayed-with.nix - data/nix/tests/lang/eval-okay-dynamic-attrs-2.exp - data/nix/tests/lang/eval-okay-dynamic-attrs-2.nix - data/nix/tests/lang/eval-okay-dynamic-attrs-bare.exp - data/nix/tests/lang/eval-okay-dynamic-attrs-bare.nix - data/nix/tests/lang/eval-okay-dynamic-attrs.exp - data/nix/tests/lang/eval-okay-dynamic-attrs.nix - data/nix/tests/lang/eval-okay-elem.exp - data/nix/tests/lang/eval-okay-elem.nix - data/nix/tests/lang/eval-okay-empty-args.exp - data/nix/tests/lang/eval-okay-empty-args.nix - data/nix/tests/lang/eval-okay-eq-derivations.exp - data/nix/tests/lang/eval-okay-eq-derivations.nix - data/nix/tests/lang/eval-okay-eq.exp.disabled - data/nix/tests/lang/eval-okay-eq.nix - data/nix/tests/lang/eval-okay-filter.exp - data/nix/tests/lang/eval-okay-filter.nix - data/nix/tests/lang/eval-okay-flatten.exp - data/nix/tests/lang/eval-okay-flatten.nix - data/nix/tests/lang/eval-okay-float.exp - data/nix/tests/lang/eval-okay-float.nix - data/nix/tests/lang/eval-okay-fromjson.exp - data/nix/tests/lang/eval-okay-fromjson.nix - data/nix/tests/lang/eval-okay-fromTOML.exp - data/nix/tests/lang/eval-okay-fromTOML.nix - data/nix/tests/lang/eval-okay-functionargs.exp.xml - data/nix/tests/lang/eval-okay-functionargs.nix - data/nix/tests/lang/eval-okay-getattrpos.exp - data/nix/tests/lang/eval-okay-getattrpos.nix - data/nix/tests/lang/eval-okay-getattrpos-undefined.exp - data/nix/tests/lang/eval-okay-getattrpos-undefined.nix - data/nix/tests/lang/eval-okay-getenv.exp - data/nix/tests/lang/eval-okay-getenv.nix - data/nix/tests/lang/eval-okay-hash.exp - data/nix/tests/lang/eval-okay-hashfile.exp - data/nix/tests/lang/eval-okay-hashfile.nix - data/nix/tests/lang/eval-okay-hashstring.exp - data/nix/tests/lang/eval-okay-hashstring.nix - data/nix/tests/lang/eval-okay-if.exp - data/nix/tests/lang/eval-okay-if.nix - data/nix/tests/lang/eval-okay-import.exp - data/nix/tests/lang/eval-okay-import.nix - data/nix/tests/lang/eval-okay-ind-string.exp - data/nix/tests/lang/eval-okay-ind-string.nix - data/nix/tests/lang/eval-okay-let.exp - data/nix/tests/lang/eval-okay-let.nix - data/nix/tests/lang/eval-okay-list.exp - data/nix/tests/lang/eval-okay-list.nix - data/nix/tests/lang/eval-okay-listtoattrs.exp - data/nix/tests/lang/eval-okay-listtoattrs.nix - data/nix/tests/lang/eval-okay-logic.exp - data/nix/tests/lang/eval-okay-logic.nix - data/nix/tests/lang/eval-okay-mapattrs.exp - data/nix/tests/lang/eval-okay-mapattrs.nix - data/nix/tests/lang/eval-okay-map.exp - data/nix/tests/lang/eval-okay-map.nix - data/nix/tests/lang/eval-okay-nested-with.exp - data/nix/tests/lang/eval-okay-nested-with.nix - data/nix/tests/lang/eval-okay-new-let.exp - data/nix/tests/lang/eval-okay-new-let.nix - data/nix/tests/lang/eval-okay-null-dynamic-attrs.exp - data/nix/tests/lang/eval-okay-null-dynamic-attrs.nix - data/nix/tests/lang/eval-okay-overrides.exp - data/nix/tests/lang/eval-okay-overrides.nix - data/nix/tests/lang/eval-okay-partition.exp - data/nix/tests/lang/eval-okay-partition.nix - data/nix/tests/lang/eval-okay-pathexists.exp - data/nix/tests/lang/eval-okay-pathexists.nix - data/nix/tests/lang/eval-okay-path.nix - data/nix/tests/lang/eval-okay-patterns.exp - data/nix/tests/lang/eval-okay-patterns.nix - data/nix/tests/lang/eval-okay-readDir.exp - data/nix/tests/lang/eval-okay-readDir.nix - data/nix/tests/lang/eval-okay-readfile.exp - data/nix/tests/lang/eval-okay-readfile.nix - data/nix/tests/lang/eval-okay-redefine-builtin.exp - data/nix/tests/lang/eval-okay-redefine-builtin.nix - data/nix/tests/lang/eval-okay-regex-match.exp - data/nix/tests/lang/eval-okay-regex-match.nix - data/nix/tests/lang/eval-okay-regex-split.exp - data/nix/tests/lang/eval-okay-regex-split.nix - data/nix/tests/lang/eval-okay-remove.exp - data/nix/tests/lang/eval-okay-remove.nix - data/nix/tests/lang/eval-okay-replacestrings.exp - data/nix/tests/lang/eval-okay-replacestrings.nix - data/nix/tests/lang/eval-okay-scope-1.exp - data/nix/tests/lang/eval-okay-scope-1.nix - data/nix/tests/lang/eval-okay-scope-2.exp - data/nix/tests/lang/eval-okay-scope-2.nix - data/nix/tests/lang/eval-okay-scope-3.exp - data/nix/tests/lang/eval-okay-scope-3.nix - data/nix/tests/lang/eval-okay-scope-4.exp - data/nix/tests/lang/eval-okay-scope-4.nix - data/nix/tests/lang/eval-okay-scope-6.exp - data/nix/tests/lang/eval-okay-scope-6.nix - data/nix/tests/lang/eval-okay-scope-7.exp - data/nix/tests/lang/eval-okay-scope-7.nix - data/nix/tests/lang/eval-okay-search-path.exp - data/nix/tests/lang/eval-okay-search-path.flags - data/nix/tests/lang/eval-okay-search-path.nix - data/nix/tests/lang/eval-okay-seq.exp - data/nix/tests/lang/eval-okay-seq.nix - data/nix/tests/lang/eval-okay-sort.exp - data/nix/tests/lang/eval-okay-sort.nix - data/nix/tests/lang/eval-okay-splitversion.exp - data/nix/tests/lang/eval-okay-splitversion.nix - data/nix/tests/lang/eval-okay-string.exp - data/nix/tests/lang/eval-okay-string.nix - data/nix/tests/lang/eval-okay-strings-as-attrs-names.exp - data/nix/tests/lang/eval-okay-strings-as-attrs-names.nix - data/nix/tests/lang/eval-okay-substring.exp - data/nix/tests/lang/eval-okay-substring.nix - data/nix/tests/lang/eval-okay-tail-call-1.exp-disabled - data/nix/tests/lang/eval-okay-tail-call-1.nix - data/nix/tests/lang/eval-okay-tojson.exp - data/nix/tests/lang/eval-okay-tojson.nix - data/nix/tests/lang/eval-okay-toxml2.exp - data/nix/tests/lang/eval-okay-toxml2.nix - data/nix/tests/lang/eval-okay-toxml.exp - data/nix/tests/lang/eval-okay-toxml.nix - data/nix/tests/lang/eval-okay-tryeval.exp - data/nix/tests/lang/eval-okay-tryeval.nix - data/nix/tests/lang/eval-okay-types.exp - data/nix/tests/lang/eval-okay-types.nix - data/nix/tests/lang/eval-okay-versions.exp - data/nix/tests/lang/eval-okay-versions.nix - data/nix/tests/lang/eval-okay-with.exp - data/nix/tests/lang/eval-okay-with.nix - data/nix/tests/lang/eval-okay-xml.exp.xml - data/nix/tests/lang/eval-okay-xml.nix - data/nix/tests/lang/imported2.nix - data/nix/tests/lang/imported.nix - data/nix/tests/lang/lib.nix - data/nix/tests/lang/parse-fail-dup-attrs-1.nix - data/nix/tests/lang/parse-fail-dup-attrs-2.nix - data/nix/tests/lang/parse-fail-dup-attrs-3.nix - data/nix/tests/lang/parse-fail-dup-attrs-4.nix - data/nix/tests/lang/parse-fail-dup-attrs-7.nix - data/nix/tests/lang/parse-fail-dup-formals.nix - data/nix/tests/lang/parse-fail-mixed-nested-attrs1.nix - data/nix/tests/lang/parse-fail-mixed-nested-attrs2.nix - data/nix/tests/lang/parse-fail-patterns-1.nix - data/nix/tests/lang/parse-fail-regression-20060610.nix - data/nix/tests/lang/parse-fail-uft8.nix - data/nix/tests/lang/parse-fail-undef-var-2.nix - data/nix/tests/lang/parse-fail-undef-var.nix - data/nix/tests/lang/parse-okay-1.nix - data/nix/tests/lang/parse-okay-crlf.nix - data/nix/tests/lang/parse-okay-dup-attrs-5.nix - data/nix/tests/lang/parse-okay-dup-attrs-6.nix - data/nix/tests/lang/parse-okay-mixed-nested-attrs-1.nix - data/nix/tests/lang/parse-okay-mixed-nested-attrs-2.nix - data/nix/tests/lang/parse-okay-mixed-nested-attrs-3.nix - data/nix/tests/lang/parse-okay-regression-20041027.nix - data/nix/tests/lang/parse-okay-regression-751.nix - data/nix/tests/lang/parse-okay-subversion.nix - data/nix/tests/lang/parse-okay-url.nix - data/nix/tests/lang/readDir/bar - data/nix/tests/lang/readDir/foo/git-hates-directories - data/nix/tests/local.mk - data/nixpkgs-all-packages.nix - data/let-comments.nix - data/let-comments-multiline.nix - data/simple-pretty.nix - data/simple.nix - data/nixpkgs-all-packages-pretty.nix - data/let.nix - LICENSE - README.md - CHANGELOG.md - tests/eval-compare/builtins.appendContext.nix - tests/eval-compare/builtins.eq-bottom-00.nix - tests/eval-compare/builtins.fetchurl-01.nix - tests/eval-compare/builtins.fromJSON-01.nix - tests/eval-compare/builtins.getContext.nix - tests/eval-compare/builtins.lessThan-01.nix - tests/eval-compare/builtins.mapAttrs-01.nix - tests/eval-compare/builtins.pathExists.nix - tests/eval-compare/builtins.replaceStrings-01.nix - tests/eval-compare/builtins.split-01.nix - tests/eval-compare/builtins.split-02.nix - tests/eval-compare/builtins.split-03.nix - tests/eval-compare/builtins.split-04.nix - tests/eval-compare/builtins.string.store.nix - tests/eval-compare/builtins.toJSON.nix - tests/eval-compare/current-system.nix - tests/eval-compare/ellipsis.nix - tests/eval-compare/ind-string-01.nix - tests/eval-compare/ind-string-02.nix - tests/eval-compare/ind-string-03.nix - tests/eval-compare/ind-string-04.nix - tests/eval-compare/ind-string-05.nix - tests/eval-compare/ind-string-06.nix - tests/eval-compare/ind-string-07.nix - tests/eval-compare/ind-string-08.nix - tests/eval-compare/ind-string-09.nix - tests/eval-compare/ind-string-10.nix - tests/eval-compare/ind-string-11.nix - tests/eval-compare/ind-string-12.nix - tests/eval-compare/ind-string-13.nix - tests/eval-compare/ind-string-14.nix - tests/eval-compare/ind-string-15.nix - tests/eval-compare/ind-string-16.nix - tests/eval-compare/ind-string-17.nix - tests/eval-compare/paths-01.nix - tests/eval-compare/placeholder.nix - tests/files/attrs.nix - tests/files/callLibs.nix - tests/files/eighty.nix - tests/files/file.nix - tests/files/file2.nix - tests/files/findFile.nix - tests/files/force.nix - tests/files/goodbye.nix - tests/files/hello.nix - tests/files/hello2.nix - tests/files/if-then.nix - tests/files/lint.nix - tests/files/loop.nix - tests/files/test.nix - tests/files/with.nix + ChangeLog.md + ReadMe.md + License + data/nix/corepkgs/buildenv.nix + data/nix/corepkgs/unpack-channel.nix + data/nix/corepkgs/derivation.nix + data/nix/corepkgs/fetchurl.nix + data/nix/corepkgs/imported-drv-to-derivation.nix + data/nix/tests/lang/binary-data + data/nix/tests/lang/data + data/nix/tests/lang/dir1/a.nix + data/nix/tests/lang/dir2/a.nix + data/nix/tests/lang/dir2/b.nix + data/nix/tests/lang/dir3/a.nix + data/nix/tests/lang/dir3/b.nix + data/nix/tests/lang/dir3/c.nix + data/nix/tests/lang/dir4/a.nix + data/nix/tests/lang/dir4/c.nix + data/nix/tests/lang/eval-fail-abort.nix + data/nix/tests/lang/eval-fail-antiquoted-path.nix + data/nix/tests/lang/eval-fail-assert.nix + data/nix/tests/lang/eval-fail-bad-antiquote-1.nix + data/nix/tests/lang/eval-fail-bad-antiquote-2.nix + data/nix/tests/lang/eval-fail-bad-antiquote-3.nix + data/nix/tests/lang/eval-fail-blackhole.nix + data/nix/tests/lang/eval-fail-deepseq.nix + data/nix/tests/lang/eval-fail-hashfile-missing.nix + data/nix/tests/lang/eval-fail-missing-arg.nix + data/nix/tests/lang/eval-fail-path-slash.nix + data/nix/tests/lang/eval-fail-remove.nix + data/nix/tests/lang/eval-fail-scope-5.nix + data/nix/tests/lang/eval-fail-seq.nix + data/nix/tests/lang/eval-fail-substring.nix + data/nix/tests/lang/eval-fail-to-path.nix + data/nix/tests/lang/eval-fail-undeclared-arg.nix + data/nix/tests/lang/eval-okay-any-all.exp + data/nix/tests/lang/eval-okay-any-all.nix + data/nix/tests/lang/eval-okay-arithmetic.exp + data/nix/tests/lang/eval-okay-arithmetic.nix + data/nix/tests/lang/eval-okay-attrnames.exp + data/nix/tests/lang/eval-okay-attrnames.nix + data/nix/tests/lang/eval-okay-attrs2.exp + data/nix/tests/lang/eval-okay-attrs2.nix + data/nix/tests/lang/eval-okay-attrs3.exp + data/nix/tests/lang/eval-okay-attrs3.nix + data/nix/tests/lang/eval-okay-attrs4.exp + data/nix/tests/lang/eval-okay-attrs4.nix + data/nix/tests/lang/eval-okay-attrs5.exp + data/nix/tests/lang/eval-okay-attrs5.nix + data/nix/tests/lang/eval-okay-attrs.exp + data/nix/tests/lang/eval-okay-attrs.nix + data/nix/tests/lang/eval-okay-autoargs.exp + data/nix/tests/lang/eval-okay-autoargs.flags + data/nix/tests/lang/eval-okay-autoargs.nix + data/nix/tests/lang/eval-okay-backslash-newline-1.exp + data/nix/tests/lang/eval-okay-backslash-newline-1.nix + data/nix/tests/lang/eval-okay-backslash-newline-2.exp + data/nix/tests/lang/eval-okay-backslash-newline-2.nix + data/nix/tests/lang/eval-okay-builtins-add.exp + data/nix/tests/lang/eval-okay-builtins-add.nix + data/nix/tests/lang/eval-okay-builtins.exp + data/nix/tests/lang/eval-okay-builtins.nix + data/nix/tests/lang/eval-okay-callable-attrs.exp + data/nix/tests/lang/eval-okay-callable-attrs.nix + data/nix/tests/lang/eval-okay-catattrs.exp + data/nix/tests/lang/eval-okay-catattrs.nix + data/nix/tests/lang/eval-okay-closure.exp.xml + data/nix/tests/lang/eval-okay-closure.nix + data/nix/tests/lang/eval-okay-comments.exp + data/nix/tests/lang/eval-okay-comments.nix + data/nix/tests/lang/eval-okay-concat.exp + data/nix/tests/lang/eval-okay-concatmap.exp + data/nix/tests/lang/eval-okay-concatmap.nix + data/nix/tests/lang/eval-okay-concat.nix + data/nix/tests/lang/eval-okay-concatstringssep.exp + data/nix/tests/lang/eval-okay-concatstringssep.nix + data/nix/tests/lang/eval-okay-context.exp + data/nix/tests/lang/eval-okay-context-introspection.exp + data/nix/tests/lang/eval-okay-context-introspection.nix + data/nix/tests/lang/eval-okay-context.nix + data/nix/tests/lang/eval-okay-curpos.exp + data/nix/tests/lang/eval-okay-curpos.nix + data/nix/tests/lang/eval-okay-deepseq.exp + data/nix/tests/lang/eval-okay-deepseq.nix + data/nix/tests/lang/eval-okay-delayed-with.exp + data/nix/tests/lang/eval-okay-delayed-with-inherit.exp + data/nix/tests/lang/eval-okay-delayed-with-inherit.nix + data/nix/tests/lang/eval-okay-delayed-with.nix + data/nix/tests/lang/eval-okay-dynamic-attrs-2.exp + data/nix/tests/lang/eval-okay-dynamic-attrs-2.nix + data/nix/tests/lang/eval-okay-dynamic-attrs-bare.exp + data/nix/tests/lang/eval-okay-dynamic-attrs-bare.nix + data/nix/tests/lang/eval-okay-dynamic-attrs.exp + data/nix/tests/lang/eval-okay-dynamic-attrs.nix + data/nix/tests/lang/eval-okay-elem.exp + data/nix/tests/lang/eval-okay-elem.nix + data/nix/tests/lang/eval-okay-empty-args.exp + data/nix/tests/lang/eval-okay-empty-args.nix + data/nix/tests/lang/eval-okay-eq-derivations.exp + data/nix/tests/lang/eval-okay-eq-derivations.nix + data/nix/tests/lang/eval-okay-eq.exp.disabled + data/nix/tests/lang/eval-okay-eq.nix + data/nix/tests/lang/eval-okay-filter.exp + data/nix/tests/lang/eval-okay-filter.nix + data/nix/tests/lang/eval-okay-flatten.exp + data/nix/tests/lang/eval-okay-flatten.nix + data/nix/tests/lang/eval-okay-float.exp + data/nix/tests/lang/eval-okay-float.nix + data/nix/tests/lang/eval-okay-fromjson.exp + data/nix/tests/lang/eval-okay-fromjson.nix + data/nix/tests/lang/eval-okay-fromTOML.exp + data/nix/tests/lang/eval-okay-fromTOML.nix + data/nix/tests/lang/eval-okay-functionargs.exp.xml + data/nix/tests/lang/eval-okay-functionargs.nix + data/nix/tests/lang/eval-okay-getattrpos.exp + data/nix/tests/lang/eval-okay-getattrpos.nix + data/nix/tests/lang/eval-okay-getattrpos-undefined.exp + data/nix/tests/lang/eval-okay-getattrpos-undefined.nix + data/nix/tests/lang/eval-okay-getenv.exp + data/nix/tests/lang/eval-okay-getenv.nix + data/nix/tests/lang/eval-okay-hash.exp + data/nix/tests/lang/eval-okay-hashfile.exp + data/nix/tests/lang/eval-okay-hashfile.nix + data/nix/tests/lang/eval-okay-hashstring.exp + data/nix/tests/lang/eval-okay-hashstring.nix + data/nix/tests/lang/eval-okay-if.exp + data/nix/tests/lang/eval-okay-if.nix + data/nix/tests/lang/eval-okay-import.exp + data/nix/tests/lang/eval-okay-import.nix + data/nix/tests/lang/eval-okay-ind-string.exp + data/nix/tests/lang/eval-okay-ind-string.nix + data/nix/tests/lang/eval-okay-let.exp + data/nix/tests/lang/eval-okay-let.nix + data/nix/tests/lang/eval-okay-list.exp + data/nix/tests/lang/eval-okay-list.nix + data/nix/tests/lang/eval-okay-listtoattrs.exp + data/nix/tests/lang/eval-okay-listtoattrs.nix + data/nix/tests/lang/eval-okay-logic.exp + data/nix/tests/lang/eval-okay-logic.nix + data/nix/tests/lang/eval-okay-mapattrs.exp + data/nix/tests/lang/eval-okay-mapattrs.nix + data/nix/tests/lang/eval-okay-map.exp + data/nix/tests/lang/eval-okay-map.nix + data/nix/tests/lang/eval-okay-nested-with.exp + data/nix/tests/lang/eval-okay-nested-with.nix + data/nix/tests/lang/eval-okay-new-let.exp + data/nix/tests/lang/eval-okay-new-let.nix + data/nix/tests/lang/eval-okay-null-dynamic-attrs.exp + data/nix/tests/lang/eval-okay-null-dynamic-attrs.nix + data/nix/tests/lang/eval-okay-overrides.exp + data/nix/tests/lang/eval-okay-overrides.nix + data/nix/tests/lang/eval-okay-partition.exp + data/nix/tests/lang/eval-okay-partition.nix + data/nix/tests/lang/eval-okay-pathexists.exp + data/nix/tests/lang/eval-okay-pathexists.nix + data/nix/tests/lang/eval-okay-path.nix + data/nix/tests/lang/eval-okay-patterns.exp + data/nix/tests/lang/eval-okay-patterns.nix + data/nix/tests/lang/eval-okay-readDir.exp + data/nix/tests/lang/eval-okay-readDir.nix + data/nix/tests/lang/eval-okay-readfile.exp + data/nix/tests/lang/eval-okay-readfile.nix + data/nix/tests/lang/eval-okay-redefine-builtin.exp + data/nix/tests/lang/eval-okay-redefine-builtin.nix + data/nix/tests/lang/eval-okay-regex-match.exp + data/nix/tests/lang/eval-okay-regex-match.nix + data/nix/tests/lang/eval-okay-regex-split.exp + data/nix/tests/lang/eval-okay-regex-split.nix + data/nix/tests/lang/eval-okay-remove.exp + data/nix/tests/lang/eval-okay-remove.nix + data/nix/tests/lang/eval-okay-replacestrings.exp + data/nix/tests/lang/eval-okay-replacestrings.nix + data/nix/tests/lang/eval-okay-scope-1.exp + data/nix/tests/lang/eval-okay-scope-1.nix + data/nix/tests/lang/eval-okay-scope-2.exp + data/nix/tests/lang/eval-okay-scope-2.nix + data/nix/tests/lang/eval-okay-scope-3.exp + data/nix/tests/lang/eval-okay-scope-3.nix + data/nix/tests/lang/eval-okay-scope-4.exp + data/nix/tests/lang/eval-okay-scope-4.nix + data/nix/tests/lang/eval-okay-scope-6.exp + data/nix/tests/lang/eval-okay-scope-6.nix + data/nix/tests/lang/eval-okay-scope-7.exp + data/nix/tests/lang/eval-okay-scope-7.nix + data/nix/tests/lang/eval-okay-search-path.exp + data/nix/tests/lang/eval-okay-search-path.flags + data/nix/tests/lang/eval-okay-search-path.nix + data/nix/tests/lang/eval-okay-seq.exp + data/nix/tests/lang/eval-okay-seq.nix + data/nix/tests/lang/eval-okay-sort.exp + data/nix/tests/lang/eval-okay-sort.nix + data/nix/tests/lang/eval-okay-splitversion.exp + data/nix/tests/lang/eval-okay-splitversion.nix + data/nix/tests/lang/eval-okay-string.exp + data/nix/tests/lang/eval-okay-string.nix + data/nix/tests/lang/eval-okay-strings-as-attrs-names.exp + data/nix/tests/lang/eval-okay-strings-as-attrs-names.nix + data/nix/tests/lang/eval-okay-substring.exp + data/nix/tests/lang/eval-okay-substring.nix + data/nix/tests/lang/eval-okay-tail-call-1.exp-disabled + data/nix/tests/lang/eval-okay-tail-call-1.nix + data/nix/tests/lang/eval-okay-tojson.exp + data/nix/tests/lang/eval-okay-tojson.nix + data/nix/tests/lang/eval-okay-toxml2.exp + data/nix/tests/lang/eval-okay-toxml2.nix + data/nix/tests/lang/eval-okay-toxml.exp + data/nix/tests/lang/eval-okay-toxml.nix + data/nix/tests/lang/eval-okay-tryeval.exp + data/nix/tests/lang/eval-okay-tryeval.nix + data/nix/tests/lang/eval-okay-types.exp + data/nix/tests/lang/eval-okay-types.nix + data/nix/tests/lang/eval-okay-versions.exp + data/nix/tests/lang/eval-okay-versions.nix + data/nix/tests/lang/eval-okay-with.exp + data/nix/tests/lang/eval-okay-with.nix + data/nix/tests/lang/eval-okay-xml.exp.xml + data/nix/tests/lang/eval-okay-xml.nix + data/nix/tests/lang/imported2.nix + data/nix/tests/lang/imported.nix + data/nix/tests/lang/lib.nix + data/nix/tests/lang/parse-fail-dup-attrs-1.nix + data/nix/tests/lang/parse-fail-dup-attrs-2.nix + data/nix/tests/lang/parse-fail-dup-attrs-3.nix + data/nix/tests/lang/parse-fail-dup-attrs-4.nix + data/nix/tests/lang/parse-fail-dup-attrs-7.nix + data/nix/tests/lang/parse-fail-dup-formals.nix + data/nix/tests/lang/parse-fail-mixed-nested-attrs1.nix + data/nix/tests/lang/parse-fail-mixed-nested-attrs2.nix + data/nix/tests/lang/parse-fail-patterns-1.nix + data/nix/tests/lang/parse-fail-regression-20060610.nix + data/nix/tests/lang/parse-fail-uft8.nix + data/nix/tests/lang/parse-fail-undef-var-2.nix + data/nix/tests/lang/parse-fail-undef-var.nix + data/nix/tests/lang/parse-okay-1.nix + data/nix/tests/lang/parse-okay-crlf.nix + data/nix/tests/lang/parse-okay-dup-attrs-5.nix + data/nix/tests/lang/parse-okay-dup-attrs-6.nix + data/nix/tests/lang/parse-okay-mixed-nested-attrs-1.nix + data/nix/tests/lang/parse-okay-mixed-nested-attrs-2.nix + data/nix/tests/lang/parse-okay-mixed-nested-attrs-3.nix + data/nix/tests/lang/parse-okay-regression-20041027.nix + data/nix/tests/lang/parse-okay-regression-751.nix + data/nix/tests/lang/parse-okay-subversion.nix + data/nix/tests/lang/parse-okay-url.nix + data/nix/tests/lang/readDir/bar + data/nix/tests/lang/readDir/foo/git-hates-directories + data/nix/tests/local.mk + data/nixpkgs-all-packages.nix + data/let-comments.nix + data/let-comments-multiline.nix + data/simple-pretty.nix + data/simple.nix + data/nixpkgs-all-packages-pretty.nix + data/let.nix + tests/eval-compare/builtins.appendContext.nix + tests/eval-compare/builtins.eq-bottom-00.nix + tests/eval-compare/builtins.fetchurl-01.nix + tests/eval-compare/builtins.fromJSON-01.nix + tests/eval-compare/builtins.getContext.nix + tests/eval-compare/builtins.lessThan-01.nix + tests/eval-compare/builtins.mapAttrs-01.nix + tests/eval-compare/builtins.pathExists.nix + tests/eval-compare/builtins.replaceStrings-01.nix + tests/eval-compare/builtins.split-01.nix + tests/eval-compare/builtins.split-02.nix + tests/eval-compare/builtins.split-03.nix + tests/eval-compare/builtins.split-04.nix + tests/eval-compare/builtins.string.store.nix + tests/eval-compare/builtins.toJSON.nix + tests/eval-compare/current-system.nix + tests/eval-compare/ellipsis.nix + tests/eval-compare/ind-string-01.nix + tests/eval-compare/ind-string-02.nix + tests/eval-compare/ind-string-03.nix + tests/eval-compare/ind-string-04.nix + tests/eval-compare/ind-string-05.nix + tests/eval-compare/ind-string-06.nix + tests/eval-compare/ind-string-07.nix + tests/eval-compare/ind-string-08.nix + tests/eval-compare/ind-string-09.nix + tests/eval-compare/ind-string-10.nix + tests/eval-compare/ind-string-11.nix + tests/eval-compare/ind-string-12.nix + tests/eval-compare/ind-string-13.nix + tests/eval-compare/ind-string-14.nix + tests/eval-compare/ind-string-15.nix + tests/eval-compare/ind-string-16.nix + tests/eval-compare/ind-string-17.nix + tests/eval-compare/paths-01.nix + tests/eval-compare/placeholder.nix + tests/files/attrs.nix + tests/files/callLibs.nix + tests/files/eighty.nix + tests/files/file.nix + tests/files/file2.nix + tests/files/findFile.nix + tests/files/force.nix + tests/files/goodbye.nix + tests/files/hello.nix + tests/files/hello2.nix + tests/files/if-then.nix + tests/files/lint.nix + tests/files/loop.nix + tests/files/test.nix + tests/files/with.nix source-repository head type: git @@ -332,7 +332,7 @@ flag optimize description: Enable all optimization flags manual: True - default: False + default: True flag profiling description: Enable profiling @@ -341,63 +341,71 @@ library exposed-modules: - Nix - Nix.Atoms - Nix.Builtins - Nix.Cache - Nix.Cited - Nix.Cited.Basic - Nix.Context - Nix.Convert - Nix.Effects - Nix.Effects.Basic - Nix.Effects.Derivation - Nix.Eval - Nix.Exec - Nix.Expr - Nix.Expr.Shorthands - Nix.Expr.Strings - Nix.Expr.Types - Nix.Expr.Types.Annotated - Nix.Frames - Nix.Fresh - Nix.Fresh.Basic - Nix.Json - Nix.Lint - Nix.Normal - Nix.Options - Nix.Parser - Nix.Pretty - Nix.Reduce - Nix.Render - Nix.Render.Frame - Nix.Scope - Nix.Standard - Nix.String - Nix.String.Coerce - Nix.TH - Nix.Thunk - Nix.Thunk.Basic - Nix.Type.Assumption - Nix.Type.Env - Nix.Type.Infer - Nix.Type.Type - Nix.Utils - Nix.Utils.Fix1 - Nix.Value - Nix.Value.Equal - Nix.Value.Monad - Nix.Var - Nix.XML + Nix + Nix.Atoms + Nix.Builtins + Nix.Cache + Nix.Cited + Nix.Cited.Basic + Nix.Context + Nix.Convert + Nix.Effects + Nix.Effects.Basic + Nix.Effects.Derivation + Nix.Eval + Nix.Exec + Nix.Expr + Nix.Expr.Shorthands + Nix.Expr.Strings + Nix.Expr.Types + Nix.Expr.Types.Annotated + Nix.Frames + Nix.Fresh + Nix.Fresh.Basic + Nix.Json + Nix.Lint + Nix.Normal + Nix.Options + Nix.Options.Parser + Nix.Parser + Nix.Pretty + Nix.Reduce + Nix.Render + Nix.Render.Frame + Nix.Scope + Nix.Standard + Nix.String + Nix.String.Coerce + Nix.TH + Nix.Thunk + Nix.Thunk.Basic + Nix.Type.Assumption + Nix.Type.Env + Nix.Type.Infer + Nix.Type.Type + Nix.Utils + Nix.Utils.Fix1 + Nix.Value + Nix.Value.Equal + Nix.Value.Monad + Nix.Var + Nix.XML other-modules: - Paths_hnix + Paths_hnix + autogen-modules: + Paths_hnix hs-source-dirs: - src + src + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude ghc-options: -Wall -fprint-potential-instances build-depends: aeson >= 1.4.2 && < 1.6 , array >= 0.4 && < 0.6 - , base >= 4.11 && < 5 + , base >= 4.12 && < 5 + , base16-bytestring >= 0.1.1 && < 1.1 , binary >= 0.8.5 && < 0.9 , bytestring >= 0.10.8 && < 0.11 , comonad >= 5.0.4 && < 5.1 @@ -414,7 +422,7 @@ , hashing >= 0.1.0 && < 0.2 , hnix-store-core >= 0.4.0 && < 0.5 , hnix-store-remote >= 0.4.0 && < 0.5 - , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.7 + , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.2 && < 0.13 , lens-family >= 1.2.2 && < 2.2 @@ -427,18 +435,26 @@ , mtl >= 2.2.2 && < 2.3 , neat-interpolation >= 0.4 && < 0.6 , optparse-applicative >= 0.14.3 && < 0.17 - , parser-combinators >= 1.0.1 && < 1.3 + , parser-combinators >= 1.0.1 && < 1.4 + , pretty-show >= 1.9.5 && < 1.11 , prettyprinter >= 1.7.0 && < 1.8 , process >= 1.6.3 && < 1.7 - , ref-tf >= 0.4.0 && < 0.5 + , ref-tf >= 0.5 && < 0.6 , regex-tdfa >= 1.2.3 && < 1.4 + , relude >= 0.7.0 && < 1.1.0 , scientific >= 0.3.6 && < 0.4 - , semialign >= 1 && < 1.2 - , semialign-indexed >= 1 && < 1.2 + , semialign >= 1 && < 1.3 + , serialise >= 0.2.1 && < 0.3 , some >= 1.0.1 && < 1.1 , split >= 0.2.3 && < 0.3 , syb >= 0.7 && < 0.8 - , template-haskell >= 2.13 && < 2.17 + , template-haskell >= 2.13 && < 2.18 + -- provides: + -- * compat instances for old versions of TH for old GHCs + -- * orphan instances for TH missing instances + -- aka Lift Text, Bytestring, Vector, Containers, + -- we use Lift Text particulrarly for GHC 8.6 + , th-lift-instances >= 0.1 && < 0.2 , text >= 1.2.3 && < 1.3 , these >= 1.0.1 && < 1.2 , time >= 1.8.0 && < 1.9 || >= 1.9.3 && < 1.10 @@ -448,33 +464,30 @@ , unordered-containers >= 0.2.9 && < 0.3 , vector >= 0.12.0 && < 0.13 , xml >= 1.3.14 && < 1.4 + default-extensions: + OverloadedStrings if flag(optimize) + default-extensions: + ApplicativeDo ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if !impl(ghcjs) - exposed-modules: - Nix.Options.Parser - build-depends: - base16-bytestring >= 0.1.1 && < 1.1 - , pretty-show >= 1.9.5 && < 1.11 - , serialise >= 0.2.1 && < 0.3 -- if !flag(profiling) -- build-depends: -- ghc-datasize default-language: Haskell2010 executable hnix + hs-source-dirs: + main main-is: Main.hs other-modules: - Repl - Paths_hnix - hs-source-dirs: - main - ghc-options: -Wall -rtsopts + Repl + Paths_hnix + autogen-modules: + Paths_hnix + ghc-options: -Wall build-depends: aeson , base - , base16-bytestring - , bytestring , comonad , containers , data-fix @@ -484,64 +497,67 @@ , free , haskeline >= 0.8.0.0 && < 0.9 , hnix - , mtl , optparse-applicative , pretty-show , prettyprinter , ref-tf + , relude , repline >= 0.4.0.0 && < 0.5 , serialise , template-haskell - , text , time - , transformers - , unordered-containers + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude + default-extensions: + OverloadedStrings if flag(optimize) + default-extensions: + ApplicativeDo ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 if impl(ghc < 8.10) -- GHC < 8.10 comes with haskeline < 0.8, which we don't support. -- To simplify CI, we just disable the component. buildable: False - if impl(ghcjs) - buildable: False default-language: Haskell2010 test-suite hnix-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - EvalTests - NixLanguageTests - ParserTests - PrettyParseTests - PrettyTests - ReduceExprTests - TestCommon - Paths_hnix + EvalTests + NixLanguageTests + ParserTests + PrettyParseTests + PrettyTests + ReduceExprTests + TestCommon + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude hs-source-dirs: - tests + tests ghc-options: -Wall -threaded build-depends: Diff , Glob , base - , base16-bytestring - , bytestring , containers , data-fix - , deepseq , directory , exceptions , filepath , hedgehog , hnix , megaparsec - , mtl , neat-interpolation , optparse-applicative , pretty-show , prettyprinter , process + , relude , split , tasty , tasty-hedgehog @@ -549,47 +565,44 @@ , tasty-th , serialise , template-haskell - , text , time - , transformers , unix - , unordered-containers + default-extensions: + OverloadedStrings if flag(optimize) + default-extensions: + ApplicativeDo ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if impl(ghcjs) - buildable: False default-language: Haskell2010 benchmark hnix-benchmarks type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - ParserBench - Paths_hnix + ParserBench hs-source-dirs: - benchmarks + benchmarks + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude ghc-options: -Wall build-depends: base - , base16-bytestring - , bytestring - , containers , criterion , data-fix - , deepseq , exceptions , filepath , hnix - , mtl , optparse-applicative + , relude , serialise , template-haskell - , text , time - , transformers - , unordered-containers + default-extensions: + OverloadedStrings if flag(optimize) + default-extensions: + ApplicativeDo ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if impl(ghcjs) - buildable: False default-language: Haskell2010 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -9,19 +9,19 @@ module Main where +import Nix.Utils import Control.Comonad ( extract ) import qualified Control.DeepSeq as Deep import qualified Control.Exception as Exc -import Control.Monad +import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.Catch +import System.IO ( hPutStrLn, getContents ) import Control.Monad.Free -import Control.Monad.IO.Class import qualified Data.HashMap.Lazy as M import qualified Data.Map as Map -import Data.List ( sortOn ) import Data.Maybe ( fromJust ) +import qualified Data.String as String import Data.Time -import qualified Data.Text as Text import qualified Data.Text.IO as Text import Nix import Nix.Convert @@ -33,203 +33,251 @@ import Nix.Thunk.Basic import qualified Nix.Type.Env as Env import qualified Nix.Type.Infer as HM -import Nix.Utils import Nix.Var import Nix.Value.Monad import Options.Applicative hiding ( ParserResult(..) ) -import Prettyprinter +import Prettyprinter hiding ( list ) import Prettyprinter.Render.Text import qualified Repl import System.FilePath -import System.IO import qualified Text.Show.Pretty as PS +import Nix.Utils.Fix1 ( Fix1T ) main :: IO () -main = do - time <- getCurrentTime - opts <- execParser (nixOptionsInfo time) - runWithBasicEffectsIO opts $ case readFrom opts of - Just path -> do - let file = addExtension (dropExtension path) "nixc" - process opts (Just file) =<< liftIO (readCache path) - Nothing -> case expression opts of - Just s -> handleResult opts Nothing (parseNixTextLoc s) - Nothing -> case fromFile opts of - Just "-" -> mapM_ (processFile opts) =<< (lines <$> liftIO getContents) - Just path -> - mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path)) - Nothing -> case filePaths opts of - [] -> withNixContext Nothing Repl.main - ["-"] -> - handleResult opts Nothing - . parseNixTextLoc - =<< liftIO Text.getContents - paths -> mapM_ (processFile opts) paths - where - processFile opts path = do - eres <- parseNixFileLoc path - handleResult opts (Just path) eres +main = + do + time <- getCurrentTime + opts <- execParser (nixOptionsInfo time) - handleResult opts mpath = \case - Failure err -> - (if ignoreErrors opts - then liftIO . hPutStrLn stderr - else errorWithoutStackTrace - ) - $ "Parse failed: " - ++ show err + runWithBasicEffectsIO opts $ execContentsFilesOrRepl opts - Success expr -> do - when (check opts) $ do - expr' <- liftIO (reduceExpr mpath expr) - case HM.inferTop Env.empty [("it", stripAnnotation expr')] of - Left err -> errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err - Right ty -> liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow - (fromJust (Map.lookup "it" (Env.types ty))) + where + execContentsFilesOrRepl opts = + maybe + (maybe + (maybe + (list + (withNixContext mempty Repl.main) -- run REPL + (\case + ["-"] -> handleResult opts mempty . parseNixTextLoc =<< liftIO Text.getContents + _paths -> traverse_ (processFile opts) _paths + ) + (filePaths opts) + ) + (\ x -> + -- We can start use Text as in the base case, requires changing FilePath -> Text + traverse_ (processFile opts) . String.lines =<< liftIO + (case x of + "-" -> getContents -- get user input + _path -> readFile _path + ) + ) + (fromFile opts) + ) + (handleResult opts mempty . parseNixTextLoc) + (expression opts) + ) + (\ path -> + do + let file = addExtension (dropExtension path) "nixc" + process opts (pure file) =<< liftIO (readCache path) + ) + (readFrom opts) - -- liftIO $ putStrLn $ runST $ - -- runLintM opts . renderSymbolic =<< lint opts expr + processFile opts path = + do + eres <- parseNixFileLoc path + handleResult opts (pure path) eres - catch (process opts mpath expr) $ \case - NixException frames -> + handleResult opts mpath = + either + (\ err -> + bool errorWithoutStackTrace - . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames + (liftIO . hPutStrLn stderr) + (ignoreErrors opts) + $ "Parse failed: " <> show err + ) - when (repl opts) $ - if evaluate opts - then do - val <- Nix.nixEvalExprLoc mpath expr - withNixContext Nothing (Repl.main' $ Just val) - else withNixContext Nothing Repl.main + (\ expr -> + do + when (check opts) $ + do + expr' <- liftIO (reduceExpr mpath expr) + either + (\ err -> errorWithoutStackTrace $ "Type error: " <> PS.ppShow err) + (\ ty -> liftIO $ putStrLn $ "Type of expression: " <> PS.ppShow + (fromJust $ Map.lookup "it" $ Env.types ty) + ) + (HM.inferTop Env.empty [("it", stripAnnotation expr')]) + -- liftIO $ putStrLn $ runST $ + -- runLintM opts . renderSymbolic =<< lint opts expr + + catch (process opts mpath expr) $ + \case + NixException frames -> + errorWithoutStackTrace . show =<< + renderFrames + @(StdValue (StandardT (StdIdT IO))) + @(StdThunk (StandardT (StdIdT IO))) + frames + + when (repl opts) $ + withNixContext mempty $ + bool + Repl.main + (do + val <- Nix.nixEvalExprLoc mpath expr + Repl.main' $ pure val + ) + (evaluate opts) + ) + process opts mpath expr - | evaluate opts - , tracing opts - = evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr - | evaluate opts - , Just path <- reduce opts - = evaluateExpression mpath (reduction path) printer expr - | evaluate opts - , not (null (arg opts) && null (argstr opts)) - = evaluateExpression mpath Nix.nixEvalExprLoc printer expr - | evaluate opts - = processResult printer =<< Nix.nixEvalExprLoc mpath expr - | xml opts - = error "Rendering expression trees to XML is not yet implemented" - | json opts - = error "Rendering expression trees to JSON is not implemented" - | verbose opts >= DebugInfo - = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr + | evaluate opts = + if + | tracing opts -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr + | Just path <- reduce opts -> evaluateExpression mpath (reduction path) printer expr + | not ( null (arg opts) + && null (argstr opts) + ) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr + | otherwise -> processResult printer =<< Nix.nixEvalExprLoc mpath expr + | xml opts = fail "Rendering expression trees to XML is not yet implemented" + | json opts = fail "Rendering expression trees to JSON is not implemented" + | verbose opts >= DebugInfo = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr | cache opts - , Just path <- mpath - = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr - | parseOnly opts - = void $ liftIO $ Exc.evaluate $ Deep.force expr - | otherwise - = liftIO - $ renderIO stdout - . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) - . prettyNix - . stripAnnotation - $ expr + , Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr + | parseOnly opts = void $ liftIO $ Exc.evaluate $ Deep.force expr + | otherwise = + liftIO $ + renderIO + stdout + . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) + . prettyNix + . stripAnnotation $ + expr where printer - | finder opts - = fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) >=> findAttrs - | xml opts - = liftIO - . putStrLn - . Text.unpack - . principledStringIgnoreContext - . toXML - <=< normalForm - | json opts - = liftIO - . Text.putStrLn - . principledStringIgnoreContext - <=< nvalueToJSONNixString - | strict opts - = liftIO . print . prettyNValue <=< normalForm - | values opts - = liftIO . print . prettyNValueProv <=< removeEffects - | otherwise - = liftIO . print . prettyNValue <=< removeEffects + | finder opts = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) + | xml opts = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm + | json opts = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString + | strict opts = liftIO . print . prettyNValue <=< normalForm + | values opts = liftIO . print . prettyNValueProv <=< removeEffects + | otherwise = liftIO . print . prettyNValue <=< removeEffects where findAttrs :: AttrSet (StdValue (StandardT (StdIdT IO))) -> StandardT (StdIdT IO) () - findAttrs = go "" + findAttrs = go mempty where - go prefix s = do - xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of - Free v -> pure (k, Just (Free v)) - Pure (StdThunk (extract -> Thunk _ _ ref)) -> do - let path = prefix ++ Text.unpack k - (_, descend) = filterEntry path k - val <- readVar @(StandardT (StdIdT IO)) ref - case val of - Computed _ -> pure (k, Nothing) - _ | descend -> (k, ) <$> forceEntry path nv - | otherwise -> pure (k, Nothing) + go prefix s = + do + xs <- + traverse + (\ (k, nv) -> + free + (\ (StdThunk (extract -> Thunk _ _ ref)) -> + do + let + path = prefix <> k + (_, descend) = filterEntry path k - forM_ xs $ \(k, mv) -> do - let path = prefix ++ Text.unpack k - (report, descend) = filterEntry path k - when report $ do - liftIO $ putStrLn path - when descend $ case mv of - Nothing -> pure () - Just v -> case v of - NVSet s' _ -> go (path ++ ".") s' - _ -> pure () + val <- readVar @(StandardT (StdIdT IO)) ref + case val of + Computed _ -> pure (k, Nothing) + _ -> + bool + (pure (k, Nothing)) + ((k, ) <$> forceEntry path nv) + descend + ) + (\ v -> pure (k, pure (Free v))) + nv + ) + (sortWith fst (M.toList s)) + traverse_ + (\ (k, mv) -> + do + let + path = prefix <> k + (report, descend) = filterEntry path k + when report $ + do + liftIO $ Text.putStrLn path + when descend $ + maybe + pass + (\case + NVSet s' _ -> go (path <> ".") s' + _ -> pass + ) + mv + ) + xs where filterEntry path k = case (path, k) of - ("stdenv", "stdenv" ) -> (True, True) + ("stdenv", "stdenv" ) -> (True , True ) (_ , "stdenv" ) -> (False, False) - (_ , "out" ) -> (True, False) - (_ , "src" ) -> (True, False) - (_ , "mirrorsFile" ) -> (True, False) - (_ , "buildPhase" ) -> (True, False) + (_ , "out" ) -> (True , False) + (_ , "src" ) -> (True , False) + (_ , "mirrorsFile" ) -> (True , False) + (_ , "buildPhase" ) -> (True , False) (_ , "builder" ) -> (False, False) (_ , "drvPath" ) -> (False, False) (_ , "outPath" ) -> (False, False) (_ , "__impureHostDeps") -> (False, False) (_ , "__sandboxProfile") -> (False, False) - ("pkgs" , "pkgs" ) -> (True, True) + ("pkgs" , "pkgs" ) -> (True , True ) (_ , "pkgs" ) -> (False, False) (_ , "drvAttrs" ) -> (False, False) - _ -> (True, True) + _ -> (True , True ) + forceEntry + :: MonadValue a (Fix1T StandardTF (StdIdT IO)) + => Text + -> a + -> Fix1T StandardTF (StdIdT IO) (Maybe a) forceEntry k v = - catch (Just <$> demand v pure) $ \(NixException frames) -> do - liftIO - . putStrLn - . ("Exception forcing " ++) - . (k ++) - . (": " ++) - . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames - pure Nothing + catch + (pure <$> demand v) + (\ (NixException frames) -> + do + liftIO + . Text.putStrLn + . (("Exception forcing " <> k <> ": ") <>) + . show =<< + renderFrames + @(StdValue (StandardT (StdIdT IO))) + @(StdThunk (StandardT (StdIdT IO))) + frames + pure Nothing + ) - reduction path mp x = do - eres <- Nix.withNixContext mp - $ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x - handleReduced path eres + reduction path mp x = + do + eres <- + Nix.withNixContext + mp + (Nix.reducingEvalExpr + (Eval.eval . annotated . getCompose) + mp + x + ) + handleReduced path eres handleReduced :: (MonadThrow m, MonadIO m) => FilePath -> (NExprLoc, Either SomeException (NValue t f m)) -> m (NValue t f m) - handleReduced path (expr', eres) = do - liftIO $ do - putStrLn $ "Wrote winnowed expression tree to " ++ path - writeFile path $ show $ prettyNix (stripAnnotation expr') - case eres of - Left err -> throwM err - Right v -> pure v + handleReduced path (expr', eres) = + do + liftIO $ + do + putStrLn $ "Wrote winnowed expression tree to " <> path + writeFile path $ show $ prettyNix (stripAnnotation expr') + either + throwM + pure + eres diff --git a/main/Repl.hs b/main/Repl.hs --- a/main/Repl.hs +++ b/main/Repl.hs @@ -9,10 +9,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -27,25 +24,23 @@ ) import Nix.Scope import Nix.Utils -import Nix.Value.Monad (demand) +import Nix.Value.Monad ( demand ) -import qualified Data.List -import qualified Data.Maybe import qualified Data.HashMap.Lazy -import Data.Text (Text) -import qualified Data.Text -import qualified Data.Text.IO +import Data.Char ( isSpace ) +import Data.List ( dropWhileEnd ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Data.Version ( showVersion ) import Paths_hnix ( version ) import Control.Monad.Catch -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State.Strict -import Prettyprinter (Doc, (<+>)) +import Prettyprinter ( Doc + , space + ) import qualified Prettyprinter -import qualified Prettyprinter.Render.Text +import qualified Prettyprinter.Render.Text as Prettyprinter import System.Console.Haskeline.Completion ( Completion(isFinished) @@ -55,13 +50,15 @@ ) import System.Console.Repline ( Cmd , CompletionFunc - , CompleterStyle (Prefix) + , CompleterStyle(Prefix) + , MultiLine(SingleLine, MultiLine) , ExitDecision(Exit) , HaskelineT + , evalRepl ) -import qualified System.Console.Repline -import qualified System.Exit -import qualified System.IO.Error +import qualified System.Console.Repline as Console +import qualified System.Exit as Exit +import qualified System.IO.Error as Error -- | Repl entry point main :: (MonadNix e t f m, MonadIO m, MonadMask m) => m () @@ -71,43 +68,57 @@ -- -- Passed value is stored in context with "input" key. main' :: (MonadNix e t f m, MonadIO m, MonadMask m) => Maybe (NValue t f m) -> m () -main' iniVal = initState iniVal >>= \s -> flip evalStateT s - $ System.Console.Repline.evalRepl +main' iniVal = + do + s <- initState iniVal + + evalStateT + (evalRepl banner - cmd + (cmd . toText) options - (Just commandPrefix) - (Just "paste") + (pure commandPrefix) + (pure "paste") completion - (rcFile >> greeter) + (rcFile *> greeter) finalizer + ) + s where commandPrefix = ':' banner = pure . \case - System.Console.Repline.SingleLine -> "hnix> " - System.Console.Repline.MultiLine -> "| " + SingleLine -> "hnix> " + MultiLine -> "| " greeter = - liftIO - $ putStrLn - $ "Welcome to hnix " - <> showVersion version - <> ". For help type :help\n" + liftIO $ + putStrLn $ + "Welcome to hnix " + <> showVersion version + <> ". For help type :help\n" finalizer = do liftIO $ putStrLn "Goodbye." pure Exit - rcFile = do - f <- liftIO $ Data.Text.IO.readFile ".hnixrc" `catch` handleMissing - forM_ (map (words . Data.Text.unpack) $ Data.Text.lines f) $ \case - ((prefix:command) : xs) | prefix == commandPrefix -> do - let arguments = unwords xs - optMatcher command options arguments - x -> cmd $ unwords x + rcFile = + do + f <- liftIO $ Text.readFile ".hnixrc" `catch` handleMissing + traverse_ + (\case + (prefixedCommand : xs) | Text.head prefixedCommand == commandPrefix -> + do + let + arguments = Text.unwords xs + command = Text.tail prefixedCommand + optMatcher command options arguments + x -> cmd $ Text.unwords x + ) + (Text.words <$> lines f) + handleMissing e - | System.IO.Error.isDoesNotExistError e = pure "" + | Error.isDoesNotExistError e = pure "" | otherwise = throwIO e -- Replicated and slightly adjusted `optMatcher` from `System.Console.Repline` @@ -115,18 +126,17 @@ -- * @MonadIO m@ instead of @MonadHaskeline m@ -- * @putStrLn@ instead of @outputStrLn@ optMatcher :: MonadIO m - => String - -> System.Console.Repline.Options m - -> String + => Text + -> Console.Options m + -> Text -> m () - optMatcher s [] _ = liftIO $ putStrLn $ "No such command :" ++ s + optMatcher s [] _ = liftIO $ Text.putStrLn $ "No such command :" <> s optMatcher s ((x, m) : xs) args - | s `Data.List.isPrefixOf` x = m args + | s `Text.isPrefixOf` toText x = m $ toString args | otherwise = optMatcher s xs args ---------------------------------------------------------------------------------- + -- * Types ---------------------------------------------------------------------------------- data IState t f m = IState { replIt :: Maybe NExprLoc -- ^ Last expression entered @@ -155,25 +165,28 @@ opts :: Nix.Options <- asks (view hasLens) - pure $ IState - Nothing - (Data.HashMap.Lazy.fromList - $ ("builtins", builtins) : fmap ("input",) (Data.Maybe.maybeToList mIni)) - defReplConfig - { cfgStrict = strict opts - , cfgValues = values opts - } + pure $ + IState + Nothing + (Data.HashMap.Lazy.fromList $ + ("builtins", builtins) : fmap ("input",) (maybeToList mIni) + ) + defReplConfig + { cfgStrict = strict opts + , cfgValues = values opts + } where evalText :: (MonadNix e t f m) => Text -> m (NValue t f m) - evalText expr = case parseNixTextLoc expr of - Failure e -> error $ "Impossible happened: Unable to parse expression - '" ++ Data.Text.unpack expr ++ "' error was " ++ show e - Success e -> do evalExprLoc e + evalText expr = + either + (\ e -> fail $ toString $ "Impossible happened: Unable to parse expression - '" <> expr <> "' fail was " <> show e) + evalExprLoc + (parseNixTextLoc expr) type Repl e t f m = HaskelineT (StateT (IState t f m) m) ---------------------------------------------------------------------------------- + -- * Execution ---------------------------------------------------------------------------------- exec :: forall e t f m @@ -189,10 +202,10 @@ -- Parser ( returns AST as `NExprLoc` ) case parseExprOrBinding source of - (Failure err, _) -> do + (Left err, _) -> do liftIO $ print err pure Nothing - (Success expr, isBinding) -> do + (Right expr, isBinding) -> do -- Type Inference ( returns Typing Environment ) -- @@ -204,22 +217,24 @@ mVal <- lift $ lift $ try $ pushScope (replCtx st) (evalExprLoc expr) - case mVal of - Left (NixException frames) -> do + either + (\ (NixException frames) -> do lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames - pure Nothing - Right val -> do + pure Nothing) + (\ val -> do -- Update the interpreter state when (update && isBinding) $ do -- Set `replIt` to last entered expression - put st { replIt = Just expr } + put st { replIt = pure expr } -- If the result value is a set, update our context with it case val of NVSet xs _ -> put st { replCtx = Data.HashMap.Lazy.union xs (replCtx st) } - _ -> pure () + _ -> pass - pure $ Just val + pure $ pure val + ) + mVal where -- If parsing fails, turn the input into singleton attribute set -- and try again. @@ -227,109 +242,121 @@ -- This allows us to handle assignments like @a = 42@ -- which get turned into @{ a = 42; }@ parseExprOrBinding i = - case parseNixTextLoc i of - Success expr -> (Success expr, False) - Failure e -> - case parseNixTextLoc $ toAttrSet i of - Failure _ -> (Failure e, False) -- return the first parsing failure - Success e' -> (Success e', True) + either + (\ e -> + either + (const (Left e, False)) -- return the first parsing failure + (\ e' -> (pure e', True)) + (parseNixTextLoc $ toAttrSet i)) + (\ expr -> (pure expr, False)) + (parseNixTextLoc i) - toAttrSet i = "{" <> i <> (if Data.Text.isSuffixOf ";" i then mempty else ";") <> "}" + toAttrSet i = + "{" <> i <> bool ";" mempty (Text.isSuffixOf ";" i) <> "}" cmd :: (MonadNix e t f m, MonadIO m) - => String + => Text -> Repl e t f m () -cmd source = do - mVal <- exec True (Data.Text.pack source) - case mVal of - Nothing -> pure () - Just val -> printValue val +cmd source = + do + mVal <- exec True source + maybe + pass + printValue + mVal printValue :: (MonadNix e t f m, MonadIO m) => NValue t f m -> Repl e t f m () printValue val = do cfg <- replCfg <$> get - lift $ lift $ do - if - | cfgStrict cfg -> liftIO . print . prettyNValue =<< normalForm val - | cfgValues cfg -> liftIO . print . prettyNValueProv =<< removeEffects val - | otherwise -> liftIO . print . prettyNValue =<< removeEffects val + lift $ lift $ + (if + | cfgStrict cfg -> liftIO . print . prettyNValue <=< normalForm + | cfgValues cfg -> liftIO . print . prettyNValueProv <=< removeEffects + | otherwise -> liftIO . print . prettyNValue <=< removeEffects + ) val ---------------------------------------------------------------------------------- + -- * Commands ---------------------------------------------------------------------------------- --- :browse command +-- | @:browse@ command browse :: (MonadNix e t f m, MonadIO m) - => String + => Text -> Repl e t f m () browse _ = do st <- get - forM_ (Data.HashMap.Lazy.toList $ replCtx st) $ \(k, v) -> do - liftIO $ putStr $ Data.Text.unpack $ k <> " = " + for_ (Data.HashMap.Lazy.toList $ replCtx st) $ \(k, v) -> do + liftIO $ Text.putStr $ k <> " = " printValue v --- :load command +-- | @:load@ command load :: (MonadNix e t f m, MonadIO m) + -- This one does I String -> O String pretty fast, it is ugly to double marshall here. => String -> Repl e t f m () -load args = do - contents <- liftIO - $ Data.Text.IO.readFile - $ Data.Text.unpack - $ Data.Text.strip - $ Data.Text.pack args - void $ exec True contents +load args = + do + contents <- liftIO $ + Text.readFile $ + trim args + void $ exec True contents + where + trim = dropWhileEnd isSpace . dropWhile isSpace --- :type command +-- | @:type@ command typeof :: (MonadNix e t f m, MonadIO m) - => String + => Text -> Repl e t f m () typeof args = do st <- get - mVal <- case Data.HashMap.Lazy.lookup line (replCtx st) of - Just val -> pure $ Just val - Nothing -> do - exec False line + mVal <- + maybe + (exec False line) + (pure . pure) + (Data.HashMap.Lazy.lookup line (replCtx st)) - forM_ mVal $ \val -> do - s <- lift . lift . showValueType $ val - liftIO $ putStrLn s + traverse_ printValueType mVal - where line = Data.Text.pack args + where + line = args + printValueType val = + do + s <- lift . lift . showValueType $ val + liftIO $ Text.putStrLn s --- :quit command + +-- | @:quit@ command quit :: (MonadNix e t f m, MonadIO m) => a -> Repl e t f m () -quit _ = liftIO System.Exit.exitSuccess +quit _ = liftIO Exit.exitSuccess --- :set command -setConfig :: (MonadNix e t f m, MonadIO m) => String -> Repl e t f m () -setConfig args = case words args of - [] -> liftIO $ putStrLn "No option to set specified" - (x:_xs) -> - case filter ((==x) . helpSetOptionName) helpSetOptions of - [opt] -> modify (\s -> s { replCfg = helpSetOptionFunction opt (replCfg s) }) - _ -> liftIO $ putStrLn "No such option" +-- | @:set@ command +setConfig :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () +setConfig args = + case Text.words args of + [] -> liftIO $ Text.putStrLn "No option to set specified" + (x:_xs) -> + case filter ((==x) . helpSetOptionName) helpSetOptions of + [opt] -> modify (\s -> s { replCfg = helpSetOptionFunction opt (replCfg s) }) + _ -> liftIO $ Text.putStrLn "No such option" ---------------------------------------------------------------------------------- + -- * Interactive Shell ---------------------------------------------------------------------------------- --- Prefix tab completer +-- | Prefix tab completer defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] defaultMatcher = - [ (":load", System.Console.Repline.fileCompleter) + [ (":load", Console.fileCompleter) ] completion :: (MonadNix e t f m, MonadIO m) => CompleterStyle (StateT (IState t f m) m) completion = System.Console.Repline.Prefix - (completeWordWithPrev (Just '\\') separators completeFunc) + (completeWordWithPrev (pure '\\') separators completeFunc) defaultMatcher where separators :: String @@ -341,76 +368,89 @@ -- adjusted to monadic variant able to `demand` thunks. completeFunc :: forall e t f m . (MonadNix e t f m, MonadIO m) + -- 2021-04-02: So far conversiton to Text here is not productive, + -- since Haskeline uses String of all this. => String -> String -> (StateT (IState t f m) m) [Completion] completeFunc reversedPrev word -- Commands - | reversedPrev == ":" - = pure . listCompletion - $ map helpOptionName (helpOptions :: HelpOptions e t f m) + | reversedPrev == ":" = + pure . listCompletion $ + toString . helpOptionName <$> + (helpOptions :: HelpOptions e t f m) -- Files - | any (`Data.List.isPrefixOf` word) [ "/", "./", "../", "~/" ] - = listFiles word + | any (`isPrefixOf` word) [ "/", "./", "../", "~/" ] = + listFiles word -- Attributes of sets in REPL context - | var : subFields <- Data.Text.split (== '.') (Data.Text.pack word) - , not $ null subFields - = do - s <- get - case Data.HashMap.Lazy.lookup var (replCtx s) of - Nothing -> pure [] - Just binding -> do - candidates <- lift $ algebraicComplete subFields binding - pure - $ map notFinished - $ listCompletion (Data.Text.unpack . (var <>) <$> candidates) + | var : subFields <- Text.split (== '.') (toText word) , not $ null subFields = + do + s <- get + maybe + stub + (\ binding -> + do + candidates <- lift $ algebraicComplete subFields binding + pure $ + notFinished <$> + listCompletion + (toString . (var <>) <$> + candidates + ) + ) + (Data.HashMap.Lazy.lookup var (replCtx s)) -- Builtins, context variables - | otherwise - = do - s <- get - let contextKeys = Data.HashMap.Lazy.keys (replCtx s) - (Just (NVSet builtins _)) = Data.HashMap.Lazy.lookup "builtins" (replCtx s) - shortBuiltins = Data.HashMap.Lazy.keys builtins + | otherwise = + do + s <- get + let contextKeys = Data.HashMap.Lazy.keys (replCtx s) + (Just (NVSet builtins _)) = Data.HashMap.Lazy.lookup "builtins" (replCtx s) + shortBuiltins = Data.HashMap.Lazy.keys builtins - pure $ listCompletion - $ ["__includes"] - ++ (Data.Text.unpack <$> contextKeys) - ++ (Data.Text.unpack <$> shortBuiltins) + pure $ listCompletion $ toString <$> + ["__includes"] + <> contextKeys + <> shortBuiltins where - listCompletion = map simpleCompletion . filter (word `Data.List.isPrefixOf`) + listCompletion = fmap simpleCompletion . filter (word `isPrefixOf`) notFinished x = x { isFinished = False } - algebraicComplete :: (MonadNix e t f m) - => [Text] - -> NValue t f m - -> m [Text] + algebraicComplete + :: (MonadNix e t f m) + => [Text] + -> NValue t f m + -> m [Text] algebraicComplete subFields val = - let keys = fmap ("." <>) . Data.HashMap.Lazy.keys - withMap m = - case subFields of - [] -> pure $ keys m - -- Stop on last subField (we care about the keys at this level) - [_] -> pure $ keys m - f:fs -> - case Data.HashMap.Lazy.lookup f m of - Nothing -> pure [] - Just e -> - demand e - (\e' -> fmap (("." <> f) <>) <$> algebraicComplete fs e') + let + keys = fmap ("." <>) . Data.HashMap.Lazy.keys - in case val of + withMap m = + case subFields of + [] -> pure $ keys m + -- Stop on last subField (we care about the keys at this level) + [_] -> pure $ keys m + f:fs -> + maybe + stub + ((<<$>>) + (("." <> f) <>) + . algebraicComplete fs <=< demand + ) + (Data.HashMap.Lazy.lookup f m) + in + case val of NVSet xs _ -> withMap xs - _ -> pure [] + _ -> stub --- HelpOption inspired by Dhall Repl +-- | HelpOption inspired by Dhall Repl -- with `Doc` instead of String for syntax and doc data HelpOption e t f m = HelpOption - { helpOptionName :: String + { helpOptionName :: Text , helpOptionSyntax :: Doc () , helpOptionDoc :: Doc () , helpOptionFunction :: Cmd (Repl e t f m) @@ -424,7 +464,7 @@ "help" "" "Print help text" - (help helpOptions) + (help helpOptions . toText) , HelpOption "paste" "" @@ -439,12 +479,12 @@ "browse" "" "Browse bindings in interpreter context" - browse + (browse . toText) , HelpOption "type" "EXPRESSION" "Evaluate expression or binding from context and print the type of the result value" - typeof + (typeof . toText) , HelpOption "quit" "" @@ -453,18 +493,18 @@ , HelpOption "set" "" - ( "Set REPL option" + ("Set REPL option" <> Prettyprinter.line <> "Available options:" <> Prettyprinter.line <> renderSetOptions helpSetOptions ) - setConfig + (setConfig . toText) ] --- Options for :set +-- | Options for :set data HelpSetOption = HelpSetOption - { helpSetOptionName :: String + { helpSetOptionName :: Text , helpSetOptionSyntax :: Doc () , helpSetOptionDoc :: Doc () , helpSetOptionFunction :: ReplConfig -> ReplConfig @@ -506,34 +546,33 @@ renderSetOptions :: [HelpSetOption] -> Doc () renderSetOptions so = - Prettyprinter.indent 4 - $ Prettyprinter.vsep - $ flip map so - $ \h -> - Prettyprinter.pretty (helpSetOptionName h) - <+> helpSetOptionSyntax h - <> Prettyprinter.line - <> Prettyprinter.indent 4 (helpSetOptionDoc h) + Prettyprinter.indent 4 $ + Prettyprinter.vsep $ + (\h -> + Prettyprinter.pretty (helpSetOptionName h) <> space + <> helpSetOptionSyntax h + <> Prettyprinter.line + <> Prettyprinter.indent 4 (helpSetOptionDoc h) + ) <$> so help :: (MonadNix e t f m, MonadIO m) => HelpOptions e t f m - -> String + -> Text -> Repl e t f m () help hs _ = do liftIO $ putStrLn "Available commands:\n" - forM_ hs $ \h -> - liftIO - . Data.Text.IO.putStrLn - . Prettyprinter.Render.Text.renderStrict - . Prettyprinter.layoutPretty - Prettyprinter.defaultLayoutOptions - $ ":" - <> Prettyprinter.pretty (helpOptionName h) - <+> helpOptionSyntax h - <> Prettyprinter.line - <> Prettyprinter.indent 4 (helpOptionDoc h) + for_ hs $ \h -> + liftIO . + Text.putStrLn . + Prettyprinter.renderStrict . + Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions $ + ":" + <> Prettyprinter.pretty (helpOptionName h) <> space + <> helpOptionSyntax h + <> Prettyprinter.line + <> Prettyprinter.indent 4 (helpOptionDoc h) options :: (MonadNix e t f m, MonadIO m) - => System.Console.Repline.Options (Repl e t f m) -options = (\h -> (helpOptionName h, helpOptionFunction h)) <$> helpOptions + => Console.Options (Repl e t f m) +options = (\h -> (toString $ helpOptionName h, helpOptionFunction h)) <$> helpOptions diff --git a/src/Nix.hs b/src/Nix.hs --- a/src/Nix.hs +++ b/src/Nix.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -28,10 +27,9 @@ ) where -import Control.Applicative -import Control.Arrow ( second ) -import Control.Monad.Reader -import Data.Fix +import Relude.Unsafe ( (!!) ) +import GHC.Err ( errorWithoutStackTrace ) +import Data.Fix ( Fix ) import qualified Data.HashMap.Lazy as M import qualified Data.Text as Text import qualified Data.Text.Read as Text @@ -81,10 +79,11 @@ => Maybe FilePath -> NExprLoc -> m (NValue t f m) -nixEvalExprLoc mpath = nixEval - mpath - (Eval.addStackFrames . Eval.addSourcePositions) - (Eval.eval . annotated . getCompose) +nixEvalExprLoc mpath = + nixEval + mpath + (Eval.addStackFrames . Eval.addSourcePositions) + (Eval.eval . annotated . getCompose) -- | Evaluate a nix expression with tracing in the default context. Note that -- this function doesn't do any tracing itself, but 'evalExprLoc' will be @@ -105,23 +104,31 @@ -> (NValue t f m -> m a) -> NExprLoc -> m a -evaluateExpression mpath evaluator handler expr = do - opts :: Options <- asks (view hasLens) - args <- traverse (traverse eval') $ map (second parseArg) (arg opts) ++ map - (second mkStr) - (argstr opts) - evaluator mpath expr >>= \f -> demand f $ \f' -> - processResult handler =<< case f' of - NVClosure _ g -> g (argmap args) - _ -> pure f +evaluateExpression mpath evaluator handler expr = + do + opts :: Options <- asks $ view hasLens + args <- + (traverse . traverse) + eval' + $ (second parseArg <$> arg opts) <> + (second mkStr <$> argstr opts) + f <- evaluator mpath expr + f' <- demand f + val <- + case f' of + NVClosure _ g -> g $ argmap args + _ -> pure f + processResult handler val where - parseArg s = case parseNixText s of - Success x -> x - Failure err -> errorWithoutStackTrace (show err) + parseArg s = + either + (errorWithoutStackTrace . show) + id + (parseNixText s) eval' = normalForm <=< nixEvalExpr mpath - argmap args = nvSet (M.fromList args) mempty + argmap args = nvSet mempty (M.fromList args) processResult :: forall e t f m a @@ -131,35 +138,33 @@ -> m a processResult h val = do opts :: Options <- asks (view hasLens) - case attr opts of - Nothing -> h val - Just (Text.splitOn "." -> keys) -> go keys val + maybe + (h val) + (\ (Text.splitOn "." -> keys) -> go keys val) + (attr opts) where go :: [Text.Text] -> NValue t f m -> m a go [] v = h v - go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case - NVList xs -> case ks of - [] -> h (xs !! n) - _ -> go ks (xs !! n) - _ -> - errorWithoutStackTrace - $ "Expected a list for selector '" - ++ show n - ++ "', but got: " - ++ show v - go (k : ks) v = demand v $ \case - NVSet xs _ -> case M.lookup k xs of - Nothing -> - errorWithoutStackTrace - $ "Set does not contain key '" - ++ Text.unpack k - ++ "'" - Just v' -> case ks of - [] -> h v' - _ -> go ks v' - _ -> - errorWithoutStackTrace - $ "Expected a set for selector '" - ++ Text.unpack k - ++ "', but got: " - ++ show v + go ((Text.decimal -> Right (n,"")) : ks) v = + (\case + NVList xs -> + list + h + go + ks + (xs !! n) + _ -> errorWithoutStackTrace $ "Expected a list for selector '" <> show n <> "', but got: " <> show v + ) =<< demand v + go (k : ks) v = + (\case + NVSet xs _ -> + maybe + (errorWithoutStackTrace $ toString $ "Set does not contain key '" <> k <> "'") + (list + h + go + ks + ) + (M.lookup k xs) + _ -> errorWithoutStackTrace $ toString $ "Expected a set for selector '" <> k <> "', but got: " <> show v + ) =<< demand v diff --git a/src/Nix/Atoms.hs b/src/Nix/Atoms.hs --- a/src/Nix/Atoms.hs +++ b/src/Nix/Atoms.hs @@ -2,25 +2,30 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Nix.Atoms where #ifdef MIN_VERSION_serialise -import Codec.Serialise +import Codec.Serialise ( Serialise ) #endif -import Control.DeepSeq -import Data.Data -import Data.Fixed (mod') -import Data.Hashable -import Data.Text ( Text - , pack + +import Data.Data ( Data) +import Data.Fixed ( mod' ) +import Data.Binary ( Binary ) +import Data.Aeson.Types ( FromJSON + , ToJSON ) -import GHC.Generics --- | Atoms are values that evaluate to themselves. This means that +-- | Atoms are values that evaluate to themselves. +-- In other words - this is a constructors that are literals in Nix. +-- This means that -- they appear in both the parsed AST (in the form of literals) and --- the evaluated form. +-- the evaluated form as themselves. +-- Once HNix parsed or evaluated into atom - that is a literal +-- further after, for any further evaluation it is in all cases stays +-- constantly itself. +-- "atom", Ancient Greek \( atomos \) - "indivisible" particle, +-- indivisible expression. data NAtom -- | An URI like @https://example.com@. = NURI Text @@ -33,21 +38,37 @@ | NBool Bool -- | Null values. There's only one of this variant: @null@. | NNull - deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData, - Hashable) + deriving + ( Eq + , Ord + , Generic + , Typeable + , Data + , Show + , Read + , NFData + , Hashable + ) #ifdef MIN_VERSION_serialise instance Serialise NAtom #endif --- | Translate an atom into its nix representation. +instance Binary NAtom +instance ToJSON NAtom +instance FromJSON NAtom + +-- | Translate an atom into its Nix representation. atomText :: NAtom -> Text atomText (NURI t) = t -atomText (NInt i) = pack (show i) -atomText (NFloat f) = pack (showNixFloat f) +atomText (NInt i) = show i +atomText (NFloat f) = showNixFloat f where - showNixFloat x - | x `mod'` 1 /= 0 = show x - | otherwise = show (truncate x :: Int) + showNixFloat :: Float -> Text + showNixFloat x = + bool + (show x) + (show (truncate x :: Int)) + (x `mod'` 1 == 0) atomText (NBool b) = if b then "true" else "false" atomText NNull = "null" diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -8,1521 +8,1937 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- | Code that implements Nix builtins. Lists the functions that are built into the Nix expression evaluator. Some built-ins (aka `derivation`), are always in the scope, so they can be accessed by the name. To keap the namespace clean, most built-ins are inside the `builtins` scope - a set that contains all what is a built-in. -module Nix.Builtins (withNixContext, builtins) where - -import Control.Comonad -import Control.Monad -import Control.Monad.Catch -import Control.Monad.ListM ( sortByM ) -import Control.Monad.Reader ( asks ) -import Crypto.Hash -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.Hash.SHA512 as SHA512 -import qualified Data.Aeson as A -import Data.Align ( alignWith ) -import Data.Array -import Data.Bits -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as B -import Data.ByteString.Base16 as Base16 -import Data.Char ( isDigit ) -import Data.Fix ( foldFix ) -import Data.Foldable ( foldrM ) -import qualified Data.HashMap.Lazy as M -import Data.List -import Data.Maybe -import Data.Scientific -import Data.Set ( Set ) -import qualified Data.Set as S -import Data.Text ( Text ) -import qualified Data.Text as Text -import Data.Text.Encoding -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Builder as Builder -import Data.These ( fromThese ) -import qualified Data.Time.Clock.POSIX as Time -import Data.Traversable ( for ) -import qualified Data.Vector as V -import NeatInterpolation ( text ) -import Nix.Atoms -import Nix.Convert -import Nix.Effects -import Nix.Effects.Basic ( fetchTarball ) -import qualified Nix.Eval as Eval -import Nix.Exec -import Nix.Expr.Types -import Nix.Expr.Types.Annotated -import Nix.Frames -import Nix.Json -import Nix.Normal -import Nix.Options -import Nix.Parser hiding ( nixPath ) -import Nix.Render -import Nix.Scope -import Nix.String -import Nix.String.Coerce -import Nix.Utils -import Nix.Value -import Nix.Value.Equal -import Nix.Value.Monad -import Nix.XML -import System.Nix.Base32 as Base32 -import System.FilePath -import System.Posix.Files ( isRegularFile - , isDirectory - , isSymbolicLink - ) -import Text.Read -import Text.Regex.TDFA - --- | Evaluate a nix expression in the default context -withNixContext - :: forall e t f m r - . (MonadNix e t f m, Has e Options) - => Maybe FilePath - -> m r - -> m r -withNixContext mpath action = do - base <- builtins - opts :: Options <- asks (view hasLens) - let i = nvList $ map - ( nvStr - . hackyMakeNixStringWithoutContext - . Text.pack - ) - (include opts) - pushScope (M.singleton "__includes" i) $ pushScopes base $ case mpath of - Nothing -> action - Just path -> do - traceM $ "Setting __cur_file = " ++ show path - let ref = nvPath path - pushScope (M.singleton "__cur_file" ref) action - -builtins :: (MonadNix e t f m, Scoped (NValue t f m) m) - => m (Scopes m (NValue t f m)) -builtins = do - ref <- defer $ flip nvSet M.empty <$> buildMap - lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins - pushScope (M.fromList lst) currentScopes - where - buildMap = M.fromList . map mapping <$> builtinsList - topLevelBuiltins = map mapping <$> fullBuiltinsList - - fullBuiltinsList = map go <$> builtinsList - where - go b@(Builtin TopLevel _) = b - go (Builtin Normal (name, builtin)) = - Builtin TopLevel ("__" <> name, builtin) - -data BuiltinType = Normal | TopLevel -data Builtin v = Builtin - { _kind :: BuiltinType - , mapping :: (Text, v) - } - -builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] -builtinsList = sequence - [ do - version <- toValue (principledMakeNixStringWithoutContext "2.3") - pure $ Builtin Normal ("nixVersion", version) - , do - version <- toValue (5 :: Int) - pure $ Builtin Normal ("langVersion", version) - - , add TopLevel "abort" throw_ -- for now - , add2 Normal "add" add_ - , add2 Normal "addErrorContext" addErrorContext - , add2 Normal "all" all_ - , add2 Normal "any" any_ - , add2 Normal "appendContext" appendContext - , add Normal "attrNames" attrNames - , add Normal "attrValues" attrValues - , add TopLevel "baseNameOf" baseNameOf - , add2 Normal "bitAnd" bitAnd - , add2 Normal "bitOr" bitOr - , add2 Normal "bitXor" bitXor - , add0 Normal "builtins" builtinsBuiltin - , add2 Normal "catAttrs" catAttrs - , add2 Normal "compareVersions" compareVersions_ - , add Normal "concatLists" concatLists - , add2 Normal "concatMap" concatMap_ - , add' Normal "concatStringsSep" (arity2 principledIntercalateNixString) - , add0 Normal "currentSystem" currentSystem - , add0 Normal "currentTime" currentTime_ - , add2 Normal "deepSeq" deepSeq - - -- This is compiled in so that we only parse and evaluate it once, at - -- compile-time. - , add0 TopLevel "derivation" $(do - let Success expr = parseNixText [text| - drvAttrs @ { outputs ? [ "out" ], ... }: - - let - - strict = derivationStrict drvAttrs; - - commonAttrs = drvAttrs - // (builtins.listToAttrs outputsList) - // { all = map (x: x.value) outputsList; - inherit drvAttrs; - }; - - outputToAttrListElement = outputName: - { name = outputName; - value = commonAttrs // { - outPath = builtins.getAttr outputName strict; - drvPath = strict.drvPath; - type = "derivation"; - inherit outputName; - }; - }; - - outputsList = map outputToAttrListElement outputs; - - in (builtins.head outputsList).value|] - [| foldFix Eval.eval expr |] - ) - - , add TopLevel "derivationStrict" derivationStrict_ - , add TopLevel "dirOf" dirOf - , add2 Normal "div" div_ - , add2 Normal "elem" elem_ - , add2 Normal "elemAt" elemAt_ - , add Normal "exec" exec_ - , add0 Normal "false" (pure $ nvConstant $ NBool False) - --, add Normal "fetchGit" fetchGit - --, add Normal "fetchMercurial" fetchMercurial - , add Normal "fetchTarball" fetchTarball - , add Normal "fetchurl" fetchurl - , add2 Normal "filter" filter_ - --, add Normal "filterSource" filterSource - , add2 Normal "findFile" findFile_ - , add3 Normal "foldl'" foldl'_ - , add Normal "fromJSON" fromJSON - --, add Normal "fromTOML" fromTOML - , add Normal "functionArgs" functionArgs - , add Normal "genericClosure" genericClosure - , add2 Normal "genList" genList - , add2 Normal "getAttr" getAttr - , add Normal "getContext" getContext - , add Normal "getEnv" getEnv_ - , add2 Normal "hasAttr" hasAttr - , add Normal "hasContext" hasContext - , add' Normal "hashString" (hashString @e @t @f @m) - , add Normal "head" head_ - , add TopLevel "import" import_ - , add2 Normal "intersectAttrs" intersectAttrs - , add Normal "isAttrs" isAttrs - , add Normal "isBool" isBool - , add Normal "isFloat" isFloat - , add Normal "isFunction" isFunction - , add Normal "isInt" isInt - , add Normal "isList" isList - , add TopLevel "isNull" isNull - , add Normal "isString" isString - , add Normal "length" length_ - , add2 Normal "lessThan" lessThan - , add Normal "listToAttrs" listToAttrs - , add2 TopLevel "map" map_ - , add2 TopLevel "mapAttrs" mapAttrs_ - , add2 Normal "match" match_ - , add2 Normal "mul" mul_ - , add0 Normal "nixPath" nixPath - , add0 Normal "null" (pure $ nvConstant NNull) - , add Normal "parseDrvName" parseDrvName - , add2 Normal "partition" partition_ - --, add Normal "path" path - , add Normal "pathExists" pathExists_ - , add TopLevel "placeholder" placeHolder - , add Normal "readDir" readDir_ - , add Normal "readFile" readFile_ - , add2 TopLevel "removeAttrs" removeAttrs - , add3 Normal "replaceStrings" replaceStrings - , add2 TopLevel "scopedImport" scopedImport - , add2 Normal "seq" seq_ - , add2 Normal "sort" sort_ - , add2 Normal "split" split_ - , add Normal "splitVersion" splitVersion_ - , add0 Normal "storeDir" (pure $ nvStr $ principledMakeNixStringWithoutContext "/nix/store") - --, add Normal "storePath" storePath - , add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext) - , add' Normal "sub" (arity2 ((-) @Integer)) - , add' Normal "substring" substring - , add Normal "tail" tail_ - , add TopLevel "throw" throw_ - , add2 Normal "toFile" toFile - , add Normal "toJSON" prim_toJSON - , add Normal "toPath" toPath - , add TopLevel "toString" toString - , add Normal "toXML" toXML_ - , add2 TopLevel "trace" trace_ - , add0 Normal "true" (pure $ nvConstant $ NBool True) - , add Normal "tryEval" tryEval - , add Normal "typeOf" typeOf - --, add0 Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependency - , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext - , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos - , add Normal "valueSize" getRecursiveSize - ] - where - wrap :: BuiltinType -> Text -> v -> Builtin v - wrap t n f = Builtin t (n, f) - - arity1 :: forall a b. (a -> b) -> (a -> Prim m b) - arity1 f = Prim . pure . f - arity2 :: forall a b c. (a -> b -> c) -> (a -> b -> Prim m c) - arity2 f = ((Prim . pure) .) . f - - mkThunk n = defer . withFrame - Info - (ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n") - - add0 t n v = wrap t n <$> mkThunk n v - add t n v = wrap t n <$> mkThunk n (builtin (Text.unpack n) v) - add2 t n v = wrap t n <$> mkThunk n (builtin2 (Text.unpack n) v) - add3 t n v = wrap t n <$> mkThunk n (builtin3 (Text.unpack n) v) - - add' :: forall a. ToBuiltin t f m a - => BuiltinType -> Text -> a -> m (Builtin (NValue t f m)) - add' t n v = wrap t n <$> mkThunk n (toBuiltin (Text.unpack n) v) - --- Primops - -foldNixPath - :: forall e t f m r - . MonadNix e t f m - => (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) - -> r - -> m r -foldNixPath f z = do - mres <- lookupVar "__includes" - dirs <- case mres of - Nothing -> pure [] - Just v -> demand v $ fromValue . Deeper - mPath <- getEnvVar "NIX_PATH" - mDataDir <- getEnvVar "NIX_DATA_DIR" - dataDir <- maybe getDataDir pure mDataDir - foldrM go z - $ map (fromInclude . principledStringIgnoreContext) dirs - ++ case mPath of - Nothing -> [] - Just str -> uriAwareSplit (Text.pack str) - ++ [ fromInclude $ Text.pack $ "nix=" ++ dataDir ++ "/nix/corepkgs" ] - where - fromInclude x | "://" `Text.isInfixOf` x = (x, PathEntryURI) - | otherwise = (x, PathEntryPath) - go (x, ty) rest = case Text.splitOn "=" x of - [p] -> f (Text.unpack p) Nothing ty rest - [n, p] -> f (Text.unpack p) (Just (Text.unpack n)) ty rest - _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x - -nixPath :: MonadNix e t f m => m (NValue t f m) -nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest -> - pure - $ flip nvSet mempty ( M.fromList - [ case ty of - PathEntryPath -> ("path", nvPath p) - PathEntryURI -> - ( "uri" - , nvStr $ hackyMakeNixStringWithoutContext $ Text.pack p - ) - - , ( "prefix" - , nvStr - $ hackyMakeNixStringWithoutContext $ Text.pack $ fromMaybe "" mn - ) - ] - ) - : rest - -toString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toString = coerceToString callFunc DontCopyToStore CoerceAny >=> toValue - -hasAttr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -hasAttr x y = fromValue x >>= fromStringNoContext >>= \key -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y - >>= \(aset, _) -> toValue $ M.member key aset - -attrsetGet :: MonadNix e t f m => Text -> AttrSet (NValue t f m) -> m (NValue t f m) -attrsetGet k s = case M.lookup k s of - Just v -> pure v - Nothing -> - throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required" - -hasContext :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -hasContext = toValue . stringHasContext <=< fromValue - -getAttr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -getAttr x y = fromValue x >>= fromStringNoContext >>= \key -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y - >>= \(aset, _) -> attrsetGet key aset - -unsafeGetAttrPos - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -unsafeGetAttrPos x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of - (NVStr ns, NVSet _ apos) -> - case M.lookup (hackyStringIgnoreContext ns) apos of - Nothing -> pure $ nvConstant NNull - Just delta -> toValue delta - (x, y) -> - throwError - $ ErrorCall - $ "Invalid types for builtins.unsafeGetAttrPos: " - ++ show (x, y) - --- This function is a bit special in that it doesn't care about the contents --- of the list. -length_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -length_ = toValue . (length :: [NValue t f m] -> Int) <=< fromValue - -add_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -add_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x + y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x + fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x + y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x + y) - (_ , _ ) -> throwError $ Addition x' y' - -mul_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mul_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x * y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x * fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y) - (_, _) -> throwError $ Multiplication x' y' - -div_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -div_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> - toValue (floor (fromInteger x / fromInteger y :: Double) :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> - toValue (x / fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> - toValue (fromInteger x / y) - (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue (x / y) - (_, _) -> throwError $ Division x' y' - -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = pure False -anyM p (x : xs) = do - q <- p x - if q then pure True else anyM p xs - -any_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -any_ f = toValue <=< anyM fromValue <=< mapM (f `callFunc`) <=< fromValue - -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = pure True -allM p (x : xs) = do - q <- p x - if q then allM p xs else pure False - -all_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -all_ f = toValue <=< allM fromValue <=< mapM (f `callFunc`) <=< fromValue - -foldl'_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) -foldl'_ f z xs = fromValue @[NValue t f m] xs >>= foldM go z - where go b a = f `callFunc` b >>= (`callFunc` a) - -head_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -head_ = fromValue >=> \case - [] -> throwError $ ErrorCall "builtins.head: empty list" - h : _ -> pure h - -tail_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -tail_ = fromValue >=> \case - [] -> throwError $ ErrorCall "builtins.tail: empty list" - _ : t -> pure $ nvList t - -data VersionComponent - = VersionComponent_Pre -- ^ The string "pre" - | VersionComponent_String Text -- ^ A string other than "pre" - | VersionComponent_Number Integer -- ^ A number - deriving (Show, Read, Eq, Ord) - -versionComponentToString :: VersionComponent -> Text -versionComponentToString = \case - VersionComponent_Pre -> "pre" - VersionComponent_String s -> s - VersionComponent_Number n -> Text.pack $ show n - --- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44 -versionComponentSeparators :: String -versionComponentSeparators = ".-" - -splitVersion :: Text -> [VersionComponent] -splitVersion s = case Text.uncons s of - Nothing -> [] - Just (h, t) - | h `elem` versionComponentSeparators - -> splitVersion t - | isDigit h - -> let (digits, rest) = Text.span isDigit s - in - VersionComponent_Number - (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) - $ readMaybe - $ Text.unpack digits - ) - : splitVersion rest - | otherwise - -> let (chars, rest) = Text.span - (\c -> not $ isDigit c || c `elem` versionComponentSeparators) - s - thisComponent = case chars of - "pre" -> VersionComponent_Pre - x -> VersionComponent_String x - in thisComponent : splitVersion rest - -splitVersion_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -splitVersion_ = fromValue >=> fromStringNoContext >=> \s -> - pure - $ nvList - $ flip map (splitVersion s) - $ nvStr - . principledMakeNixStringWithoutContext - . versionComponentToString - -compareVersions :: Text -> Text -> Ordering -compareVersions s1 s2 = mconcat - $ alignWith f (splitVersion s1) (splitVersion s2) - where - z = VersionComponent_String "" - f = uncurry compare . fromThese z z - -compareVersions_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -compareVersions_ t1 t2 = fromValue t1 >>= fromStringNoContext >>= \s1 -> - fromValue t2 >>= fromStringNoContext >>= \s2 -> - pure $ nvConstant $ NInt $ case compareVersions s1 s2 of - LT -> -1 - EQ -> 0 - GT -> 1 - -splitDrvName :: Text -> (Text, Text) -splitDrvName s = - let - sep = "-" - pieces = Text.splitOn sep s - isFirstVersionPiece p = case Text.uncons p of - Just (h, _) | isDigit h -> True - _ -> False - -- Like 'break', but always puts the first item into the first result - -- list - breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) - breakAfterFirstItem f = \case - h : t -> let (a, b) = break f t in (h : a, b) - [] -> ([], []) - (namePieces, versionPieces) = - breakAfterFirstItem isFirstVersionPiece pieces - in - (Text.intercalate sep namePieces, Text.intercalate sep versionPieces) - -parseDrvName - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do - let (name :: Text, version :: Text) = splitDrvName s - toValue @(AttrSet (NValue t f m)) $ M.fromList - [ ( "name" :: Text - , nvStr $ principledMakeNixStringWithoutContext name - ) - , ( "version" - , nvStr $ principledMakeNixStringWithoutContext version - ) - ] - -match_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -match_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> - fromValue str >>= \ns -> do - -- NOTE: Currently prim_match in nix/src/libexpr/primops.cc ignores the - -- context of its second argument. This is probably a bug but we're - -- going to preserve the behavior here until it is fixed upstream. - -- Relevant issue: https://github.com/NixOS/nix/issues/2547 - let s = principledStringIgnoreContext ns - - let re = makeRegex (encodeUtf8 p) :: Regex - let mkMatch t - | Text.null t = toValue () - | -- Shorthand for Null - otherwise = toValue $ principledMakeNixStringWithoutContext t - case matchOnceText re (encodeUtf8 s) of - Just ("", sarr, "") -> do - let s = map fst (elems sarr) - nvList <$> traverse (mkMatch . decodeUtf8) - (if length s > 1 then tail s else s) - _ -> pure $ nvConstant NNull - -split_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -split_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> - fromValue str >>= \ns -> do - -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the - -- context of its second argument. This is probably a bug but we're - -- going to preserve the behavior here until it is fixed upstream. - -- Relevant issue: https://github.com/NixOS/nix/issues/2547 - let s = principledStringIgnoreContext ns - let re = makeRegex (encodeUtf8 p) :: Regex - haystack = encodeUtf8 s - pure $ nvList $ splitMatches 0 - (map elems $ matchAllText re haystack) - haystack - -splitMatches - :: forall e t f m - . MonadNix e t f m - => Int - -> [[(ByteString, (Int, Int))]] - -> ByteString - -> [NValue t f m] -splitMatches _ [] haystack = [thunkStr haystack] -splitMatches _ ([] : _) _ = - error "Error in splitMatches: this should never happen!" -splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = - thunkStr before : caps : splitMatches (numDropped + relStart + len) - mts - (B.drop len rest) - where - relStart = max 0 start - numDropped - (before, rest) = B.splitAt relStart haystack - caps = nvList (map f captures) - f (a, (s, _)) = if s < 0 then nvConstant NNull else thunkStr a - -thunkStr s = nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)) - -substring :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString -substring start len str = Prim $ - if start < 0 - then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start - else pure $ principledModifyNixContents (take . Text.drop start) str - where - --NOTE: negative values of 'len' are OK, and mean "take everything" - take = if len < 0 then id else Text.take len - -attrNames - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -attrNames = - fromValue @(AttrSet (NValue t f m)) - >=> fmap getDeeper - . toValue - . map principledMakeNixStringWithoutContext - . sort - . M.keys - -attrValues - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -attrValues = - fromValue @(AttrSet (NValue t f m)) - >=> toValue - . fmap snd - . sortOn (fst @Text @(NValue t f m)) - . M.toList - -map_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -map_ f = - toValue - <=< traverse - ( defer @(NValue t f m) - . withFrame Debug (ErrorCall "While applying f in map:\n") - . (f `callFunc`) - ) - <=< fromValue @[NValue t f m] - -mapAttrs_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mapAttrs_ f xs = fromValue @(AttrSet (NValue t f m)) xs >>= \aset -> do - let pairs = M.toList aset - values <- for pairs $ \(key, value) -> - defer @(NValue t f m) - $ withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") - $ callFunc ?? value - =<< callFunc f (nvStr (principledMakeNixStringWithoutContext key)) - toValue . M.fromList . zip (map fst pairs) $ values - -filter_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -filter_ f = - toValue - <=< filterM (fromValue <=< callFunc f) - <=< fromValue - -catAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -catAttrs attrName xs = fromValue attrName >>= fromStringNoContext >>= \n -> - fromValue @[NValue t f m] xs >>= \l -> - fmap (nvList . catMaybes) - $ forM l - $ fmap (M.lookup n) - . flip demand fromValue - -baseNameOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -baseNameOf x = do - ns <- coerceToString callFunc DontCopyToStore CoerceStringy x - pure $ nvStr - (principledModifyNixContents (Text.pack . takeFileName . Text.unpack) ns) - -bitAnd - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitAnd x y = - fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .&. b) - -bitOr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitOr x y = - fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .|. b) - -bitXor - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitXor x y = fromValue @Integer x - >>= \a -> fromValue @Integer y >>= \b -> toValue (a `xor` b) - -builtinsBuiltin - :: forall e t f m - . MonadNix e t f m - => m (NValue t f m) -builtinsBuiltin = (throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred") - -dirOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -dirOf x = demand x $ \case - NVStr ns -> pure $ nvStr - (principledModifyNixContents (Text.pack . takeDirectory . Text.unpack) ns) - NVPath path -> pure $ nvPath $ takeDirectory path - v -> - throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v - --- jww (2018-04-28): This should only be a string argument, and not coerced? -unsafeDiscardStringContext - :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -unsafeDiscardStringContext mnv = do - ns <- fromValue mnv - toValue $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext - ns - -seq_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -seq_ a b = demand a $ \_ -> pure b - --- | We evaluate 'a' only for its effects, so data cycles are ignored. -deepSeq - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -deepSeq a b = b <$ normalForm_ a - -elem_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -elem_ x = toValue <=< anyM (valueEqM x) <=< fromValue - -elemAt :: [a] -> Int -> Maybe a -elemAt ls i = case drop i ls of - [] -> Nothing - a : _ -> Just a - -elemAt_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' -> - case elemAt xs' n' of - Just a -> pure a - Nothing -> - throwError - $ ErrorCall - $ "builtins.elem: Index " - ++ show n' - ++ " too large for list of length " - ++ show (length xs') - -genList - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -genList f = fromValue @Integer >=> \n -> if n >= 0 - then toValue =<< forM [0 .. n - 1] (\i -> defer $ (f `callFunc`) =<< toValue i) - else - throwError - $ ErrorCall - $ "builtins.genList: Expected a non-negative number, got " - ++ show n - --- We wrap values solely to provide an Ord instance for genericClosure -newtype WValue t f m = WValue (NValue t f m) - -instance Comonad f => Eq (WValue t f m) where - WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = - x == fromInteger y - WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = - fromInteger x == y - WValue (NVConstant (NInt x)) == WValue (NVConstant (NInt y)) = x == y - WValue (NVConstant (NFloat x)) == WValue (NVConstant (NFloat y)) = x == y - WValue (NVPath x ) == WValue (NVPath y ) = x == y - WValue (NVStr x) == WValue (NVStr y) = - hackyStringIgnoreContext x == hackyStringIgnoreContext y - _ == _ = False - -instance Comonad f => Ord (WValue t f m) where - WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = - x <= fromInteger y - WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = - fromInteger x <= y - WValue (NVConstant (NInt x)) <= WValue (NVConstant (NInt y)) = x <= y - WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NFloat y)) = x <= y - WValue (NVPath x ) <= WValue (NVPath y ) = x <= y - WValue (NVStr x) <= WValue (NVStr y) = - hackyStringIgnoreContext x <= hackyStringIgnoreContext y - _ <= _ = False - -genericClosure - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -genericClosure = fromValue @(AttrSet (NValue t f m)) >=> \s -> - case (M.lookup "startSet" s, M.lookup "operator" s) of - (Nothing, Nothing) -> - throwError - $ ErrorCall - $ "builtins.genericClosure: " - ++ "Attributes 'startSet' and 'operator' required" - (Nothing, Just _) -> - throwError - $ ErrorCall - $ "builtins.genericClosure: Attribute 'startSet' required" - (Just _, Nothing) -> - throwError - $ ErrorCall - $ "builtins.genericClosure: Attribute 'operator' required" - (Just startSet, Just operator) -> - demand startSet $ fromValue @[NValue t f m] >=> \ss -> - demand operator $ \op -> toValue @[NValue t f m] =<< snd <$> go op ss S.empty - where - go - :: NValue t f m - -> [NValue t f m] - -> Set (WValue t f m) - -> m (Set (WValue t f m), [NValue t f m]) - go _ [] ks = pure (ks, []) - go op (t : ts) ks = demand t $ \v -> fromValue @(AttrSet (NValue t f m)) v >>= \s -> do - k <- attrsetGet "key" s - demand k $ \k' -> do - if S.member (WValue k') ks - then go op ts ks - else do - ys <- fromValue @[NValue t f m] =<< (op `callFunc` v) - case S.toList ks of - [] -> checkComparable k' k' - WValue j : _ -> checkComparable k' j - fmap (t :) <$> go op (ts ++ ys) (S.insert (WValue k') ks) - -replaceStrings - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) -replaceStrings tfrom tto ts = fromValue (Deeper tfrom) >>= \(nsFrom :: [NixString]) -> - fromValue (Deeper tto) >>= \(nsTo :: [NixString]) -> - fromValue ts >>= \(ns :: NixString) -> do - let from = map principledStringIgnoreContext nsFrom - when (length nsFrom /= length nsTo) - $ throwError - $ ErrorCall - $ "'from' and 'to' arguments to 'replaceStrings'" - ++ " have different lengths" - let - lookupPrefix s = do - (prefix, replacement) <- find ((`Text.isPrefixOf` s) . fst) - $ zip from nsTo - let rest = Text.drop (Text.length prefix) s - pure (prefix, replacement, rest) - finish b = - principledMakeNixString (LazyText.toStrict $ Builder.toLazyText b) - go orig result ctx = case lookupPrefix orig of - Nothing -> case Text.uncons orig of - Nothing -> finish result ctx - Just (h, t) -> go t (result <> Builder.singleton h) ctx - Just (prefix, replacementNS, rest) -> - let replacement = principledStringIgnoreContext replacementNS - newCtx = principledGetContext replacementNS - in case prefix of - "" -> case Text.uncons rest of - Nothing -> finish - (result <> Builder.fromText replacement) - (ctx <> newCtx) - Just (h, t) -> go - t - (mconcat - [ result - , Builder.fromText replacement - , Builder.singleton h - ] - ) - (ctx <> newCtx) - _ -> go rest - (result <> Builder.fromText replacement) - (ctx <> newCtx) - toValue - $ go (principledStringIgnoreContext ns) mempty - $ principledGetContext ns - -removeAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -removeAttrs set = fromValue . Deeper >=> \(nsToRemove :: [NixString]) -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set >>= \(m, p) -> do - toRemove <- mapM fromStringNoContext nsToRemove - toValue (go m toRemove, go p toRemove) - where go = foldl' (flip M.delete) - -intersectAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -intersectAttrs set1 set2 = - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 >>= \(s1, p1) -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 >>= \(s2, p2) -> - pure $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) - -functionArgs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -functionArgs fun = demand fun $ \case - NVClosure p _ -> - toValue @(AttrSet (NValue t f m)) $ nvConstant . NBool <$> case p of - Param name -> M.singleton name False - ParamSet s _ _ -> isJust <$> M.fromList s - v -> - throwError - $ ErrorCall - $ "builtins.functionArgs: expected function, got " - ++ show v - -toFile - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -toFile name s = do - name' <- fromStringNoContext =<< fromValue name - s' <- fromValue s - -- TODO Using hacky here because we still need to turn the context into - -- runtime references of the resulting file. - -- See prim_toFile in nix/src/libexpr/primops.cc - mres <- toFile_ (Text.unpack name') - (Text.unpack $ hackyStringIgnoreContext s') - let t = Text.pack $ unStorePath mres - sc = StringContext t DirectPath - toValue $ principledMakeNixStringWithSingletonContext t sc - -toPath :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toPath = fromValue @Path >=> toValue @Path - -pathExists_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -pathExists_ path = demand path $ \case - NVPath p -> toValue =<< pathExists p - NVStr ns -> toValue =<< pathExists (Text.unpack (hackyStringIgnoreContext ns)) - v -> - throwError - $ ErrorCall - $ "builtins.pathExists: expected path, got " - ++ show v - -hasKind - :: forall a e t f m - . (MonadNix e t f m, FromValue a m (NValue t f m)) - => NValue t f m - -> m (NValue t f m) -hasKind = fromValueMay >=> toValue . \case - Just (_ :: a) -> True - _ -> False - -isAttrs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isAttrs = hasKind @(AttrSet (NValue t f m)) - -isList - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isList = hasKind @[NValue t f m] - -isInt - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isInt = hasKind @Int - -isFloat - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isFloat = hasKind @Float - -isBool - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isBool = hasKind @Bool - -isNull - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isNull = hasKind @() - --- isString cannot use `hasKind` because it coerces derivations to strings. -isString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -isString v = demand v $ \case - NVStr{} -> toValue True - _ -> toValue False - -isFunction :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -isFunction func = demand func $ \case - NVClosure{} -> toValue True - _ -> toValue False - -throw_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -throw_ mnv = do - ns <- coerceToString callFunc CopyToStore CoerceStringy mnv - throwError . ErrorCall . Text.unpack $ principledStringIgnoreContext ns - -import_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -import_ = scopedImport (nvSet M.empty M.empty) - -scopedImport - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -scopedImport asetArg pathArg = fromValue @(AttrSet (NValue t f m)) asetArg >>= \s -> - fromValue pathArg >>= \(Path p) -> do - path <- pathToDefaultNix @t @f @m p - mres <- lookupVar "__cur_file" - path' <- case mres of - Nothing -> do - traceM "No known current directory" - pure path - Just p -> demand p $ fromValue >=> \(Path p') -> do - traceM $ "Current file being evaluated is: " ++ show p' - pure $ takeDirectory p' path - clearScopes @(NValue t f m) - $ withNixContext (Just path') - $ pushScope s - $ importPath @t @f @m path' - -getEnv_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -getEnv_ = fromValue >=> fromStringNoContext >=> \s -> do - mres <- getEnvVar (Text.unpack s) - toValue $ principledMakeNixStringWithoutContext $ maybe "" Text.pack mres - -sort_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -sort_ comp = fromValue >=> sortByM (cmp comp) >=> toValue - where - cmp f a b = do - isLessThan <- f `callFunc` a >>= (`callFunc` b) - fromValue isLessThan >>= \case - True -> pure LT - False -> do - isGreaterThan <- f `callFunc` b >>= (`callFunc` a) - fromValue isGreaterThan <&> \case - True -> GT - False -> EQ - -lessThan - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -lessThan ta tb = demand ta $ \va -> demand tb $ \vb -> do - let badType = - throwError - $ ErrorCall - $ "builtins.lessThan: expected two numbers or two strings, " - ++ "got " - ++ show va - ++ " and " - ++ show vb - nvConstant . NBool <$> case (va, vb) of - (NVConstant ca, NVConstant cb) -> case (ca, cb) of - (NInt a, NInt b ) -> pure $ a < b - (NFloat a, NInt b ) -> pure $ a < fromInteger b - (NInt a, NFloat b) -> pure $ fromInteger a < b - (NFloat a, NFloat b) -> pure $ a < b - _ -> badType - (NVStr a, NVStr b) -> - pure $ principledStringIgnoreContext a < principledStringIgnoreContext b - _ -> badType - -concatLists - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -concatLists = - fromValue @[NValue t f m] - >=> mapM (flip demand $ fromValue @[NValue t f m] >=> pure) - >=> toValue - . concat - -concatMap_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -concatMap_ f = - fromValue @[NValue t f m] - >=> traverse applyFunc - >=> toValue . concat - where - applyFunc :: NValue t f m -> m [NValue t f m] - applyFunc = (f `callFunc`) >=> fromValue - -listToAttrs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -listToAttrs = fromValue @[NValue t f m] >=> \l -> - fmap (flip nvSet M.empty . M.fromList . reverse) - $ forM l - $ flip demand - $ fromValue @(AttrSet (NValue t f m)) - >=> \s -> do - t <- attrsetGet "name" s - demand t $ fromValue >=> \n -> do - name <- fromStringNoContext n - val <- attrsetGet "value" s - pure (name, val) - --- prim_hashString from nix/src/libexpr/primops.cc --- fail if context in the algo arg --- propagate context from the s arg --- | The result coming out of hashString is base16 encoded -hashString - :: forall e t f m. MonadNix e t f m => NixString -> NixString -> Prim m NixString -hashString nsAlgo ns = Prim $ do - algo <- fromStringNoContext nsAlgo - let f g = pure $ principledModifyNixContents g ns - case algo of - "md5" -> - f $ \s -> - Text.pack $ show (hash (encodeUtf8 s) :: MD5.MD5) - "sha1" -> - f $ \s -> - Text.pack $ show (hash (encodeUtf8 s) :: SHA1.SHA1) - "sha256" -> - f $ \s -> - Text.pack $ show (hash (encodeUtf8 s) :: SHA256.SHA256) - "sha512" -> - f $ \s -> - Text.pack $ show (hash (encodeUtf8 s) :: SHA512.SHA512) - _ -> - throwError - $ ErrorCall - $ "builtins.hashString: " - ++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " - ++ show algo - -placeHolder :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -placeHolder = fromValue >=> fromStringNoContext >=> \t -> do - h <- runPrim - (hashString (principledMakeNixStringWithoutContext "sha256") - (principledMakeNixStringWithoutContext ("nix-output:" <> t)) - ) - toValue - $ principledMakeNixStringWithoutContext - $ Text.cons '/' - $ Base32.encode - $ case Base16.decode (text h) of -- The result coming out of hashString is base16 encoded -#if MIN_VERSION_base16_bytestring(1,0,0) - Right d -> d - Left e -> error $ "Couldn't Base16 decode the text: '" <> show (text h) <> "'.\nThe Left error content: '" <> e <> "'." -#else - (d, "") -> d - (_, e) -> error $ "Couldn't Base16 decode the text: '" <> show (text h) <> "'.\nUndecodable remainder: '" <> show e <> "'." -#endif - where - text h = encodeUtf8 $ principledStringIgnoreContext h - -absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m FilePath -absolutePathFromValue = \case - NVStr ns -> do - let path = Text.unpack $ hackyStringIgnoreContext ns - unless (isAbsolute path) - $ throwError - $ ErrorCall - $ "string " - ++ show path - ++ " doesn't represent an absolute path" - pure path - NVPath path -> pure path - v -> throwError $ ErrorCall $ "expected a path, got " ++ show v - -readFile_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -readFile_ path = demand path $ - absolutePathFromValue >=> Nix.Render.readFile >=> toValue - -findFile_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -findFile_ aset filePath = demand aset $ \aset' -> demand filePath $ \filePath' -> - case (aset', filePath') of - (NVList x, NVStr ns) -> do - mres <- findPath @t @f @m x (Text.unpack (hackyStringIgnoreContext ns)) - pure $ nvPath mres - (NVList _, y) -> - throwError $ ErrorCall $ "expected a string, got " ++ show y - (x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x - (x, y) -> - throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show - (x, y) - -data FileType - = FileTypeRegular - | FileTypeDirectory - | FileTypeSymlink - | FileTypeUnknown - deriving (Show, Read, Eq, Ord) - -instance Convertible e t f m => ToValue FileType m (NValue t f m) where - toValue = toValue . principledMakeNixStringWithoutContext . \case - FileTypeRegular -> "regular" :: Text - FileTypeDirectory -> "directory" - FileTypeSymlink -> "symlink" - FileTypeUnknown -> "unknown" - -readDir_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -readDir_ p = demand p $ \path' -> do - path <- absolutePathFromValue path' - items <- listDirectory path - itemsWithTypes <- forM items $ \item -> do - s <- getSymbolicLinkStatus $ path item - let t = if - | isRegularFile s -> FileTypeRegular - | isDirectory s -> FileTypeDirectory - | isSymbolicLink s -> FileTypeSymlink - | otherwise -> FileTypeUnknown - pure (Text.pack item, t) - getDeeper <$> toValue (M.fromList itemsWithTypes) - -fromJSON - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fromJSON arg = demand arg $ fromValue >=> fromStringNoContext >=> \encoded -> - case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of - Left jsonError -> - throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError - Right v -> jsonToNValue v - where - jsonToNValue = \case - A.Object m -> flip nvSet M.empty <$> traverse jsonToNValue m - A.Array l -> nvList <$> traverse jsonToNValue (V.toList l) - A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s - A.Number n -> pure $ nvConstant $ case floatingOrInteger n of - Left r -> NFloat r - Right i -> NInt i - A.Bool b -> pure $ nvConstant $ NBool b - A.Null -> pure $ nvConstant NNull - -prim_toJSON :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -prim_toJSON x = demand x $ fmap nvStr . nvalueToJSONNixString - -toXML_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toXML_ v = demand v $ fmap (nvStr . toXML) . normalForm - -typeOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -typeOf v = demand v $ toValue . principledMakeNixStringWithoutContext . \case - NVConstant a -> case a of - NURI _ -> "string" - NInt _ -> "int" - NFloat _ -> "float" - NBool _ -> "bool" - NNull -> "null" - NVStr _ -> "string" - NVList _ -> "list" - NVSet _ _ -> "set" - NVClosure{} -> "lambda" - NVPath _ -> "path" - NVBuiltin _ _ -> "lambda" - _ -> error "Pattern synonyms obscure complete patterns" - -tryEval - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -tryEval e = catch (demand e (pure . onSuccess)) (pure . onError) - where - onSuccess v = flip nvSet M.empty $ M.fromList - [("success", nvConstant (NBool True)), ("value", v)] - - onError :: SomeException -> NValue t f m - onError _ = flip nvSet M.empty $ M.fromList - [ ("success", nvConstant (NBool False)) - , ("value" , nvConstant (NBool False)) - ] - -trace_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -trace_ msg action = do - traceEffect @t @f @m - . Text.unpack - . principledStringIgnoreContext - =<< fromValue msg - pure action - --- TODO: remember error context -addErrorContext - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -addErrorContext _ action = pure action - -exec_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -exec_ xs = do - ls <- fromValue @[NValue t f m] xs - xs <- traverse (coerceToString callFunc DontCopyToStore CoerceStringy) ls - -- TODO Still need to do something with the context here - -- See prim_exec in nix/src/libexpr/primops.cc - -- Requires the implementation of EvalState::realiseContext - exec (map (Text.unpack . hackyStringIgnoreContext) xs) - -fetchurl - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fetchurl v = demand v $ \case - NVSet s _ -> attrsetGet "url" s >>= demand ?? go (M.lookup "sha256" s) - v@NVStr{} -> go Nothing v - v -> - throwError - $ ErrorCall - $ "builtins.fetchurl: Expected URI or set, got " - ++ show v - where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) - go _msha = \case - NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha - Left e -> throwError e - Right p -> toValue p - v -> - throwError - $ ErrorCall - $ "builtins.fetchurl: Expected URI or string, got " - ++ show v - - noContextAttrs ns = case principledGetStringNoContext ns of - Nothing -> - throwError $ ErrorCall $ "builtins.fetchurl: unsupported arguments to url" - Just t -> pure t - -partition_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -partition_ f = fromValue @[NValue t f m] >=> \l -> do - let match t = f `callFunc` t >>= fmap (, t) . fromValue - selection <- traverse match l - let (right, wrong) = partition fst selection - let makeSide = nvList . map snd - toValue @(AttrSet (NValue t f m)) - $ M.fromList [("right", makeSide right), ("wrong", makeSide wrong)] - -currentSystem :: MonadNix e t f m => m (NValue t f m) -currentSystem = do - os <- getCurrentSystemOS - arch <- getCurrentSystemArch - pure $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os) - -currentTime_ :: MonadNix e t f m => m (NValue t f m) -currentTime_ = do - opts :: Options <- asks (view hasLens) - toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) - -derivationStrict_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -derivationStrict_ = derivationStrict - -getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) -getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize - -getContext - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -getContext x = demand x $ \case - (NVStr ns) -> do - let context = - getNixLikeContext $ toNixLikeContext $ principledGetContext ns - valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context - pure $ nvSet valued M.empty - x -> - throwError $ ErrorCall $ "Invalid type for builtins.getContext: " ++ show x - -appendContext - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of - (NVStr ns, NVSet attrs _) -> do - newContextValues <- forM attrs $ \attr -> demand attr $ \case - NVSet attrs _ -> do - -- TODO: Fail for unexpected keys. - path <- maybe (pure False) (demand ?? fromValue) - $ M.lookup "path" attrs - allOutputs <- maybe (pure False) (demand ?? fromValue) - $ M.lookup "allOutputs" attrs - outputs <- case M.lookup "outputs" attrs of - Nothing -> pure [] - Just os -> demand os $ \case - NVList vs -> - forM vs $ fmap principledStringIgnoreContext . fromValue - x -> - throwError - $ ErrorCall - $ "Invalid types for context value outputs in builtins.appendContext: " - ++ show x - pure $ NixLikeContextValue path allOutputs outputs - x -> - throwError - $ ErrorCall - $ "Invalid types for context value in builtins.appendContext: " - ++ show x - toValue - $ principledMakeNixString (principledStringIgnoreContext ns) - $ fromNixLikeContext - $ NixLikeContext - $ M.unionWith (<>) newContextValues - $ getNixLikeContext - $ toNixLikeContext - $ principledGetContext ns - (x, y) -> - throwError - $ ErrorCall - $ "Invalid types for builtins.appendContext: " - ++ show (x, y) - -newtype Prim m a = Prim { runPrim :: m a } - --- | Types that support conversion to nix in a particular monad -class ToBuiltin t f m a | a -> m where - toBuiltin :: String -> a -> m (NValue t f m) - -instance (MonadNix e t f m, ToValue a m (NValue t f m)) - => ToBuiltin t f m (Prim m a) where - toBuiltin _ p = toValue =<< runPrim p - -instance ( MonadNix e t f m - , FromValue a m (Deeper (NValue t f m)) - , ToBuiltin t f m b - ) - => ToBuiltin t f m (a -> b) where - toBuiltin name f = - pure $ nvBuiltin name (fromValue . Deeper >=> toBuiltin name . f) +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Code that implements Nix builtins. Lists the functions that are built into the Nix expression evaluator. Some built-ins (aka `derivation`), are always in the scope, so they can be accessed by the name. To keap the namespace clean, most built-ins are inside the `builtins` scope - a set that contains all what is a built-in. +module Nix.Builtins + ( withNixContext + , builtins + ) +where + + +import Prelude hiding ( traceM ) +import Relude.Unsafe as Unsafe +import Nix.Utils +import Control.Comonad ( Comonad ) +import Control.Monad ( foldM ) +import Control.Monad.Catch ( MonadCatch(catch) ) +import Control.Monad.ListM ( sortByM ) +import Crypto.Hash +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA512 as SHA512 +import qualified Data.Aeson as A +import Data.Align ( alignWith ) +import Data.Array +import Data.Bits +import qualified Data.ByteString as B +import Data.ByteString.Base16 as Base16 +import Data.Char ( isDigit ) +import Data.Foldable ( foldrM ) +import Data.Fix ( foldFix ) +import Data.List ( partition ) +import qualified Data.HashMap.Lazy as M +import Data.Scientific +import qualified Data.Set as S +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Builder as Builder +import Data.These ( fromThese ) +import qualified Data.Time.Clock.POSIX as Time +import qualified Data.Vector as V +import NeatInterpolation ( text ) +import Nix.Atoms +import Nix.Convert +import Nix.Effects +import Nix.Effects.Basic ( fetchTarball ) +import Nix.Exec +import Nix.Expr.Types +import Nix.Expr.Types.Annotated +import qualified Nix.Eval as Eval +import Nix.Frames +import Nix.Json +import Nix.Normal +import Nix.Options +import Nix.Parser +import Nix.Render +import Nix.Scope +import Nix.String +import Nix.String.Coerce +import Nix.Value +import Nix.Value.Equal +import Nix.Value.Monad +import Nix.XML +import System.Nix.Base32 as Base32 +import System.FilePath +import System.Posix.Files ( isRegularFile + , isDirectory + , isSymbolicLink + ) +import Text.Regex.TDFA + + +-- This is a big module. There is recursive reuse: +-- @builtins -> builtinsList -> scopedImport -> withNixContext -> builtins@, +-- since @builtins@ is self-recursive: aka we ship @builtins.builtins.builtins...@. + +-- * Internal + +-- ** Nix Builtins Haskell type level + +newtype Prim m a = Prim { runPrim :: m a } + +data BuiltinType = Normal | TopLevel +data Builtin v = + Builtin + { _kind :: BuiltinType + , mapping :: (Text, v) + } + +-- *** @class ToBuiltin@ and its instances + +-- | Types that support conversion to nix in a particular monad +class ToBuiltin t f m a | a -> m where + toBuiltin :: Text -> a -> m (NValue t f m) + +instance + ( MonadNix e t f m + , ToValue a m (NValue t f m) + ) + => ToBuiltin t f m (Prim m a) where + toBuiltin _ p = toValue =<< runPrim p + +instance + ( MonadNix e t f m + , FromValue a m (Deeper (NValue t f m)) + , ToBuiltin t f m b + ) + => ToBuiltin t f m (a -> b) where + toBuiltin name f = + pure $ nvBuiltin name (toBuiltin name . f <=< fromValue . Deeper) + +-- *** @WValue@ closure wrapper to have @Ord@ + +-- We wrap values solely to provide an Ord instance for genericClosure +newtype WValue t f m = WValue (NValue t f m) + +instance Comonad f => Eq (WValue t f m) where + WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = + x == fromInteger y + WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = + fromInteger x == y + WValue (NVConstant (NInt x)) == WValue (NVConstant (NInt y)) = x == y + WValue (NVConstant (NFloat x)) == WValue (NVConstant (NFloat y)) = x == y + WValue (NVPath x ) == WValue (NVPath y ) = x == y + WValue (NVStr x) == WValue (NVStr y) = + stringIgnoreContext x == stringIgnoreContext y + _ == _ = False + +instance Comonad f => Ord (WValue t f m) where + WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = + x <= fromInteger y + WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = + fromInteger x <= y + WValue (NVConstant (NInt x)) <= WValue (NVConstant (NInt y)) = x <= y + WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NFloat y)) = x <= y + WValue (NVPath x ) <= WValue (NVPath y ) = x <= y + WValue (NVStr x) <= WValue (NVStr y) = + stringIgnoreContext x <= stringIgnoreContext y + _ <= _ = False + +-- ** Helpers + +nVNull + :: MonadNix e t f m + => NValue t f m +nVNull = nvConstant NNull + +mkNVBool + :: MonadNix e t f m + => Bool + -> NValue t f m +mkNVBool = nvConstant . NBool + +foldNixPath + :: forall e t f m r + . MonadNix e t f m + => r + -> (FilePath -> Maybe Text -> NixPathEntryType -> r -> m r) + -> m r +foldNixPath z f = + do + mres <- lookupVar "__includes" + dirs <- + maybe + stub + ((fromValue . Deeper) <=< demand) + mres + mPath <- getEnvVar "NIX_PATH" + mDataDir <- getEnvVar "NIX_DATA_DIR" + dataDir <- + maybe + getDataDir + (pure . toString) + mDataDir + + foldrM + go + z + $ (fromInclude . stringIgnoreContext <$> dirs) + <> maybe + mempty + uriAwareSplit + mPath + <> [ fromInclude $ "nix=" <> toText dataDir <> "/nix/corepkgs" ] + where + + fromInclude x = (x, ) $ + bool + PathEntryPath + PathEntryURI + ("://" `Text.isInfixOf` x) + + go (x, ty) rest = + case Text.splitOn "=" x of + [p] -> f (toString p) mempty ty rest + [n, p] -> f (toString p) (pure n) ty rest + _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " <> show x + +attrsetGet :: MonadNix e t f m => Text -> AttrSet (NValue t f m) -> m (NValue t f m) +attrsetGet k s = + maybe + (throwError $ ErrorCall $ "Attribute '" <> toString k <> "' required") + pure + (M.lookup k s) + +data VersionComponent + = VersionComponentPre -- ^ The string "pre" + | VersionComponentString Text -- ^ A string other than "pre" + | VersionComponentNumber Integer -- ^ A number + deriving (Show, Read, Eq, Ord) + +versionComponentToString :: VersionComponent -> Text +versionComponentToString = + \case + VersionComponentPre -> "pre" + VersionComponentString s -> s + VersionComponentNumber n -> show n + +-- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44 +versionComponentSeparators :: String +versionComponentSeparators = ".-" + +splitVersion :: Text -> [VersionComponent] +splitVersion s = + case Text.uncons s of + Nothing -> mempty + Just (h, t) + + | h `elem` versionComponentSeparators -> splitVersion t + + | isDigit h -> + let (digits, rest) = Text.span isDigit s + in + VersionComponentNumber + (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) $ readMaybe $ toString digits) : splitVersion rest + + | otherwise -> + let + (chars, rest) = + Text.span + (\c -> not $ isDigit c || c `elem` versionComponentSeparators) + s + thisComponent = + case chars of + "pre" -> VersionComponentPre + x -> VersionComponentString x + in + thisComponent : splitVersion rest + +compareVersions :: Text -> Text -> Ordering +compareVersions s1 s2 = + mconcat $ + alignWith + f + (splitVersion s1) + (splitVersion s2) + where + z = VersionComponentString "" + f = uncurry compare . fromThese z z + +splitDrvName :: Text -> (Text, Text) +splitDrvName s = + let + sep = "-" + pieces = Text.splitOn sep s + isFirstVersionPiece p = + case Text.uncons p of + Just (h, _) -> isDigit h + _ -> False + -- Like 'break', but always puts the first item into the first result + -- list + breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) + breakAfterFirstItem f = + list + (mempty, mempty) + (\ (h : t) -> let (a, b) = break f t in (h : a, b)) + (namePieces, versionPieces) = + breakAfterFirstItem isFirstVersionPiece pieces + in + (Text.intercalate sep namePieces, Text.intercalate sep versionPieces) + +splitMatches + :: forall e t f m + . MonadNix e t f m + => Int + -> [[(ByteString, (Int, Int))]] + -> ByteString + -> [NValue t f m] +splitMatches _ [] haystack = [thunkStr haystack] +splitMatches _ ([] : _) _ = + fail "Fail in splitMatches: this should never happen!" +splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = + thunkStr before : caps : splitMatches (numDropped + relStart + len) + mts + (B.drop len rest) + where + relStart = max 0 start - numDropped + (before, rest) = B.splitAt relStart haystack + caps = nvList (f <$> captures) + f (a, (s, _)) = + bool + nVNull + (thunkStr a) + (s >= 0) + +thunkStr :: Applicative f => ByteString -> NValue t f m +thunkStr s = nvStr $ makeNixStringWithoutContext $ decodeUtf8 s + +elemAt :: [a] -> Int -> Maybe a +elemAt ls i = + list + Nothing + (pure . Unsafe.head) + (drop i ls) + +hasKind + :: forall a e t f m + . (MonadNix e t f m, FromValue a m (NValue t f m)) + => NValue t f m + -> m (NValue t f m) +hasKind nv = + do + v <- fromValueMay nv + + toValue $ + case v of + Just (_ :: a) -> True + _ -> False + + +absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m FilePath +absolutePathFromValue = + \case + NVStr ns -> + do + let + path = toString $ stringIgnoreContext ns + + unless (isAbsolute path) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" + pure path + + NVPath path -> pure path + v -> throwError $ ErrorCall $ "expected a path, got " <> show v + + +data FileType + = FileTypeRegular + | FileTypeDirectory + | FileTypeSymlink + | FileTypeUnknown + deriving (Show, Read, Eq, Ord) + +instance Convertible e t f m => ToValue FileType m (NValue t f m) where + toValue = + toValue . makeNixStringWithoutContext . + \case + FileTypeRegular -> "regular" :: Text + FileTypeDirectory -> "directory" + FileTypeSymlink -> "symlink" + FileTypeUnknown -> "unknown" + +-- ** Builtin functions + +derivationNix + :: forall e t f m. (MonadNix e t f m, Scoped (NValue t f m) m) + => m (NValue t f m) +derivationNix = foldFix Eval.eval $$(do + -- This is compiled in so that we only parse it once at compile-time. + let Right expr = parseNixText [text| + drvAttrs @ { outputs ? [ "out" ], ... }: + + let + + strict = derivationStrict drvAttrs; + + commonAttrs = drvAttrs + // (builtins.listToAttrs outputsList) + // { all = map (x: x.value) outputsList; + inherit drvAttrs; + }; + + outputToAttrListElement = outputName: + { name = outputName; + value = commonAttrs // { + outPath = builtins.getAttr outputName strict; + drvPath = strict.drvPath; + type = "derivation"; + inherit outputName; + }; + }; + + outputsList = map outputToAttrListElement outputs; + + in (builtins.head outputsList).value|] + [|| expr ||] + ) + +nixPathNix :: MonadNix e t f m => m (NValue t f m) +nixPathNix = + fmap + nvList + (foldNixPath mempty $ + \p mn ty rest -> + pure $ + pure + (nvSet + mempty + (M.fromList + [case ty of + PathEntryPath -> ("path", nvPath p) + PathEntryURI -> ( "uri", mkNvStr p) + + , ( "prefix", mkNvStr $ toString $ fromMaybe "" mn) + ] + ) + ) + <> rest + ) + where + mkNvStr = nvStr . makeNixStringWithoutContext . toText + +toStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toStringNix = toValue <=< coerceToString callFunc DontCopyToStore CoerceAny + +hasAttrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +hasAttrNix x y = + do + key <- fromStringNoContext =<< fromValue x + (aset, _) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y + + toValue $ M.member key aset + +hasContextNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +hasContextNix = toValue . stringHasContext <=< fromValue + +getAttrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +getAttrNix x y = + do + key <- fromStringNoContext =<< fromValue x + (aset, _) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y + + attrsetGet key aset + +unsafeGetAttrPosNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +unsafeGetAttrPosNix nvX nvY = + do + x <- demand nvX + y <- demand nvY + + case (x, y) of + (NVStr ns, NVSet _ apos) -> + maybe + (pure nVNull) + toValue + (M.lookup (stringIgnoreContext ns) apos) + _xy -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPosNix: " <> show _xy + +-- This function is a bit special in that it doesn't care about the contents +-- of the list. +lengthNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +lengthNix = toValue . (length :: [NValue t f m] -> Int) <=< fromValue + +addNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +addNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) -> toValue ( x + y :: Integer ) + (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue $ x + fromInteger y + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue $ fromInteger x + y + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue $ x + y + (_x , _y ) -> throwError $ Addition _x _y + +mulNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mulNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) -> toValue (x * y :: Integer ) + (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue (x * fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y ) + (_x , _y ) -> throwError $ Multiplication _x _y + +divNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +divNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue ( floor (fromInteger x / fromInteger y :: Double) :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> toValue $ x / fromInteger y + (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> toValue $ fromInteger x / y + (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue $ x / y + (_x , _y ) -> throwError $ Division _x _y + +anyNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +anyNix f = toValue <=< anyMNix fromValue <=< traverse (callFunc f) <=< fromValue + where + anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + anyMNix _ [] = pure False + anyMNix p (x : xs) = + bool + (anyMNix p xs) + (pure True) + =<< p x + +allNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +allNix f = toValue <=< allMNix fromValue <=< traverse (callFunc f) <=< fromValue + where + allMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + allMNix _ [] = pure True + allMNix p (x : xs) = + bool + (pure False) + (allMNix p xs) + =<< p x + +foldl'Nix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) +foldl'Nix f z xs = foldM go z =<< fromValue @[NValue t f m] xs + where + go b a = (`callFunc` a) =<< callFunc f b + +headNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +headNix = + list + (throwError $ ErrorCall "builtins.head: empty list") + (pure . Unsafe.head) + <=< fromValue + +tailNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +tailNix = + list + (throwError $ ErrorCall "builtins.tail: empty list") + (pure . nvList . Unsafe.tail) + <=< fromValue + +splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +splitVersionNix v = + do + version <- fromStringNoContext =<< fromValue v + pure $ + nvList $ + nvStr . makeNixStringWithoutContext . versionComponentToString <$> + splitVersion version + +compareVersionsNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +compareVersionsNix t1 t2 = + do + s1 <- mkText t1 + s2 <- mkText t2 + + let + cmpVers = + case compareVersions s1 s2 of + LT -> -1 + EQ -> 0 + GT -> 1 + + pure $ nvConstant $ NInt cmpVers + + where + mkText = fromStringNoContext <=< fromValue + +parseDrvNameNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +parseDrvNameNix drvname = + do + s <- fromStringNoContext =<< fromValue drvname + + let + (name :: Text, version :: Text) = splitDrvName s + + toValue @(AttrSet (NValue t f m)) $ + M.fromList + [ ( "name" :: Text + , mkNVStr name + ) + , ( "version" + , mkNVStr version + ) + ] + + where + mkNVStr = nvStr . makeNixStringWithoutContext + +matchNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +matchNix pat str = + do + p <- fromStringNoContext =<< fromValue pat + ns <- fromValue str + + -- NOTE: 2018-11-19: Currently prim_match in nix/src/libexpr/primops.cc + -- ignores the context of its second argument. This is probably a bug but we're + -- going to preserve the behavior here until it is fixed upstream. + -- Relevant issue: https://github.com/NixOS/nix/issues/2547 + let + s = stringIgnoreContext ns + re = makeRegex p :: Regex + mkMatch t = + bool + (toValue ()) -- Shorthand for Null + (toValue $ makeNixStringWithoutContext t) + (not $ Text.null t) + + maybe + (pure nVNull) + (\case + ("", sarr, "") -> + do + let s = fst <$> elems sarr + nvList <$> + traverse + mkMatch + (bool + id -- (length <= 1) allowed & passes-through here the full string + Unsafe.tail + (length s > 1) + s + ) + _ -> (pure nVNull) + ) + (matchOnceText re s) + +splitNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +splitNix pat str = + do + p <- fromStringNoContext =<< fromValue pat + ns <- fromValue str + -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the + -- context of its second argument. This is probably a bug but we're + -- going to preserve the behavior here until it is fixed upstream. + -- Relevant issue: https://github.com/NixOS/nix/issues/2547 + let + s = stringIgnoreContext ns + regex = makeRegex p :: Regex + haystack = encodeUtf8 s + + pure $ nvList $ splitMatches 0 (elems <$> matchAllText regex haystack) haystack + +substringNix :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString +substringNix start len str = + Prim $ + bool + (throwError $ ErrorCall $ "builtins.substring: negative start position: " <> show start) + (pure $ modifyNixContents (take . Text.drop start) str) + (start >= 0) + where + take = + bool + id --NOTE: negative values of 'len' are OK, and mean "take everything" + (Text.take len) + (len >= 0) + +attrNamesNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +attrNamesNix = + (fmap getDeeper . toValue . fmap makeNixStringWithoutContext . sort . M.keys) + <=< fromValue @(AttrSet (NValue t f m)) + +attrValuesNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +attrValuesNix nvattrs = + do + attrs <- fromValue @(AttrSet (NValue t f m)) nvattrs + toValue $ + snd <$> + sortOn + (fst @Text @(NValue t f m)) + (M.toList attrs) + +mapNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mapNix f = + toValue <=< + traverse + (defer @(NValue t f m) + . withFrame Debug (ErrorCall "While applying f in map:\n") + . callFunc f + ) + <=< fromValue @[NValue t f m] + +mapAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mapAttrsNix f xs = + do + nixAttrset <- fromValue @(AttrSet (NValue t f m)) xs + let + keyVals = M.toList nixAttrset + keys = fst <$> keyVals + + applyFunToKeyVal (key, val) = + do + runFunForKey <- callFunc f $ nvStr $ makeNixStringWithoutContext key + callFunc runFunForKey val + + newVals <- + traverse + (defer @(NValue t f m) . withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") . applyFunToKeyVal) + keyVals + + toValue $ M.fromList $ zip keys newVals + +filterNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +filterNix f = + toValue <=< + filterM + (fromValue <=< callFunc f) + <=< fromValue + +catAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +catAttrsNix attrName xs = + do + n <- fromStringNoContext =<< fromValue attrName + l <- fromValue @[NValue t f m] xs + + nvList . catMaybes <$> + traverse + (fmap (M.lookup n) . fromValue <=< demand) + l + +baseNameOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +baseNameOfNix x = + do + ns <- coerceToString callFunc DontCopyToStore CoerceStringy x + pure $ + nvStr $ + modifyNixContents + (toText . takeFileName . toString) + ns + +bitAndNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitAndNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue (a .&. b) + +bitOrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitOrNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue (a .|. b) + +bitXorNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitXorNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue (a `xor` b) + +builtinsBuiltinNix + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) +builtinsBuiltinNix = throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred" + +dirOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +dirOfNix nvdir = + do + dir <- demand nvdir + + case dir of + NVStr ns -> pure $ nvStr $ modifyNixContents (toText . takeDirectory . toString) ns + NVPath path -> pure $ nvPath $ takeDirectory path + v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " <> show v + +-- jww (2018-04-28): This should only be a string argument, and not coerced? +unsafeDiscardStringContextNix + :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +unsafeDiscardStringContextNix mnv = do + ns <- fromValue mnv + toValue $ makeNixStringWithoutContext $ stringIgnoreContext ns + +-- | Evaluate `a` to WHNF to collect its topmost effect. +seqNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +seqNix a b = b <$ demand a + +-- | Evaluate 'a' to NF to collect all of its effects, therefore data cycles are ignored. +deepSeqNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +deepSeqNix a b = b <$ normalForm_ a + +elemNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +elemNix x = toValue <=< anyMNix (valueEqM x) <=< fromValue + where + anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + anyMNix _ [] = pure False + anyMNix p (x : xs) = + bool + (anyMNix p xs) + (pure True) + =<< p x + +elemAtNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +elemAtNix xs n = + do + n' <- fromValue n + xs' <- fromValue xs + maybe + (throwError $ ErrorCall $ "builtins.elem: Index " <> show n' <> " too large for list of length " <> show (length xs')) + pure + (elemAt xs' n') + +genListNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +genListNix f nixN = + do + n <- fromValue @Integer nixN + bool + (throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got " <> show n) + (toValue =<< traverse (defer . callFunc f <=< toValue) [0 .. n - 1]) + (n >= 0) + +genericClosureNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +genericClosureNix c = + do + s <- fromValue @(AttrSet (NValue t f m)) c + + case (M.lookup "startSet" s, M.lookup "operator" s) of + (Nothing , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attributes 'startSet' and 'operator' required" + (Nothing , Just _ ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'startSet' required" + (Just _ , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'operator' required" + (Just startSet, Just operator) -> + do + ss <- fromValue @[NValue t f m] =<< demand startSet + op <- demand operator + + toValue @[NValue t f m] =<< snd <$> go op S.empty ss + where + go + :: NValue t f m + -> Set (WValue t f m) + -> [NValue t f m] + -> m (Set (WValue t f m), [NValue t f m]) + go _ ks [] = pure (ks, mempty) + go op ks (t : ts) = + do + v <- demand t + k <- demand =<< attrsetGet "key" =<< fromValue @(AttrSet (NValue t f m)) v + + bool + (do + ys <- fromValue @[NValue t f m] =<< callFunc op v + checkComparable k + (case S.toList ks of + [] -> k + WValue j : _ -> j + ) + (t :) <<$>> go op (S.insert (WValue k) ks) (ts <> ys) + ) + (go op ks ts) + (S.member (WValue k) ks) + +-- | Takes: +-- 1. List of strings to match. +-- 2. List of strings to replace corresponding match occurance. (arg 1 & 2 lists matched by index) +-- 3. String to process +-- -> returns the string with requested replacements. +-- +-- Example: +-- builtins.replaceStrings ["ll" "e"] [" " "i"] "Hello world" == "Hi o world". +replaceStringsNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) +replaceStringsNix tfrom tto ts = + do + -- NixStrings have context - remember + (fromKeys :: [NixString]) <- fromValue (Deeper tfrom) + (toVals :: [NixString]) <- fromValue (Deeper tto) + (string :: NixString ) <- fromValue ts + + when (length fromKeys /= length toVals) $ throwError $ ErrorCall "builtins.replaceStrings: Arguments `from`&`to` construct a key-value map, so the number of their elements must always match." + + let + -- 2021-02-18: NOTE: if there is no match - the process does not changes the context, simply slides along the string. + -- So it isbe more effective to pass the context as the first argument. + -- And moreover, the `passOneCharNgo` passively passes the context, to context can be removed from it and inherited directly. + -- Then the solution would've been elegant, but the Nix bug prevents elegant implementation. + go ctx input output = + maybe + -- Passively pass the chars + passOneChar + replace + maybePrefixMatch + + where + -- When prefix matched something - returns (match, replacement, reminder) + maybePrefixMatch :: Maybe (Text, NixString, Text) + maybePrefixMatch = formMatchReplaceTailInfo <$> find ((`Text.isPrefixOf` input) . fst) fromKeysToValsMap + where + formMatchReplaceTailInfo = (\(m, r) -> (m, r, Text.drop (Text.length m) input)) + + fromKeysToValsMap = zip (stringIgnoreContext <$> fromKeys) toVals + + -- Not passing args => It is constant that gets embedded into `go` => It is simple `go` tail recursion + passOneChar = + maybe + (finish ctx output) -- The base case - there is no chars left to process -> finish + (\(c, i) -> go ctx i (output <> Builder.singleton c)) -- If there are chars - pass one char & continue + (Text.uncons input) -- chip first char + + -- 2021-02-18: NOTE: rly?: toStrict . toLazyText + -- Maybe `text-builder`, `text-show`? + finish ctx output = makeNixString (LazyText.toStrict $ Builder.toLazyText output) ctx + + replace (key, replacementNS, unprocessedInput) = replaceWithNixBug unprocessedInput updatedOutput + + where + replaceWithNixBug = + bool + (go updatedCtx) -- tail recursion + -- Allowing match on "" is a inherited bug of Nix, + -- when "" is checked - it always matches. And so - when it checks - it always insers a replacement, and then process simply passesthrough the char that was under match. + -- + -- repl> builtins.replaceStrings ["" "e"] [" " "i"] "Hello world" + -- " H e l l o w o r l d " + -- repl> builtins.replaceStrings ["ll" ""] [" " "i"] "Hello world" + -- "iHie ioi iwioirilidi" + -- 2021-02-18: NOTE: There is no tests for this + bugPassOneChar -- augmented recursion + isNixBugCase + + isNixBugCase = key == mempty + + updatedOutput = output <> replacement + updatedCtx = ctx <> replacementCtx + + replacement = Builder.fromText $ stringIgnoreContext replacementNS + replacementCtx = getContext replacementNS + + -- The bug modifies the content => bug demands `pass` to be a real function => + -- `go` calls `pass` function && `pass` calls `go` function + -- => mutual recusion case, so placed separately. + bugPassOneChar input output = + maybe + (finish updatedCtx output) -- The base case - there is no chars left to process -> finish + (\(c, i) -> go updatedCtx i (output <> Builder.singleton c)) -- If there are chars - pass one char & continue + (Text.uncons input) -- chip first char + + toValue $ go (getContext string) (stringIgnoreContext string) mempty + +removeAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +removeAttrsNix set v = + do + (m, p) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set + (nsToRemove :: [NixString]) <- fromValue $ Deeper v + toRemove <- traverse fromStringNoContext nsToRemove + toValue (go m toRemove, go p toRemove) + where + go = foldl' (flip M.delete) + +intersectAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +intersectAttrsNix set1 set2 = + do + (s1, p1) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 + (s2, p2) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 + + pure $ nvSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) + +functionArgsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +functionArgsNix nvfun = + do + fun <- demand nvfun + case fun of + NVClosure p _ -> + toValue @(AttrSet (NValue t f m)) $ mkNVBool <$> + case p of + Param name -> M.singleton name False + ParamSet s _ _ -> isJust <$> M.fromList s + _v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show _v + +toFileNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +toFileNix name s = + do + name' <- fromStringNoContext =<< fromValue name + s' <- fromValue s + mres <- + toFile_ + (toString name') + (toString $ stringIgnoreContext s') + + let + t = toText $ unStorePath mres + sc = StringContext t DirectPath + + toValue $ makeNixStringWithSingletonContext t sc + +toPathNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toPathNix = toValue @Path <=< fromValue @Path + +pathExistsNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +pathExistsNix nvpath = + do + path <- demand nvpath + toValue =<< + case path of + NVPath p -> pathExists p + NVStr ns -> pathExists (toString $ stringIgnoreContext ns) + _v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show _v + +isAttrsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isAttrsNix = hasKind @(AttrSet (NValue t f m)) + +isListNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isListNix = hasKind @[NValue t f m] + +isIntNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isIntNix = hasKind @Int + +isFloatNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isFloatNix = hasKind @Float + +isBoolNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isBoolNix = hasKind @Bool + +isNullNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isNullNix = hasKind @() + +-- isString cannot use `hasKind` because it coerces derivationNixs to strings. +isStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isStringNix nv = + do + v <- demand nv + + toValue $ + case v of + NVStr{} -> True + _ -> False + +isFunctionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isFunctionNix nv = + do + v <- demand nv + + toValue $ + case v of + NVClosure{} -> True + _ -> False + +throwNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +throwNix mnv = + do + ns <- coerceToString callFunc CopyToStore CoerceStringy mnv + + throwError . ErrorCall . toString $ stringIgnoreContext ns + +importNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +importNix = scopedImportNix (nvSet mempty mempty) + +scopedImportNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +scopedImportNix asetArg pathArg = + do + s <- fromValue @(AttrSet (NValue t f m)) asetArg + (Path p) <- fromValue pathArg + + path <- pathToDefaultNix @t @f @m p + path' <- + maybe + (do + traceM "No known current directory" + pure path + ) + (\ res -> + do + (Path p') <- fromValue =<< demand res + + traceM $ "Current file being evaluated is: " <> show p' + pure $ takeDirectory p' path + ) + =<< lookupVar "__cur_file" + + clearScopes @(NValue t f m) + $ withNixContext (pure path') + $ pushScope s + $ importPath @t @f @m path' + +getEnvNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +getEnvNix v = + do + s <- fromStringNoContext =<< fromValue v + mres <- getEnvVar s + + toValue $ makeNixStringWithoutContext $ + fromMaybe mempty mres + +sortNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +sortNix comp = toValue <=< sortByM (cmp comp) <=< fromValue + where + cmp f a b = + do + isLessThan <- (`callFunc` b) =<< callFunc f a + bool + (do + isGreaterThan <- (`callFunc` a) =<< callFunc f b + fromValue isGreaterThan <&> + bool + EQ + GT + ) + (pure LT) + =<< fromValue isLessThan + +lessThanNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +lessThanNix ta tb = + do + va <- demand ta + vb <- demand tb + + let + badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, " <> "got " <> show va <> " and " <> show vb + + mkNVBool <$> + case (va, vb) of + (NVConstant ca, NVConstant cb) -> + case (ca, cb) of + (NInt a, NInt b ) -> pure $ a < b + (NFloat a, NInt b ) -> pure $ a < fromInteger b + (NInt a, NFloat b) -> pure $ fromInteger a < b + (NFloat a, NFloat b) -> pure $ a < b + _ -> badType + (NVStr a, NVStr b) -> pure $ stringIgnoreContext a < stringIgnoreContext b + _ -> badType + +concatListsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +concatListsNix = + toValue . concat <=< + traverse + (fromValue @[NValue t f m] <=< demand) + <=< fromValue @[NValue t f m] + +concatMapNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +concatMapNix f = + toValue . concat <=< + traverse + applyFunc + <=< fromValue @[NValue t f m] + where + applyFunc :: NValue t f m -> m [NValue t f m] + applyFunc = fromValue <=< callFunc f + +listToAttrsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +listToAttrsNix lst = + do + l <- fromValue @[NValue t f m] lst + fmap + (nvSet mempty . M.fromList . reverse) + (traverse + (\ nvattrset -> + do + a <- fromValue @(AttrSet (NValue t f m)) =<< demand nvattrset + name <- fromStringNoContext =<< fromValue =<< demand =<< attrsetGet "name" a + val <- attrsetGet "value" a + + pure (name, val) + ) + l + ) + +-- prim_hashString from nix/src/libexpr/primops.cc +-- fail if context in the algo arg +-- propagate context from the s arg +-- | The result coming out of hashString is base16 encoded +hashStringNix + :: forall e t f m. MonadNix e t f m => NixString -> NixString -> Prim m NixString +hashStringNix nsAlgo ns = + Prim $ + do + algo <- fromStringNoContext nsAlgo + let + f g = pure $ modifyNixContents g ns + + case algo of + -- 2021-03-04: Pattern can not be taken-out because hashes represented as different types + "md5" -> f (show . mkHash @MD5.MD5) + "sha1" -> f (show . mkHash @SHA1.SHA1) + "sha256" -> f (show . mkHash @SHA256.SHA256) + "sha512" -> f (show . mkHash @SHA512.SHA512) + + _ -> throwError $ ErrorCall $ "builtins.hashString: expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " <> show algo + + where + -- This intermidiary `a` is only needed because of the type application + mkHash :: (Show a, HashAlgorithm a) => Text -> a + mkHash s = hash (encodeUtf8 s) + + +placeHolderNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +placeHolderNix p = + do + t <- fromStringNoContext =<< fromValue p + h <- + runPrim + (hashStringNix + (makeNixStringWithoutContext "sha256" ) + (makeNixStringWithoutContext ("nix-output:" <> t)) + ) + toValue + $ makeNixStringWithoutContext + $ Text.cons '/' + $ Base32.encode + -- Please, stop Text -> Bytestring here after migration to Text + $ case Base16.decode (bytes h) of -- The result coming out of hashString is base16 encoded +#if MIN_VERSION_base16_bytestring(1,0,0) + -- Please, stop Text -> String here after migration to Text + Left e -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nThe Left fail content: '" <> show e <> "'." + Right d -> d +#else + (d, "") -> d + (_, e) -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nUndecodable remainder: '" <> show e <> "'." +#endif + where + bytes :: NixString -> ByteString + bytes = encodeUtf8 . body + + body h = stringIgnoreContext h + +readFileNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +readFileNix = toValue <=< Nix.Render.readFile <=< absolutePathFromValue <=< demand + +findFileNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +findFileNix nvaset nvfilepath = + do + aset <- demand nvaset + filePath <- demand nvfilepath + + case (aset, filePath) of + (NVList x, NVStr ns) -> + do + mres <- findPath @t @f @m x (toString (stringIgnoreContext ns)) + + pure $ nvPath mres + + (NVList _, _y ) -> throwError $ ErrorCall $ "expected a string, got " <> show _y + (_x , NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show _x + (_x , _y ) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " <> show (_x, _y) + +readDirNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +readDirNix nvpath = + do + path <- absolutePathFromValue =<< demand nvpath + items <- listDirectory path + + let + detectFileTypes item = + do + s <- getSymbolicLinkStatus $ path item + let + t = + if + | isRegularFile s -> FileTypeRegular + | isDirectory s -> FileTypeDirectory + | isSymbolicLink s -> FileTypeSymlink + | otherwise -> FileTypeUnknown + + pure (toText item, t) + + itemsWithTypes <- + traverse + detectFileTypes + items + + getDeeper <$> toValue (M.fromList itemsWithTypes) + +fromJSONNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +fromJSONNix nvjson = + do + j <- demand nvjson + jText <- fromStringNoContext =<< fromValue j + + either + (\ jsonError -> throwError $ ErrorCall $ "builtins.fromJSON: " <> jsonError) + jsonToNValue + -- do we really need to marshall Text -> ByteString -> Aeson.Value (that is a Text) + (A.eitherDecodeStrict' @A.Value $ encodeUtf8 jText) + + where + jsonToNValue = \case + A.Object m -> nvSet mempty <$> traverse jsonToNValue m + A.Array l -> nvList <$> traverse jsonToNValue (V.toList l) + A.String s -> pure $ nvStr $ makeNixStringWithoutContext s + A.Number n -> + pure $ + nvConstant $ + either + NFloat + NInt + (floatingOrInteger n) + A.Bool b -> pure $ mkNVBool b + A.Null -> pure nVNull + +toJSONNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toJSONNix = (fmap nvStr . nvalueToJSONNixString) <=< demand + +toXMLNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toXMLNix = (fmap (nvStr . toXML) . normalForm) <=< demand + +typeOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +typeOfNix nvv = + do + v <- demand nvv + let + detectType = + case v of + NVConstant a -> + case a of + NURI _ -> "string" + NInt _ -> "int" + NFloat _ -> "float" + NBool _ -> "bool" + NNull -> "null" + NVStr _ -> "string" + NVList _ -> "list" + NVSet _ _ -> "set" + NVClosure{} -> "lambda" + NVPath _ -> "path" + NVBuiltin _ _ -> "lambda" + _ -> error "Pattern synonyms obscure complete patterns" + + toValue $ makeNixStringWithoutContext detectType + +tryEvalNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +tryEvalNix e = catch (onSuccess <$> demand e) (pure . onError) + where + onSuccess v = + nvSet + mempty + $ M.fromList + [ ("success", mkNVBool True) + , ("value", v) + ] + + onError :: SomeException -> NValue t f m + onError _ = + nvSet + mempty + $ M.fromList + $ ($ mkNVBool False) <$> + [ ("success",) + , ("value" ,) + ] + +traceNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +traceNix msg action = + do + traceEffect @t @f @m . toString . stringIgnoreContext =<< fromValue msg + pure action + +-- Please, can function remember fail context +addErrorContextNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m -- action + -> m (NValue t f m) +addErrorContextNix _ = pure + +execNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +execNix xs = + do + ls <- fromValue @[NValue t f m] xs + xs <- traverse (coerceToString callFunc DontCopyToStore CoerceStringy) ls + -- 2018-11-19: NOTE: Still need to do something with the context here + -- See prim_exec in nix/src/libexpr/primops.cc + -- Requires the implementation of EvalState::realiseContext + exec (stringIgnoreContext <$> xs) + +fetchurlNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +fetchurlNix = + (\case + NVSet s _ -> go (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s + v@NVStr{} -> go Nothing v + v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v + ) <=< demand + + where + go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) + go _msha = + \case + NVStr ns -> + either -- msha + throwError + toValue + =<< getURL =<< noContextAttrs ns + + v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or string, got " <> show v + + noContextAttrs ns = + maybe + (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") + pure + (getStringNoContext ns) + +partitionNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +partitionNix f nvlst = + do + l <- fromValue @[NValue t f m] nvlst + let + match t = (, t) <$> (fromValue =<< callFunc f t) + selection <- traverse match l + + let + (right, wrong) = partition fst selection + makeSide = nvList . fmap snd + + toValue @(AttrSet (NValue t f m)) + $ M.fromList [("right", makeSide right), ("wrong", makeSide wrong)] + +currentSystemNix :: MonadNix e t f m => m (NValue t f m) +currentSystemNix = + do + os <- getCurrentSystemOS + arch <- getCurrentSystemArch + + pure $ nvStr $ makeNixStringWithoutContext (arch <> "-" <> os) + +currentTimeNix :: MonadNix e t f m => m (NValue t f m) +currentTimeNix = + do + opts :: Options <- asks (view hasLens) + toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) + +derivationStrictNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +derivationStrictNix = derivationStrict + +getRecursiveSizeNix :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) +getRecursiveSizeNix = fmap (nvConstant . NInt . fromIntegral) . recursiveSize + +getContextNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +getContextNix v = + do + v' <- demand v + case v' of + (NVStr ns) -> do + let context = getNixLikeContext $ toNixLikeContext $ getContext ns + valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context + pure $ nvSet mempty valued + x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x + +appendContextNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +appendContextNix tx ty = + do + x <- demand tx + y <- demand ty + + case (x, y) of + (NVStr ns, NVSet attrs _) -> + do + newContextValues <- traverse getPathNOuts attrs + + toValue $ addContext ns newContextValues + + _xy -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show _xy + + where + getPathNOuts tx = + do + x <- demand tx + + case x of + NVSet attrs _ -> + do + -- TODO: Fail for unexpected keys. + + let + getPaths = + maybe + (pure False) + (fromValue <=< demand) + (M.lookup "path" attrs) + + getAllOutputs = + maybe + (pure False) + (fromValue <=< demand) + (M.lookup "allOutputs" attrs) + + getOutputs = + maybe + stub + (\ touts -> + do + outs <- demand touts + + case outs of + NVList vs -> traverse (fmap stringIgnoreContext . fromValue) vs + _x -> throwError $ ErrorCall $ "Invalid types for context value outputs in builtins.appendContext: " <> show _x + ) + (M.lookup "outputs" attrs) + + path <- getPaths + allOutputs <- getAllOutputs + + NixLikeContextValue path allOutputs <$> getOutputs + + _x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show _x + + addContext ns newContextValues = + makeNixString + (stringIgnoreContext ns) + (fromNixLikeContext $ + NixLikeContext $ + M.unionWith + (<>) + newContextValues + (getNixLikeContext $ + toNixLikeContext $ + getContext ns + ) + ) + + +-- ** @builtinsList@ + +builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] +builtinsList = sequence + [ do + version <- toValue (makeNixStringWithoutContext "2.3") + pure $ Builtin Normal ("nixVersion", version) + , do + version <- toValue (5 :: Int) + pure $ Builtin Normal ("langVersion", version) + + , add TopLevel "abort" throwNix -- for now + , add2 Normal "add" addNix + , add2 Normal "addErrorContext" addErrorContextNix + , add2 Normal "all" allNix + , add2 Normal "any" anyNix + , add2 Normal "appendContext" appendContextNix + , add Normal "attrNames" attrNamesNix + , add Normal "attrValues" attrValuesNix + , add TopLevel "baseNameOf" baseNameOfNix + , add2 Normal "bitAnd" bitAndNix + , add2 Normal "bitOr" bitOrNix + , add2 Normal "bitXor" bitXorNix + , add0 Normal "builtins" builtinsBuiltinNix + , add2 Normal "catAttrs" catAttrsNix + , add2 Normal "compareVersions" compareVersionsNix + , add Normal "concatLists" concatListsNix + , add2 Normal "concatMap" concatMapNix + , add' Normal "concatStringsSep" (arity2 intercalateNixString) + , add0 Normal "currentSystem" currentSystemNix + , add0 Normal "currentTime" currentTimeNix + , add2 Normal "deepSeq" deepSeqNix + , add0 TopLevel "derivation" derivationNix + , add TopLevel "derivationStrict" derivationStrictNix + , add TopLevel "dirOf" dirOfNix + , add2 Normal "div" divNix + , add2 Normal "elem" elemNix + , add2 Normal "elemAt" elemAtNix + , add Normal "exec" execNix + , add0 Normal "false" (pure $ mkNVBool False) + --, add Normal "fetchGit" fetchGit + --, add Normal "fetchMercurial" fetchMercurial + , add Normal "fetchTarball" fetchTarball + , add Normal "fetchurl" fetchurlNix + , add2 Normal "filter" filterNix + --, add Normal "filterSource" filterSource + , add2 Normal "findFile" findFileNix + , add3 Normal "foldl'" foldl'Nix + , add Normal "fromJSON" fromJSONNix + --, add Normal "fromTOML" fromTOML + , add Normal "functionArgs" functionArgsNix + , add Normal "genericClosure" genericClosureNix + , add2 Normal "genList" genListNix + , add2 Normal "getAttr" getAttrNix + , add Normal "getContext" getContextNix + , add Normal "getEnv" getEnvNix + , add2 Normal "hasAttr" hasAttrNix + , add Normal "hasContext" hasContextNix + , add' Normal "hashString" (hashStringNix @e @t @f @m) + , add Normal "head" headNix + , add TopLevel "import" importNix + , add2 Normal "intersectAttrs" intersectAttrsNix + , add Normal "isAttrs" isAttrsNix + , add Normal "isBool" isBoolNix + , add Normal "isFloat" isFloatNix + , add Normal "isFunction" isFunctionNix + , add Normal "isInt" isIntNix + , add Normal "isList" isListNix + , add TopLevel "isNull" isNullNix + , add Normal "isString" isStringNix + , add Normal "length" lengthNix + , add2 Normal "lessThan" lessThanNix + , add Normal "listToAttrs" listToAttrsNix + , add2 TopLevel "map" mapNix + , add2 TopLevel "mapAttrs" mapAttrsNix + , add2 Normal "match" matchNix + , add2 Normal "mul" mulNix + , add0 Normal "nixPath" nixPathNix + , add0 Normal "null" (pure nVNull) + , add Normal "parseDrvName" parseDrvNameNix + , add2 Normal "partition" partitionNix + --, add Normal "path" path + , add Normal "pathExists" pathExistsNix + , add TopLevel "placeholder" placeHolderNix + , add Normal "readDir" readDirNix + , add Normal "readFile" readFileNix + , add2 TopLevel "removeAttrs" removeAttrsNix + , add3 Normal "replaceStrings" replaceStringsNix + , add2 TopLevel "scopedImport" scopedImportNix + , add2 Normal "seq" seqNix + , add2 Normal "sort" sortNix + , add2 Normal "split" splitNix + , add Normal "splitVersion" splitVersionNix + , add0 Normal "storeDir" (pure $ nvStr $ makeNixStringWithoutContext "/nix/store") + --, add Normal "storePath" storePath + , add' Normal "stringLength" (arity1 $ Text.length . stringIgnoreContext) + , add' Normal "sub" (arity2 ((-) @Integer)) + , add' Normal "substring" substringNix + , add Normal "tail" tailNix + , add TopLevel "throw" throwNix + , add2 Normal "toFile" toFileNix + , add Normal "toJSON" toJSONNix + , add Normal "toPath" toPathNix + , add TopLevel "toString" toStringNix + , add Normal "toXML" toXMLNix + , add2 TopLevel "trace" traceNix + , add0 Normal "true" (pure $ mkNVBool True) + , add Normal "tryEval" tryEvalNix + , add Normal "typeOf" typeOfNix + --, add0 Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependency + , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContextNix + , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPosNix + , add Normal "valueSize" getRecursiveSizeNix + ] + where + arity1 :: (a -> b) -> (a -> Prim m b) + arity1 f = Prim . pure . f + + arity2 :: (a -> b -> c) -> (a -> b -> Prim m c) + arity2 f = ((Prim . pure) .) . f + + mkBuiltin :: BuiltinType -> Text -> m (NValue t f m) -> m (Builtin (NValue t f m)) + mkBuiltin t n v = wrap t n <$> mkThunk n v + where + wrap :: BuiltinType -> Text -> v -> Builtin v + wrap t n f = Builtin t (n, f) + + mkThunk :: Text -> m (NValue t f m) -> m (NValue t f m) + mkThunk n = defer . withFrame Info (ErrorCall $ "While calling builtin " <> toString n <> "\n") + + add0 + :: BuiltinType + -> Text + -> m (NValue t f m) + -> m (Builtin (NValue t f m)) + add0 t n v = mkBuiltin t n v + + add + :: BuiltinType + -> Text + -> ( NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add t n v = mkBuiltin t n (builtin n v) + + add2 + :: BuiltinType + -> Text + -> ( NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add2 t n v = mkBuiltin t n (builtin2 n v) + + add3 + :: BuiltinType + -> Text + -> ( NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add3 t n v = mkBuiltin t n (builtin3 n v) + + add' + :: ToBuiltin t f m a + => BuiltinType + -> Text + -> a + -> m (Builtin (NValue t f m)) + add' t n v = mkBuiltin t n (toBuiltin n v) + + +-- * Exported + +-- | Evaluate a nix expression in the default context +withNixContext + :: forall e t f m r + . (MonadNix e t f m, Has e Options) + => Maybe FilePath + -> m r + -> m r +withNixContext mpath action = + do + base <- builtins + opts :: Options <- asks $ view hasLens + let + i = nvList $ nvStr . makeNixStringWithoutContext . toText <$> include opts + + pushScope (M.singleton "__includes" i) $ pushScopes base $ + maybe + action + (\ path -> + do + traceM $ "Setting __cur_file = " <> show path + let ref = nvPath path + pushScope (M.singleton "__cur_file" ref) action + ) + mpath + +builtins + :: ( MonadNix e t f m + , Scoped (NValue t f m) m + ) + => m (Scopes m (NValue t f m)) +builtins = + do + ref <- defer $ nvSet mempty <$> buildMap + lst <- ([("builtins", ref)] <>) <$> topLevelBuiltins + pushScope (M.fromList lst) currentScopes + where + buildMap = fmap (M.fromList . fmap mapping) builtinsList + topLevelBuiltins = mapping <<$>> fullBuiltinsList + + fullBuiltinsList = go <<$>> builtinsList + where + go b@(Builtin TopLevel _) = b + go (Builtin Normal (name, builtin)) = + Builtin TopLevel ("__" <> name, builtin) + diff --git a/src/Nix/Cache.hs b/src/Nix/Cache.hs --- a/src/Nix/Cache.hs +++ b/src/Nix/Cache.hs @@ -7,12 +7,13 @@ import Nix.Expr.Types.Annotated #if defined (__linux__) +-- This is about: https://hackage.haskell.org/package/compact #define USE_COMPACT 1 #endif #ifdef USE_COMPACT -import qualified Data.Compact as C -import qualified Data.Compact.Serialize as C +import qualified Data.Compact as C +import qualified Data.Compact.Serialize as C #endif #ifdef MIN_VERSION_serialise import qualified Codec.Serialise as S @@ -21,18 +22,20 @@ readCache :: FilePath -> IO NExprLoc readCache path = do #if USE_COMPACT - eres <- C.unsafeReadCompact path - case eres of - Left err -> error $ "Error reading cache file: " ++ err - Right expr -> return $ C.getCompact expr + eres <- C.unsafeReadCompact path + either + (\ err -> fail $ "Error reading cache file: " <> err) + (\ expr -> pure $ C.getCompact expr) + eres #else #ifdef MIN_VERSION_serialise eres <- S.deserialiseOrFail <$> BS.readFile path - case eres of - Left err -> error $ "Error reading cache file: " ++ show err - Right expr -> return expr + either + (\ err -> fail $ "Error reading cache file: " <> show err) + pure + eres #else - error "readCache not implemented for this platform" + fail "readCache not implemented for this platform" #endif #endif @@ -44,6 +47,6 @@ #ifdef MIN_VERSION_serialise BS.writeFile path (S.serialise expr) #else - error "writeCache not implemented for this platform" + fail "writeCache not implemented for this platform" #endif #endif diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs --- a/src/Nix/Cited.hs +++ b/src/Nix/Cited.hs @@ -12,14 +12,15 @@ import Control.Comonad import Control.Comonad.Env -import Data.Typeable ( Typeable ) -import GHC.Generics import Lens.Family2.TH import Nix.Expr.Types.Annotated import Nix.Scope +import Nix.Value ( NValue, NValue'(NValue') ) +import Control.Monad.Free ( Free(Pure, Free) ) -data Provenance m v = Provenance +data Provenance m v = + Provenance { _lexicalScope :: Scopes m v , _originExpr :: NExprLocF (Maybe v) -- ^ When calling the function x: x + 2 with argument x = 3, the @@ -36,7 +37,7 @@ deriving (Generic, Typeable, Functor, Foldable, Traversable, Show) instance Applicative (NCited m v) where - pure = NCited [] + pure = NCited mempty NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) instance Comonad (NCited m v) where @@ -49,14 +50,26 @@ $(makeLenses ''Provenance) $(makeLenses ''NCited) +class HasCitations1 m v f where + citations1 :: f a -> [Provenance m v] + addProvenance1 :: Provenance m v -> f a -> f a + class HasCitations m v a where - citations :: a -> [Provenance m v] - addProvenance :: Provenance m v -> a -> a + citations :: a -> [Provenance m v] + addProvenance :: Provenance m v -> a -> a instance HasCitations m v (NCited m v a) where citations = _provenance addProvenance x (NCited p v) = NCited (x : p) v -class HasCitations1 m v f where - citations1 :: f a -> [Provenance m v] - addProvenance1 :: Provenance m v -> f a -> f a +instance HasCitations1 m v f + => HasCitations m v (NValue' t f m a) where + citations (NValue' f) = citations1 f + addProvenance x (NValue' f) = NValue' $ addProvenance1 x f + +instance (HasCitations1 m v f, HasCitations m v t) + => HasCitations m v (NValue t f m) where + citations (Pure t) = citations t + citations (Free v) = citations v + addProvenance x (Pure t) = Pure $ addProvenance x t + addProvenance x (Free v) = Free $ addProvenance x v diff --git a/src/Nix/Cited/Basic.hs b/src/Nix/Cited/Basic.hs --- a/src/Nix/Cited/Basic.hs +++ b/src/Nix/Cited/Basic.hs @@ -8,15 +8,15 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE InstanceSigs #-} module Nix.Cited.Basic where +import Prelude hiding ( force ) import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) -import Control.Monad.Reader import Data.Fix -import GHC.Generics import Nix.Cited import Nix.Eval as Eval import Nix.Exec @@ -41,7 +41,7 @@ instance HasCitations1 m (NValue t f m) (Cited t f m) where citations1 (Cited c) = citations c - addProvenance1 x (Cited c) = Cited (addProvenance x c) + addProvenance1 x (Cited c) = Cited $ addProvenance x c instance ( Has e Options , Framed e m @@ -52,49 +52,106 @@ , MonadCatch m ) => MonadThunk (Cited u f m t) m v where + + thunk :: m v -> m (Cited u f m t) thunk mv = do opts :: Options <- asks (view hasLens) - if thunks opts - then do + bool + (Cited . NCited mempty <$> thunk mv) + (do frames :: Frames <- asks (view hasLens) -- Gather the current evaluation context at the time of thunk -- creation, and record it along with the thunk. let go (fromException -> Just (EvaluatingExpr scope - (Fix (Compose (Ann s e))))) = + (Fix (Compose (Ann s e))))) = let e' = Compose (Ann s (Nothing <$ e)) in [Provenance scope e'] - go _ = [] + go _ = mempty ps = concatMap (go . frame) frames - fmap (Cited . NCited ps) . thunk $ mv - else fmap (Cited . NCited []) . thunk $ mv + Cited . NCited ps <$> thunk mv + ) + (thunks opts) + thunkId :: Cited u f m t -> ThunkId m thunkId (Cited (NCited _ t)) = thunkId @_ @m t - queryM (Cited (NCited _ t)) = queryM t + queryM :: m v -> Cited u f m t -> m v + queryM m (Cited (NCited _ t)) = queryM m t -- | The ThunkLoop exception is thrown as an exception with MonadThrow, -- which does not capture the current stack frame information to provide -- it in a NixException, so we catch and re-throw it here using -- 'throwError' from Frames.hs. - force (Cited (NCited ps t)) f = - catch go (throwError @ThunkLoop) - where - go = case ps of - [] -> force t f - Provenance scope e@(Compose (Ann s _)) : _ -> - withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f) + force :: Cited u f m t -> m v + force (Cited (NCited ps t)) = handleDisplayProvenance ps $ force t - forceEff (Cited (NCited ps t)) f = catch - go + forceEff :: Cited u f m t -> m v + forceEff (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceEff t + + further :: Cited u f m t -> m (Cited u f m t) + further (Cited (NCited ps t)) = Cited . NCited ps <$> further t + + +-- * Kleisli functor HOFs + +-- Please, do not use MonadThunkF for MonadThunk, later uses more straight-forward specialized line of functions. +instance ( Has e Options + , Framed e m + , MonadThunkF t m v + , Typeable m + , Typeable f + , Typeable u + , MonadCatch m + ) + => MonadThunkF (Cited u f m t) m v where + + queryMF :: (v -> m r) -> m r -> Cited u f m t -> m r + queryMF k m (Cited (NCited _ t)) = queryMF k m t + + forceF :: (v -> m r) -> Cited u f m t -> m r + forceF k (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceF k t + + forceEffF :: (v -> m r) -> Cited u f m t -> m r + forceEffF k (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceEffF k t + + furtherF :: (m v -> m v) -> Cited u f m t -> m (Cited u f m t) + furtherF k (Cited (NCited ps t)) = Cited . NCited ps <$> furtherF k t + + +-- ** Utils + +handleDisplayProvenance + :: (MonadCatch m + , Typeable m + , Typeable v + , Has e Frames + , MonadReader e m + ) + => [Provenance m v] + -> m a + -> m a +handleDisplayProvenance ps f = + catch + (displayProvenance ps f) (throwError @ThunkLoop) - where - go = case ps of - [] -> forceEff t f - Provenance scope e@(Compose (Ann s _)) : _ -> - withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f) - further (Cited (NCited ps t)) f = Cited . NCited ps <$> further t f +displayProvenance + :: (MonadThrow m + , MonadReader e m + , Has e Frames + , Typeable m + , Typeable v + ) + => [Provenance m v] + -> m a + -> m a +displayProvenance = + list + id + (\ (Provenance scope e@(Compose (Ann s _)) : _) -> + withFrame Info (ForcingExpr scope (wrapExprLoc s e)) + ) diff --git a/src/Nix/Context.hs b/src/Nix/Context.hs --- a/src/Nix/Context.hs +++ b/src/Nix/Context.hs @@ -4,13 +4,14 @@ module Nix.Context where -import Nix.Options -import Nix.Scope -import Nix.Frames -import Nix.Utils +import Nix.Options ( Options ) +import Nix.Scope ( Scopes + , emptyScopes ) +import Nix.Frames ( Frames ) import Nix.Expr.Types.Annotated ( SrcSpan , nullSpan ) +import Nix.Utils ( Has(..) ) data Context m t = Context { scopes :: Scopes m t @@ -20,16 +21,16 @@ } instance Has (Context m t) (Scopes m t) where - hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x + hasLens f a = (\x -> a { scopes = x }) <$> f (scopes a) instance Has (Context m t) SrcSpan where - hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y + hasLens f a = (\x -> a { source = x }) <$> f (source a) instance Has (Context m t) Frames where - hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z + hasLens f a = (\x -> a { frames = x }) <$> f (frames a) instance Has (Context m t) Options where - hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w + hasLens f a = (\x -> a { options = x }) <$> f (options a) newContext :: Options -> Context m t -newContext = Context emptyScopes nullSpan [] +newContext = Context emptyScopes nullSpan mempty diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -6,14 +6,12 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | Although there are a lot of instances in this file, really it's just a @@ -25,15 +23,9 @@ module Nix.Convert where +import Prelude hiding ( force ) import Control.Monad.Free -import Data.ByteString import qualified Data.HashMap.Lazy as M -import Data.Maybe -import Data.Text ( Text ) -import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 - , decodeUtf8 - ) import Nix.Atoms import Nix.Effects import Nix.Expr.Types @@ -61,14 +53,47 @@ -} ---------------------------------------------------------------------------------- + -- * FromValue ---------------------------------------------------------------------------------- class FromValue a m v where - fromValue :: v -> m a - fromValueMay :: v -> m (Maybe a) + fromValue :: v -> m a + fromValueMay :: v -> m (Maybe a) + +-- Please, hide these helper function from export, to be sure they get optimized away. +fromMayToValue + :: forall t f m a e + . ( Convertible e t f m + , FromValue a m (NValue' t f m (NValue t f m)) + ) + => ValueType + -> NValue' t f m (NValue t f m) + -> m a +fromMayToValue t v = + do + v' <- fromValueMay v + maybe + (throwError $ Expectation @t @f @m t (Free v)) + pure + v' + +fromMayToDeeperValue + :: forall t f m a e m1 + . ( Convertible e t f m + , FromValue (m1 a) m (Deeper (NValue' t f m (NValue t f m))) + ) + => ValueType + -> Deeper (NValue' t f m (NValue t f m)) + -> m (m1 a) +fromMayToDeeperValue t v = + do + v' <- fromValueMay v + maybe + (throwError $ Expectation @t @f @m t (Free $ getDeeper v)) + pure + v' + type Convertible e t f m = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) @@ -77,101 +102,127 @@ , FromValue a m (NValue' t f m (NValue t f m)) ) => FromValue a m (NValue t f m) where - fromValueMay = flip demand $ \case - Pure t -> force t fromValueMay - Free v -> fromValueMay v - fromValue = flip demand $ \case - Pure t -> force t fromValue - Free v -> fromValue v + fromValueMay = + free + (fromValueMay <=< force) + fromValueMay + <=< demand + + fromValue = + free + (fromValue <=< force) + fromValue + <=< demand + instance ( Convertible e t f m , MonadValue (NValue t f m) m , FromValue a m (Deeper (NValue' t f m (NValue t f m))) ) => FromValue a m (Deeper (NValue t f m)) where - fromValueMay (Deeper v) = demand v $ \case - Pure t -> force t (fromValueMay . Deeper) - Free v -> fromValueMay (Deeper v) - fromValue (Deeper v) = demand v $ \case - Pure t -> force t (fromValue . Deeper) - Free v -> fromValue (Deeper v) + fromValueMay (Deeper v) = + free + ((fromValueMay . Deeper) <=< force) + (fromValueMay . Deeper) + =<< demand v + + fromValue (Deeper v) = + free + ((fromValue . Deeper) <=< force) + (fromValue . Deeper) + =<< demand v + instance Convertible e t f m => FromValue () m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVConstant' NNull -> pure $ Just () - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TNull (Free v) + fromValueMay = + pure . + \case + NVConstant' NNull -> pass + _ -> mempty + + fromValue = fromMayToValue TNull + instance Convertible e t f m => FromValue Bool m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVConstant' (NBool b) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TBool (Free v) + fromValueMay = + pure . + \case + NVConstant' (NBool b) -> pure b + _ -> Nothing + + fromValue = fromMayToValue TBool + instance Convertible e t f m => FromValue Int m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVConstant' (NInt b) -> pure $ Just (fromInteger b) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TInt (Free v) + fromValueMay = + pure . + \case + NVConstant' (NInt b) -> pure (fromInteger b) + _ -> Nothing + + fromValue = fromMayToValue TInt + instance Convertible e t f m => FromValue Integer m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVConstant' (NInt b) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TInt (Free v) + fromValueMay = + pure . + \case + NVConstant' (NInt b) -> pure b + _ -> Nothing + + fromValue = fromMayToValue TInt + instance Convertible e t f m => FromValue Float m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVConstant' (NFloat b) -> pure $ Just b - NVConstant' (NInt i) -> pure $ Just (fromInteger i) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TFloat (Free v) + fromValueMay = + pure . + \case + NVConstant' (NFloat b) -> pure b + NVConstant' (NInt i) -> pure (fromInteger i) + _ -> Nothing + + fromValue = fromMayToValue TFloat + instance ( Convertible e t f m , MonadValue (NValue t f m) m , MonadEffects t f m ) => FromValue NixString m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVStr' ns -> pure $ Just ns - NVPath' p -> - Just - . (\s -> principledMakeNixStringWithSingletonContext s (StringContext s DirectPath)) - . Text.pack - . unStorePath - <$> addPath p - NVSet' s _ -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) + fromValueMay = + \case + NVStr' ns -> pure $ pure ns + NVPath' p -> + fmap + (pure . (\s -> makeNixStringWithSingletonContext s (StringContext s DirectPath)) . toText . unStorePath) + (addPath p) + NVSet' s _ -> + maybe + stub + fromValueMay + (M.lookup "outPath" s) + _ -> stub + + fromValue = fromMayToValue (TString NoContext) + instance Convertible e t f m => FromValue ByteString m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) + fromValueMay = + pure. + \case + NVStr' ns -> encodeUtf8 <$> getStringNoContext ns + _ -> mempty + + fromValue = fromMayToValue (TString NoContext) + + newtype Path = Path { getPath :: FilePath } deriving Show @@ -179,79 +230,91 @@ , MonadValue (NValue t f m) m ) => FromValue Path m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVPath' p -> pure $ Just (Path p) - NVStr' ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns - NVSet' s _ -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay @Path p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TPath (Free v) + fromValueMay = + \case + NVPath' p -> pure $ pure $ Path p + NVStr' ns -> pure $ Path . toString <$> getStringNoContext ns + NVSet' s _ -> + maybe + (pure Nothing) + (fromValueMay @Path) + (M.lookup "outPath" s) + _ -> pure Nothing + + fromValue = fromMayToValue TPath + instance Convertible e t f m => FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVList' l -> pure $ Just l - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TList (Free v) + fromValueMay = + pure. + \case + NVList' l -> pure l + _ -> mempty + + fromValue = fromMayToValue TList + instance ( Convertible e t f m , FromValue a m (NValue t f m) ) => FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where - fromValueMay = \case - Deeper (NVList' l) -> sequence <$> traverse fromValueMay l - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TList (Free (getDeeper v)) + fromValueMay = + \case + Deeper (NVList' l) -> sequence <$> traverse fromValueMay l + _ -> stub + + fromValue = fromMayToDeeperValue TList + instance Convertible e t f m => FromValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVSet' s _ -> pure $ Just s - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free v) + fromValueMay = + pure . + \case + NVSet' s _ -> pure s + _ -> mempty + + fromValue = fromMayToValue TSet + instance ( Convertible e t f m , FromValue a m (NValue t f m) ) => FromValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where - fromValueMay = \case - Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) + fromValueMay = + \case + Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s + _ -> stub + + fromValue = fromMayToDeeperValue TSet + instance Convertible e t f m => FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m (NValue' t f m (NValue t f m)) where - fromValueMay = \case - NVSet' s p -> pure $ Just (s, p) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free v) + fromValueMay = + pure . + \case + NVSet' s p -> pure (s, p) + _ -> mempty + + fromValue = fromMayToValue TSet + instance ( Convertible e t f m , FromValue a m (NValue t f m) ) => FromValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m (NValue t f m))) where - fromValueMay = \case - Deeper (NVSet' s p) -> fmap (, p) . sequence <$> traverse fromValueMay s - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) + fromValueMay = + \case + Deeper (NVSet' s p) -> fmap (, p) . sequence <$> traverse fromValueMay s + _ -> stub + + fromValue = fromMayToDeeperValue TSet + -- This instance needs IncoherentInstances, and only because of ToBuiltin instance ( Convertible e t f m , FromValue a m (NValue' t f m (NValue t f m)) @@ -260,9 +323,8 @@ fromValueMay = fromValueMay . getDeeper fromValue = fromValue . getDeeper ---------------------------------------------------------------------------------- + -- * ToValue ---------------------------------------------------------------------------------- class ToValue a m v where toValue :: a -> m v @@ -303,7 +365,7 @@ instance Convertible e t f m => ToValue ByteString m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' . hackyMakeNixStringWithoutContext . decodeUtf8 + toValue = pure . nvStr' . makeNixStringWithoutContext . decodeUtf8 instance Convertible e t f m => ToValue Path m (NValue' t f m (NValue t f m)) where @@ -317,11 +379,11 @@ ) => ToValue SourcePos m (NValue' t f m (NValue t f m)) where toValue (SourcePos f l c) = do - f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f)) + f' <- toValue (makeNixStringWithoutContext (toText f)) l' <- toValue (unPos l) c' <- toValue (unPos c) let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')] - pure $ nvSet' pos mempty + pure $ nvSet' mempty pos -- | With 'ToValue', we can always act recursively instance Convertible e t f m @@ -334,37 +396,49 @@ instance Convertible e t f m => ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where - toValue s = pure $ nvSet' s mempty + toValue s = pure $ nvSet' mempty s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where - toValue s = (Deeper .) . nvSet' <$> traverse toValue s <*> pure mempty + toValue s = + liftA2 + (\ v s -> Deeper $ nvSet' s v) + (traverse toValue s) + stub instance Convertible e t f m => ToValue (AttrSet (NValue t f m), AttrSet SourcePos) m (NValue' t f m (NValue t f m)) where - toValue (s, p) = pure $ nvSet' s p + toValue (s, p) = pure $ nvSet' p s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m (NValue t f m))) where - toValue (s, p) = (Deeper .) . nvSet' <$> traverse toValue s <*> pure p + toValue (s, p) = (\ v s -> Deeper $ nvSet' s v) <$> traverse toValue s <*> pure p instance Convertible e t f m => ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where toValue nlcv = do - path <- if nlcvPath nlcv then Just <$> toValue True else pure Nothing - allOutputs <- if nlcvAllOutputs nlcv - then Just <$> toValue True - else pure Nothing + path <- + bool + (pure Nothing) + (pure <$> toValue True) + (nlcvPath nlcv) + allOutputs <- + bool + (pure Nothing) + (pure <$> toValue True) + (nlcvAllOutputs nlcv) outputs <- do - let outputs = - principledMakeNixStringWithoutContext <$> nlcvOutputs nlcv + let + outputs = makeNixStringWithoutContext <$> nlcvOutputs nlcv + ts :: [NValue t f m] <- traverse toValue outputs - case ts of - [] -> pure Nothing - _ -> Just <$> toValue ts - pure $ flip nvSet' M.empty $ M.fromList $ catMaybes + list + (pure Nothing) + (fmap pure . toValue) + ts + pure $ nvSet' mempty $ M.fromList $ catMaybes [ ("path",) <$> path , ("allOutputs",) <$> allOutputs , ("outputs",) <$> outputs diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -5,57 +5,68 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + + module Nix.Effects where -import Prelude hiding ( putStr +import Prelude hiding ( traceM + , putStr , putStrLn , print ) import qualified Prelude - -import Control.Monad.Trans +import Nix.Utils import qualified Data.HashSet as HS -import Data.Text ( Text ) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.Text as Text import Network.HTTP.Client hiding ( path, Proxy ) import Network.HTTP.Client.TLS import Network.HTTP.Types +import Nix.Utils.Fix1 import Nix.Expr import Nix.Frames hiding ( Proxy ) import Nix.Parser import Nix.Render -import Nix.Utils import Nix.Value import qualified Paths_hnix -import System.Environment import System.Exit +import qualified System.Environment as Env import System.FilePath ( takeFileName ) import qualified System.Info import System.Process import qualified System.Nix.Hash as Store -import qualified System.Nix.Store.Remote as Store -import qualified System.Nix.Store.Remote.Types as Store +import qualified System.Nix.Store.Remote as Store.Remote import qualified System.Nix.StorePath as Store -- | A path into the nix store newtype StorePath = StorePath { unStorePath :: FilePath } -class (MonadFile m, - MonadStore m, - MonadPutStr m, - MonadHttp m, - MonadEnv m, - MonadPaths m, - MonadInstantiate m, - MonadExec m, - MonadIntrospect m) => MonadEffects t f m where + +-- All of the following type classes defer to the underlying 'm'. + +-- * @class MonadEffects t f m@ + +class + ( MonadFile m + , MonadStore m + , MonadPutStr m + , MonadHttp m + , MonadEnv m + , MonadPaths m + , MonadInstantiate m + , MonadExec m + , MonadIntrospect m + ) + => MonadEffects t f m where + -- | Determine the absolute path of relative path in the current context makeAbsolutePath :: FilePath -> m FilePath findEnvPath :: String -> m FilePath @@ -69,172 +80,299 @@ derivationStrict :: NValue t f m -> m (NValue t f m) + -- 2021-04-01: for trace, so leaving String here traceEffect :: String -> m () -class Monad m => MonadIntrospect m where + +-- ** Instances + +instance + ( MonadFix1T t m + , MonadStore m + ) + => MonadStore (Fix1T t m) + where + addToStore a b c d = lift $ addToStore a b c d + addTextToStore' a b c d = lift $ addTextToStore' a b c d + +-- * @class MonadIntrospect m@ + +class + Monad m + => MonadIntrospect m + where recursiveSize :: a -> m Word default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word recursiveSize = lift . recursiveSize + +-- ** Instances + instance MonadIntrospect IO where recursiveSize = #ifdef MIN_VERSION_ghc_datasize #if MIN_VERSION_ghc_datasize(0,2,0) -recursiveSize + recursiveSize #else -\_ -> return 0 + \_ -> pure 0 #endif #else - \_ -> pure 0 + \_ -> pure 0 #endif -class Monad m => MonadExec m where - exec' :: [String] -> m (Either ErrorCall NExprLoc) +deriving + instance + MonadIntrospect (t (Fix1 t)) + => MonadIntrospect (Fix1 t) + +deriving + instance + MonadIntrospect (t (Fix1T t m) m) + => MonadIntrospect (Fix1T t m) + + +-- * @class MonadExec m@ + +class + Monad m + => MonadExec m where + + exec' :: [Text] -> m (Either ErrorCall NExprLoc) default exec' :: (MonadTrans t, MonadExec m', m ~ t m') - => [String] -> m (Either ErrorCall NExprLoc) + => [Text] -> m (Either ErrorCall NExprLoc) exec' = lift . exec' + +-- ** Instances + instance MonadExec IO where exec' = \case [] -> pure $ Left $ ErrorCall "exec: missing program" (prog : args) -> do - (exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args "" - let t = T.strip (T.pack out) - let emsg = "program[" ++ prog ++ "] args=" ++ show args + (exitCode, out, _) <- liftIO $ readProcessWithExitCode (toString prog) (toString <$> args) "" + let t = Text.strip (toText out) + let emsg = "program[" <> prog <> "] args=" <> show args case exitCode of - ExitSuccess -> if T.null t - then pure $ Left $ ErrorCall $ "exec has no output :" ++ emsg - else case parseNixTextLoc t of - Failure err -> - pure - $ Left - $ ErrorCall - $ "Error parsing output of exec: " - ++ show err - ++ " " - ++ emsg - Success v -> pure $ Right v - err -> - pure - $ Left - $ ErrorCall - $ "exec failed: " - ++ show err - ++ " " - ++ emsg + ExitSuccess -> + if Text.null t + then pure $ Left $ ErrorCall $ toString $ "exec has no output :" <> emsg + else + either + (\ err -> pure $ Left $ ErrorCall $ toString $ "Error parsing output of exec: " <> show err <> " " <> emsg) + (pure . pure) + (parseNixTextLoc t) + err -> pure $ Left $ ErrorCall $ toString $ "exec failed: " <> show err <> " " <> emsg -class Monad m => MonadInstantiate m where - instantiateExpr :: String -> m (Either ErrorCall NExprLoc) - default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> m (Either ErrorCall NExprLoc) +deriving + instance + MonadExec (t (Fix1 t)) + => MonadExec (Fix1 t) + +deriving + instance + MonadExec (t (Fix1T t m) m) + => MonadExec (Fix1T t m) + + +-- * @class MonadInstantiate m@ + +class + Monad m + => MonadInstantiate m where + + instantiateExpr :: Text -> m (Either ErrorCall NExprLoc) + default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => Text -> m (Either ErrorCall NExprLoc) instantiateExpr = lift . instantiateExpr + +-- ** Instances + instance MonadInstantiate IO where - instantiateExpr expr = do - traceM $ "Executing: " ++ show - ["nix-instantiate", "--eval", "--expr ", expr] - (exitCode, out, err) <- readProcessWithExitCode "nix-instantiate" - ["--eval", "--expr", expr] - "" - case exitCode of - ExitSuccess -> case parseNixTextLoc (T.pack out) of - Failure e -> - pure - $ Left - $ ErrorCall - $ "Error parsing output of nix-instantiate: " - ++ show e - Success v -> pure $ Right v - status -> - pure - $ Left - $ ErrorCall - $ "nix-instantiate failed: " - ++ show status - ++ ": " - ++ err -pathExists :: MonadFile m => FilePath -> m Bool -pathExists = doesPathExist + instantiateExpr expr = + do + traceM $ + "Executing: " <> show ["nix-instantiate", "--eval", "--expr ", expr] -class Monad m => MonadEnv m where - getEnvVar :: String -> m (Maybe String) - default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String) - getEnvVar = lift . getEnvVar - getCurrentSystemOS :: m Text - default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text - getCurrentSystemOS = lift getCurrentSystemOS - getCurrentSystemArch :: m Text - default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text - getCurrentSystemArch = lift getCurrentSystemArch + (exitCode, out, err) <- + readProcessWithExitCode + "nix-instantiate" + ["--eval", "--expr", toString expr] + "" + pure $ + case exitCode of + ExitSuccess -> + either + (\ e -> Left $ ErrorCall $ "Error parsing output of nix-instantiate: " <> show e) + pure + (parseNixTextLoc (toText out)) + status -> Left $ ErrorCall $ "nix-instantiate failed: " <> show status <> ": " <> err + +deriving + instance + MonadInstantiate (t (Fix1 t)) + => MonadInstantiate (Fix1 t) + +deriving + instance + MonadInstantiate (t (Fix1T t m) m) + => MonadInstantiate (Fix1T t m) + + +-- * @class MonadEnv m@ + +class + Monad m + => MonadEnv m where + + getEnvVar :: Text -> m (Maybe Text) + default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => Text -> m (Maybe Text) + getEnvVar = lift . getEnvVar + + getCurrentSystemOS :: m Text + default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemOS = lift getCurrentSystemOS + + getCurrentSystemArch :: m Text + default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemArch = lift getCurrentSystemArch + + +-- ** Instances + instance MonadEnv IO where - getEnvVar = lookupEnv + getEnvVar = (<<$>>) toText . Env.lookupEnv . toString - getCurrentSystemOS = pure $ T.pack System.Info.os + getCurrentSystemOS = pure $ toText System.Info.os -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 - getCurrentSystemArch = pure $ T.pack $ case System.Info.arch of + getCurrentSystemArch = pure $ toText $ case System.Info.arch of "i386" -> "i686" arch -> arch -class Monad m => MonadPaths m where - getDataDir :: m FilePath - default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath - getDataDir = lift getDataDir +deriving + instance + MonadEnv (t (Fix1 t)) + => MonadEnv (Fix1 t) +deriving + instance + MonadEnv (t (Fix1T t m) m) + => MonadEnv (Fix1T t m) + + +-- * @class MonadPaths m@ + +class + Monad m + => MonadPaths m where + getDataDir :: m FilePath + default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath + getDataDir = lift getDataDir + + +-- ** Instances + instance MonadPaths IO where - getDataDir = Paths_hnix.getDataDir + getDataDir = Paths_hnix.getDataDir -class Monad m => MonadHttp m where - getURL :: Text -> m (Either ErrorCall StorePath) - default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) - getURL = lift . getURL +deriving + instance + MonadPaths (t (Fix1 t)) + => MonadPaths (Fix1 t) +deriving + instance + MonadPaths (t (Fix1T t m) m) + => MonadPaths (Fix1T t m) + + +-- * @class MonadHttp m@ + +class + Monad m + => MonadHttp m where + + getURL :: Text -> m (Either ErrorCall StorePath) + default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) + getURL = lift . getURL + + +-- ** Instances + instance MonadHttp IO where getURL url = do - let urlstr = T.unpack url - traceM $ "fetching HTTP URL: " ++ urlstr + let urlstr = toString url + traceM $ "fetching HTTP URL: " <> urlstr req <- parseRequest urlstr - manager <- if secure req - then newTlsManager - else newManager defaultManagerSettings + manager <- + if secure req + then newTlsManager + else newManager defaultManagerSettings -- print req response <- httpLbs (req { method = "GET" }) manager let status = statusCode (responseStatus response) - if status /= 200 + pure $ Left $ ErrorCall $ if status /= 200 then - pure - $ Left - $ ErrorCall - $ "fail, got " - ++ show status - ++ " when fetching url:" - ++ urlstr - else -- do + "fail, got " <> show status <> " when fetching url:" <> urlstr + else + -- do -- let bstr = responseBody response - pure - $ Left - $ ErrorCall - $ "success in downloading but hnix-store is not yet ready; url = " - ++ urlstr + "success in downloading but hnix-store is not yet ready; url = " <> urlstr +deriving + instance + MonadHttp (t (Fix1 t)) + => MonadHttp (Fix1 t) -class Monad m => MonadPutStr m where - --TODO: Should this be used *only* when the Nix to be evaluated invokes a - --`trace` operation? - putStr :: String -> m () - default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m () - putStr = lift . putStr +deriving + instance + MonadHttp (t (Fix1T t m) m) + => MonadHttp (Fix1T t m) + +-- * @class MonadPutStr m@ + +class + Monad m + => MonadPutStr m where + + --TODO: Should this be used *only* when the Nix to be evaluated invokes a + --`trace` operation? + -- 2021-04-01: Due to trace operation here, leaving it as String. + putStr :: String -> m () + default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m () + putStr = lift . putStr + + +-- ** Instances + +instance MonadPutStr IO where + putStr = Prelude.putStr + +deriving + instance + MonadPutStr (t (Fix1 t)) + => MonadPutStr (Fix1 t) + +deriving + instance + MonadPutStr (t (Fix1T t m) m) + => MonadPutStr (Fix1T t m) + + +-- ** Functions + putStrLn :: MonadPutStr m => String -> m () -putStrLn = putStr . (++ "\n") +putStrLn = putStr . (<> "\n") print :: (MonadPutStr m, Show a) => a -> m () print = putStrLn . show -instance MonadPutStr IO where - putStr = Prelude.putStr +-- * Store effects +-- ** Data type synonyms type RecursiveFlag = Bool type RepairFlag = Bool @@ -242,48 +380,84 @@ type FilePathFilter m = FilePath -> m Bool type StorePathSet = HS.HashSet StorePath -class Monad m => MonadStore m where +-- ** @class MonadStore m@ - -- | Copy the contents of a local path to the store. The resulting store - -- path is returned. Note: This does not support yet support the expected - -- `filter` function that allows excluding some files. - addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) - default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) - addToStore a b c d = lift $ addToStore a b c d +class + Monad m + => MonadStore m where - -- | Like addToStore, but the contents written to the output path is a - -- regular file containing the given string. - addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath) - default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath) - addTextToStore' a b c d = lift $ addTextToStore' a b c d + -- | Copy the contents of a local path to the store. The resulting store + -- path is returned. Note: This does not support yet support the expected + -- `filter` function that allows excluding some files. + addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + addToStore a b c d = lift $ addToStore a b c d -parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a) -parseStoreResult name res = case res of - (Left msg, logs) -> return $ Left $ ErrorCall $ "Failed to execute '" ++ name ++ "': " ++ msg ++ "\n" ++ show logs - (Right result, _) -> return $ Right result + -- | Like addToStore, but the contents written to the output path is a + -- regular file containing the given string. + addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath) + default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath) + addTextToStore' a b c d = lift $ addTextToStore' a b c d + +-- *** Instances + instance MonadStore IO where - addToStore name path recursive repair = case Store.makeStorePathName name of - Left err -> return $ Left $ ErrorCall $ "String '" ++ show name ++ "' is not a valid path name: " ++ err - Right pathName -> do - -- TODO: redesign the filter parameter - res <- Store.runStore $ Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair - parseStoreResult "addToStore" res >>= \case - Left err -> return $ Left err - Right storePath -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath + addToStore name path recursive repair = + either + (\ err -> pure $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err) + (\ pathName -> + do + -- TODO: redesign the filter parameter + res <- Store.Remote.runStore $ Store.Remote.addToStore @'Store.SHA256 pathName path recursive (const False) repair + either + Left -- err + (pure . StorePath . decodeUtf8 . Store.storePathToRawFilePath) -- store path + <$> parseStoreResult "addToStore" res + ) + (Store.makeStorePathName name) - addTextToStore' name text references repair = do - res <- Store.runStore $ Store.addTextToStore name text references repair - parseStoreResult "addTextToStore" res >>= \case - Left err -> return $ Left err - Right path -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path + addTextToStore' name text references repair = + do + res <- Store.Remote.runStore $ Store.Remote.addTextToStore name text references repair + either + Left -- err + (pure . StorePath . decodeUtf8 . Store.storePathToRawFilePath) -- path + <$> parseStoreResult "addTextToStore" res + +-- ** Functions + +parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) +parseStoreResult name res = + pure $ either + (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) + pure -- result + (fst res) + where + logs = snd res + addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath -addTextToStore a b c d = either throwError return =<< addTextToStore' a b c d +addTextToStore a b c d = + either + throwError + pure + =<< addTextToStore' a b c d addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath -addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p True False +addPath p = + either + throwError + pure + =<< addToStore (toText $ takeFileName p) p True False toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath -toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False +toFile_ p contents = addTextToStore (toText p) (toText contents) HS.empty False + + +-- * misc + +-- Please, get rid of pathExists in favour of @doesPathExist@ +pathExists :: MonadFile m => FilePath -> m Bool +pathExists = doesPathExist diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -1,24 +1,23 @@ -{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Nix.Effects.Basic where -import Control.Monad -import Control.Monad.State.Strict -import Data.HashMap.Lazy ( HashMap ) +import Prelude hiding ( traceM + , head + ) +import Relude.Unsafe ( head ) +import Nix.Utils +import Control.Monad ( foldM ) import qualified Data.HashMap.Lazy as M -import Data.List -import Data.List.Split -import Data.Text ( Text ) +import Data.List.Split ( splitOn ) import qualified Data.Text as Text -import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc ( fillSep ) +import System.FilePath import Nix.Convert import Nix.Effects import Nix.Exec ( MonadNix @@ -31,10 +30,8 @@ import Nix.Render import Nix.Scope import Nix.String -import Nix.Utils import Nix.Value import Nix.Value.Monad -import System.FilePath #ifdef MIN_VERSION_ghc_datasize #if MIN_VERSION_ghc_datasize(0,2,0) @@ -45,27 +42,28 @@ defaultMakeAbsolutePath :: MonadNix e t f m => FilePath -> m FilePath defaultMakeAbsolutePath origPath = do origPathExpanded <- expandHomePath origPath - absPath <- if isAbsolute origPathExpanded - then pure origPathExpanded - else do - cwd <- do - mres <- lookupVar "__cur_file" - case mres of - Nothing -> getCurrentDirectory - Just v -> demand v $ \case - NVPath s -> pure $ takeDirectory s - val -> - throwError - $ ErrorCall - $ "when resolving relative path," - ++ " __cur_file is in scope," - ++ " but is not a path; it is: " - ++ show val - pure $ cwd origPathExpanded + absPath <- + bool + (do + cwd <- do + mres <- lookupVar "__cur_file" + maybe + getCurrentDirectory + ( + (\case + NVPath s -> pure $ takeDirectory s + val -> throwError $ ErrorCall $ "when resolving relative path, __cur_file is in scope, but is not a path; it is: " <> show val + ) <=< demand + ) + mres + pure $ cwd origPathExpanded + ) + (pure origPathExpanded) + (isAbsolute origPathExpanded) removeDotDotIndirections <$> canonicalizePath absPath expandHomePath :: MonadFile m => FilePath -> m FilePath -expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory +expandHomePath ('~' : xs) = (<> xs) <$> getHomeDirectory expandHomePath p = pure p -- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@. @@ -73,7 +71,7 @@ -- parent may be a different directory from @a@. See the discussion at -- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath removeDotDotIndirections :: FilePath -> FilePath -removeDotDotIndirections = intercalate "/" . go [] . splitOn "/" +removeDotDotIndirections = intercalate "/" . go mempty . splitOn "/" where go s [] = reverse s go (_ : s) (".." : rest) = go s rest @@ -86,7 +84,7 @@ where joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) = joinPath $ head - [ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ] + [ xs <> drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ] defaultFindEnvPath :: MonadNix e t f m => String -> m FilePath defaultFindEnvPath = findEnvPathM @@ -94,20 +92,34 @@ findEnvPathM :: forall e t f m . MonadNix e t f m => FilePath -> m FilePath findEnvPathM name = do mres <- lookupVar "__nixPath" - case mres of - Nothing -> error "impossible" - Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) -> - findPathBy nixFilePath l name + + maybe + (fail "impossible") + ( + (\ nv -> + do + (l :: [NValue t f m]) <- fromValue nv + findPathBy nixFilePath l name + ) <=< demand + ) + mres + where nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) nixFilePath path = do absPath <- makeAbsolutePath @t @f path isDir <- doesDirectoryExist absPath - absFile <- if isDir - then makeAbsolutePath @t @f $ absPath "default.nix" - else return absPath + absFile <- + bool + (pure absPath) + (makeAbsolutePath @t @f $ absPath "default.nix") + isDir exists <- doesFileExist absFile - pure $ if exists then Just absFile else Nothing + pure $ + bool + mempty + (pure absFile) + exists findPathBy :: forall e t f m @@ -117,96 +129,100 @@ -> FilePath -> m FilePath findPathBy finder ls name = do - mpath <- foldM go Nothing ls - case mpath of - Nothing -> - throwError - $ ErrorCall - $ "file '" - ++ name - ++ "' was not found in the Nix search path" - ++ " (add it's using $NIX_PATH or -I)" - Just path -> pure path + mpath <- foldM go mempty ls + maybe + (throwError $ ErrorCall $ "file '" <> name <> "' was not found in the Nix search path (add it's using $NIX_PATH or -I)") + pure + mpath where go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath) - go p@(Just _) _ = pure p - go Nothing l = - demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do - p <- resolvePath s - demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of - Nothing -> tryPath path Nothing - Just pf -> demand pf $ fromValueMay >=> \case - Just (nsPfx :: NixString) -> - let pfx = hackyStringIgnoreContext nsPfx - in if not (Text.null pfx) - then tryPath path (Just (Text.unpack pfx)) - else tryPath path Nothing - _ -> tryPath path Nothing + go mp = + maybe + (\ nv -> + do + (s :: HashMap Text (NValue t f m)) <- fromValue =<< demand nv + p <- resolvePath s + nvpath <- demand p + (Path path) <- fromValue nvpath + maybe + (tryPath path mempty) + (\ nv' -> + do + mns <- fromValueMay =<< demand nv' + tryPath path $ + case mns of + Just (nsPfx :: NixString) -> + let pfx = stringIgnoreContext nsPfx in + bool + mempty + (pure (toString pfx)) + (not $ Text.null pfx) + _ -> mempty + ) + (M.lookup "prefix" s) + ) + (const . pure . pure) + mp + + tryPath :: FilePath -> Maybe FilePath -> m (Maybe FilePath) tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' = finder $ p joinPath ns tryPath p _ = finder $ p name - resolvePath s = case M.lookup "path" s of - Just t -> pure t - Nothing -> case M.lookup "uri" s of - Just ut -> defer $ fetchTarball ut - Nothing -> - throwError - $ ErrorCall - $ "__nixPath must be a list of attr sets" - ++ " with 'path' elements, but received: " - ++ show s + resolvePath s = + maybe + (maybe + (throwError $ ErrorCall $ "__nixPath must be a list of attr sets with 'path' elements, but received: " <> show s) + (defer . fetchTarball) + (M.lookup "uri" s) + ) + pure + (M.lookup "path" s) fetchTarball :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fetchTarball = flip demand $ \case - NVSet s _ -> case M.lookup "url" s of - Nothing -> - throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute" - Just url -> demand url $ go (M.lookup "sha256" s) - v@NVStr{} -> go Nothing v - v -> - throwError - $ ErrorCall - $ "builtins.fetchTarball: Expected URI or set, got " - ++ show v +fetchTarball = + \case + NVSet s _ -> + maybe + (throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute") + (go (M.lookup "sha256" s) <=< demand) + (M.lookup "url" s) + v@NVStr{} -> go Nothing v + v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or set, got " <> show v + <=< demand where go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) go msha = \case - NVStr ns -> fetch (hackyStringIgnoreContext ns) msha - v -> - throwError - $ ErrorCall - $ "builtins.fetchTarball: Expected URI or string, got " - ++ show v + NVStr ns -> fetch (stringIgnoreContext ns) msha + v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or string, got " <> show v {- jww (2018-04-11): This should be written using pipes in another module fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m) - fetch uri msha = case takeExtension (Text.unpack uri) of + fetch uri msha = case takeExtension uri of ".tgz" -> undefined ".gz" -> undefined ".bz2" -> undefined ".xz" -> undefined ".tar" -> undefined ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '" - ++ ext ++ "'" + <> ext <> "'" -} fetch :: Text -> Maybe (NValue t f m) -> m (NValue t f m) fetch uri Nothing = - nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\"" - fetch url (Just t) = demand t $ fromValue >=> \nsSha -> - let sha = hackyStringIgnoreContext nsSha - in nixInstantiateExpr - $ "builtins.fetchTarball { " - ++ "url = \"" - ++ Text.unpack url - ++ "\"; " - ++ "sha256 = \"" - ++ Text.unpack sha - ++ "\"; }" + nixInstantiateExpr $ "builtins.fetchTarball \"" <> uri <> "\"" + fetch url (Just t) = + (\nv -> do + nsSha <- fromValue nv + let sha = stringIgnoreContext nsSha + + nixInstantiateExpr + $ "builtins.fetchTarball { " <> "url = \"" <> url <> "\"; " <> "sha256 = \"" <> sha <> "\"; }" + ) =<< demand t + defaultFindPath :: MonadNix e t f m => [NValue t f m] -> FilePath -> m FilePath defaultFindPath = findPathM @@ -219,31 +235,35 @@ findPathM = findPathBy existingPath where existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) - existingPath path = do - apath <- makeAbsolutePath @t @f path - exists <- doesPathExist apath - pure $ if exists then Just apath else Nothing + existingPath path = + do + apath <- makeAbsolutePath @t @f path + doesExist <- doesPathExist apath + pure $ pure apath `whenTrue` doesExist defaultImportPath :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m) => FilePath -> m (NValue t f m) defaultImportPath path = do - traceM $ "Importing file " ++ path - withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do + traceM $ "Importing file " <> path + withFrame Info (ErrorCall $ "While importing file " <> show path) $ do imports <- gets fst - evalExprLoc =<< case M.lookup path imports of - Just expr -> pure expr - Nothing -> do - eres <- parseNixFileLoc path - case eres of - Failure err -> - throwError - $ ErrorCall - . show $ fillSep ["Parse during import failed:", err] - Success expr -> do - modify (\(a, b) -> (M.insert path expr a, b)) - pure expr + evalExprLoc =<< + maybe + (do + eres <- parseNixFileLoc path + either + (\ err -> throwError $ ErrorCall . show $ fillSep ["Parse during import failed:", err]) + (\ expr -> + do + modify (first (M.insert path expr)) + pure expr + ) + eres + ) + pure -- return expr + (M.lookup path imports) defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath defaultPathToDefaultNix = pathToDefaultNixFile @@ -252,7 +272,7 @@ pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath pathToDefaultNixFile p = do isDir <- doesDirectoryExist p - pure $ if isDir then p "default.nix" else p + pure $ p "default.nix" `whenTrue` isDir defaultTraceEffect :: MonadPutStr m => String -> m () defaultTraceEffect = Nix.Effects.putStrLn diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -2,45 +2,37 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - -module Nix.Effects.Derivation ( defaultDerivationStrict ) where -import Prelude hiding ( readFile ) - -import Control.Arrow ( first, second ) -import Control.Monad ( (>=>), forM, when ) -import Control.Monad.Writer ( join, lift ) -import Control.Monad.State ( MonadState, gets, modify ) +module Nix.Effects.Derivation ( defaultDerivationStrict ) where -import Data.Char ( isAscii, isAlphaNum ) +import Nix.Utils +import Data.Char ( isAscii + , isAlphaNum + ) import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Strict as MS import qualified Data.HashSet as S -import Data.List +import Data.Foldable ( foldl ) import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) import qualified Data.Set as Set -import Data.Set ( Set ) -import Data.Text ( Text ) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import Nix.Atoms import Nix.Convert import Nix.Effects -import Nix.Exec ( MonadNix , callFunc) +import Nix.Exec ( MonadNix + , callFunc + ) import Nix.Frames import Nix.Json ( nvalueToJSONNixString ) import Nix.Render import Nix.String import Nix.String.Coerce -import Nix.Utils hiding ( readFile ) import Nix.Value import Nix.Value.Monad @@ -50,6 +42,7 @@ import Text.Megaparsec import Text.Megaparsec.Char +import Prelude hiding (readFile) data Derivation = Derivation @@ -66,96 +59,109 @@ } deriving Show -defaultDerivation :: Derivation -defaultDerivation = Derivation - { name = undefined - , outputs = Map.empty - , inputs = (Set.empty, Map.empty) - , platform = undefined - , builder = undefined - , args = [] - , env = Map.empty - , mFixed = Nothing - , hashMode = Flat - , useJson = False - } - data HashMode = Flat | Recursive deriving (Show, Eq) makeStorePathName :: (Framed e m) => Text -> m Store.StorePathName makeStorePathName name = case Store.makeStorePathName name of - Left err -> throwError $ ErrorCall $ "Invalid name '" ++ show name ++ "' for use in a store path: " ++ err - Right spname -> return spname + Left err -> throwError $ ErrorCall $ "Invalid name '" <> show name <> "' for use in a store path: " <> err + Right spname -> pure spname parsePath :: (Framed e m) => Text -> m Store.StorePath -parsePath p = case Store.parsePath "/nix/store" (Text.encodeUtf8 p) of - Left err -> throwError $ ErrorCall $ "Cannot parse store path " ++ show p ++ ":\n" ++ show err - Right path -> return path +parsePath p = case Store.parsePath "/nix/store" (encodeUtf8 p) of + Left err -> throwError $ ErrorCall $ "Cannot parse store path " <> show p <> ":\n" <> show err + Right path -> pure path writeDerivation :: (Framed e m, MonadStore m) => Derivation -> m Store.StorePath -writeDerivation (drv@Derivation {inputs, name}) = do +writeDerivation drv@Derivation{inputs, name} = do let (inputSrcs, inputDrvs) = inputs - references <- Set.fromList <$> (mapM parsePath $ Set.toList $ inputSrcs `Set.union` (Set.fromList $ Map.keys inputDrvs)) + references <- fmap Set.fromList $ traverse parsePath $ Set.toList $ Set.union inputSrcs $ Set.fromList $ Map.keys inputDrvs path <- addTextToStore (Text.append name ".drv") (unparseDrv drv) (S.fromList $ Set.toList references) False - parsePath $ Text.pack $ unStorePath path + parsePath $ toText $ unStorePath path -- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash. -- this avoids propagating changes to their .drv when the output hash stays the same. hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256) -hashDerivationModulo (Derivation { - mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)), - outputs, - hashMode - }) = case Map.toList outputs of - [("out", path)] -> return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 - $ "fixed:out" - <> (if hashMode == Recursive then ":r" else "") - <> ":" <> (Store.algoName @hashType) - <> ":" <> (Store.encodeInBase Store.Base16 digest) - <> ":" <> path - outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " ++ show outputsList -hashDerivationModulo drv@(Derivation {inputs = (inputSrcs, inputDrvs)}) = do - cache <- gets snd - inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) -> - case MS.lookup path cache of - Just hash -> return (hash, outs) - Nothing -> do - drv' <- readDerivation $ Text.unpack path - hash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv' - return (hash, outs) - ) - return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)}) +hashDerivationModulo + Derivation + { mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)) + , outputs + , hashMode + } = + case Map.toList outputs of + [("out", path)] -> pure $ + Store.hash @'Store.SHA256 $ + encodeUtf8 $ + "fixed:out" + <> (if hashMode == Recursive then ":r" else "") + <> ":" <> (Store.algoName @hashType) + <> ":" <> Store.encodeInBase Store.Base16 digest + <> ":" <> path + _outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " <> show _outputsList +hashDerivationModulo + drv@Derivation + { inputs = ( inputSrcs + , inputDrvs + ) + } = + do + cache <- gets snd + inputsModulo <- + Map.fromList <$> + traverse + (\(path, outs) -> + maybe + (do + drv' <- readDerivation $ toString path + hash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv' + pure (hash, outs) + ) + (\ hash -> pure (hash, outs)) + (MS.lookup path cache) + ) + (Map.toList inputDrvs) + pure $ Store.hash @'Store.SHA256 $ encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)}) unparseDrv :: Derivation -> Text -unparseDrv (Derivation {..}) = Text.append "Derive" $ parens - [ -- outputs: [("out", "/nix/store/.....-out", "", ""), ...] - list $ flip map (Map.toList outputs) (\(outputName, outputPath) -> - let prefix = if hashMode == Recursive then "r:" else "" in - case mFixed of - Nothing -> parens [s outputName, s outputPath, s "", s ""] - Just (Store.SomeDigest (digest :: Store.Digest hashType)) -> - parens [s outputName, s outputPath, s $ prefix <> Store.algoName @hashType, s $ Store.encodeInBase Store.Base16 digest] - ) - , -- inputDrvs - list $ flip map (Map.toList $ snd inputs) (\(path, outs) -> - parens [s path, list $ map s $ sort outs]) - , -- inputSrcs - list (map s $ Set.toList $ fst inputs) - , s platform - , s builder - , -- run script args - list $ map s args - , -- env (key value pairs) - list $ flip map (Map.toList env) (\(k, v) -> - parens [s k, s v]) - ] +unparseDrv Derivation{..} = + Text.append + "Derive" + $ parens + [ -- outputs: [("out", "/nix/store/.....-out", "", ""), ...] + serializeList $ + produceOutputInfo <$> Map.toList outputs + , -- inputDrvs + serializeList $ + (\(path, outs) -> + parens [s path, serializeList $ s <$> sort outs] + ) <$> Map.toList (snd inputs) + , -- inputSrcs + serializeList $ s <$> Set.toList (fst inputs) + , s platform + , s builder + , -- run script args + serializeList $ s <$> args + , -- env (key value pairs) + serializeList $ (\(k, v) -> parens [s k, s v]) <$> Map.toList env + ] where + produceOutputInfo (outputName, outputPath) = + let prefix = if hashMode == Recursive then "r:" else "" in + parens $ (s <$>) $ ([outputName, outputPath] <>) $ + maybe + [mempty, mempty] + (\ (Store.SomeDigest (digest :: Store.Digest hashType)) -> + [prefix <> Store.algoName @hashType, Store.encodeInBase Store.Base16 digest] + ) + mFixed parens :: [Text] -> Text parens ts = Text.concat ["(", Text.intercalate "," ts, ")"] - list :: [Text] -> Text - list ls = Text.concat ["[", Text.intercalate "," ls, "]"] - s = (Text.cons '\"') . (flip Text.snoc '\"') . Text.concatMap escape + + serializeList :: [Text] -> Text + serializeList ls = Text.concat ["[", Text.intercalate "," ls, "]"] + + s = Text.cons '\"' . (`Text.snoc` '\"') . Text.concatMap escape + escape :: Char -> Text escape '\\' = "\\\\" escape '\"' = "\\\"" @@ -166,41 +172,42 @@ readDerivation :: (Framed e m, MonadFile m) => FilePath -> m Derivation readDerivation path = do - content <- Text.decodeUtf8 <$> readFile path - case parse derivationParser path content of - Left err -> throwError $ ErrorCall $ "Failed to parse " ++ show path ++ ":\n" ++ show err - Right drv -> return drv + content <- decodeUtf8 <$> readFile path + either + (\ err -> throwError $ ErrorCall $ "Failed to parse " <> show path <> ":\n" <> show err) + pure + (parse derivationParser path content) derivationParser :: Parsec () Text Derivation derivationParser = do _ <- "Derive(" - fullOutputs <- list $ - fmap (\[n, p, ht, h] -> (n, p, ht, h)) $ parens s + fullOutputs <- serializeList $ + (\[n, p, ht, h] -> (n, p, ht, h)) <$> parens s _ <- "," - inputDrvs <- fmap Map.fromList $ list $ - fmap (,) ("(" *> s <* ",") <*> (list s <* ")") + inputDrvs <- Map.fromList <$> serializeList + (liftA2 (,) ("(" *> s <* ",") (serializeList s <* ")")) _ <- "," - inputSrcs <- fmap Set.fromList $ list s + inputSrcs <- Set.fromList <$> serializeList s _ <- "," platform <- s _ <- "," builder <- s _ <- "," - args <- list s + args <- serializeList s _ <- "," - env <- fmap Map.fromList $ list $ fmap (\[a, b] -> (a, b)) $ parens s + env <- fmap Map.fromList $ serializeList $ (\[a, b] -> (a, b)) <$> parens s _ <- ")" eof - let outputs = Map.fromList $ map (\(a, b, _, _) -> (a, b)) fullOutputs + let outputs = Map.fromList $ (\(a, b, _, _) -> (a, b)) <$> fullOutputs let (mFixed, hashMode) = parseFixed fullOutputs let name = "" -- FIXME (extract from file path ?) let useJson = ["__json"] == Map.keys env - return $ Derivation {inputs = (inputSrcs, inputDrvs), ..} + pure $ Derivation {inputs = (inputSrcs, inputDrvs), ..} where s :: Parsec () Text Text - s = fmap Text.pack $ string "\"" *> manyTill (escaped <|> regular) (string "\"") + s = fmap toText $ string "\"" *> manyTill (escaped <|> regular) (string "\"") escaped = char '\\' *> ( '\n' <$ string "n" <|> '\r' <$ string "r" @@ -210,24 +217,30 @@ regular = noneOf ['\\', '"'] parens :: Parsec () Text a -> Parsec () Text [a] - parens p = (string "(") *> sepBy p (string ",") <* (string ")") - list p = (string "[") *> sepBy p (string ",") <* (string "]") + parens p = + (string "(") *> sepBy p (string ",") <* (string ")") + serializeList p = (string "[") *> sepBy p (string ",") <* (string "]") parseFixed :: [(Text, Text, Text, Text)] -> (Maybe Store.SomeNamedDigest, HashMode) parseFixed fullOutputs = case fullOutputs of [("out", _path, rht, hash)] | rht /= "" && hash /= "" -> - let (hashType, hashMode) = case Text.splitOn ":" rht of - ["r", ht] -> (ht, Recursive) - [ht] -> (ht, Flat) - _ -> error $ "Unsupported hash type for output of fixed-output derivation in .drv file: " ++ show fullOutputs - in case Store.mkNamedDigest hashType hash of - Right digest -> (Just digest, hashMode) - Left err -> error $ "Unsupported hash " ++ show (hashType <> ":" <> hash) ++ "in .drv file: " ++ err + let + (hashType, hashMode) = case Text.splitOn ":" rht of + ["r", ht] -> (ht, Recursive) + [ht] -> (ht, Flat) + _ -> error $ "Unsupported hash type for output of fixed-output derivation in .drv file: " <> show fullOutputs + in + either + -- Please, no longer `error show` after migrating to Text + (\ err -> error $ show $ "Unsupported hash " <> show (hashType <> ":" <> hash) <> "in .drv file: " <> err) + (\ digest -> (pure digest, hashMode)) + (Store.mkNamedDigest hashType hash) _ -> (Nothing, Flat) defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m) -defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do +defaultDerivationStrict val = do + s <- fromValue @(AttrSet (NValue t f m)) val (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s drvName <- makeStorePathName $ name drv let inputs = toStorePaths ctx @@ -238,7 +251,7 @@ Just (Store.SomeDigest digest) -> do let out = pathToText $ Store.makeFixedOutputPath "/nix/store" (hashMode drv == Recursive) digest drvName let env' = if useJson drv then env drv else Map.insert "out" out (env drv) - return $ drv { inputs, env = env', outputs = Map.singleton "out" out } + pure $ drv { inputs, env = env', outputs = Map.singleton "out" out } Nothing -> do hash <- hashDerivationModulo $ drv @@ -248,7 +261,7 @@ else foldl' (\m k -> Map.insert k "" m) (env drv) (Map.keys $ outputs drv) } outputs' <- sequence $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) (outputs drv) - return $ drv + pure $ drv { inputs , outputs = outputs' , env = if useJson drv then env drv else Map.union outputs' (env drv) @@ -258,27 +271,27 @@ -- Memoize here, as it may be our last chance in case of readonly stores. drvHash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv' - modify (\(a, b) -> (a, MS.insert drvPath drvHash b)) + modify $ second $ MS.insert drvPath drvHash - let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv') - drvPathWithContext = principledMakeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs) + let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath $ DerivationOutput out)) (outputs drv') + drvPathWithContext = makeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs) attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext -- TODO: Add location information for all the entries. -- here --v - return $ nvSet attrSet M.empty + pure $ nvSet mempty attrSet where - pathToText = Text.decodeUtf8 . Store.storePathToRawFilePath + pathToText = decodeUtf8 . Store.storePathToRawFilePath makeOutputPath o h n = do name <- makeStorePathName (Store.unStorePathName n <> if o == "out" then "" else "-" <> o) - return $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> Text.encodeUtf8 o) h name + pure $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> encodeUtf8 o) h name - toStorePaths ctx = foldl (flip addToInputs) (Set.empty, Map.empty) ctx + toStorePaths ctx = foldl (flip addToInputs) (mempty, mempty) ctx addToInputs (StringContext path kind) = case kind of DirectPath -> first (Set.insert path) - DerivationOutput o -> second (Map.insertWith (++) path [o]) + DerivationOutput o -> second (Map.insertWith (<>) path [o]) AllOutputs -> -- TODO: recursive lookup. See prim_derivationStrict -- XXX: When is this really used ? @@ -291,61 +304,72 @@ buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => AttrSet (NValue t f m) -> WithStringContextT m Derivation buildDerivationWithContext drvAttrs = do -- Parse name first, so we can add an informative frame - drvName <- getAttr "name" $ extractNixString >=> assertDrvStoreName - withFrame' Info (ErrorCall $ "While evaluating derivation " ++ show drvName) $ do + drvName <- getAttr "name" $ assertDrvStoreName <=< extractNixString + withFrame' Info (ErrorCall $ "While evaluating derivation " <> show drvName) $ do - useJson <- getAttrOr "__structuredAttrs" False $ return - ignoreNulls <- getAttrOr "__ignoreNulls" False $ return + useJson <- getAttrOr "__structuredAttrs" False pure + ignoreNulls <- getAttrOr "__ignoreNulls" False pure - args <- getAttrOr "args" [] $ mapM (fromValue' >=> extractNixString) - builder <- getAttr "builder" $ extractNixString - platform <- getAttr "system" $ extractNoCtx >=> assertNonNull - mHash <- getAttrOr "outputHash" Nothing $ extractNoCtx >=> (return . Just) - hashMode <- getAttrOr "outputHashMode" Flat $ extractNoCtx >=> parseHashMode - outputs <- getAttrOr "outputs" ["out"] $ mapM (fromValue' >=> extractNoCtx) + args <- getAttrOr "args" mempty $ traverse (extractNixString <=< fromValue') + builder <- getAttr "builder" extractNixString + platform <- getAttr "system" $ assertNonNull <=< extractNoCtx + mHash <- getAttrOr "outputHash" mempty $ (pure . pure) <=< extractNoCtx + hashMode <- getAttrOr "outputHashMode" Flat $ parseHashMode <=< extractNoCtx + outputs <- getAttrOr "outputs" ["out"] $ traverse (extractNoCtx <=< fromValue') - mFixedOutput <- case mHash of - Nothing -> return Nothing - Just hash -> do - when (outputs /= ["out"]) $ lift $ throwError $ ErrorCall $ "Multiple outputs are not supported for fixed-output derivations" - hashType <- getAttr "outputHashAlgo" $ extractNoCtx - digest <- lift $ either (throwError . ErrorCall) return $ Store.mkNamedDigest hashType hash - return $ Just digest + mFixedOutput <- + maybe + (pure Nothing) + (\ hash -> do + when (outputs /= ["out"]) $ lift $ throwError $ ErrorCall "Multiple outputs are not supported for fixed-output derivations" + hashType <- getAttr "outputHashAlgo" extractNoCtx + digest <- lift $ either (throwError . ErrorCall) pure $ Store.mkNamedDigest hashType hash + pure $ pure digest) + mHash -- filter out null values if needed. - attrs <- if not ignoreNulls - then return drvAttrs - else M.mapMaybe id <$> forM drvAttrs (demand' ?? (\case - NVConstant NNull -> return Nothing - value -> return $ Just value - )) + attrs <- + lift $ + bool + (pure drvAttrs) + (M.mapMaybe id <$> + traverse + (fmap + (\case + NVConstant NNull -> Nothing + _value -> Just _value + ) + . demand + ) + drvAttrs + ) + ignoreNulls env <- if useJson then do - jsonString :: NixString <- lift $ nvalueToJSONNixString $ flip nvSet M.empty $ + jsonString :: NixString <- lift $ nvalueToJSONNixString $ nvSet mempty $ deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs rawString :: Text <- extractNixString jsonString - return $ Map.singleton "__json" rawString + pure $ Map.singleton "__json" rawString else - mapM (lift . coerceToString callFunc CopyToStore CoerceAny >=> extractNixString) $ + traverse (extractNixString <=< lift . coerceToString callFunc CopyToStore CoerceAny) $ Map.fromList $ M.toList $ deleteKeys [ "args", "__ignoreNulls" ] attrs - return $ defaultDerivation { platform, builder, args, env, hashMode, useJson + pure $ Derivation { platform, builder, args, env, hashMode, useJson , name = drvName - , outputs = Map.fromList $ map (\o -> (o, "")) outputs + , outputs = Map.fromList $ (, mempty) <$> outputs , mFixed = mFixedOutput + , inputs = (mempty, mempty) -- stub for now } where - -- common functions, lifted to WithStringContextT - demand' :: NValue t f m -> (NValue t f m -> WithStringContextT m a) -> WithStringContextT m a - demand' v f = join $ lift $ demand v (return . f) + -- common functions, lifted to WithStringContextT fromValue' :: (FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) => NValue t f m -> WithStringContextT m a fromValue' = lift . fromValue withFrame' :: (Framed e m, Exception s) => NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a - withFrame' level f = join . lift . withFrame level f . return + withFrame' level f = join . lift . withFrame level f . pure -- shortcuts to get the (forced) value of an AttrSet field @@ -353,40 +377,42 @@ => Text -> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a getAttrOr' n d f = case M.lookup n drvAttrs of Nothing -> lift d - Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" ++ show n ++ "'") $ + Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" <> show n <> "'") $ fromValue' v >>= f - getAttrOr n d f = getAttrOr' n (return d) f + getAttrOr n d f = getAttrOr' n (pure d) f - getAttr n = getAttrOr' n (throwError $ ErrorCall $ "Required attribute '" ++ show n ++ "' not found.") + getAttr n = getAttrOr' n (throwError $ ErrorCall $ "Required attribute '" <> show n <> "' not found.") -- Test validity for fields assertDrvStoreName :: MonadNix e t f m => Text -> WithStringContextT m Text assertDrvStoreName name = lift $ do let invalid c = not $ isAscii c && (isAlphaNum c || c `elem` ("+-._?=" :: String)) -- isAlphaNum allows non-ascii chars. - let failWith reason = throwError $ ErrorCall $ "Store name " ++ show name ++ " " ++ reason + let failWith reason = throwError $ ErrorCall $ "Store name " <> show name <> " " <> reason when ("." `Text.isPrefixOf` name) $ failWith "cannot start with a period" when (Text.length name > 211) $ failWith "must be no longer than 211 characters" when (Text.any invalid name) $ failWith "contains some invalid character" when (".drv" `Text.isSuffixOf` name) $ failWith "is not allowed to end in '.drv'" - return name + pure name extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text - extractNoCtx ns = case principledGetStringNoContext ns of - Nothing -> lift $ throwError $ ErrorCall $ "The string " ++ show ns ++ " is not allowed to have a context." - Just v -> return v + extractNoCtx ns = + maybe + (lift $ throwError $ ErrorCall $ "The string " <> show ns <> " is not allowed to have a context.") + pure + (getStringNoContext ns) assertNonNull :: MonadNix e t f m => Text -> WithStringContextT m Text assertNonNull t = do when (Text.null t) $ lift $ throwError $ ErrorCall "Value must not be empty" - return t + pure t parseHashMode :: MonadNix e t f m => Text -> WithStringContextT m HashMode parseHashMode = \case - "flat" -> return Flat - "recursive" -> return Recursive - other -> lift $ throwError $ ErrorCall $ "Hash mode " ++ show other ++ " is not valid. It must be either 'flat' or 'recursive'" + "flat" -> pure Flat + "recursive" -> pure Recursive + other -> lift $ throwError $ ErrorCall $ "Hash mode " <> show other <> " is not valid. It must be either 'flat' or 'recursive'" -- Other helpers diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -9,27 +8,17 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + module Nix.Eval where -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Reader -import Control.Monad.State.Strict +import Control.Monad ( foldM ) +import Control.Monad.Fix ( MonadFix ) import Data.Semialign.Indexed ( ialignWith ) -import Data.Either ( isRight ) import Data.Fix ( Fix(Fix) ) -import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( fromMaybe - , catMaybes - ) -import Data.Text ( Text ) import Data.These ( These(..) ) -import Data.Traversable ( for ) import Nix.Atoms import Nix.Convert import Nix.Expr @@ -59,7 +48,14 @@ evalAssert :: v -> m v -> m v evalApp :: v -> m v -> m v evalAbs :: Params (m v) - -> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v)) + -> ( forall a + . m v + -> ( AttrSet (m v) + -> m v + -> m (a, v) + ) + -> m (a, v) + ) -> m v {- evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v @@ -91,18 +87,19 @@ ) data EvalFrame m v - = EvaluatingExpr (Scopes m v) NExprLoc - | ForcingExpr (Scopes m v) NExprLoc - | Calling String SrcSpan - | SynHole (SynHoleInfo m v) - deriving (Show, Typeable) + = EvaluatingExpr (Scopes m v) NExprLoc + | ForcingExpr (Scopes m v) NExprLoc + | Calling Text SrcSpan + | SynHole (SynHoleInfo m v) + deriving (Show, Typeable) instance (Typeable m, Typeable v) => Exception (EvalFrame m v) data SynHoleInfo m v = SynHoleInfo - { _synHoleInfo_expr :: NExprLoc - , _synHoleInfo_scope :: Scopes m v - } deriving (Show, Typeable) + { _synHoleInfo_expr :: NExprLoc + , _synHoleInfo_scope :: Scopes m v + } + deriving (Show, Typeable) instance (Typeable m, Typeable v) => Exception (SynHoleInfo m v) @@ -113,11 +110,13 @@ eval (NSym "__curPos") = evalCurPos -eval (NSym var ) = do - mres <- lookupVar var - case mres of - Just x -> demand x $ evaledSym var - Nothing -> freeVariable var +eval (NSym var ) = + do + mres <- lookupVar var + maybe + (freeVariable var) + (evaledSym var <=< demand) + mres eval (NConstant x ) = evalConstant x eval (NStr str ) = evalString str @@ -125,34 +124,45 @@ eval (NEnvPath p ) = evalEnvPath p eval (NUnary op arg ) = evalUnary op =<< arg -eval (NBinary NApp fun arg) = do - scope <- currentScopes :: m (Scopes m v) - fun >>= (`evalApp` withScopes scope arg) +eval (NBinary NApp fun arg) = + do + scope <- currentScopes :: m (Scopes m v) + (`evalApp` withScopes scope arg) =<< fun eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id - where go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt + where go (s, ks) = fromMaybe (attrMissing ks (pure s)) alt eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight -eval (NList l ) = do - scope <- currentScopes - for l (defer @v @m . withScopes @v scope) >>= toValue +eval (NList l ) = + do + scope <- currentScopes + toValue =<< traverse (defer @v @m . withScopes @v scope) l eval (NSet NNonRecursive binds) = - evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue + toValue =<< evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds) eval (NSet NRecursive binds) = - evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue + toValue =<< evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds) -eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst +eval (NLet binds body ) = + do + (x, _) <- evalBinds True binds + pushScope x body -eval (NIf cond t f ) = cond >>= \v -> evalIf v t f +eval (NIf cond t f ) = + do + v <- cond + evalIf v t f eval (NWith scope body) = evalWith scope body -eval (NAssert cond body) = cond >>= evalAssert ?? body +eval (NAssert cond body) = + do + x <- cond + evalAssert x body eval (NAbs params body) = do -- It is the environment at the definition site, not the call site, that @@ -162,7 +172,7 @@ scope <- currentScopes :: m (Scopes m v) evalAbs params $ \arg k -> withScopes scope $ do args <- buildArgument params arg - pushScope args (k (fmap (inform ?? withScopes scope) args) body) + pushScope args $ k (withScopes scope . inform <$> args) body eval (NSynHole name) = synHole name @@ -176,7 +186,8 @@ -- computed once. scope <- currentScopes :: m (Scopes m v) s <- defer $ withScopes scope aset - let s' = demand s $ fmap fst . fromValue @(AttrSet v, AttrSet SourcePos) + let s' = fst <$> (fromValue @(AttrSet v, AttrSet SourcePos) =<< demand s) + pushWeakScope s' body attrSetAlter @@ -188,54 +199,65 @@ -> AttrSet SourcePos -> m v -> m (AttrSet (m v), AttrSet SourcePos) -attrSetAlter [] _ _ _ _ = - evalError @v $ ErrorCall "invalid selector with no components" - -attrSetAlter (k : ks) pos m p val = case M.lookup k m of - Nothing | null ks -> go - | otherwise -> recurse M.empty M.empty - Just x - | null ks - -> go - | otherwise - -> x >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(st, sp) -> - recurse (demand ?? pure <$> st) sp +attrSetAlter [] _ _ _ _ = evalError @v $ ErrorCall "invalid selector with no components" +attrSetAlter (k : ks) pos m p val = + bool + go + (maybe + (recurse mempty mempty) + (\x -> + do + (st, sp) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< x + recurse (demand <$> st) sp + ) + (M.lookup k m) + ) + (not $ null ks) where go = pure (M.insert k val m, M.insert k pos p) - recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) -> - ( M.insert - k - (toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st') - m - , M.insert k pos p - ) + recurse st sp = + (\(st', _) -> + (M.insert + k + (toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st') + m + , M.insert k pos p + ) + ) <$> attrSetAlter ks pos st sp val desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r] -desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty +desugarBinds embed binds = evalState (traverse (go <=< collect) binds) mempty where collect :: Binding r -> State (HashMap VarName (SourcePos, [Binding r])) (Either VarName (Binding r)) - collect (NamedVar (StaticKey x :| y : ys) val p) = do - m <- get - put $ M.insert x ?? m $ case M.lookup x m of - Nothing -> (p, [NamedVar (y :| ys) val p]) - Just (q, v) -> (q, NamedVar (y :| ys) val q : v) - pure $ Left x - collect x = pure $ Right x + collect (NamedVar (StaticKey x :| y : ys) val p) = + do + m <- get + put $ M.insert x ?? m $ + maybe + (p, [NamedVar (y :| ys) val p]) + (\ (q, v) -> (q, NamedVar (y :| ys) val q : v)) + (M.lookup x m) + pure $ Left x + collect x = pure $ pure x go :: Either VarName (Binding r) -> State (HashMap VarName (SourcePos, [Binding r])) (Binding r) - go (Right x) = pure x - go (Left x) = do - maybeValue <- gets (M.lookup x) - case maybeValue of - Nothing -> error ("No binding " ++ show x) - Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p + go = + either + (\ x -> do + maybeValue <- gets (M.lookup x) + maybe + (error $ "No binding " <> show x) + (\ (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p) + maybeValue + ) + pure evalBinds :: forall v m @@ -243,96 +265,146 @@ => Bool -> [Binding (m v)] -> m (AttrSet v, AttrSet SourcePos) -evalBinds recursive binds = do - scope <- currentScopes :: m (Scopes m v) - buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) - where - moveOverridesLast = uncurry (++) . partition - (\case - NamedVar (StaticKey "__overrides" :| []) _ _pos -> False - _ -> True - ) - - go :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] - go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = - finalValue >>= fromValue >>= \(o', p') -> - -- jww (2018-05-09): What to do with the key position here? - pure $ map - (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand v pure)) - (M.toList o') - - go _ (NamedVar pathExpr finalValue pos) = do - let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v) - go = \case - h :| t -> evalSetterKeyName h >>= \case - Nothing -> - pure - ( [] - , nullPos - , toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty) - ) - Just k -> case t of - [] -> pure ([k], pos, finalValue) - x : xs -> do - (restOfPath, _, v) <- go (x :| xs) - pure (k : restOfPath, pos, v) - go pathExpr <&> \case - -- When there are no path segments, e.g. `${null} = 5;`, we don't - -- bind anything - ([], _, _) -> [] - result -> [result] +evalBinds recursive binds = + do + scope <- currentScopes :: m (Scopes m v) - go scope (Inherit ms names pos) = - fmap catMaybes $ forM names $ evalSetterKeyName >=> \case - Nothing -> pure Nothing - Just key -> pure $ Just - ( [key] - , pos - , do - mv <- case ms of - Nothing -> withScopes scope $ lookupVar key - Just s -> - s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(s, _) -> - clearScopes @v $ pushScope s $ lookupVar key - case mv of - Nothing -> attrMissing (key :| []) Nothing - Just v -> demand v pure - ) + buildResult scope . concat =<< traverse (applyBindToAdt scope) (moveOverridesLast binds) + where buildResult :: Scopes m v -> [([Text], SourcePos, m v)] -> m (AttrSet v, AttrSet SourcePos) - buildResult scope bindings = do - (s, p) <- foldM insert (M.empty, M.empty) bindings - res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s - pure (res, p) + buildResult scope bindings = + do + (s, p) <- foldM insert (mempty, mempty) bindings + res <- + bool + (traverse mkThunk s) + (loebM $ encapsulate <$> s) + recursive + + pure (res, p) + where mkThunk = defer . withScopes scope - encapsulate f attrs = mkThunk . pushScope attrs $ f + encapsulate f attrs = mkThunk $ pushScope attrs f insert (m, p) (path, pos, value) = attrSetAlter path pos m p value + applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] + applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = + do + (o', p') <- fromValue =<< finalValue + -- jww (2018-05-09): What to do with the key position here? + pure $ + (\ (k, v) -> + ( [k] + , fromMaybe pos (M.lookup k p') + , demand v + ) + ) <$> M.toList o' + + applyBindToAdt _ (NamedVar pathExpr finalValue pos) = + (\case + -- When there are no path segments, e.g. `${null} = 5;`, we don't + -- bind anything + ([], _, _) -> mempty + result -> [result] + ) <$> processAttrSetKeys pathExpr + + where + processAttrSetKeys :: NAttrPath (m v) -> m ([Text], SourcePos, m v) + processAttrSetKeys = + \case + h :| t -> + maybe + -- Empty attrset - return a stub. + (pure ( mempty, nullPos, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)) ) + (\ k -> + list + -- No more keys in the attrset - return the result + (pure ( [k], pos, finalValue ) ) + -- There are unprocessed keys in attrset - recurse appending the results + (\ (x : xs) -> + do + (restOfPath, _, v) <- processAttrSetKeys (x :| xs) + pure ( k : restOfPath, pos, v ) + ) + t + ) + =<< evalSetterKeyName h + + applyBindToAdt scope (Inherit ms names pos) = + catMaybes <$> + traverse + processScope + names + where + processScope + :: NKeyName (m v) + -> m (Maybe ([Text], SourcePos, m v)) + processScope nkeyname = + (\ mkey -> + do + key <- mkey + pure + ([key] + , pos + , maybe + (attrMissing (key :| []) Nothing) + demand + =<< maybe + (withScopes scope $ lookupVar key) + (\ s -> + do + (attrset, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< s + + clearScopes @v $ pushScope attrset $ lookupVar key + ) + ms + ) + ) <$> + evalSetterKeyName nkeyname + + moveOverridesLast = uncurry (<>) . partition + (\case + NamedVar (StaticKey "__overrides" :| []) _ _pos -> False + _ -> True + ) + evalSelect :: forall v m . MonadNixEval v m => m v -> NAttrPath (m v) -> m (Either (v, NonEmpty Text) (m v)) -evalSelect aset attr = do - s <- aset - path <- traverse evalGetterKeyName attr - extract s path +evalSelect aset attr = + do + s <- aset + path <- traverse evalGetterKeyName attr + + extract s path + where - extract x path@(k :| ks) = fromValueMay x >>= \case - Just (s :: AttrSet v, p :: AttrSet SourcePos) - | Just t <- M.lookup k s -> case ks of - [] -> pure $ Right $ demand t pure - y : ys -> demand t $ extract ?? (y :| ys) - | otherwise -> Left . (, path) <$> toValue (s, p) - Nothing -> pure $ Left (x, path) + extract x path@(k :| ks) = + do + x' <- fromValueMay x + case x' of + Nothing -> pure $ Left (x, path) + Just (s :: AttrSet v, p :: AttrSet SourcePos) + | Just t <- M.lookup k s -> + do + list + (pure . pure) + (\ (y : ys) -> ((extract ?? (y :| ys)) =<<)) + ks + $ demand t + | otherwise -> Left . (, path) <$> toValue (s, p) + -- | Evaluate a component of an attribute path in a context where we are -- *retrieving* a value evalGetterKeyName @@ -340,10 +412,11 @@ . (MonadEval v m, FromValue NixString m v) => NKeyName (m v) -> m Text -evalGetterKeyName = evalSetterKeyName >=> \case - Just k -> pure k - Nothing -> - evalError @v $ ErrorCall "value is null while a string was expected" +evalGetterKeyName = + maybe + (evalError @v $ ErrorCall "value is null while a string was expected") + pure + <=< evalSetterKeyName -- | Evaluate a component of an attribute path in a context where we are -- *binding* a value @@ -351,44 +424,60 @@ :: (MonadEval v m, FromValue NixString m v) => NKeyName (m v) -> m (Maybe Text) -evalSetterKeyName = \case - StaticKey k -> pure (Just k) - DynamicKey k -> - runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case - Just ns -> Just (hackyStringIgnoreContext ns) - _ -> Nothing +evalSetterKeyName = + \case + StaticKey k -> pure $ pure k + DynamicKey k -> + maybe + mempty + (pure . stringIgnoreContext) + <$> runAntiquoted "\n" assembleString (fromValueMay =<<) k assembleString :: forall v m . (MonadEval v m, FromValue NixString m v) => NString (m v) -> m (Maybe NixString) -assembleString = \case - Indented _ parts -> fromParts parts - DoubleQuoted parts -> fromParts parts +assembleString = + fromParts . + \case + Indented _ parts -> parts + DoubleQuoted parts -> parts where - fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go + fromParts xs = (mconcat <$>) . sequence <$> traverse go xs - go = runAntiquoted "\n" - (pure . Just . principledMakeNixStringWithoutContext) - (>>= fromValueMay) + go = + runAntiquoted + "\n" + (pure . pure . makeNixStringWithoutContext) + (fromValueMay =<<) buildArgument :: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v) -buildArgument params arg = do - scope <- currentScopes :: m (Scopes m v) - case params of - Param name -> M.singleton name <$> defer (withScopes scope arg) - ParamSet s isVariadic m -> - arg >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(args, _) -> do - let inject = case m of - Nothing -> id - Just n -> M.insert n $ const $ defer (withScopes scope arg) - loebM - (inject $ M.mapMaybe id $ ialignWith (assemble scope isVariadic) - args - (M.fromList s) - ) +buildArgument params arg = + do + scope <- currentScopes :: m (Scopes m v) + case params of + Param name -> M.singleton name <$> defer (withScopes scope arg) + ParamSet s isVariadic m -> + do + (args, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< arg + let + inject = + maybe + id + (\ n -> M.insert n $ const $ defer $ withScopes scope arg) + m + loebM + (inject $ + M.mapMaybe + id + (ialignWith + (assemble scope isVariadic) + args + $ M.fromList s + ) + ) where assemble :: Scopes m v @@ -396,45 +485,39 @@ -> Text -> These v (Maybe (m v)) -> Maybe (AttrSet v -> m v) - assemble scope isVariadic k = \case - That Nothing -> - Just - $ const - $ evalError @v - $ ErrorCall - $ "Missing value for parameter: " - ++ show k - That (Just f) -> - Just $ \args -> defer $ withScopes scope $ pushScope args f - This _ - | isVariadic - -> Nothing - | otherwise - -> Just - $ const - $ evalError @v - $ ErrorCall - $ "Unexpected parameter: " - ++ show k - These x _ -> Just (const (pure x)) + assemble scope isVariadic k = + \case + That Nothing -> pure $ const $ evalError @v $ ErrorCall $ "Missing value for parameter: " <> show k + That (Just f) -> pure $ \args -> defer $ withScopes scope $ pushScope args f + This _ + | isVariadic -> Nothing + | otherwise -> pure $ const $ evalError @v $ ErrorCall $ "Unexpected parameter: " <> show k + These x _ -> pure $ const $ pure x addSourcePositions :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a) addSourcePositions f v@(Fix (Compose (Ann ann _))) = - local (set hasLens ann) (f v) + local (set hasLens ann) $ f v addStackFrames :: forall v e m a . (Scoped v m, Framed e m, Typeable v, Typeable m) => Transform NExprLocF (m a) -addStackFrames f v = do - scopes <- currentScopes :: m (Scopes m v) - withFrame Info (EvaluatingExpr scopes v) (f v) +addStackFrames f v = + do + scopes <- currentScopes :: m (Scopes m v) + -- sectioning gives GHC optimization + -- If opimization question would arrive again, check the @(`withFrameInfo` f v) $ EvaluatingExpr scopes v@ + -- for possible @scopes@ implementation @v@ type arguments sharing between runs. + (`withFrameInfo` f v) $ (`EvaluatingExpr` v) scopes + where + withFrameInfo = withFrame Info + framedEvalExprLoc :: forall e v m . (MonadNixEval v m, Framed e m, Has e SrcSpan, Typeable m, Typeable v) => NExprLoc -> m v framedEvalExprLoc = - adi (eval . annotated . getCompose) (addStackFrames @v . addSourcePositions) + adi (eval . annotated . getCompose) $ addStackFrames @v . addSourcePositions diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -1,12 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,10 +12,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} + module Nix.Exec where import Prelude hiding ( putStr @@ -26,18 +23,12 @@ , print ) -import Control.Applicative -import Control.Monad import Control.Monad.Catch hiding ( catchJust ) import Control.Monad.Fix -import Control.Monad.Reader import Data.Fix import qualified Data.HashMap.Lazy as M -import Data.List import qualified Data.List.NonEmpty as NE -import Data.Text ( Text ) import qualified Data.Text as Text -import Data.Typeable import Nix.Atoms import Nix.Cited import Nix.Convert @@ -58,7 +49,7 @@ import Nix.Value.Monad import Prettyprinter #ifdef MIN_VERSION_pretty_show -import qualified Text.Show.Pretty as PS +import qualified Text.Show.Pretty as PS #endif #ifdef MIN_VERSION_ghc_datasize @@ -67,14 +58,17 @@ #endif #endif -type MonadCited t f m - = ( HasCitations m (NValue t f m) t +type MonadCited t f m = + ( HasCitations m (NValue t f m) t , HasCitations1 m (NValue t f m) f , MonadDataContext f m ) nvConstantP - :: MonadCited t f m => Provenance m (NValue t f m) -> NAtom -> NValue t f m + :: MonadCited t f m + => Provenance m (NValue t f m) + -> NAtom + -> NValue t f m nvConstantP p x = addProvenance p (nvConstant x) nvStrP @@ -85,7 +79,10 @@ nvStrP p ns = addProvenance p (nvStr ns) nvPathP - :: MonadCited t f m => Provenance m (NValue t f m) -> FilePath -> NValue t f m + :: MonadCited t f m + => Provenance m (NValue t f m) + -> FilePath + -> NValue t f m nvPathP p x = addProvenance p (nvPath x) nvListP @@ -98,10 +95,10 @@ nvSetP :: MonadCited t f m => Provenance m (NValue t f m) - -> AttrSet (NValue t f m) -> AttrSet SourcePos + -> AttrSet (NValue t f m) -> NValue t f m -nvSetP p s x = addProvenance p (nvSet s x) +nvSetP p x s = addProvenance p (nvSet x s) nvClosureP :: MonadCited t f m @@ -114,7 +111,7 @@ nvBuiltinP :: MonadCited t f m => Provenance m (NValue t f m) - -> String + -> Text -> (NValue t f m -> m (NValue t f m)) -> NValue t f m nvBuiltinP p name f = addProvenance p (nvBuiltin name f) @@ -141,7 +138,7 @@ ) data ExecFrame t f m = Assertion SrcSpan (NValue t f m) - deriving (Show, Typeable) + deriving (Show, Typeable) instance MonadDataErrorContext t f m => Exception (ExecFrame t f m) @@ -153,78 +150,83 @@ wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc wrapExprLoc span x = Fix (Fix (NSym_ span "") <$ x) +{-# inline wrapExprLoc #-} +-- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class. +-- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`. instance MonadNix e t f m => MonadEval (NValue t f m) m where freeVariable var = - nverr @e @t @f - $ ErrorCall - $ "Undefined variable '" - ++ Text.unpack var - ++ "'" + nverr @e @t @f $ ErrorCall $ "Undefined variable '" <> toString var <> "'" synHole name = do span <- currentPos scope <- currentScopes - evalError @(NValue t f m) $ SynHole $ SynHoleInfo - { _synHoleInfo_expr = Fix $ NSynHole_ span name - , _synHoleInfo_scope = scope - } + evalError @(NValue t f m) $ SynHole $ + SynHoleInfo + { _synHoleInfo_expr = Fix $ NSynHole_ span name + , _synHoleInfo_scope = scope + } - attrMissing ks Nothing = - evalError @(NValue t f m) - $ ErrorCall - $ "Inheriting unknown attribute: " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - attrMissing ks (Just s) = - evalError @(NValue t f m) - $ ErrorCall - $ "Could not look up attribute " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - ++ " in " - ++ show (prettyNValue s) + attrMissing ks ms = + evalError @(NValue t f m) $ ErrorCall $ toString $ + maybe + ("Inheriting unknown attribute: " <> attr) + (\ s -> + "Could not look up attribute " <> attr <> " in " <> show (prettyNValue s) + ) + ms + where + attr = Text.intercalate "." (NE.toList ks) evalCurPos = do scope <- currentScopes span@(SrcSpan delta _) <- currentPos addProvenance @_ @_ @(NValue t f m) - (Provenance scope (NSym_ span "__curPos")) - <$> toValue delta + (Provenance scope (NSym_ span "__curPos")) <$> + toValue delta evaledSym name val = do scope <- currentScopes span <- currentPos - pure $ addProvenance @_ @_ @(NValue t f m) - (Provenance scope (NSym_ span name)) - val + pure $ + addProvenance @_ @_ @(NValue t f m) + (Provenance scope (NSym_ span name)) + val evalConstant c = do scope <- currentScopes span <- currentPos pure $ nvConstantP (Provenance scope (NConstant_ span c)) c - evalString = assembleString >=> \case - Just ns -> do - scope <- currentScopes - span <- currentPos - pure $ nvStrP - (Provenance - scope - (NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])) - ) - ns - Nothing -> nverr $ ErrorCall "Failed to assemble string" + evalString = + maybe + (nverr $ ErrorCall "Failed to assemble string") + (\ ns -> + do + scope <- currentScopes + span <- currentPos + pure $ + nvStrP + (Provenance + scope + (NStr_ span (DoubleQuoted [Plain (stringIgnoreContext ns)])) + ) + ns + ) + <=< assembleString evalLiteralPath p = do scope <- currentScopes span <- currentPos - nvPathP (Provenance scope (NLiteralPath_ span p)) - <$> makeAbsolutePath @t @f @m p + nvPathP (Provenance scope (NLiteralPath_ span p)) <$> + makeAbsolutePath @t @f @m p evalEnvPath p = do scope <- currentScopes span <- currentPos - nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath @t @f @m p + nvPathP (Provenance scope (NEnvPath_ span p)) <$> + findEnvPath @t @f @m p evalUnary op arg = do scope <- currentScopes @@ -239,49 +241,51 @@ evalWith c b = do scope <- currentScopes span <- currentPos - (\b -> addProvenance (Provenance scope (NWith_ span Nothing (Just b))) b) + (\b -> addProvenance (Provenance scope (NWith_ span Nothing (pure b))) b) <$> evalWithAttrSet c b evalIf c t f = do scope <- currentScopes span <- currentPos - fromValue c >>= \b -> if b - then - (\t -> addProvenance - (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) - t - ) - <$> t - else - (\f -> addProvenance - (Provenance scope (NIf_ span (Just c) Nothing (Just f))) - f - ) - <$> f + b <- fromValue c - evalAssert c body = fromValue c >>= \b -> do - span <- currentPos - if b - then do - scope <- currentScopes - (\b -> - addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b - ) - <$> body - else nverr $ Assertion span c + let + fun x y = addProvenance (Provenance scope (NIf_ span (pure c) x y)) + bool + ( (\ f' -> fun Nothing (pure f') f') <$> f ) + ( (\ t' -> fun (pure t') Nothing t') <$> t ) + b + + evalAssert c body = + do + span <- currentPos + b <- fromValue c + bool + (nverr $ Assertion span c) + (do + scope <- currentScopes + (\b -> + addProvenance (Provenance scope (NAssert_ span (pure c) (pure b))) b + ) <$> + body + ) + b + evalApp f x = do scope <- currentScopes span <- currentPos - addProvenance (Provenance scope (NBinary_ span NApp (Just f) Nothing)) - <$> (callFunc f =<< defer x) + addProvenance (Provenance scope (NBinary_ span NApp (pure f) Nothing)) <$> + (callFunc f =<< defer x) evalAbs p k = do scope <- currentScopes span <- currentPos - pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) - (void p) - (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) + pure $ + nvClosureP + (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) + (void p) + (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) evalError = throwError @@ -292,20 +296,22 @@ => NValue t f m -> NValue t f m -> m (NValue t f m) -callFunc fun arg = demand fun $ \fun' -> do - frames :: Frames <- asks (view hasLens) - when (length frames > 2000) $ throwError $ ErrorCall - "Function call stack exhausted" - case fun' of - NVClosure _params f -> do - f arg - NVBuiltin name f -> do - span <- currentPos - withFrame Info (Calling @m @(NValue t f m) name span) (f arg) - s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do - demand f $ (`callFunc` s) >=> (`callFunc` arg) - x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x +callFunc fun arg = + do + frames :: Frames <- asks (view hasLens) + when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" + fun' <- demand fun + case fun' of + NVClosure _params f -> f arg + NVBuiltin name f -> + do + span <- currentPos + withFrame Info ((Calling @m @(NValue t f m)) name span) (f arg) + (NVSet m _) | Just f <- M.lookup "__functor" m -> + ((`callFunc` arg) <=< (`callFunc` fun')) =<< demand f + x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x + execUnaryOp :: (Framed e m, MonadCited t f m, Show t) => Scopes m (NValue t f m) @@ -315,23 +321,17 @@ -> m (NValue t f m) execUnaryOp scope span op arg = do case arg of - NVConstant c -> case (op, c) of - (NNeg, NInt i ) -> unaryOp $ NInt (-i) - (NNeg, NFloat f) -> unaryOp $ NFloat (-f) - (NNot, NBool b ) -> unaryOp $ NBool (not b) - _ -> - throwError - $ ErrorCall - $ "unsupported argument type for unary operator " - ++ show op + NVConstant c -> + case (op, c) of + (NNeg, NInt i ) -> unaryOp $ NInt (-i) + (NNeg, NFloat f) -> unaryOp $ NFloat (-f) + (NNot, NBool b ) -> unaryOp $ NBool (not b) + _ -> + throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show op x -> - throwError - $ ErrorCall - $ "argument to unary operator" - ++ " must evaluate to an atomic type: " - ++ show x + throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show x where - unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg))) + unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (pure arg))) execBinaryOp :: forall e t f m @@ -343,31 +343,49 @@ -> m (NValue t f m) -> m (NValue t f m) -execBinaryOp scope span op lval rarg = case op of - NEq -> rarg >>= \rval -> valueEqM lval rval >>= boolOp rval - NNEq -> rarg >>= \rval -> valueEqM lval rval >>= boolOp rval . not - NOr -> fromValue lval >>= \l -> if l - then bypass True - else rarg >>= \rval -> fromValue rval >>= boolOp rval - NAnd -> fromValue lval >>= \l -> if l - then rarg >>= \rval -> fromValue rval >>= boolOp rval - else bypass False - NImpl -> fromValue lval >>= \l -> if l - then rarg >>= \rval -> fromValue rval >>= boolOp rval - else bypass True - _ -> rarg >>= \rval -> - demand rval $ \rval' -> - demand lval $ \lval' -> - execBinaryOpForced scope span op lval' rval' +execBinaryOp scope span op lval rarg = + case op of + NEq -> helperEq id + NNEq -> helperEq not + NOr -> helperLogic flip True + NAnd -> helperLogic id False + NImpl -> helperLogic id True + _ -> + do + rval <- rarg + rval' <- demand rval + lval' <- demand lval + execBinaryOpForced scope span op lval' rval' + where - toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) - toBoolOp r b = pure $ nvConstantP - (Provenance scope (NBinary_ span op (Just lval) r)) - (NBool b) - boolOp rval = toBoolOp (Just rval) + + helperEq flag = + do + rval <- rarg + eq <- valueEqM lval rval + boolOp rval $ flag eq + + helperLogic flp flag = + flp bool + (bypass flag) + (do + rval <- rarg + x <- fromValue rval + boolOp rval x + ) + =<< fromValue lval + + boolOp rval = toBoolOp (pure rval) + bypass = toBoolOp Nothing + toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) + toBoolOp r b = + pure $ + nvConstantP + (Provenance scope (NBinary_ span op (pure lval) r)) + (NBool b) execBinaryOpForced :: forall e t f m @@ -380,55 +398,61 @@ -> m (NValue t f m) execBinaryOpForced scope span op lval rval = case op of - NLt -> compare (<) - NLte -> compare (<=) - NGt -> compare (>) - NGte -> compare (>=) + NLt -> compare (<) + NLte -> compare (<=) + NGt -> compare (>) + NGte -> compare (>=) NMinus -> numBinOp (-) NMult -> numBinOp (*) NDiv -> numBinOp' div (/) - NConcat -> case (lval, rval) of - (NVList ls, NVList rs) -> pure $ nvListP prov $ ls ++ rs - _ -> unsupportedTypes + NConcat -> + case (lval, rval) of + (NVList ls, NVList rs) -> pure $ nvListP prov $ ls <> rs + _ -> unsupportedTypes - NUpdate -> case (lval, rval) of - (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rs `M.union` ls) (rp `M.union` lp) - (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov ls lp - (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rs rp - _ -> unsupportedTypes + NUpdate -> + case (lval, rval) of + (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp `M.union` lp) (rs `M.union` ls) + (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov lp ls + (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rp rs + _ -> unsupportedTypes - NPlus -> case (lval, rval) of - (NVConstant _, NVConstant _) -> numBinOp (+) + NPlus -> + case (lval, rval) of + (NVConstant _, NVConstant _) -> numBinOp (+) - (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls `principledStringMappend` rs) - (NVStr ls, rs@NVPath{}) -> - (\rs2 -> nvStrP prov (ls `principledStringMappend` rs2)) - <$> coerceToString callFunc CopyToStore CoerceStringy rs - (NVPath ls, NVStr rs) -> case principledGetStringNoContext rs of - Just rs2 -> nvPathP prov <$> makeAbsolutePath @t @f (ls `mappend` Text.unpack rs2) - Nothing -> throwError $ ErrorCall $ - -- data/nix/src/libexpr/eval.cc:1412 - "A string that refers to a store path cannot be appended to a path." - (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls ++ rs) + (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls <> rs) + (NVStr ls, rs@NVPath{}) -> + (\rs2 -> nvStrP prov (ls <> rs2)) <$> + coerceToString callFunc CopyToStore CoerceStringy rs + (NVPath ls, NVStr rs) -> + maybe + (throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412 + (\ rs2 -> + nvPathP prov <$> + makeAbsolutePath @t @f (ls <> toString rs2) + ) + (getStringNoContext rs) + (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs) - (ls@NVSet{}, NVStr rs) -> - (\ls2 -> nvStrP prov (ls2 `principledStringMappend` rs)) - <$> coerceToString callFunc DontCopyToStore CoerceStringy ls - (NVStr ls, rs@NVSet{}) -> - (\rs2 -> nvStrP prov (ls `principledStringMappend` rs2)) - <$> coerceToString callFunc DontCopyToStore CoerceStringy rs - _ -> unsupportedTypes + (ls@NVSet{}, NVStr rs) -> + (\ls2 -> nvStrP prov (ls2 <> rs)) <$> + coerceToString callFunc DontCopyToStore CoerceStringy ls + (NVStr ls, rs@NVSet{}) -> + (\rs2 -> nvStrP prov (ls <> rs2)) <$> + coerceToString callFunc DontCopyToStore CoerceStringy rs + _ -> unsupportedTypes NEq -> alreadyHandled NNEq -> alreadyHandled NAnd -> alreadyHandled NOr -> alreadyHandled NImpl -> alreadyHandled - NApp -> throwError $ ErrorCall $ "NApp should be handled by evalApp" + NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" where prov :: Provenance m (NValue t f m) - prov = Provenance scope (NBinary_ span op (Just lval) (Just rval)) + prov = Provenance scope (NBinary_ span op (pure lval) (pure rval)) toBool = pure . nvConstantP prov . NBool compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m) @@ -457,25 +481,19 @@ _ -> unsupportedTypes _ -> unsupportedTypes - unsupportedTypes = throwError $ ErrorCall $ - "Unsupported argument types for binary operator " - ++ show op - ++ ": " - ++ show lval - ++ ", " - ++ show rval + unsupportedTypes = throwError $ ErrorCall $ "Unsupported argument types for binary operator " <> show op <> ": " <> show lval <> ", " <> show rval - alreadyHandled = throwError $ ErrorCall $ - "This cannot happen: operator " - ++ show op - ++ " should have been handled in execBinaryOp." + alreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp." + -- This function is here, rather than in 'Nix.String', because of the need to -- use 'throwError'. fromStringNoContext :: Framed e m => NixString -> m Text -fromStringNoContext ns = case principledGetStringNoContext ns of - Just str -> pure str - Nothing -> throwError $ ErrorCall $ "expected string with no context, but got " ++ show ns +fromStringNoContext ns = + maybe + (throwError $ ErrorCall $ "expected string with no context, but got " <> show ns) + pure + (getStringNoContext ns) addTracing :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) @@ -488,14 +506,18 @@ v'@(Compose (Ann span x)) <- sequence v pure $ do opts :: Options <- asks (view hasLens) - let rendered = if verbose opts >= Chatty + let + rendered = + if verbose opts >= Chatty + then + pretty $ #ifdef MIN_VERSION_pretty_show - then pretty $ PS.ppShow (void x) + PS.ppShow (void x) #else - then pretty $ show (void x) + show (void x) #endif else prettyNix (Fix (Fix (NSym "?") <$ x)) - msg x = pretty ("eval: " ++ replicate depth ' ') <> x + msg x = pretty ("eval: " <> replicate depth ' ') <> x loc <- renderLocation span (msg rendered <> " ...\n") putStr $ show loc res <- k v' @@ -505,19 +527,26 @@ evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m) evalExprLoc expr = do opts :: Options <- asks (view hasLens) - if tracing opts - then join . (`runReaderT` (0 :: Int)) $ adi - (addTracing phi) - (raise (addStackFrames @(NValue t f m) . addSourcePositions)) - expr - else adi phi (addStackFrames @(NValue t f m) . addSourcePositions) expr + + bool + (adi + phi + (addStackFrames @(NValue t f m) . addSourcePositions) + ) + (join . (`runReaderT` (0 :: Int)) . + adi + (addTracing phi) + (raise (addStackFrames @(NValue t f m) . addSourcePositions)) + ) + (tracing opts) + expr where phi = Eval.eval . annotated . getCompose raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x -exec :: (MonadNix e t f m, MonadInstantiate m) => [String] -> m (NValue t f m) +exec :: (MonadNix e t f m, MonadInstantiate m) => [Text] -> m (NValue t f m) exec args = either throwError evalExprLoc =<< exec' args nixInstantiateExpr - :: (MonadNix e t f m, MonadInstantiate m) => String -> m (NValue t f m) + :: (MonadNix e t f m, MonadInstantiate m) => Text -> m (NValue t f m) nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s diff --git a/src/Nix/Expr/Shorthands.hs b/src/Nix/Expr/Shorthands.hs --- a/src/Nix/Expr/Shorthands.hs +++ b/src/Nix/Expr/Shorthands.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -- | A bunch of shorthands for making nix expressions. -- @@ -8,8 +7,6 @@ module Nix.Expr.Shorthands where import Data.Fix -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Text ( Text ) import Nix.Atoms import Nix.Expr.Types import Text.Megaparsec.Pos ( SourcePos ) @@ -32,13 +29,13 @@ -- | Make a regular (double-quoted) string. mkStr :: Text -> NExpr mkStr = Fix . NStr . DoubleQuoted . \case - "" -> [] + "" -> mempty x -> [Plain x] -- | Make an indented string. mkIndentedStr :: Int -> Text -> NExpr mkIndentedStr w = Fix . NStr . Indented w . \case - "" -> [] + "" -> mempty x -> [Plain x] -- | Make a path. Use 'True' if the path should be read from the @@ -78,7 +75,7 @@ mkSynHoleF = NSynHole mkSelector :: Text -> NAttrPath NExpr -mkSelector = (:| []) . StaticKey +mkSelector = (:| mempty) . StaticKey mkBool :: Bool -> NExpr mkBool = Fix . mkBoolF @@ -99,7 +96,7 @@ mkOper2 op a = Fix . NBinary op a mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr -mkParamset params variadic = ParamSet params variadic Nothing +mkParamset params variadic = ParamSet params variadic mempty mkRecSet :: [Binding NExpr] -> NExpr mkRecSet = Fix . NSet NRecursive @@ -135,8 +132,8 @@ mkDots (Fix (NSelect e keys' x)) keys = -- Special case: if the expression in the first argument is already -- a dotted expression, just extend it. - Fix (NSelect e (keys' <> map (StaticKey ?? Nothing) keys) x) -mkDots e keys = Fix $ NSelect e (map (StaticKey ?? Nothing) keys) Nothing + Fix (NSelect e (keys' <> fmap (StaticKey ?? Nothing) keys) x) +mkDots e keys = Fix $ NSelect e (fmap (StaticKey ?? Nothing) keys) Nothing -} -- | An `inherit` clause without an expression to pull from. @@ -145,7 +142,7 @@ -- | An `inherit` clause with an expression to pull from. inheritFrom :: e -> [NKeyName e] -> SourcePos -> Binding e -inheritFrom expr = Inherit (Just expr) +inheritFrom expr = Inherit (pure expr) -- | Shorthand for producing a binding of a name to an expression. bindTo :: Text -> NExpr -> Binding NExpr @@ -174,7 +171,7 @@ -- | A let statement with multiple assignments. letsE :: [(Text, NExpr)] -> NExpr -> NExpr -letsE pairs = Fix . NLet (map (uncurry bindTo) pairs) +letsE pairs = Fix . NLet (fmap (uncurry bindTo) pairs) -- | Wrapper for a single-variable @let@. letE :: Text -> NExpr -> NExpr -> NExpr @@ -182,11 +179,11 @@ -- | Make an attribute set (non-recursive). attrsE :: [(Text, NExpr)] -> NExpr -attrsE pairs = Fix $ NSet NNonRecursive (map (uncurry bindTo) pairs) +attrsE pairs = Fix $ NSet NNonRecursive (fmap (uncurry bindTo) pairs) -- | Make an attribute set (recursive). recAttrsE :: [(Text, NExpr)] -> NExpr -recAttrsE pairs = Fix $ NSet NRecursive (map (uncurry bindTo) pairs) +recAttrsE pairs = Fix $ NSet NRecursive (fmap (uncurry bindTo) pairs) -- | Logical negation. mkNot :: NExpr -> NExpr @@ -227,9 +224,8 @@ -- | Lambda shorthand. (==>) :: Params NExpr -> NExpr -> NExpr (==>) = mkFunction - infixr 1 ==> (@.) :: NExpr -> Text -> NExpr -obj @. name = Fix (NSelect obj (StaticKey name :| []) Nothing) +obj @. name = Fix (NSelect obj (StaticKey name :| mempty) Nothing) infixl 2 @. diff --git a/src/Nix/Expr/Strings.hs b/src/Nix/Expr/Strings.hs --- a/src/Nix/Expr/Strings.hs +++ b/src/Nix/Expr/Strings.hs @@ -1,21 +1,21 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -- | Functions for manipulating nix strings. module Nix.Expr.Strings where -import Data.List ( intercalate - , dropWhileEnd - , inits +import Nix.Utils +import Relude.Unsafe as Unsafe +-- Please, switch things to NonEmpty +import Data.List ( dropWhileEnd + , minimum + , lookup ) -import Data.Text ( Text ) import qualified Data.Text as T -import Data.Tuple ( swap ) import Nix.Expr --- | Merge adjacent 'Plain' values with 'mappend'. +-- | Merge adjacent @Plain@ values with @<>@. mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r] -mergePlain [] = [] +mergePlain [] = mempty mergePlain (Plain a : EscapedNewline : Plain b : xs) = mergePlain (Plain (a <> "\n" <> b) : xs) mergePlain (Plain a : Plain b : xs) = mergePlain (Plain (a <> b) : xs) @@ -31,7 +31,7 @@ -- trimEnd xs -- | null xs = xs -- | otherwise = case last xs of - -- Plain x -> init xs ++ [Plain (T.dropWhileEnd (== ' ') x)] + -- Plain x -> init xs <> [Plain (T.dropWhileEnd (== ' ') x)] -- _ -> xs -- | Equivalent to case splitting on 'Antiquoted' strings. @@ -45,10 +45,10 @@ splitLines = uncurry (flip (:)) . go where go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls where (l : ls) = T.split (== '\n') t - f prefix (finished, current) = ((Plain prefix : current) : finished, []) + f prefix (finished, current) = ((Plain prefix : current) : finished, mempty) go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs - go [] = ([], []) + go [] = (mempty, mempty) -- | Join a stream of strings containing antiquotes again. This is the inverse -- of 'splitLines'. @@ -57,32 +57,35 @@ -- | Form an indented string by stripping spaces equal to the minimal indent. stripIndent :: [Antiquoted Text r] -> NString r -stripIndent [] = Indented 0 [] +stripIndent [] = Indented 0 mempty stripIndent xs = - Indented minIndent - . removePlainEmpty - . mergePlain - . map snd - . dropWhileEnd cleanup - . (\ys -> zip - (map - (\case - [] -> Nothing - x -> Just (last x) - ) - (inits ys) - ) - ys - ) - . unsplitLines - $ ls' + Indented + minIndent + (removePlainEmpty $ + mergePlain $ + (snd <$>) $ + dropWhileEnd + cleanup + $ pairWithLast $ unsplitLines ls' + ) where + pairWithLast ys = + zip + (list + Nothing + (pure . Unsafe.last) + <$> inits ys + ) + ys + ls = stripEmptyOpening $ splitLines xs - ls' = map (dropSpaces minIndent) ls + ls' = dropSpaces minIndent <$> ls - minIndent = case stripEmptyLines ls of - [] -> 0 - nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs + minIndent = + list + 0 + (minimum . (countSpaces . mergePlain <$>)) + (stripEmptyLines ls) stripEmptyLines = filter $ \case [Plain t] -> not $ T.null $ T.strip t @@ -98,7 +101,7 @@ dropSpaces 0 x = x dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs - dropSpaces _ _ = error "stripIndent: impossible" + dropSpaces _ _ = fail "stripIndent: impossible" cleanup (Nothing, Plain y) = T.all (== ' ') y cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y @@ -109,7 +112,7 @@ [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')] fromEscapeCode :: Char -> Maybe Char -fromEscapeCode = (`lookup` map swap escapeCodes) +fromEscapeCode = (`lookup` fmap swap escapeCodes) toEscapeCode :: Char -> Maybe Char toEscapeCode = (`lookup` escapeCodes) diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,37 +26,25 @@ module Nix.Expr.Types where #ifdef MIN_VERSION_serialise -import qualified Codec.Serialise ( Serialise(decode, encode) ) -- For instance implementation function disamburgation +import qualified Codec.Serialise as Serialise import Codec.Serialise ( Serialise ) #endif -import Control.Applicative import Control.DeepSeq -import Control.Monad import Data.Aeson import Data.Aeson.TH +import qualified Data.Binary as Binary import Data.Binary ( Binary ) -import qualified Data.Binary as Bin import Data.Data import Data.Eq.Deriving import Data.Fix import Data.Functor.Classes -import Data.Hashable import Data.Hashable.Lifted -import Data.List ( inits - , tails - ) -import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe ( fromMaybe ) import Data.Ord.Deriving -import Data.Text ( Text - , pack - , unpack - ) +import qualified Text.Show import Data.Traversable -import GHC.Exts import GHC.Generics -import Language.Haskell.TH.Syntax +import qualified Language.Haskell.TH.Syntax as TH import Lens.Family2 import Lens.Family2.TH import Nix.Atoms @@ -65,129 +52,24 @@ import Text.Megaparsec.Pos import Text.Read.Deriving import Text.Show.Deriving -import Type.Reflection ( eqTypeRep ) import qualified Type.Reflection as Reflection - -type VarName = Text - -hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) -hashAt = flip alterF - --- unfortunate orphans -instance Hashable1 NonEmpty - --- | The main Nix expression type. As it is polimophic, has a functor, --- which allows to traverse expressions and map functions over them. --- The actual 'NExpr' type is a fixed point of this functor, defined --- below. -data NExprF r - = NConstant !NAtom - -- ^ Constants: ints, floats, bools, URIs, and null. - | NStr !(NString r) - -- ^ A string, with interpolated expressions. - | NSym !VarName - -- ^ A variable. For example, in the expression @f a@, @f@ is represented - -- as @NSym "f"@ and @a@ as @NSym "a"@. - -- - -- > NSym "x" ~ x - | NList ![r] - -- ^ A list literal. - -- - -- > NList [x,y] ~ [ x y ] - | NSet !NRecordType ![Binding r] - -- ^ An attribute set literal - -- - -- > NSet NRecursive [NamedVar x y _] ~ rec { x = y; } - -- > NSet NNonRecursive [Inherit Nothing [x] _] ~ { inherit x; } - | NLiteralPath !FilePath - -- ^ A path expression, which is evaluated to a store path. The path here - -- can be relative, in which case it's evaluated relative to the file in - -- which it appears. - -- - -- > NLiteralPath "/x" ~ /x - -- > NLiteralPath "x/y" ~ x/y - | NEnvPath !FilePath - -- ^ A path which refers to something in the Nix search path (the NIX_PATH - -- environment variable. For example, @@. - -- - -- > NEnvPath "x" ~ - | NUnary !NUnaryOp !r - -- ^ Application of a unary operator to an expression. - -- - -- > NUnary NNeg x ~ - x - -- > NUnary NNot x ~ ! x - | NBinary !NBinaryOp !r !r - -- ^ Application of a binary operator to two expressions. - -- - -- > NBinary NPlus x y ~ x + y - -- > NBinary NApp f x ~ f x - | NSelect !r !(NAttrPath r) !(Maybe r) - -- ^ Dot-reference into an attribute set, optionally providing an - -- alternative if the key doesn't exist. - -- - -- > NSelect s (x :| []) Nothing ~ s.x - -- > NSelect s (x :| []) (Just y) ~ s.x or y - | NHasAttr !r !(NAttrPath r) - -- ^ Ask if a set contains a given attribute path. - -- - -- > NHasAttr s (x :| []) ~ s ? x - | NAbs !(Params r) !r - -- ^ A function literal (lambda abstraction). - -- - -- > NAbs (Param "x") y ~ x: y - | NLet ![Binding r] !r - -- ^ Evaluate the second argument after introducing the bindings. - -- - -- > NLet [] x ~ let in x - -- > NLet [NamedVar x y _] z ~ let x = y; in z - -- > NLet [Inherit Nothing x _] y ~ let inherit x; in y - | NIf !r !r !r - -- ^ If-then-else statement. - -- - -- > NIf x y z ~ if x then y else z - | NWith !r !r - -- ^ Evaluate an attribute set, bring its bindings into scope, and - -- evaluate the second argument. - -- - -- > NWith x y ~ with x; y - | NAssert !r !r - -- ^ Assert that the first returns @true@ before evaluating the second. - -- - -- > NAssert x y ~ assert x; y - | NSynHole !VarName - -- ^ Syntactic hole. - -- - -- See for context. - -- - -- > NSynHole "x" ~ ^x - deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, - Foldable, Traversable, Show, NFData, Hashable) - -instance Hashable1 NExprF - -instance NFData1 NExprF - -#ifdef MIN_VERSION_serialise -instance Serialise r => Serialise (NExprF r) +import Type.Reflection ( eqTypeRep ) +#if !MIN_VERSION_base(4,13,0) +-- NOTE: Remove package @th-lift-instances@ removing this +import Instances.TH.Lift () -- importing Lift Text fo GHC 8.6 #endif --- | We make an `IsString` for expressions, where the string is interpreted --- as an identifier. This is the most common use-case... -instance IsString NExpr where - fromString = Fix . NSym . fromString +-- * Components of Nix expressions -instance Lift (Fix NExprF) where - lift = dataToExpQ $ \b -> - case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of - Just HRefl -> Just [| pack $(liftString $ unpack b) |] - Nothing -> Nothing +-- NExpr is a composition of +-- * direct reuse of the Haskell types (list, FilePath, Text) +-- * NAtom +-- * Types in this section +-- * Fixpoint nature --- | The monomorphic expression type is a fixed point of the polymorphic one. -type NExpr = Fix NExprF +type VarName = Text -#ifdef MIN_VERSION_serialise -instance Serialise NExpr -#endif +-- ** @Binding@ -- | A single line of the bindings section of a let expression or of a set. data Binding r @@ -203,18 +85,21 @@ -- the first member of the list in the second argument. -- -- > Inherit Nothing [StaticKey "x"] SourcePos{} ~ inherit x; - -- > Inherit (Just x) [] SourcePos{} ~ inherit (x); + -- > Inherit (pure x) mempty SourcePos{} ~ inherit (x); deriving (Generic, Generic1, Typeable, Data, Ord, Eq, Functor, Foldable, Traversable, Show, NFData, Hashable) -instance Hashable1 Binding - instance NFData1 Binding +instance Hashable1 Binding + #ifdef MIN_VERSION_serialise instance Serialise r => Serialise (Binding r) #endif + +-- ** @Params@ + -- | @Params@ represents all the ways the formal parameters to a -- function can be represented. data Params r @@ -228,9 +113,10 @@ -- variadic or not. -- -- > ParamSet [("x",Nothing)] False Nothing ~ { x } - -- > ParamSet [("x",Just y)] True (Just "s") ~ s@{ x ? y, ... } - deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, Show, - Foldable, Traversable, NFData, Hashable) + -- > ParamSet [("x",pure y)] True (pure "s") ~ s@{ x ? y, ... } + deriving + (Ord, Eq, Generic, Generic1, Typeable, Data, NFData, Hashable, Show, + Functor, Foldable, Traversable) instance Hashable1 Params @@ -240,13 +126,18 @@ instance Serialise r => Serialise (Params r) #endif +instance IsString (Params r) where + fromString = Param . fromString + +-- *** @ParamSet@ + -- This uses an association list because nix XML serialization preserves the -- order of the param set. type ParamSet r = [(VarName, Maybe r)] -instance IsString (Params r) where - fromString = Param . fromString +-- ** @Antiquoted@ + -- | 'Antiquoted' represents an expression that is either -- antiquoted (surrounded by ${...}) or plain (not antiquoted). data Antiquoted (v :: *) (r :: *) @@ -266,10 +157,9 @@ instance Hashable v => Hashable1 (Antiquoted v) instance Hashable2 Antiquoted where - liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a - liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int) - liftHashWithSalt2 _ hb salt (Antiquoted b) = - hb (salt `hashWithSalt` (2 :: Int)) b + liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a + liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int) + liftHashWithSalt2 _ hb salt (Antiquoted b) = hb (salt `hashWithSalt` (2 :: Int)) b instance NFData v => NFData1 (Antiquoted v) @@ -277,6 +167,9 @@ instance (Serialise v, Serialise r) => Serialise (Antiquoted v r) #endif + +-- ** @NString@ + -- | An 'NString' is a list of things that are either a plain string -- or an antiquoted expression. After the antiquotes have been evaluated, -- the final string is constructed by concatenating all the parts. @@ -311,9 +204,12 @@ -- | For the the 'IsString' instance, we use a plain doublequoted string. instance IsString (NString r) where - fromString "" = DoubleQuoted [] - fromString string = DoubleQuoted [Plain $ pack string] + fromString "" = DoubleQuoted mempty + fromString string = DoubleQuoted [Plain $ toText string] + +-- ** @NKeyName@ + -- | A 'KeyName' is something that can appear on the left side of an -- equals sign. For example, @a@ is a 'KeyName' in @{ a = 3; }@, @let a = 3; -- in ...@, @{}.a@ or @{} ? a@. @@ -327,7 +223,7 @@ -- In particular, those include: -- -- * The RHS of a @binding@ inside @let@: @let ${"a"} = 3; in ...@ --- produces a syntax error. +-- produces a syntax fail. -- * The attribute names of an 'inherit': @inherit ${"a"};@ is forbidden. -- -- Note: In Nix, a simple string without antiquotes such as @"foo"@ is @@ -348,16 +244,16 @@ instance Serialise r => Serialise (NKeyName r) instance Serialise Pos where - encode x = Codec.Serialise.encode (unPos x) - decode = mkPos <$> Codec.Serialise.decode + encode = Serialise.encode . unPos + decode = mkPos <$> Serialise.decode instance Serialise SourcePos where - encode (SourcePos f l c) = Codec.Serialise.encode f <> Codec.Serialise.encode l <> Codec.Serialise.encode c - decode = SourcePos <$> Codec.Serialise.decode <*> Codec.Serialise.decode <*> Codec.Serialise.decode + encode (SourcePos f l c) = Serialise.encode f <> Serialise.encode l <> Serialise.encode c + decode = SourcePos <$> Serialise.decode <*> Serialise.decode <*> Serialise.decode #endif instance Hashable Pos where - hashWithSalt salt x = hashWithSalt salt (unPos x) + hashWithSalt salt = hashWithSalt salt . unPos instance Hashable SourcePos where hashWithSalt salt (SourcePos f l c) = @@ -381,9 +277,9 @@ -- | @since 0.10.1 instance Ord1 NKeyName where liftCompare cmp (DynamicKey a) (DynamicKey b) = liftCompare2 (liftCompare cmp) cmp a b - liftCompare _ (DynamicKey _) (StaticKey _) = LT - liftCompare _ (StaticKey _) (DynamicKey _) = GT - liftCompare _ (StaticKey a) (StaticKey b) = compare a b + liftCompare _ (DynamicKey _) (StaticKey _) = LT + liftCompare _ (StaticKey _) (DynamicKey _) = GT + liftCompare _ (StaticKey a) (StaticKey b) = compare a b instance Hashable1 NKeyName where liftHashWithSalt h salt (DynamicKey a) = @@ -400,7 +296,7 @@ "DynamicKey" p a - StaticKey t -> showsUnaryWith showsPrec "StaticKey" p t + StaticKey t -> showsUnaryWith Text.Show.showsPrec "StaticKey" p t -- Deriving this instance automatically is not possible because @r@ -- occurs not only as last argument in @Antiquoted (NString r) r@ @@ -419,14 +315,19 @@ DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str DynamicKey (Antiquoted e ) -> DynamicKey . Antiquoted <$> f e DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline - StaticKey key -> pure (StaticKey key) + StaticKey key -> pure $ StaticKey key + +-- ** @NAttrPath@ + -- | A selector (for example in a @let@ or an attribute set) is made up -- of strung-together key names. -- -- > StaticKey "x" :| [DynamicKey (Antiquoted y)] ~ x.${y} type NAttrPath r = NonEmpty (NKeyName r) +-- ** @NUnaryOp + -- | There are two unary operations: logical not and integer negation. data NUnaryOp = NNeg -- ^ @-@ @@ -438,6 +339,9 @@ instance Serialise NUnaryOp #endif + +-- ** @NBinaryOp@ + -- | Binary operators expressible in the nix language. data NBinaryOp = NEq -- ^ Equality (@==@) @@ -465,6 +369,9 @@ instance Serialise NBinaryOp #endif + +-- ** @NRecordType@ + -- | 'NRecordType' distinguishes between recursive and non-recursive attribute -- sets. data NRecordType @@ -477,11 +384,151 @@ instance Serialise NRecordType #endif --- | Get the name out of the parameter (there might be none). -paramName :: Params r -> Maybe VarName -paramName (Param n ) = Just n -paramName (ParamSet _ _ n) = n +-- * @NExprF@ - Nix expressions, base functor +-- | The main Nix expression type. As it is polimophic, has a functor, +-- which allows to traverse expressions and map functions over them. +-- The actual 'NExpr' type is a fixed point of this functor, defined +-- below. +data NExprF r + = NConstant !NAtom + -- ^ Constants: ints, floats, bools, URIs, and null. + | NStr !(NString r) + -- ^ A string, with interpolated expressions. + | NSym !VarName + -- ^ A variable. For example, in the expression @f a@, @f@ is represented + -- as @NSym "f"@ and @a@ as @NSym "a"@. + -- + -- > NSym "x" ~ x + | NList ![r] + -- ^ A list literal. + -- + -- > NList [x,y] ~ [ x y ] + | NSet !NRecordType ![Binding r] + -- ^ An attribute set literal + -- + -- > NSet NRecursive [NamedVar x y _] ~ rec { x = y; } + -- > NSet NNonRecursive [Inherit Nothing [x] _] ~ { inherit x; } + | NLiteralPath !FilePath + -- ^ A path expression, which is evaluated to a store path. The path here + -- can be relative, in which case it's evaluated relative to the file in + -- which it appears. + -- + -- > NLiteralPath "/x" ~ /x + -- > NLiteralPath "x/y" ~ x/y + | NEnvPath !FilePath + -- ^ A path which refers to something in the Nix search path (the NIX_PATH + -- environment variable. For example, @@. + -- + -- > NEnvPath "x" ~ + | NUnary !NUnaryOp !r + -- ^ Application of a unary operator to an expression. + -- + -- > NUnary NNeg x ~ - x + -- > NUnary NNot x ~ ! x + | NBinary !NBinaryOp !r !r + -- ^ Application of a binary operator to two expressions. + -- + -- > NBinary NPlus x y ~ x + y + -- > NBinary NApp f x ~ f x + | NSelect !r !(NAttrPath r) !(Maybe r) + -- ^ Dot-reference into an attribute set, optionally providing an + -- alternative if the key doesn't exist. + -- + -- > NSelect s (x :| []) Nothing ~ s.x + -- > NSelect s (x :| []) (pure y) ~ s.x or y + | NHasAttr !r !(NAttrPath r) + -- ^ Ask if a set contains a given attribute path. + -- + -- > NHasAttr s (x :| []) ~ s ? x + | NAbs !(Params r) !r + -- ^ A function literal (lambda abstraction). + -- + -- > NAbs (Param "x") y ~ x: y + | NLet ![Binding r] !r + -- ^ Evaluate the second argument after introducing the bindings. + -- + -- > NLet [] x ~ let in x + -- > NLet [NamedVar x y _] z ~ let x = y; in z + -- > NLet [Inherit Nothing x _] y ~ let inherit x; in y + | NIf !r !r !r + -- ^ If-then-else statement. + -- + -- > NIf x y z ~ if x then y else z + | NWith !r !r + -- ^ Evaluate an attribute set, bring its bindings into scope, and + -- evaluate the second argument. + -- + -- > NWith x y ~ with x; y + | NAssert !r !r + -- ^ Assert that the first returns @true@ before evaluating the second. + -- + -- > NAssert x y ~ assert x; y + | NSynHole !VarName + -- ^ Syntactic hole. + -- + -- See for context. + -- + -- > NSynHole "x" ~ ^x + deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, + Foldable, Traversable, Show, NFData, Hashable) + +instance NFData1 NExprF + +#ifdef MIN_VERSION_serialise +instance Serialise r => Serialise (NExprF r) +#endif + +-- | We make an `IsString` for expressions, where the string is interpreted +-- as an identifier. This is the most common use-case... +instance IsString NExpr where + fromString = Fix . NSym . fromString + +instance TH.Lift (Fix NExprF) where + lift = + TH.dataToExpQ + (\b -> + do + -- Binding on constructor ensures type match and gives type inference to TH + HRefl <- + eqTypeRep + (Reflection.typeRep @Text) + (Reflection.typeOf b ) + pure [| $(TH.lift b) |] + ) +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = unsafeCodeCoerce . lift +#elif MIN_VERSION_template_haskell(2,16,0) + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + +#if !MIN_VERSION_hashable(1,3,1) +-- there was none before, remove this in year >2022 +instance Hashable1 NonEmpty +#endif + +instance Hashable1 NExprF + + +-- *** @NExpr@ + +-- | The monomorphic expression type is a fixed point of the polymorphic one. +type NExpr = Fix NExprF + +#ifdef MIN_VERSION_serialise +instance Serialise NExpr +#endif + + +-- ** @class NExprAnn@ + +class NExprAnn ann g | g -> ann where + fromNExpr :: g r -> (NExprF r, ann) + toNExpr :: (NExprF r, ann) -> g r + + +-- ** Additional instances + $(deriveEq1 ''NExprF) $(deriveEq1 ''NString) $(deriveEq1 ''Binding) @@ -519,12 +566,11 @@ instance Binary a => Binary (NString a) instance Binary a => Binary (Binding a) instance Binary Pos where - put x = Bin.put (unPos x) - get = mkPos <$> Bin.get + put = Binary.put . unPos + get = mkPos <$> Binary.get instance Binary SourcePos instance Binary a => Binary (NKeyName a) instance Binary a => Binary (Params a) -instance Binary NAtom instance Binary NUnaryOp instance Binary NBinaryOp instance Binary NRecordType @@ -534,11 +580,10 @@ instance ToJSON a => ToJSON (NString a) instance ToJSON a => ToJSON (Binding a) instance ToJSON Pos where - toJSON x = toJSON (unPos x) + toJSON = toJSON . unPos instance ToJSON SourcePos instance ToJSON a => ToJSON (NKeyName a) instance ToJSON a => ToJSON (Params a) -instance ToJSON NAtom instance ToJSON NUnaryOp instance ToJSON NBinaryOp instance ToJSON NRecordType @@ -552,7 +597,6 @@ instance FromJSON SourcePos instance FromJSON a => FromJSON (NKeyName a) instance FromJSON a => FromJSON (Params a) -instance FromJSON NAtom instance FromJSON NUnaryOp instance FromJSON NBinaryOp instance FromJSON NRecordType @@ -569,42 +613,59 @@ --x $(makeLenses ''Fix) -class NExprAnn ann g | g -> ann where - fromNExpr :: g r -> (NExprF r, ann) - toNExpr :: (NExprF r, ann) -> g r +-- ** Methods + +hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) +hashAt = flip alterF + +-- | Get the name out of the parameter (there might be none). +paramName :: Params r -> Maybe VarName +paramName (Param n ) = pure n +paramName (ParamSet _ _ n) = n + ekey :: NExprAnn ann g => NonEmpty Text -> SourcePos -> Lens' (Fix g) (Maybe (Fix g)) -ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = case go xs of - ((v, [] ) : _) -> fromMaybe e <$> f (Just v) - ((v, r : rest) : _) -> ekey (r :| rest) pos f v +ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = + case go xs of + ((v, [] ) : _) -> fromMaybe e <$> f (pure v) + ((v, r : rest) : _) -> ekey (r :| rest) pos f v - _ -> f Nothing <&> \case - Nothing -> e - Just v -> - let entry = NamedVar (NE.map StaticKey keys) v pos - in Fix (toNExpr (NSet NNonRecursive (entry : xs), ann)) - where - go xs = do - let keys' = NE.toList keys - (ks, rest) <- zip (inits keys') (tails keys') - case ks of - [] -> empty - j : js -> do - NamedVar ns v _p <- xs - guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) - pure (v, rest) + _ -> + maybe + e + (\ v -> + let entry = NamedVar (NE.map StaticKey keys) v pos in + Fix (toNExpr (NSet NNonRecursive (entry : xs), ann))) + <$> + f Nothing + where + go xs = + do + let keys' = NE.toList keys + (ks, rest) <- zip (inits keys') (tails keys') + list + mempty + (\ (j : js) -> + do + NamedVar ns v _p <- xs + guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) + pure (v, rest) + ) + ks ekey _ _ f e = fromMaybe e <$> f Nothing stripPositionInfo :: NExpr -> NExpr stripPositionInfo = transport phi where - phi (NSet recur binds) = NSet recur (map go binds) - phi (NLet binds body) = NLet (map go binds) body + transport f (Fix x) = Fix $ fmap (transport f) (f x) + + phi (NSet recur binds) = NSet recur $ fmap go binds + phi (NLet binds body) = NLet (fmap go binds) body phi x = x go (NamedVar path r _pos) = NamedVar path r nullPos diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -33,15 +32,11 @@ import Data.Binary ( Binary(..) ) import Data.Data import Data.Eq.Deriving -import Data.Fix ( Fix(..), unfoldFix ) -import Data.Function ( on ) +import Data.Fix ( Fix(..) + , unfoldFix ) import Data.Functor.Compose -import Data.Hashable import Data.Hashable.Lifted import Data.Ord.Deriving -import Data.Text ( Text - , pack - ) import GHC.Generics import Nix.Atoms import Nix.Expr.Types @@ -135,45 +130,48 @@ stripAnn = annotated . getCompose nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc -nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NUnary u e1) +nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NUnary u e1 nUnary _ _ = error "nUnary: unexpected" +{-# inline nUnary #-} nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) = - AnnE (s1 <> s2 <> s3) (NBinary b e1 e2) + AnnE (s1 <> s2 <> s3) $ NBinary b e1 e2 nBinary _ _ _ = error "nBinary: unexpected" nSelectLoc :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of - Nothing -> AnnE (s1 <> s2) (NSelect e1 ats Nothing) - Just e2@(AnnE s3 _) -> AnnE (s1 <> s2 <> s3) (NSelect e1 ats (Just e2)) + Nothing -> AnnE (s1 <> s2) $ NSelect e1 ats Nothing + Just e2@(AnnE s3 _) -> AnnE (s1 <> s2 <> s3) $ NSelect e1 ats $ pure e2 _ -> error "nSelectLoc: unexpected" nSelectLoc _ _ _ = error "nSelectLoc: unexpected" nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc -nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) (NHasAttr e1 ats) +nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) $ NHasAttr e1 ats nHasAttr _ _ = error "nHasAttr: unexpected" nApp :: NExprLoc -> NExprLoc -> NExprLoc -nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) (NBinary NApp e1 e2) +nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) $ NBinary NApp e1 e2 nApp _ _ = error "nApp: unexpected" nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc -nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NAbs ps e1) +nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NAbs ps e1 nAbs _ _ = error "nAbs: unexpected" nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc -nStr (Ann s1 s) = AnnE s1 (NStr s) +nStr (Ann s1 s) = AnnE s1 $ NStr s deltaInfo :: SourcePos -> (Text, Int, Int) -deltaInfo (SourcePos fp l c) = (pack fp, unPos l, unPos c) +deltaInfo (SourcePos fp l c) = (toText fp, unPos l, unPos c) nNull :: NExprLoc -nNull = Fix (Compose (Ann nullSpan (NConstant NNull))) +nNull = Fix $ Compose $ Ann nullSpan $ NConstant NNull +{-# inline nNull #-} nullSpan :: SrcSpan nullSpan = SrcSpan nullPos nullPos +{-# inline nullSpan #-} -- | Pattern systems for matching on NExprLocF constructions. diff --git a/src/Nix/Frames.hs b/src/Nix/Frames.hs --- a/src/Nix/Frames.hs +++ b/src/Nix/Frames.hs @@ -18,13 +18,18 @@ ) where +import Prelude hiding ( traceM ) +import Data.Typeable hiding ( typeOf ) +import Control.Monad.Catch ( MonadThrow(..) ) import Control.Exception hiding ( catch , evaluate ) -import Control.Monad.Catch -import Control.Monad.Reader -import Data.Typeable hiding ( typeOf ) -import Nix.Utils +import qualified Text.Show +import Nix.Utils ( Has(..) + , view + , over + , traceM + ) data NixLevel = Fatal | Error | Warning | Info | Debug deriving (Ord, Eq, Bounded, Enum, Show) @@ -36,7 +41,7 @@ instance Show NixFrame where show (NixFrame level f) = - "Nix frame at level " ++ show level ++ ": " ++ show f + "Nix frame at level " <> show level <> ": " <> show f type Frames = [NixFrame] @@ -55,5 +60,5 @@ :: forall s e m a . (Framed e m, Exception s, MonadThrow m) => s -> m a throwError err = do context <- asks (view hasLens) - traceM "Throwing error..." + traceM "Throwing fail..." throwM $ NixException (NixFrame Error (toException err) : context) diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -1,32 +1,30 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Fresh where -import Control.Applicative -import Control.Monad.Base -import Control.Monad.Catch -import Control.Monad.Except -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail -#endif -import Control.Monad.Reader -import Control.Monad.Ref -import Control.Monad.ST -import Data.Typeable +import Control.Monad.Base ( MonadBase(..) ) +import Control.Monad.Catch ( MonadCatch + , MonadMask + , MonadThrow + ) +import Control.Monad.Except ( MonadFix ) +import Control.Monad.Ref ( MonadAtomicRef(..) + , MonadRef() + ) import Nix.Var import Nix.Thunk + newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a } deriving ( Functor @@ -50,14 +48,16 @@ instance MonadBase b m => MonadBase b (FreshIdT i m) where liftBase = FreshIdT . liftBase -instance ( MonadVar m - , Eq i - , Ord i - , Show i - , Enum i - , Typeable i - ) - => MonadThunkId (FreshIdT i m) where +instance + ( MonadVar m + , Eq i + , Ord i + , Show i + , Enum i + , Typeable i + ) + => MonadThunkId (FreshIdT i m) + where type ThunkId (FreshIdT i m) = i freshId = FreshIdT $ do v <- ask @@ -65,18 +65,3 @@ runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a runFreshIdT i m = runReaderT (unFreshIdT m) i - --- Orphan instance needed by Infer.hs and Lint.hs - --- Since there's no forking, it's automatically atomic. -instance MonadAtomicRef (ST s) where - atomicModifyRef r f = do - v <- readRef r - let (a, b) = f v - writeRef r a - return b - atomicModifyRef' r f = do - v <- readRef r - let (a, b) = f v - writeRef r $! a - return b diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs --- a/src/Nix/Fresh/Basic.hs +++ b/src/Nix/Fresh/Basic.hs @@ -3,16 +3,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Fresh.Basic where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Control.Monad.Reader import Nix.Effects import Nix.Render import Nix.Fresh @@ -20,6 +19,7 @@ type StdIdT = FreshIdT Int +-- NOTE: These would be removed by: https://github.com/haskell-nix/hnix/pull/804 instance (MonadFail m, MonadFile m) => MonadFile (StdIdT m) instance MonadIntrospect m => MonadIntrospect (StdIdT m) instance MonadStore m => MonadStore (StdIdT m) @@ -36,15 +36,15 @@ findEnvPath = lift . findEnvPath @t @f @m findPath vs path = do i <- FreshIdT ask - let vs' = map (unliftNValue (runFreshIdT i)) vs + let vs' = fmap (unliftNValue (runFreshIdT i)) vs lift $ findPath @t @f @m vs' path importPath path = do i <- FreshIdT ask p <- lift $ importPath @t @f @m path - return $ liftNValue (runFreshIdT i) p + pure $ liftNValue (runFreshIdT i) p pathToDefaultNix = lift . pathToDefaultNix @t @f @m derivationStrict v = do i <- FreshIdT ask - p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v) - return $ liftNValue (runFreshIdT i) p + p <- lift $ derivationStrict @t @f @m $ unliftNValue (runFreshIdT i) v + pure $ liftNValue (runFreshIdT i) p traceEffect = lift . traceEffect @t @f @m diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -1,16 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} module Nix.Json where -import Control.Monad -import Control.Monad.Trans import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import qualified Data.HashMap.Lazy as HM -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Vector as V import Nix.Atoms @@ -24,33 +19,35 @@ nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString nvalueToJSONNixString = - runWithStringContextT - . fmap - ( TL.toStrict - . TL.decodeUtf8 - . A.encodingToLazyByteString - . toEncodingSorted - ) - . nvalueToJSON + runWithStringContextT . + fmap + ( toStrict + . TL.decodeUtf8 + . A.encodingToLazyByteString + . toEncodingSorted + ) + . nvalueToJSON + nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value nvalueToJSON = \case NVConstant (NInt n) -> pure $ A.toJSON n NVConstant (NFloat n) -> pure $ A.toJSON n NVConstant (NBool b) -> pure $ A.toJSON b - NVConstant NNull -> pure $ A.Null + NVConstant NNull -> pure A.Null NVStr ns -> A.toJSON <$> extractNixString ns - NVList l -> - A.Array - . V.fromList - <$> traverse (join . lift . flip demand (pure . nvalueToJSON)) l - NVSet m _ -> case HM.lookup "outPath" m of - Nothing -> - A.Object - <$> traverse (join . lift . flip demand (pure . nvalueToJSON)) m - Just outPath -> join $ lift $ demand outPath (pure . nvalueToJSON) - NVPath p -> do - fp <- lift $ unStorePath <$> addPath p - addSingletonStringContext $ StringContext (Text.pack fp) DirectPath - pure $ A.toJSON fp + NVList l -> A.Array . V.fromList <$> traverse intoJson l + NVSet m _ -> + maybe + (A.Object <$> traverse intoJson m) + intoJson + (HM.lookup "outPath" m) + NVPath p -> + do + fp <- lift $ unStorePath <$> addPath p + addSingletonStringContext $ StringContext (toText fp) DirectPath + pure $ A.toJSON fp v -> lift $ throwError $ CoercionToJson v + + where + intoJson nv = join $ lift $ nvalueToJSON <$> demand nv diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} @@ -13,25 +12,28 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -Wno-missing-methods #-} module Nix.Lint where -import Control.Monad +import Prelude hiding ( head + , force + ) +import Nix.Utils +import Control.Monad ( foldM ) import Control.Monad.Catch import Control.Monad.Fix -import Control.Monad.Reader ( MonadReader ) import Control.Monad.Ref import Control.Monad.ST -import Control.Monad.Trans.Reader -import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M +-- Plese, use NonEmpty import Data.List import qualified Data.List.NonEmpty as NE -import Data.Text ( Text ) import qualified Data.Text as Text +import qualified Text.Show import Nix.Atoms import Nix.Context import Nix.Convert @@ -45,7 +47,6 @@ import Nix.Scope import Nix.Thunk import Nix.Thunk.Basic -import Nix.Utils import Nix.Var import Nix.Value.Monad @@ -57,14 +58,14 @@ deriving (Show, Eq, Ord) data NTypeF (m :: * -> *) r - = TConstant [TAtom] - | TStr - | TList r - | TSet (Maybe (HashMap Text r)) - | TClosure (Params ()) - | TPath - | TBuiltin String (Symbolic m -> m r) - deriving Functor + = TConstant [TAtom] + | TStr + | TList r + | TSet (Maybe (HashMap Text r)) + | TClosure (Params ()) + | TPath + | TBuiltin Text (Symbolic m -> m r) + deriving Functor compareTypes :: NTypeF m r -> NTypeF m r -> Ordering compareTypes (TConstant _) (TConstant _) = EQ @@ -88,9 +89,9 @@ compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ data NSymbolicF r - = NAny - | NMany [r] - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + = NAny + | NMany [r] + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) type SThunk (m :: * -> *) = NThunkF m (Symbolic m) @@ -101,57 +102,64 @@ instance Show (Symbolic m) where show _ = "" -everyPossible :: MonadVar m => m (Symbolic m) +everyPossible + :: MonadVar m + => m (Symbolic m) everyPossible = packSymbolic NAny -mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m) +mkSymbolic + :: MonadVar m + => [NTypeF m (Symbolic m)] + -> m (Symbolic m) mkSymbolic xs = packSymbolic (NMany xs) packSymbolic - :: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m) + :: MonadVar m + => NSymbolicF (NTypeF m (Symbolic m)) + -> m (Symbolic m) packSymbolic = fmap SV . newVar unpackSymbolic :: (MonadVar m, MonadThunkId m, MonadCatch m) => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))) -unpackSymbolic = flip demand $ readVar . getSV +unpackSymbolic = readVar . getSV <=< demand -type MonadLint e m - = ( Scoped (Symbolic m) m +type MonadLint e m = + ( Scoped (Symbolic m) m , Framed e m , MonadVar m , MonadCatch m , MonadThunkId m ) -symerr :: forall e m a . MonadLint e m => String -> m a -symerr = evalError @(Symbolic m) . ErrorCall +symerr :: forall e m a . MonadLint e m => Text -> m a +symerr = evalError @(Symbolic m) . ErrorCall . toString -renderSymbolic :: MonadLint e m => Symbolic m -> m String +renderSymbolic :: MonadLint e m => Symbolic m -> m Text renderSymbolic = unpackSymbolic >=> \case NAny -> pure "" - NMany xs -> fmap (intercalate ", ") $ forM xs $ \case - TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case - TInt -> pure "int" - TFloat -> pure "float" - TBool -> pure "bool" - TNull -> pure "null" + NMany xs -> fmap (Text.intercalate ", ") $ forM xs $ \case + TConstant ys -> fmap (Text.intercalate ", ") $ forM ys $ pure . \case + TInt -> "int" + TFloat -> "float" + TBool -> "bool" + TNull -> "null" TStr -> pure "string" TList r -> do - x <- demand r renderSymbolic - pure $ "[" ++ x ++ "]" + x <- renderSymbolic =<< demand r + pure $ "[" <> x <> "]" TSet Nothing -> pure "" TSet (Just s) -> do - x <- traverse (`demand` renderSymbolic) s - pure $ "{" ++ show x ++ "}" + x <- traverse (renderSymbolic <=< demand) s + pure $ "{" <> show x <> "}" f@(TClosure p) -> do (args, sym) <- do f' <- mkSymbolic [f] lintApp (NAbs (void p) ()) f' everyPossible args' <- traverse renderSymbolic args sym' <- renderSymbolic sym - pure $ "(" ++ show args' ++ " -> " ++ sym' ++ ")" + pure $ "(" <> show args' <> " -> " <> sym' <> ")" TPath -> pure "path" TBuiltin _n _f -> pure "" @@ -169,28 +177,38 @@ :: [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)] - go [] _ = pure [] - go _ [] = pure [] + go [] _ = stub + go _ [] = stub go (x : xs) (y : ys) = case (x, y) of (TStr , TStr ) -> (TStr :) <$> go xs ys (TPath, TPath) -> (TPath :) <$> go xs ys (TConstant ls, TConstant rs) -> (TConstant (ls `intersect` rs) :) <$> go xs ys - (TList l, TList r) -> demand l $ \l' -> demand r $ \r' -> do - m <- defer $ unify context l' r' - (TList m :) <$> go xs ys + (TList l, TList r) -> + (\l' -> + (\r' -> do + m <- defer $ unify context l' r' + (TList m :) <$> go xs ys + ) =<< demand r + ) =<< demand l (TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys (TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys (TSet (Just l), TSet (Just r)) -> do m <- sequenceA $ M.intersectionWith - (\i j -> i >>= \i' -> - j - >>= \j' -> demand i' - $ \i'' -> demand j' $ \j'' -> defer $ unify context i'' j'' + (\ i j -> + do + i'' <- demand =<< i + j'' <- demand =<< j + (defer . unify context i'') j'' ) (pure <$> l) (pure <$> r) - if M.null m then go xs ys else (TSet (Just m) :) <$> go xs ys + bool + id + ((TSet (pure m) :) <$>) + (not $ M.null m) + (go xs ys) + (TClosure{}, TClosure{}) -> throwError $ ErrorCall "Cannot unify functions" (TBuiltin _ _, TBuiltin _ _) -> @@ -203,12 +221,12 @@ mergeFunctions pl nl fl pr fr xs ys = do m <- sequenceA $ M.intersectionWith (\i j -> i >>= \i' -> j >>= \j' -> case (i', j') of - (Nothing, Nothing) -> return $ Just Nothing - (_, Nothing) -> return Nothing - (Nothing, _) -> return Nothing + (Nothing, Nothing) -> pure $ pure Nothing + (_, Nothing) -> pure Nothing + (Nothing, _) -> pure Nothing (Just i'', Just j'') -> - Just . Just <$> unify context i'' j'') - (return <$> pl) (return <$> pr) + pure . pure <$> unify context i'' j'') + (pure <$> pl) (pure <$> pr) let Just m' = sequenceA $ M.filter isJust m if M.null m' then go xs ys @@ -218,7 +236,7 @@ <$> go xs ys -} --- | unify raises an error if the result is would be 'NMany []'. +-- | unify raises an fail if the result is would be 'NMany mempty'. unify :: forall e m . MonadLint e m @@ -238,17 +256,19 @@ pure $ SV x (NMany xs, NMany ys) -> do m <- merge context xs ys - if null m - then do + bool + (do + writeVar x (NMany m) + writeVar y (NMany m) + packSymbolic (NMany m)) + (do -- x' <- renderSymbolic (Symbolic x) -- y' <- renderSymbolic (Symbolic y) throwError $ ErrorCall "Cannot unify " - -- ++ show x' ++ " with " ++ show y' - -- ++ " in context: " ++ show context - else do - writeVar x (NMany m) - writeVar y (NMany m) - packSymbolic (NMany m) + -- <> show x' <> " with " <> show y' + -- <> " in context: " <> show context + ) + (null m) unify _ _ _ = error "The unexpected hath transpired!" -- These aren't worth defining yet, because once we move to Hindley-Milner, @@ -266,44 +286,50 @@ instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m) => MonadValue (Symbolic m) m where + + defer :: m (Symbolic m) -> m (Symbolic m) defer = fmap ST . thunk - demand (ST v) f = force v (flip demand f) - demand (SV v) f = f (SV v) -instance MonadLint e m => MonadEval (Symbolic m) m where - freeVariable var = symerr $ "Undefined variable '" ++ Text.unpack var ++ "'" + demand :: Symbolic m -> m (Symbolic m) + demand (ST v)= demand =<< force v + demand (SV v)= pure (SV v) - attrMissing ks Nothing = - evalError @(Symbolic m) - $ ErrorCall - $ "Inheriting unknown attribute: " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - attrMissing ks (Just s) = - evalError @(Symbolic m) - $ ErrorCall - $ "Could not look up attribute " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - ++ " in " - ++ show s +instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m) + => MonadValueF (Symbolic m) m where + demandF :: (Symbolic m -> m r) -> Symbolic m -> m r + demandF f (ST v)= demandF f =<< force v + demandF f (SV v)= f (SV v) + + +instance MonadLint e m => MonadEval (Symbolic m) m where + freeVariable var = symerr $ "Undefined variable '" <> var <> "'" + + attrMissing ks ms = + evalError @(Symbolic m) $ ErrorCall $ toString $ + maybe + ("Inheriting unknown attribute: " <> attr) + (\ s -> "Could not look up attribute " <> attr <> " in " <> show s) + ms + where + attr = Text.intercalate "." (NE.toList ks) + evalCurPos = do f <- mkSymbolic [TPath] l <- mkSymbolic [TConstant [TInt]] c <- mkSymbolic [TConstant [TInt]] - mkSymbolic [TSet (Just (M.fromList (go f l c)))] - where - go f l c = - [(Text.pack "file", f), (Text.pack "line", l), (Text.pack "col", c)] + mkSymbolic [TSet (pure (M.fromList [("file", f), ("line", l), ("col", c)]))] evalConstant c = mkSymbolic [go c] where - go = \case - NURI _ -> TStr - NInt _ -> TConstant [TInt] - NFloat _ -> TConstant [TFloat] - NBool _ -> TConstant [TBool] - NNull -> TConstant [TNull] + go = + \case + NURI _ -> TStr + NInt _ -> TConstant [TInt] + NFloat _ -> TConstant [TFloat] + NBool _ -> TConstant [TBool] + NNull -> TConstant [TNull] evalString = const $ mkSymbolic [TStr] evalLiteralPath = const $ mkSymbolic [TPath] @@ -318,26 +344,34 @@ -- each time a name is looked up within the weak scope, and we want to be -- sure the action it evaluates is to force a thunk, so its value is only -- computed once. - evalWith scope body = do - s <- defer scope - pushWeakScope ?? body $ demand s $ unpackSymbolic >=> \case - NMany [TSet (Just s')] -> pure s' - NMany [TSet Nothing] -> error "NYI: with unknown" - _ -> throwError $ ErrorCall "scope must be a set in with statement" + evalWith scope body = + do + s <- unpackSymbolic =<< demand =<< defer scope - evalIf cond t f = do - t' <- t - f' <- f - let e = NIf cond t' f' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - unify (void e) t' f' + pushWeakScope + (case s of + NMany [TSet (Just s')] -> pure s' + NMany [TSet Nothing] -> error "NYI: with unknown" + _ -> throwError $ ErrorCall "scope must be a set in with statement" + ) + body - evalAssert cond body = do - body' <- body - let e = NAssert cond body' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - pure body' + evalIf cond t f = + do + t' <- t + f' <- f + let e = NIf cond t' f' + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + unify (void e) t' f' + + evalAssert cond body = + do + body' <- body + let e = NAssert cond body' + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + pure body' + evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) evalAbs params _ = mkSymbolic [TClosure (void params)] @@ -350,40 +384,48 @@ -> Symbolic m -> m (Symbolic m) -> m (Symbolic m) -lintBinaryOp op lsym rarg = do - rsym <- rarg - y <- defer everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - NEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] - NNEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] +lintBinaryOp op lsym rarg = + do + rsym <- rarg + y <- defer everyPossible - NLt -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NLte -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NGt -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NGte -> check lsym rsym [TConstant [TInt, TBool, TNull]] + case op of + NApp -> symerr "lintBinaryOp:NApp: should never get here" + _ -> check lsym rsym $ + case op of + NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NAnd -> check lsym rsym [TConstant [TBool]] - NOr -> check lsym rsym [TConstant [TBool]] - NImpl -> check lsym rsym [TConstant [TBool]] + NLt -> [TConstant [TInt, TBool, TNull]] + NLte -> [TConstant [TInt, TBool, TNull]] + NGt -> [TConstant [TInt, TBool, TNull]] + NGte -> [TConstant [TInt, TBool, TNull]] - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> check lsym rsym [TConstant [TInt], TStr, TPath] - NMinus -> check lsym rsym [TConstant [TInt]] - NMult -> check lsym rsym [TConstant [TInt]] - NDiv -> check lsym rsym [TConstant [TInt]] + NAnd -> [TConstant [TBool]] + NOr -> [TConstant [TBool]] + NImpl -> [TConstant [TBool]] - NUpdate -> check lsym rsym [TSet Nothing] + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> [TConstant [TInt], TStr, TPath] + NMinus -> [TConstant [TInt]] + NMult -> [TConstant [TInt]] + NDiv -> [TConstant [TInt]] - NConcat -> check lsym rsym [TList y] + NUpdate -> [TSet mempty] + + NConcat -> [TList y] + + _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope where - check lsym rsym xs = do - let e = NBinary op lsym rsym - m <- mkSymbolic xs - _ <- unify (void e) lsym m - _ <- unify (void e) rsym m - unify (void e) lsym rsym + check lsym rsym xs = + do + let e = NBinary op lsym rsym + m <- mkSymbolic xs + _ <- unify (void e) lsym m + _ <- unify (void e) rsym m + unify (void e) lsym rsym + infixl 1 `lintApp` lintApp :: forall e m @@ -429,26 +471,34 @@ throwM e = Lint $ ReaderT $ \_ -> throw e instance MonadCatch (Lint s) where - catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'" + catch _m _h = Lint $ ReaderT $ \_ -> fail "Cannot catch in 'Lint s'" runLintM :: Options -> Lint s a -> ST s a runLintM opts action = do i <- newVar (1 :: Int) - runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action + runFreshIdT i $ (`runReaderT` newContext opts) $ runLint action -symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m)) +symbolicBaseEnv + :: Monad m + => m (Scopes m (Symbolic m)) symbolicBaseEnv = pure emptyScopes lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s)) lint opts expr = - runLintM opts - $ symbolicBaseEnv - >>= (`pushScopes` adi (Eval.eval . annotated . getCompose) - Eval.addSourcePositions - expr + runLintM opts $ + do + basis <- symbolicBaseEnv + + pushScopes + basis + (adi + (Eval.eval . annotated . getCompose) + Eval.addSourcePositions + expr ) -instance Scoped (Symbolic (Lint s)) (Lint s) where +instance + Scoped (Symbolic (Lint s)) (Lint s) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(Lint s) @(Symbolic (Lint s)) pushScopes = pushScopesReader diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -3,29 +3,27 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} -- | Code for normalization (reduction into a normal form) of Nix expressions. -- Nix language allows recursion, so some expressions do not converge. -- And so do not converge into a normal form. module Nix.Normal where -import Control.Monad -import Control.Monad.Free -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State -import Data.Set +import Prelude hiding ( force ) +import Nix.Utils +import Control.Monad.Free ( Free(..) ) +import Data.Set ( member + , insert + ) import Nix.Cited import Nix.Frames import Nix.String import Nix.Thunk import Nix.Value -import Nix.Utils newtype NormalLoop t f m = NormalLoop (NValue t f m) deriving Show @@ -40,10 +38,53 @@ , MonadDataErrorContext t f m , Ord (ThunkId m) ) + => NValue t f m + -> m (NValue t f m) +normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v + where + start = 0 :: Int + table = mempty + + run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r + run = (`evalStateT` table) . (`runReaderT` start) + + go + :: t + -> ( NValue t f m + -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) + ) + -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) + go t k = do + b <- seen t + bool + (do + i <- ask + when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" + lifted (lifted $ \f -> f =<< force t) $ local succ . k + ) + (pure $ pure t) + b + + seen t = do + let tid = thunkId t + lift $ do + res <- gets $ member tid + unless res $ modify $ insert tid + pure res + +-- 2021-05-09: NOTE: This seems a bit excessive. If these functorial versions are not used for recursion schemes - just free from it. +-- | Normalization HOF (functorial) version of @normalizeValue@. Accepts the special thunk operating/forcing/nirmalizing function & internalizes it. +normalizeValueF + :: forall e t m f + . ( Framed e m + , MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , Ord (ThunkId m) + ) => (forall r . t -> (NValue t f m -> m r) -> m r) -> NValue t f m -> m (NValue t f m) -normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run) +normalizeValueF f = run . iterNValueM run go (fmap Free . sequenceNValue' run) where start = 0 :: Int table = mempty @@ -59,21 +100,25 @@ -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) go t k = do b <- seen t - if b - then pure $ Pure t - else do + bool + (do i <- ask - when (i > 2000) - $ error "Exceeded maximum normalization depth of 2000 levels" - lifted (lifted (f t)) $ local succ . k + when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" + lifted (lifted $ f t) $ local succ . k + ) + (pure $ pure t) + b seen t = do let tid = thunkId t lift $ do - res <- gets (member tid) - unless res $ modify (insert tid) + res <- gets $ member tid + unless res $ modify $ insert tid pure res +-- | Normalize value. +-- Detect cycles. +-- If cycles were detected - put a stub on them. normalForm :: ( Framed e m , MonadThunk t m (NValue t f m) @@ -84,8 +129,9 @@ ) => NValue t f m -> m (NValue t f m) -normalForm = fmap stubCycles . normalizeValue force +normalForm t = stubCycles <$> normalizeValue t +-- | Monadic context of the result. normalForm_ :: ( Framed e m , MonadThunk t m (NValue t f m) @@ -94,8 +140,9 @@ ) => NValue t f m -> m () -normalForm_ = void <$> normalizeValue forceEff +normalForm_ t = void $ normalizeValue t +-- | Detect cycles & stub them. stubCycles :: forall t f m . ( MonadDataContext f m @@ -104,14 +151,19 @@ ) => NValue t f m -> NValue t f m -stubCycles = flip iterNValue Free $ \t _ -> - Free - $ NValue - $ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc - $ reverse - $ citations @m @(NValue t f m) t +stubCycles = + iterNValue + (\t _ -> + Free $ + NValue' $ + foldr + (addProvenance1 @m @(NValue t f m)) + cyc + (reverse $ citations @m @(NValue t f m) t) + ) + Free where - Free (NValue cyc) = opaque + Free (NValue' cyc) = opaque removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m) @@ -120,14 +172,15 @@ removeEffects = iterNValueM id - (`queryM` pure opaque) + -- 2021-02-25: NOTE: Please, unflip this up the stack + (\ t f -> f =<< queryM (pure opaque) t) (fmap Free . sequenceNValue' id) opaque :: Applicative f => NValue t f m -opaque = nvStr $ principledMakeNixStringWithoutContext "" +opaque = nvStr $ makeNixStringWithoutContext "" dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => t -> m (NValue t f m) -dethunk t = queryM t (pure opaque) removeEffects +dethunk = removeEffects <=< queryM (pure opaque) diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs --- a/src/Nix/Options.hs +++ b/src/Nix/Options.hs @@ -1,7 +1,6 @@ -- | Definitions & defaults for the CLI options module Nix.Options where -import Data.Text ( Text ) import Data.Time data Options = Options @@ -9,7 +8,7 @@ , tracing :: Bool , thunks :: Bool , values :: Bool - , scopes :: Bool + , showScopes :: Bool , reduce :: Maybe FilePath , reduceSets :: Bool , reduceLists :: Bool @@ -42,31 +41,31 @@ , tracing = False , thunks = False , values = False - , scopes = False - , reduce = Nothing + , showScopes = False + , reduce = mempty , reduceSets = False , reduceLists = False , parse = False , parseOnly = False , finder = False - , findFile = Nothing + , findFile = mempty , strict = False , evaluate = False , json = False , xml = False - , attr = Nothing - , include = [] + , attr = mempty + , include = mempty , check = False - , readFrom = Nothing + , readFrom = mempty , cache = False , repl = False , ignoreErrors = False - , expression = Nothing - , arg = [] - , argstr = [] - , fromFile = Nothing + , expression = mempty + , arg = mempty + , argstr = mempty + , fromFile = mempty , currentTime = current - , filePaths = [] + , filePaths = mempty } data Verbosity diff --git a/src/Nix/Options/Parser.hs b/src/Nix/Options/Parser.hs --- a/src/Nix/Options/Parser.hs +++ b/src/Nix/Options/Parser.hs @@ -3,12 +3,14 @@ -- | Code that configures presentation parser for the CLI options module Nix.Options.Parser where -import Control.Arrow ( second ) +import Relude.Unsafe ( read ) +import GHC.Err ( errorWithoutStackTrace ) import Data.Char ( isDigit ) -import Data.Maybe ( fromMaybe ) -import Data.Text ( Text ) import qualified Data.Text as Text -import Data.Time +import Data.Time ( UTCTime + , defaultTimeLocale + , parseTimeOrError + ) import Nix.Options import Options.Applicative hiding ( ParserResult(..) ) import Data.Version ( showVersion ) @@ -26,32 +28,37 @@ decodeVerbosity _ = Vomit argPair :: Mod OptionFields (Text, Text) -> Parser (Text, Text) -argPair = option $ str >>= \s -> case Text.findIndex (== '=') s of - Nothing -> - errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr" - Just i -> pure $ second Text.tail $ Text.splitAt i s +argPair = + option $ + do + s <- str + maybe + (errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr") + (pure . second Text.tail . (`Text.splitAt` s)) + (Text.findIndex (== '=') s) nixOptions :: UTCTime -> Parser Options nixOptions current = - Options - <$> (fromMaybe Informational <$> - optional - (option - - (do - a <- str - if all isDigit a - then pure $ decodeVerbosity (read a) - else fail "Argument to -v/--verbose must be a number" - ) + Options <$> + (fromMaybe Informational <$> + optional + (option - ( short 'v' - <> long "verbose" - <> help "Verbose output" - ) + (do + a <- str + bool + (fail "Argument to -v/--verbose must be a number") + (pure $ decodeVerbosity $ read a) + (all isDigit a) + ) + ( short 'v' + <> long "verbose" + <> help "Verbose output" ) + ) + ) <*> switch ( long "trace" <> help "Enable tracing code (even more can be seen if built with --flags=tracing)" @@ -132,7 +139,7 @@ ) <*> switch ( long "check" - <> help "Whether to check for syntax errors after parsing" + <> help "Whether to check for syntax fails after parsing" ) <*> optional (strOption @@ -149,8 +156,8 @@ <> help "After performing any indicated actions, enter the REPL" ) <*> switch - ( long "ignore-errors" - <> help "Continue parsing files, even if there are errors" + ( long "ignore-fails" + <> help "Continue parsing files, even if there are fails" ) <*> optional (strOption @@ -194,26 +201,30 @@ versionOpt = shortVersionOpt <*> debugVersionOpt where shortVersionOpt :: Parser (a -> a) - shortVersionOpt = infoOption - (showVersion version) - ( long "version" - <> help "Show release version" - ) + shortVersionOpt = + infoOption + (showVersion version) + ( long "version" + <> help "Show release version" + ) -- 2020-09-13: NOTE: Does not work for direct `nix-build`s, works for `nix-shell` `cabal` builds. debugVersionOpt :: Parser (a -> a) - debugVersionOpt = infoOption - ( concat - [ "Version: ", showVersion version - , "\nCommit: ", $(gitHash) - , "\n date: ", $(gitCommitDate) - , "\n branch: ", $(gitBranch) - ] - ) - ( long "long-version" - <> help "Show long debug version form" - ) + debugVersionOpt = + infoOption + ( concat + [ "Version: ", showVersion version + , "\nCommit: ", $(gitHash) + , "\n date: ", $(gitCommitDate) + , "\n branch: ", $(gitBranch) + ] + ) + ( long "long-version" + <> help "Show long debug version form" + ) nixOptionsInfo :: UTCTime -> ParserInfo Options -nixOptionsInfo current = info (helper <*> versionOpt <*> nixOptions current) - (fullDesc <> progDesc "" <> header "hnix") +nixOptionsInfo current = + info + (helper <*> versionOpt <*> nixOptions current) + (fullDesc <> progDesc "" <> header "hnix") diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -1,13 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | Main module for parsing Nix expressions. module Nix.Parser @@ -18,7 +15,7 @@ , parseFromFileEx , Parser , parseFromText - , Result(..) + , Result , reservedNames , OperatorInfo(..) , NSpecialOp(..) @@ -46,46 +43,53 @@ ) where -import Prelude hiding ( readFile ) +import Prelude hiding ( some + , many + , readFile + ) +import Data.Foldable ( foldr1 ) -import Control.Applicative hiding ( many - , some +import Control.Monad ( liftM2 + , msum ) -import Control.DeepSeq -import Control.Monad -import Control.Monad.Combinators.Expr -import Control.Monad.State.Strict +import Control.Monad.Combinators.Expr ( makeExprParser + , Operator( Postfix + , InfixN + , InfixR + , Prefix + , InfixL + ) + ) import Data.Char ( isAlpha , isDigit , isSpace ) import Data.Data ( Data(..) ) import Data.Fix ( Fix(..) ) -import Data.Functor -import Data.HashSet ( HashSet ) import qualified Data.HashSet as HashSet -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Text hiding ( map - , foldr1 - , concat - , concatMap - , zipWith +import Data.Text ( cons + , singleton ) -import Data.Text.Encoding -import Data.Typeable ( Typeable ) -import Data.Void -import GHC.Generics hiding ( Prefix ) import Nix.Expr hiding ( ($>) ) -import Nix.Expr.Strings -import Nix.Render +import Nix.Expr.Strings ( escapeCodes + , stripIndent + , mergePlain + , removePlainEmpty + ) +import Nix.Render ( MonadFile(readFile) ) import Prettyprinter ( Doc , pretty ) +-- `parser-combinators` ships performance enhanced & MonadPlus-aware combinators. +-- For example `smome` and `many` impoted here. import Text.Megaparsec hiding ( State ) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char ( space1 + , string + , letterChar + , char + ) +import qualified Text.Megaparsec.Char.Lexer as Lexer infixl 3 <+> (<+>) :: MonadPlus m => m a -> m a -> m a @@ -94,63 +98,66 @@ --------------------------------------------------------------------------------- nixExpr :: Parser NExprLoc -nixExpr = makeExprParser nixTerm $ map (map snd) (nixOperators nixSelector) +nixExpr = + makeExprParser + nixTerm $ snd <<$>> + nixOperators nixSelector antiStart :: Parser Text antiStart = symbol "${" show ("${" :: String) nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) nixAntiquoted p = - Antiquoted - <$> (antiStart *> nixToplevelForm <* symbol "}") - <+> Plain - <$> p - "anti-quotation" + Antiquoted <$> + (antiStart *> nixToplevelForm <* symbol "}") + <+> Plain <$> + p + "anti-quotation" selDot :: Parser () selDot = try (symbol "." *> notFollowedBy nixPath) "." nixSelect :: Parser NExprLoc -> Parser NExprLoc -nixSelect term = do - res <- build <$> term <*> optional - ((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm)) - continues <- optional $ lookAhead selDot - case continues of - Nothing -> pure res - Just _ -> nixSelect (pure res) +nixSelect term = + do + res <- + build + <$> term + <*> optional + ( (,) + <$> (selDot *> nixSelector) + <*> optional (reserved "or" *> nixTerm) + ) + continues <- optional $ lookAhead selDot + + maybe + (pure res) + (const $ nixSelect (pure res)) + continues where build :: NExprLoc - -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) + -> Maybe ( Ann SrcSpan (NAttrPath NExprLoc) + , Maybe NExprLoc + ) -> NExprLoc - build t Nothing = t - build t (Just (s, o)) = nSelectLoc t s o + build t mexpr = + maybe + t + (uncurry (nSelectLoc t)) + mexpr nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) -nixSelector = annotateLocation $ do - (x : xs) <- keyName `sepBy1` selDot - pure $ x :| xs +nixSelector = + annotateLocation $ + do + (x : xs) <- keyName `sepBy1` selDot + pure $ x :| xs nixTerm :: Parser NExprLoc nixTerm = do c <- try $ lookAhead $ satisfy $ \x -> - pathChar x - || x - == '(' - || x - == '{' - || x - == '[' - || x - == '<' - || x - == '/' - || x - == '"' - || x - == '\'' - || x - == '^' + pathChar x || (`elem` ("({[ nixSelect nixParens '{' -> nixSelect nixSet @@ -163,24 +170,25 @@ _ -> msum $ [ nixSelect nixSet | c == 'r' ] - ++ [ nixPath | pathChar c ] - ++ if isDigit c - then [nixFloat, nixInt] + <> [ nixPath | pathChar c ] + <> if isDigit c + then [ nixFloat, nixInt ] else [ nixUri | isAlpha c ] - ++ [ nixBool | c == 't' || c == 'f' ] - ++ [ nixNull | c == 'n' ] - ++ [nixSelect nixSym] + <> [ nixBool | c == 't' || c == 'f' ] + <> [ nixNull | c == 'n' ] + <> [ nixSelect nixSym ] nixToplevelForm :: Parser NExprLoc nixToplevelForm = keywords <+> nixLambda <+> nixExpr - where keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith + where + keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith nixSym :: Parser NExprLoc nixSym = annotateLocation1 $ mkSymF <$> identifier nixSynHole :: Parser NExprLoc -nixSynHole = annotateLocation1 $ mkSynHoleF <$> (char '^' >> identifier) +nixSynHole = annotateLocation1 $ mkSynHoleF <$> (char '^' *> identifier) nixInt :: Parser NExprLoc nixInt = annotateLocation1 (mkIntF <$> integer "integer") @@ -192,7 +200,8 @@ nixBool :: Parser NExprLoc nixBool = annotateLocation1 (bool "true" True <+> bool "false" False) "bool" - where bool str b = mkBoolF b <$ reserved str + where + bool str b = mkBoolF b <$ reserved str nixNull :: Parser NExprLoc nixNull = annotateLocation1 (mkNullF <$ reserved "null" "null") @@ -208,39 +217,29 @@ pathChar :: Char -> Bool pathChar x = - isAlpha x - || isDigit x - || x - == '.' - || x - == '_' - || x - == '-' - || x - == '+' - || x - == '~' + isAlpha x || isDigit x || (`elem` ("._-+~" :: String)) x slash :: Parser Char slash = try - ( char '/' - <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)) - ) + ( char '/' + <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)) + ) "slash" -- | A path surrounded by angle brackets, indicating that it should be -- looked up in the NIX_PATH environment variable at evaluation. nixSearchPath :: Parser NExprLoc -nixSearchPath = annotateLocation1 - ( mkPathF True - <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") - "spath" - ) +nixSearchPath = + annotateLocation1 + (mkPathF True <$> + try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") + "spath" + ) pathStr :: Parser FilePath pathStr = lexeme $ liftM2 - (++) + (<>) (many (satisfy pathChar)) (Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar)))) @@ -251,15 +250,18 @@ nixLet = annotateLocation1 (reserved "let" *> (letBody <+> letBinders) "let block") where - letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm) + letBinders = + NLet + <$> nixBinders + <*> (reserved "in" *> nixToplevelForm) -- Let expressions `let {..., body = ...}' are just desugared -- into `(rec {..., body = ...}).body'. - letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset + letBody = (\x -> NSelect x (StaticKey "body" :| mempty) Nothing) <$> aset aset = annotateLocation1 $ NSet NRecursive <$> braces nixBinders nixIf :: Parser NExprLoc nixIf = annotateLocation1 - ( NIf + (NIf <$> (reserved "if" *> nixExpr) <*> (reserved "then" *> nixToplevelForm) <*> (reserved "else" *> nixToplevelForm) @@ -268,7 +270,7 @@ nixAssert :: Parser NExprLoc nixAssert = annotateLocation1 - ( NAssert + (NAssert <$> (reserved "assert" *> nixToplevelForm) <*> (semi *> nixToplevelForm) "assert" @@ -276,7 +278,7 @@ nixWith :: Parser NExprLoc nixWith = annotateLocation1 - ( NWith + (NWith <$> (reserved "with" *> nixToplevelForm) <*> (semi *> nixToplevelForm) "with" @@ -291,13 +293,22 @@ nixUri :: Parser NExprLoc nixUri = lexeme $ annotateLocation1 $ try $ do start <- letterChar - protocol <- many $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("+-." :: String) + protocol <- many $ + satisfy $ + \ x -> + isAlpha x + || isDigit x + || (`elem` ("+-." :: String)) x _ <- string ":" - address <- some $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String) + address <- + some $ + satisfy $ + \ x -> + isAlpha x + || isDigit x + || (`elem` ("%/?:@&=+$,-_.!~*'" :: String)) x pure $ NStr $ DoubleQuoted - [Plain $ pack $ start : protocol ++ ':' : address] + [Plain $ toText $ start : protocol ++ ':' : address] nixString' :: Parser (NString NExprLoc) nixString' = lexeme (doubleQuoted <+> indented "string") @@ -305,12 +316,12 @@ doubleQuoted :: Parser (NString NExprLoc) doubleQuoted = DoubleQuoted - . removePlainEmpty - . mergePlain - <$> ( doubleQ - *> many (stringChar doubleQ (void $ char '\\') doubleEscape) - <* doubleQ - ) + . removePlainEmpty + . mergePlain <$> + ( doubleQ + *> many (stringChar doubleQ (void $ char '\\') doubleEscape) + <* doubleQ + ) "double quoted string" doubleQ = void (char '"') @@ -318,110 +329,139 @@ indented :: Parser (NString NExprLoc) indented = - stripIndent - <$> ( indentedQ - *> many (stringChar indentedQ indentedQ indentedEscape) - <* indentedQ - ) + stripIndent <$> + (indentedQ + *> many (stringChar indentedQ indentedQ indentedEscape) + <* indentedQ + ) "indented string" indentedQ = void (string "''" "\"''\"") - indentedEscape = try $ do - indentedQ - (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do - _ <- char '\\' - c <- escapeCode - pure $ if c == '\n' then EscapedNewline else Plain $ singleton c + indentedEscape = + try $ + do + indentedQ + (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> + do + _ <- char '\\' + c <- escapeCode + pure $ + bool + EscapedNewline + (Plain $ singleton c) + (c /= '\n') + stringChar end escStart esc = - Antiquoted - <$> (antiStart *> nixToplevelForm <* char '}') - <+> Plain - . singleton - <$> char '$' - <+> esc - <+> Plain - . pack - <$> some plainChar + Antiquoted <$> + (antiStart *> nixToplevelForm <* char '}') + <+> Plain . singleton <$> + char '$' <+> esc <+> Plain . toText <$> + some plainChar where plainChar = notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle - escapeCode = msum [ c <$ char e | (c, e) <- escapeCodes ] <+> anySingle + escapeCode = + msum + [ c <$ char e | (c, e) <- escapeCodes ] + <+> anySingle -- | Gets all of the arguments for a function. argExpr :: Parser (Params NExprLoc) -argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where +argExpr = + msum + [ atLeft + , onlyname + , atRight + ] + <* symbol ":" + where -- An argument not in curly braces. There's some potential ambiguity -- in the case of, for example `x:y`. Is it a lambda function `x: y`, or -- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if -- there's a valid URI parse here. onlyname = msum - [ nixUri >> unexpected (Label ('v' NE.:| "alid uri")) + [ nixUri *> unexpected (Label ('v' :| "alid uri")) , Param <$> identifier ] -- Parameters named by an identifier on the left (`args @ {x, y}`) - atLeft = try $ do - name <- identifier <* symbol "@" - (variadic, params) <- params - pure $ ParamSet params variadic (Just name) + atLeft = + try $ + do + name <- identifier <* symbol "@" + (variadic, params) <- params + pure $ ParamSet params variadic (pure name) -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) - atRight = do - (variadic, params) <- params - name <- optional $ symbol "@" *> identifier - pure $ ParamSet params variadic name + atRight = + do + (variadic, params) <- params + name <- optional $ symbol "@" *> identifier + pure $ ParamSet params variadic name -- Return the parameters set. - params = do - (args, dotdots) <- braces getParams - pure (dotdots, args) + params = + do + (args, dotdots) <- braces getParams + pure (dotdots, args) -- Collects the parameters within curly braces. Returns the parameters and -- a boolean indicating if the parameters are variadic. getParams :: Parser ([(Text, Maybe NExprLoc)], Bool) - getParams = go [] where + getParams = go mempty + where -- Attempt to parse `...`. If this succeeds, stop and return True. -- Otherwise, attempt to parse an argument, optionally with a -- default. If this fails, then return what has been accumulated -- so far. go acc = ((acc, True) <$ symbol "...") <+> getMore acc + getMore acc = -- Could be nothing, in which just return what we have so far. - option (acc, False) $ do - -- Get an argument name and an optional default. - pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) - -- Either return this, or attempt to get a comma and restart. - option (acc ++ [pair], False) $ comma >> go (acc ++ [pair]) + option (acc, False) $ + do + -- Get an argument name and an optional default. + pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) + -- Either return this, or attempt to get a comma and restart. + option (acc <> [pair], False) $ comma *> go (acc <> [pair]) + nixBinders :: Parser [Binding NExprLoc] nixBinders = (inherit <+> namedVar) `endBy` semi where - inherit = do + inherit = + do -- We can't use 'reserved' here because it would consume the whitespace -- after the keyword, which is not exactly the semantics of C++ Nix. - try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) - p <- getSourcePos - x <- whiteSpace *> optional scope - Inherit x <$> many keyName <*> pure p "inherited binding" - namedVar = do - p <- getSourcePos - NamedVar - <$> (annotated <$> nixSelector) - <*> (equals *> nixToplevelForm) - <*> pure p - "variable binding" + try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) + p <- getSourcePos + x <- whiteSpace *> optional scope + Inherit x + <$> many keyName + <*> pure p + "inherited binding" + namedVar = + do + p <- getSourcePos + NamedVar + <$> (annotated <$> nixSelector) + <*> (equals *> nixToplevelForm) + <*> pure p + "variable binding" scope = nixParens "inherit scope" keyName :: Parser (NKeyName NExprLoc) -keyName = dynamicKey <+> staticKey where +keyName = dynamicKey <+> staticKey + where staticKey = StaticKey <$> identifier dynamicKey = DynamicKey <$> nixAntiquoted nixString' nixSet :: Parser NExprLoc nixSet = annotateLocation1 ((isRec <*> braces nixBinders) "set") - where isRec = (reserved "rec" $> NSet NRecursive "recursive set") <+> pure (NSet NNonRecursive) + where + isRec = (reserved "rec" $> NSet NRecursive "recursive set") <+> pure (NSet NNonRecursive) parseNixFile :: MonadFile m => FilePath -> m (Result NExpr) parseNixFile = @@ -440,16 +480,16 @@ {- Parser.Library -} skipLineComment' :: Tokens Text -> Parser () -skipLineComment' prefix = string prefix - *> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r')) +skipLineComment' prefix = + string prefix *> void (takeWhileP (pure "character") (\x -> x /= '\n' && x /= '\r')) whiteSpace :: Parser () whiteSpace = do put =<< getSourcePos - L.space space1 lineCmnt blockCmnt + Lexer.space space1 lineCmnt blockCmnt where lineCmnt = skipLineComment' "#" - blockCmnt = L.skipBlockComment "/*" "*/" + blockCmnt = Lexer.skipBlockComment "/*" "*/" lexeme :: Parser a -> Parser a lexeme p = p <* whiteSpace @@ -459,41 +499,19 @@ reservedEnd :: Char -> Bool reservedEnd x = - isSpace x - || x - == '{' - || x - == '(' - || x - == '[' - || x - == '}' - || x - == ')' - || x - == ']' - || x - == ';' - || x - == ':' - || x - == '.' - || x - == '"' - || x - == '\'' - || x - == ',' + isSpace x || (`elem` ("{([})];:.\"'," :: String)) x +{-# inline reservedEnd #-} reserved :: Text -> Parser () reserved n = lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof) +identifier :: Parser Text identifier = lexeme $ try $ do ident <- cons <$> satisfy (\x -> isAlpha x || x == '_') - <*> takeWhileP Nothing identLetter + <*> takeWhileP mempty identLetter guard (not (ident `HashSet.member` reservedNames)) pure ident where @@ -505,46 +523,57 @@ -- -- Braces and angles in hnix don't enclose a single expression so this type -- restriction would not be useful. -parens, brackets :: Parser (NExprF f) -> Parser (NExprF f) -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") +parens :: Parser (NExprF f) -> Parser (NExprF f) +parens = between (symbol "(") (symbol ")") +braces :: ParsecT Void Text (State SourcePos) a -> ParsecT Void Text (State SourcePos) a +braces = between (symbol "{") (symbol "}") -- angles = between (symbol "<") (symbol ">") +brackets :: Parser (NExprF f) -> Parser (NExprF f) brackets = between (symbol "[") (symbol "]") -semi = symbol ";" -comma = symbol "," +semi :: Parser Text +semi = symbol ";" +comma :: Parser Text +comma = symbol "," -- colon = symbol ":" -- dot = symbol "." -equals = symbol "=" +equals :: Parser Text +equals = symbol "=" +question :: Parser Text question = symbol "?" integer :: Parser Integer -integer = lexeme L.decimal +integer = lexeme Lexer.decimal float :: Parser Double -float = lexeme L.float +float = lexeme Lexer.float reservedNames :: HashSet Text -reservedNames = HashSet.fromList - ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] +reservedNames = + HashSet.fromList + ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] type Parser = ParsecT Void Text (State SourcePos) -data Result a = Success a | Failure (Doc Void) deriving (Show, Functor) +type Result a = Either (Doc Void) a parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a) -parseFromFileEx p path = do - txt <- decodeUtf8 <$> readFile path - pure - $ either (Failure . pretty . errorBundlePretty) Success - . flip evalState (initialPos path) - $ runParserT p path txt +parseFromFileEx p path = + do + txt <- decodeUtf8 <$> readFile path + pure $ + either + (Left . pretty . errorBundlePretty) + Right + $ (`evalState` initialPos path) $ runParserT p path txt + parseFromText :: Parser a -> Text -> Result a parseFromText p txt = - let file = "" - in either (Failure . pretty . errorBundlePretty) Success - . flip evalState (initialPos file) - $ runParserT p file txt + let file = "" in + either + (Left . pretty . errorBundlePretty) + Right + $ (`evalState` initialPos file) $ (`runParserT` file) p txt {- Parser.Operators -} @@ -561,35 +590,51 @@ deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) annotateLocation :: Parser a -> Parser (Ann SrcSpan a) -annotateLocation p = do - begin <- getSourcePos - res <- p - end <- get -- The state set before the last whitespace - pure $ Ann (SrcSpan begin end) res +annotateLocation p = + do + begin <- getSourcePos + end <- get -- The state set before the last whitespace + Ann (SrcSpan begin end) <$> p + annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc annotateLocation1 = fmap annToAnnF . annotateLocation +manyUnaryOp :: MonadPlus f => f (a -> a) -> f (a -> a) manyUnaryOp f = foldr1 (.) <$> some f -operator "-" = lexeme . try $ string "-" <* notFollowedBy (char '>') -operator "/" = lexeme . try $ string "/" <* notFollowedBy (char '/') -operator "<" = lexeme . try $ string "<" <* notFollowedBy (char '=') -operator ">" = lexeme . try $ string ">" <* notFollowedBy (char '=') -operator n = symbol n +operator :: Text -> Parser Text +operator op = + case op of + "-" -> tuneLexer "-" '>' + "/" -> tuneLexer "/" '/' + "<" -> tuneLexer "<" '=' + ">" -> tuneLexer ">" '=' + n -> symbol n + where + tuneLexer opchar nonextchar = + lexeme . try $ string opchar <* notFollowedBy (char nonextchar) opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a -opWithLoc name op f = do - Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} - operator name - pure $ f (Ann ann op) +opWithLoc name op f = + do + Ann ann _ <- + annotateLocation $ + {- dbg (toString name) $ -} + operator name + pure $ f (Ann ann op) + +binaryN :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) binaryN name op = (NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary)) +binaryL :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) binaryL name op = (NBinaryDef name op NAssocLeft, InfixL (opWithLoc name op nBinary)) +binaryR :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) binaryR name op = (NBinaryDef name op NAssocRight, InfixR (opWithLoc name op nBinary)) +prefix :: Text -> NUnaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) prefix name op = (NUnaryDef name op, Prefix (manyUnaryOp (opWithLoc name op nUnary))) -- postfix name op = (NUnaryDef name op, @@ -609,42 +654,52 @@ -- Postfix $ do -- sel <- seldot *> selector -- mor <- optional (reserved "or" *> term) - -- return $ \x -> nSelectLoc x sel mor) ] + -- pure $ \x -> nSelectLoc x sel mor) ] {- 2 -} [ ( NBinaryDef " " NApp NAssocLeft , - -- Thanks to Brent Yorgey for showing me this trick! + -- Thanks to Brent Yorgey for showing me this trick! InfixL $ nApp <$ symbol "" ) ] , {- 3 -} - [prefix "-" NNeg] + [ prefix "-" NNeg ] , {- 4 -} [ ( NSpecialDef "?" NHasAttrOp NAssocLeft , Postfix $ symbol "?" *> (flip nHasAttr <$> selector) ) ] , {- 5 -} - [binaryR "++" NConcat] + [ binaryR "++" NConcat ] , {- 6 -} - [binaryL "*" NMult, binaryL "/" NDiv] + [ binaryL "*" NMult + , binaryL "/" NDiv + ] , {- 7 -} - [binaryL "+" NPlus, binaryL "-" NMinus] + [ binaryL "+" NPlus + , binaryL "-" NMinus + ] , {- 8 -} - [prefix "!" NNot] + [ prefix "!" NNot ] , {- 9 -} - [binaryR "//" NUpdate] + [ binaryR "//" NUpdate ] , {- 10 -} - [binaryL "<" NLt, binaryL ">" NGt, binaryL "<=" NLte, binaryL ">=" NGte] + [ binaryL "<" NLt + , binaryL ">" NGt + , binaryL "<=" NLte + , binaryL ">=" NGte + ] , {- 11 -} - [binaryN "==" NEq, binaryN "!=" NNEq] + [ binaryN "==" NEq + , binaryN "!=" NNEq + ] , {- 12 -} - [binaryL "&&" NAnd] + [ binaryL "&&" NAnd ] , {- 13 -} - [binaryL "||" NOr] + [ binaryL "||" NOr ] , {- 14 -} - [binaryR "->" NImpl] + [ binaryR "->" NImpl ] ] data OperatorInfo = OperatorInfo @@ -654,29 +709,53 @@ } deriving (Eq, Ord, Generic, Typeable, Data, Show) getUnaryOperator :: NUnaryOp -> OperatorInfo -getUnaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] - _ -> [] +getUnaryOperator = (m Map.!) + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (fail "unused")) + buildEntry i = + concatMap $ + \case + (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] + _ -> mempty + getBinaryOperator :: NBinaryOp -> OperatorInfo -getBinaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> [] +getBinaryOperator = (m Map.!) + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (fail "unused")) + buildEntry i = + concatMap $ + \case + (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] + _ -> mempty + getSpecialOperator :: NSpecialOp -> OperatorInfo getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." -getSpecialOperator o = m Map.! o where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> [] +getSpecialOperator o = m Map.! o + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (fail "unused")) + + buildEntry i = + concatMap $ + \case + (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] + _ -> mempty diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -3,37 +3,29 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Pretty where -import Control.Applicative ( (<|>) ) -import Control.Monad.Free -import Data.Fix ( Fix(..), foldFix ) +import Prelude hiding ( toList, group ) +import Nix.Utils +import Control.Monad.Free ( Free(Free) ) +import Data.Fix ( Fix(..) + , foldFix ) import Data.HashMap.Lazy ( toList ) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as HashSet -import Data.List ( isPrefixOf - , sort - ) -import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe ( isJust - , fromMaybe - ) -import Data.Text ( pack - , unpack - , replace +import Data.Text ( replace , strip ) import qualified Data.Text as Text +import Prettyprinter hiding ( list ) import Nix.Atoms import Nix.Cited import Nix.Expr @@ -43,8 +35,6 @@ import Nix.String import Nix.Thunk import Nix.Value -import Prettyprinter -import Text.Read ( readMaybe ) -- | This type represents a pretty printed nix expression -- together with some information about the expression. @@ -61,14 +51,14 @@ -- we can add brackets appropriately } -mkNixDoc :: Doc ann -> OperatorInfo -> NixDoc ann -mkNixDoc d o = NixDoc { withoutParens = d, rootOp = o, wasPath = False } +mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann +mkNixDoc o d = NixDoc { withoutParens = d, rootOp = o, wasPath = False } -- | A simple expression is never wrapped in parentheses. The expression -- behaves as if its root operator had a precedence higher than all -- other operators (including function application). simpleExpr :: Doc ann -> NixDoc ann -simpleExpr d = mkNixDoc d (OperatorInfo minBound NAssocNone "simple expr") +simpleExpr = mkNixDoc (OperatorInfo minBound NAssocNone "simple expr") pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True } @@ -80,7 +70,7 @@ -- binding). leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" + mkNixDoc (OperatorInfo maxBound NAssocNone "least precedence") appOp :: OperatorInfo appOp = getBinaryOperator NApp @@ -95,107 +85,114 @@ hasAttrOp = getSpecialOperator NHasAttrOp wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann -wrapParens op sub - | precedence (rootOp sub) < precedence op - = withoutParens sub - | precedence (rootOp sub) - == precedence op - && associativity (rootOp sub) - == associativity op - && associativity op - /= NAssocNone - = withoutParens sub - | otherwise - = parens $ withoutParens sub +wrapParens op sub = + bool + (\ a -> "(" <> a <> ")") + id + (precedence (rootOp sub) < precedence op + || (precedence (rootOp sub) == precedence op + && associativity (rootOp sub) == associativity op + && associativity op /= NAssocNone) + ) + (withoutParens sub) -- Used in the selector case to print a path in a selector as -- "${./abc}" wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann -wrapPath op sub = if wasPath sub - then dquotes $ "$" <> braces (withoutParens sub) - else wrapParens op sub +wrapPath op sub = + bool + (wrapParens op sub) + ("\"${" <> withoutParens sub <> "}\"") + (wasPath sub) prettyString :: NString (NixDoc ann) -> Doc ann -prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts +prettyString (DoubleQuoted parts) = "\"" <> (mconcat . fmap prettyPart $ parts) <> "\"" where - prettyPart (Plain t) = pretty . concatMap escape . unpack $ t + -- It serializes Text -> String, because the helper code is done for String, + -- please, can someone break that code. + prettyPart (Plain t) = pretty . concatMap escape . toString $ t prettyPart EscapedNewline = "''\\n" - prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) + prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" escape '"' = "\\\"" - escape x = maybe [x] (('\\' :) . (: [])) $ toEscapeCode x + escape x = + maybe + [x] + (('\\' :) . (: mempty)) + (toEscapeCode x) prettyString (Indented _ parts) = group $ nest 2 $ vcat - [dsquote, content, dsquote] + ["''", content, "''"] where - dsquote = squote <> squote - content = vsep . map prettyLine . stripLastIfEmpty . splitLines $ parts + content = vsep . fmap prettyLine . stripLastIfEmpty . splitLines $ parts stripLastIfEmpty = reverse . f . reverse where f ([Plain t] : xs) | Text.null (strip t) = xs f xs = xs - prettyLine = hcat . map prettyPart + prettyLine = hcat . fmap prettyPart prettyPart (Plain t) = - pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t + pretty . replace "${" "''${" . replace "''" "'''" $ t prettyPart EscapedNewline = "\\n" - prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) + prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" prettyParams :: Params (NixDoc ann) -> Doc ann -prettyParams (Param n ) = pretty $ unpack n -prettyParams (ParamSet s v mname) = prettyParamSet s v <> case mname of - Nothing -> mempty - Just name | Text.null name -> mempty - | otherwise -> "@" <> pretty (unpack name) +prettyParams (Param n ) = pretty n +prettyParams (ParamSet s v mname) = prettyParamSet s v <> + maybe + mempty + (\ name -> + bool + mempty + ("@" <> pretty name) + (not (Text.null name)) + ) + mname prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann -prettyParamSet args var = encloseSep - (lbrace <> space) - (align (space <> rbrace)) - sep - (map prettySetArg args ++ prettyVariadic) +prettyParamSet args var = + encloseSep + "{ " + (align " }") + sep + (fmap prettySetArg args <> prettyVariadic) where - prettySetArg (n, maybeDef) = case maybeDef of - Nothing -> pretty (unpack n) - Just v -> pretty (unpack n) <+> "?" <+> withoutParens v + prettySetArg (n, maybeDef) = + maybe + (pretty n) + (\x -> pretty n <> " ? " <> withoutParens x) + maybeDef prettyVariadic = [ "..." | var ] - sep = align (comma <> space) + sep = align ", " prettyBind :: Binding (NixDoc ann) -> Doc ann prettyBind (NamedVar n v _p) = - prettySelector n <+> equals <+> withoutParens v <> semi + prettySelector n <> " = " <> withoutParens v <> ";" prettyBind (Inherit s ns _p) = - "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi - where scope = maybe mempty ((<> space) . parens . withoutParens) s + "inherit " <> scope <> align (fillSep (fmap prettyKeyName ns)) <> ";" + where + scope = + maybe + mempty + ((<> " ") . parens . withoutParens) + s prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann -prettyKeyName (StaticKey "") = dquotes "" -prettyKeyName (StaticKey key) | HashSet.member key reservedNames = - dquotes $ pretty $ unpack key -prettyKeyName (StaticKey key) = pretty . unpack $ key -prettyKeyName (DynamicKey key) = runAntiquoted - (DoubleQuoted [Plain "\n"]) - prettyString - (("$" <>) . braces . withoutParens) - key +prettyKeyName (StaticKey "") = "\"\"" +prettyKeyName (StaticKey key) | HashSet.member key reservedNames = "\"" <> pretty key <> "\"" +prettyKeyName (StaticKey key) = pretty key +prettyKeyName (DynamicKey key) = + runAntiquoted + (DoubleQuoted [Plain "\n"]) + prettyString + (\ x -> "${" <> withoutParens x <> "}") + key prettySelector :: NAttrPath (NixDoc ann) -> Doc ann -prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList +prettySelector = hcat . punctuate "." . fmap prettyKeyName . NE.toList prettyAtom :: NAtom -> NixDoc ann -prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom +prettyAtom atom = simpleExpr $ pretty $ atomText atom prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . foldFix exprFNixDoc -instance HasCitations1 m v f - => HasCitations m v (NValue' t f m a) where - citations (NValue f) = citations1 f - addProvenance x (NValue f) = NValue (addProvenance1 x f) - -instance (HasCitations1 m v f, HasCitations m v t) - => HasCitations m v (NValue t f m) where - citations (Pure t) = citations t - citations (Free v) = citations v - addProvenance x (Pure t) = Pure (addProvenance x t) - addProvenance x (Free v) = Free (addProvenance x v) - prettyOriginExpr :: forall t f m ann . HasCitations1 m (NValue t f m) f @@ -218,119 +215,118 @@ exprFNixDoc = \case NConstant atom -> prettyAtom atom NStr str -> simpleExpr $ prettyString str - NList [] -> simpleExpr $ lbracket <> rbracket NList xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[lbracket], map (wrapParens appOpNonAssoc) xs, [rbracket]] - NSet NNonRecursive [] -> simpleExpr $ lbrace <> rbrace + prettyContainer "[" (wrapParens appOpNonAssoc) "]" xs NSet NNonRecursive xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[lbrace], map prettyBind xs, [rbrace]] - NSet NRecursive [] -> simpleExpr $ recPrefix <> lbrace <> rbrace + prettyContainer "{" prettyBind "}" xs NSet NRecursive xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[recPrefix <> lbrace], map prettyBind xs, [rbrace]] + prettyContainer "rec {" prettyBind "}" xs NAbs args body -> - leastPrecedence - $ nest 2 - $ vsep - $ [prettyParams args <> colon, withoutParens body] + leastPrecedence $ + nest 2 $ + vsep + [ prettyParams args <> ":" + , withoutParens body + ] NBinary NApp fun arg -> - mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp - NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep - [ wrapParens (f NAssocLeft) r1 - , pretty $ unpack $ operatorName opInfo - , wrapParens (f NAssocRight) r2 - ] + mkNixDoc appOp (wrapParens appOp fun <> " " <> wrapParens appOpNonAssoc arg) + NBinary op r1 r2 -> + mkNixDoc + opInfo $ + hsep + [ wrapParens (f NAssocLeft) r1 + , pretty $ operatorName opInfo + , wrapParens (f NAssocRight) r2 + ] where opInfo = getBinaryOperator op f x | associativity opInfo /= x = opInfo { associativity = NAssocNone } | otherwise = opInfo - NUnary op r1 -> mkNixDoc - (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1) - opInfo + NUnary op r1 -> + mkNixDoc + opInfo + (pretty (operatorName opInfo) <> wrapParens opInfo r1) where opInfo = getUnaryOperator op NSelect r' attr o -> - (if isJust o then leastPrecedence else flip mkNixDoc selectOp) - $ wrapPath selectOp r - <> dot - <> prettySelector attr - <> ordoc + maybe + (mkNixDoc selectOp) + (const leastPrecedence) + o + $ wrapPath selectOp r <> "." <> prettySelector attr <> ordoc where - r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r' - ordoc = maybe mempty (((space <> "or") <+>) . wrapParens appOpNonAssoc) o + r = mkNixDoc selectOp (wrapParens appOpNonAssoc r') + ordoc = + maybe + mempty + ((" or " <>) . wrapParens appOpNonAssoc) + o NHasAttr r attr -> - mkNixDoc (wrapParens hasAttrOp r <+> "?" <+> prettySelector attr) hasAttrOp - NEnvPath p -> simpleExpr $ pretty ("<" ++ p ++ ">") - NLiteralPath p -> pathExpr $ pretty $ case p of - "./" -> "./." - "../" -> "../." - ".." -> "../." - txt | "/" `isPrefixOf` txt -> txt - | "~/" `isPrefixOf` txt -> txt - | "./" `isPrefixOf` txt -> txt - | "../" `isPrefixOf` txt -> txt - | otherwise -> "./" ++ txt - NSym name -> simpleExpr $ pretty (unpack name) + mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr) + NEnvPath p -> simpleExpr $ pretty ("<" <> p <> ">") + NLiteralPath p -> + pathExpr $ + pretty $ + case p of + "./" -> "./." + "../" -> "../." + ".." -> "../." + _txt -> + bool + ("./" <> _txt) + _txt + (any (`isPrefixOf` _txt) ["/", "~/", "./", "../"]) + NSym name -> simpleExpr $ pretty name NLet binds body -> - leastPrecedence - $ group - $ vsep - $ [ "let" - , indent 2 (vsep (map prettyBind binds)) - , "in" <+> withoutParens body - ] + leastPrecedence $ + group $ + vsep + [ "let" + , indent 2 (vsep (fmap prettyBind binds)) + , "in " <> withoutParens body + ] NIf cond trueBody falseBody -> - leastPrecedence - $ group - $ nest 2 - $ vsep - $ [ "if" <+> withoutParens cond - , align ("then" <+> withoutParens trueBody) - , align ("else" <+> withoutParens falseBody) - ] + leastPrecedence $ + group $ + nest 2 $ + sep + [ "if " <> withoutParens cond + , align ("then " <> withoutParens trueBody) + , align ("else " <> withoutParens falseBody) + ] NWith scope body -> - leastPrecedence - $ vsep - $ ["with" <+> withoutParens scope <> semi, align $ withoutParens body] + prettyAddScope "with " scope body NAssert cond body -> - leastPrecedence - $ vsep - $ ["assert" <+> withoutParens cond <> semi, align $ withoutParens body] - NSynHole name -> simpleExpr $ pretty ("^" <> unpack name) - where recPrefix = "rec" <> space + prettyAddScope "assert " cond body + NSynHole name -> simpleExpr $ pretty ("^" <> name) + where + prettyContainer h f t c = + list + (simpleExpr (h <> t)) + (const $ simpleExpr $ group $ nest 2 $ vsep $ [h] <> (f <$> c) <> [t]) + c + prettyAddScope h c b = + leastPrecedence $ + vsep + [h <> withoutParens c <> ";", align $ withoutParens b] + + valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr -valueToExpr = iterNValue (\_ _ -> thk) phi +valueToExpr = iterNValue (\_ _ -> thk) (Fix . phi) where - thk = Fix . NSym . pack $ "" + thk = Fix . NSym $ "" - phi :: NValue' t f m NExpr -> NExpr - phi (NVConstant' a ) = Fix $ NConstant a - phi (NVStr' ns) = mkStr ns - phi (NVList' l ) = Fix $ NList l - phi (NVSet' s p ) = Fix $ NSet NNonRecursive - [ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p)) + phi :: NValue' t f m NExpr -> NExprF NExpr + phi (NVConstant' a ) = NConstant a + phi (NVStr' ns ) = NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)] + phi (NVList' l ) = NList l + phi (NVSet' s p) = NSet NNonRecursive + [ NamedVar (StaticKey k :| mempty) v (fromMaybe nullPos (M.lookup k p)) | (k, v) <- toList s ] - phi (NVClosure' _ _ ) = Fix . NSym . pack $ "" - phi (NVPath' p ) = Fix $ NLiteralPath p - phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." ++ name - phi _ = error "Pattern synonyms foil completeness check" - - mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)] + phi (NVClosure' _ _) = NSym "" + phi (NVPath' p ) = NLiteralPath p + phi (NVBuiltin' name _) = NSym $ "builtins." <> name prettyNValue :: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann @@ -345,20 +341,19 @@ ) => NValue t f m -> Doc ann -prettyNValueProv v = do - let ps = citations @m @(NValue t f m) v - case ps of - [] -> prettyNValue v - ps -> - let v' = prettyNValue v in +prettyNValueProv v = + list + prettyNVal + (\ ps -> fillSep - [ v' - , indent 2 - $ parens - $ mconcat - $ "from: " - : map (prettyOriginExpr . _originExpr) ps + [ prettyNVal + , indent 2 $ + "(" <> mconcat ("from: " : (prettyOriginExpr . _originExpr <$> ps)) <> ")" ] + ) + (citations @m @(NValue t f m) v) + where + prettyNVal = prettyNValue v prettyNThunk :: forall t f m ann @@ -369,18 +364,16 @@ ) => t -> m (Doc ann) -prettyNThunk t = do - let ps = citations @m @(NValue t f m) @t t - v' <- prettyNValue <$> dethunk t - pure - $ fillSep - $ [ v' - , indent 2 - $ parens - $ mconcat - $ "thunk from: " - : map (prettyOriginExpr . _originExpr) ps - ] +prettyNThunk t = + do + let ps = citations @m @(NValue t f m) @t t + v' <- prettyNValue <$> dethunk t + pure $ + fillSep + [ v' + , indent 2 $ + "(" <> mconcat ( "thunk from: " : (prettyOriginExpr . _originExpr <$> ps)) <> ")" + ] -- | This function is used only by the testing code. printNix :: forall t f m . MonadDataContext f m => NValue t f m -> String @@ -389,24 +382,24 @@ thk = "" phi :: NValue' t f m String -> String - phi (NVConstant' a ) = unpack $ atomText a - phi (NVStr' ns) = show $ hackyStringIgnoreContext ns - phi (NVList' l ) = "[ " ++ unwords l ++ " ]" + phi (NVConstant' a ) = toString $ atomText a + phi (NVStr' ns) = show $ stringIgnoreContext ns + phi (NVList' l ) = toString $ "[ " <> unwords (fmap toText l) <> " ]" phi (NVSet' s _) = - "{ " - ++ concat - [ check (unpack k) ++ " = " ++ v ++ "; " - | (k, v) <- sort $ toList s - ] - ++ "}" + "{ " <> + concat + [ check (toString k) <> " = " <> v <> "; " + | (k, v) <- sort $ toList s + ] <> "}" where - check v = fromMaybe - v - ( fmap (surround . show) (readMaybe v :: Maybe Int) - <|> fmap (surround . show) (readMaybe v :: Maybe Float) - ) - where surround s = "\"" ++ s ++ "\"" + check :: [Char] -> [Char] + check v = + fromMaybe + v + (fmap (surround . show) (readMaybe v :: Maybe Int) + <|> fmap (surround . show) (readMaybe v :: Maybe Float) + ) + where surround s = "\"" <> s <> "\"" phi NVClosure'{} = "<>" phi (NVPath' fp ) = fp - phi (NVBuiltin' name _) = "<>" - phi _ = error "Pattern synonyms foil completeness check" + phi (NVBuiltin' name _) = toString $ "< name <> ">>" diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,17 +7,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-orphans #-} + -- | This module provides a "reducing" expression evaluator, which reduces -- away pure, non self-referential aspects of an expression tree, yielding a -- new expression tree. It does not yet attempt to reduce everything @@ -26,31 +23,25 @@ -- original. It should be seen as an opportunistic simplifier, but which -- gives up easily if faced with any potential for ambiguity in the result. -module Nix.Reduce (reduceExpr, reducingEvalExpr) where +module Nix.Reduce + ( reduceExpr + , reducingEvalExpr + ) where -import Control.Applicative -import Control.Arrow ( second ) -import Control.Monad -import Control.Monad.Catch +import Control.Monad.Catch ( MonadCatch(catch) ) #if !MIN_VERSION_base(4,13,0) +import Prelude hiding ( fail ) import Control.Monad.Fail #endif -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Fix ( Fix(..), foldFix, foldFixM ) -import Data.HashMap.Lazy ( HashMap ) +import Control.Monad.Fix ( MonadFix ) +import Data.Fix ( Fix(..) + , foldFix + , foldFixM + ) import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Strict as MS -import Data.IORef -import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe ( fromMaybe - , mapMaybe - , catMaybes - ) -import Data.Text ( Text ) +import qualified Text.Show import Nix.Atoms import Nix.Effects.Basic ( pathToDefaultNixFile ) import Nix.Expr @@ -66,12 +57,25 @@ import System.FilePath newtype Reducer m a = Reducer - { runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc) - (StateT (HashMap FilePath NExprLoc, MS.HashMap Text Text) m) a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, - MonadFix, MonadIO, MonadFail, - MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc), - MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text)) + { runReducer :: + ReaderT + ( Maybe FilePath + , Scopes (Reducer m) NExprLoc + ) + ( StateT + ( HashMap FilePath NExprLoc + , MS.HashMap Text Text + ) + m + ) + a + } + deriving + ( Functor, Applicative, Alternative + , Monad, MonadPlus, MonadFix, MonadIO, MonadFail + , MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc) + , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) + ) staticImport :: forall m @@ -88,32 +92,39 @@ mfile <- asks fst path <- liftIO $ pathToDefaultNixFile path path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath - (maybe path (\p -> takeDirectory p path) mfile) + (maybe id (() . takeDirectory) mfile path) imports <- gets fst - case M.lookup path' imports of - Just expr -> pure expr - Nothing -> go path' + maybe + (go path') + pure + (M.lookup path' imports) where go path = do - liftIO $ putStrLn $ "Importing file " ++ path + liftIO $ putStrLn $ "Importing file " <> path eres <- liftIO $ parseNixFileLoc path - case eres of - Failure err -> error $ "Parse failed: " ++ show err - Success x -> do + either + (\ err -> fail $ "Parse failed: " <> show err) + (\ x -> do let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1) span = SrcSpan pos pos - cur = NamedVar (StaticKey "__cur_file" :| []) - (Fix (NLiteralPath_ pann path)) - pos - x' = Fix (NLet_ span [cur] x) - modify (\(a, b) -> (M.insert path x' a, b)) - local (const (Just path, emptyScopes @m @NExprLoc)) $ do - x'' <- foldFix reduce x' - modify (\(a, b) -> (M.insert path x'' a, b)) - return x'' + cur = + NamedVar + (StaticKey "__cur_file" :| mempty) + (Fix (NLiteralPath_ pann path)) + pos + x' = Fix $ NLet_ span [cur] x + modify $ first $ M.insert path x' + local + (const (pure path, emptyScopes @m @NExprLoc)) $ + do + x'' <- foldFix reduce x' + modify $ first $ M.insert path x'' + pure x'' + ) + eres -- gatherNames :: NExprLoc -> HashSet VarName -- gatherNames = foldFix $ \case @@ -123,7 +134,7 @@ reduceExpr :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc reduceExpr mpath expr = - (`evalStateT` (M.empty, MS.empty)) + (`evalStateT` (mempty, MS.empty)) . (`runReaderT` (mpath, emptyScopes)) . runReducer $ foldFix reduce expr @@ -141,17 +152,18 @@ -- | Reduce the variable to its value if defined. -- Leave it as it is otherwise. -reduce (NSym_ ann var) = lookupVar var <&> \case - Nothing -> Fix (NSym_ ann var) - Just v -> v +reduce (NSym_ ann var) = + fromMaybe (Fix (NSym_ ann var)) <$> lookupVar var -- | Reduce binary and integer negation. -reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of - (NNeg, Fix (NConstant_ cann (NInt n))) -> - return $ Fix $ NConstant_ cann (NInt (negate n)) - (NNot, Fix (NConstant_ cann (NBool b))) -> - return $ Fix $ NConstant_ cann (NBool (not b)) - _ -> return $ Fix $ NUnary_ uann op x +reduce (NUnary_ uann op arg) = + do + x <- arg + pure $ Fix $ + case (op, x) of + (NNeg, Fix (NConstant_ cann (NInt n))) -> NConstant_ cann $ NInt $ negate n + (NNot, Fix (NConstant_ cann (NBool b))) -> NConstant_ cann $ NBool $ not b + _ -> NUnary_ uann op x -- | Reduce function applications. -- @@ -160,25 +172,31 @@ -- * Reduce a lambda function by adding its name to the local -- scope and recursively reducing its body. reduce (NBinary_ bann NApp fun arg) = fun >>= \case - f@(Fix (NSym_ _ "import")) -> arg >>= \case - -- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath - Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath - v -> return $ Fix $ NBinary_ bann NApp f v + f@(Fix (NSym_ _ "import")) -> + (\case + -- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath + Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath + v -> pure $ Fix $ NBinary_ bann NApp f v + ) =<< arg - Fix (NAbs_ _ (Param name) body) -> do - x <- arg - pushScope (M.singleton name x) (foldFix reduce body) + Fix (NAbs_ _ (Param name) body) -> + do + x <- arg + pushScope + (M.singleton name x) + (foldFix reduce body) f -> Fix . NBinary_ bann NApp f <$> arg -- | Reduce an integer addition to its result. -reduce (NBinary_ bann op larg rarg) = do - lval <- larg - rval <- rarg - case (op, lval, rval) of - (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> - return $ Fix (NConstant_ ann (NInt (x + y))) - _ -> pure $ Fix $ NBinary_ bann op lval rval +reduce (NBinary_ bann op larg rarg) = + do + lval <- larg + rval <- rarg + pure $ Fix $ + case (op, lval, rval) of + (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> NConstant_ ann $ NInt $ x + y + _ -> NBinary_ bann op lval rval -- | Reduce a select on a Set by substituting the set to the selected value. -- @@ -199,9 +217,9 @@ sAttrPath [] = True sAttrPath _ = False -- Find appropriate bind in set's binds. - findBind [] _ = Nothing + findBind [] _ = Nothing findBind (x : xs) attrs@(a :| _) = case x of - n@(NamedVar (a' :| _) _ _) | a' == a -> Just n + n@(NamedVar (a' :| _) _ _) | a' == a -> pure n _ -> findBind xs attrs -- Follow the attrpath recursively in sets. inspectSet (NSet_ _ NNonRecursive binds) attrs = case findBind binds attrs of @@ -215,14 +233,22 @@ -- | Reduce a set by inlining its binds outside of the set -- if none of the binds inherit the super set. -reduce e@(NSet_ ann NNonRecursive binds) = do - let usesInherit = flip any binds $ \case - Inherit{} -> True - _ -> False - if usesInherit - then clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds - else Fix <$> sequence e +reduce e@(NSet_ ann NNonRecursive binds) = + do + let + usesInherit = + any + (\case + Inherit{} -> True + _ -> False + ) + binds + bool + (Fix <$> sequence e) + (clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds) + usesInherit + -- Encountering a 'rec set' construction eliminates any hope of inlining -- definitions. reduce (NSet_ ann NRecursive binds) = @@ -231,61 +257,79 @@ -- Encountering a 'with' construction eliminates any hope of inlining -- definitions. reduce (NWith_ ann scope body) = - clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body + clearScopes @NExprLoc $ Fix <$> (NWith_ ann <$> scope <*> body) -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope. -reduce (NLet_ ann binds body) = do - s <- fmap (M.fromList . catMaybes) $ forM binds $ \case - NamedVar (StaticKey name :| []) def _pos -> def >>= \case - d@(Fix NAbs_{} ) -> pure $ Just (name, d) - d@(Fix NConstant_{}) -> pure $ Just (name, d) - d@(Fix NStr_{} ) -> pure $ Just (name, d) - _ -> pure Nothing - _ -> pure Nothing - body' <- pushScope s body - binds' <- traverse sequence binds - -- let names = gatherNames body' - -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case - -- NamedVar (StaticKey name _ :| []) _ -> - -- name `S.member` names - -- _ -> True - pure $ Fix $ NLet_ ann binds' body' - -- where - -- go m [] = pure m - -- go m (x:xs) = case x of - -- NamedVar (StaticKey name _ :| []) def -> do - -- v <- pushScope m def - -- go (M.insert name v m) xs - -- _ -> go m xs +reduce (NLet_ ann binds body) = + do + binds' <- traverse sequence binds + body' <- + (`pushScope` body) . M.fromList . catMaybes =<< + traverse + (\case + NamedVar (StaticKey name :| []) def _pos -> + let + defcase = + \case + d@(Fix NAbs_{} ) -> pure (name, d) + d@(Fix NConstant_{}) -> pure (name, d) + d@(Fix NStr_{} ) -> pure (name, d) + _ -> Nothing + in + defcase <$> def + _ -> pure Nothing + ) + binds + + -- let names = gatherNames body' + -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case + -- NamedVar (StaticKey name _ :| mempty) _ -> + -- name `S.member` names + -- _ -> True + pure $ Fix $ NLet_ ann binds' body' + -- where + -- go m [] = pure m + -- go m (x:xs) = case x of + -- NamedVar (StaticKey name _ :| mempty) def -> do + -- v <- pushScope m def + -- go (M.insert name v m) xs + -- _ -> go m xs + -- | Reduce an if to the relevant path if -- the condition is a boolean constant. -reduce e@(NIf_ _ b t f) = b >>= \case - Fix (NConstant_ _ (NBool b')) -> if b' then t else f - _ -> Fix <$> sequence e +reduce e@(NIf_ _ b t f) = + (\case + Fix (NConstant_ _ (NBool b')) -> if b' then t else f + _ -> Fix <$> sequence e + ) =<< b -- | Reduce an assert atom to its encapsulated -- symbol if the assertion is a boolean constant. -reduce e@(NAssert_ _ b body) = b >>= \case - Fix (NConstant_ _ (NBool b')) | b' -> body - _ -> Fix <$> sequence e +reduce e@(NAssert_ _ b body) = + (\case + Fix (NConstant_ _ (NBool b')) | b' -> body + _ -> Fix <$> sequence e + ) =<< b reduce (NAbs_ ann params body) = do params' <- sequence params -- Make sure that variable definitions in scope do not override function -- arguments. - let args = case params' of - Param name -> M.singleton name (Fix (NSym_ ann name)) + let + args = + case params' of + Param name -> M.singleton name $ Fix $ NSym_ ann name ParamSet pset _ _ -> - M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset + M.fromList $ (\(k, _) -> (k, Fix $ NSym_ ann k)) <$> pset Fix . NAbs_ ann params' <$> pushScope args body reduce v = Fix <$> sequence v -- newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) } newtype FlaggedF f r = FlaggedF (IORef Bool, f r) - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable) instance Show (f r) => Show (FlaggedF f r) where show (FlaggedF (_, x)) = show x @@ -301,34 +345,47 @@ -- stripFlags = foldFix $ Fix . snd . flagged pruneTree :: MonadIO n => Options -> Flagged NExprLocF -> n (Maybe NExprLoc) -pruneTree opts = foldFixM $ \(FlaggedF (b, Compose x)) -> do - used <- liftIO $ readIORef b - pure $ if used then Fix . Compose <$> traverse prune x else Nothing +pruneTree opts = + foldFixM $ + \(FlaggedF (b, Compose x)) -> + bool + Nothing + (Fix . Compose <$> traverse prune x) + <$> liftIO (readIORef b) where prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc) prune = \case - NStr str -> Just $ NStr (pruneString str) + NStr str -> pure $ NStr $ pruneString str NHasAttr (Just aset) attr -> - Just $ NHasAttr aset (NE.map pruneKeyName attr) - NAbs params (Just body) -> Just $ NAbs (pruneParams params) body + pure $ NHasAttr aset $ NE.map pruneKeyName attr + NAbs params (Just body) -> pure $ NAbs (pruneParams params) body - NList l | reduceLists opts -> Just $ NList (catMaybes l) - | otherwise -> Just $ NList (map (fromMaybe nNull) l) - NSet recur binds - | reduceSets opts -> Just $ NSet recur (mapMaybe sequence binds) - | otherwise -> Just $ NSet recur (map (fmap (fromMaybe nNull)) binds) + NList l -> pure $ NList $ + bool + (fromMaybe nNull <$>) + catMaybes + (reduceLists opts) -- Reduce list members that aren't used; breaks if elemAt is used + l + NSet recur binds -> pure $ NSet recur $ + bool + (fromMaybe nNull <<$>>) + (mapMaybe sequence) + (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + binds NLet binds (Just body@(Fix (Compose (Ann _ x)))) -> - Just $ case mapMaybe pruneBinding binds of - [] -> x - xs -> NLet xs body + pure $ + list + x + (`NLet` body) + (mapMaybe pruneBinding binds) NSelect (Just aset) attr alt -> - Just $ NSelect aset (NE.map pruneKeyName attr) (join alt) + pure $ NSelect aset (NE.map pruneKeyName attr) (join alt) -- These are the only short-circuiting binary operators - NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg - NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg + NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> pure larg + NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> pure larg -- If the function was never called, it means its argument was in a -- thunk that was forced elsewhere. @@ -336,24 +393,24 @@ -- The idea behind emitted a binary operator where one side may be -- invalid is that we're trying to emit what will reproduce whatever - -- error the user encountered, which means providing all aspects of + -- fail the user encountered, which means providing all aspects of -- the evaluation path they ultimately followed. - NBinary op Nothing (Just rarg) -> Just $ NBinary op nNull rarg - NBinary op (Just larg) Nothing -> Just $ NBinary op larg nNull + NBinary op Nothing (Just rarg) -> pure $ NBinary op nNull rarg + NBinary op (Just larg) Nothing -> pure $ NBinary op larg nNull -- If the scope of a with was never referenced, it's not needed - NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> Just body + NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> pure body NAssert Nothing _ -> - error "How can an assert be used, but its condition not?" + fail "How can an assert be used, but its condition not?" - NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body - NAssert (Just cond) _ -> Just $ NAssert cond nNull + NAssert _ (Just (Fix (Compose (Ann _ body)))) -> pure body + NAssert (Just cond) _ -> pure $ NAssert cond nNull - NIf Nothing _ _ -> error "How can an if be used, but its condition not?" + NIf Nothing _ _ -> fail "How can an if be used, but its condition not?" - NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f - NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t + NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> pure f + NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> pure t x -> sequence x @@ -364,18 +421,18 @@ pruneAntiquotedText :: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc) - pruneAntiquotedText (Plain v) = Just (Plain v) - pruneAntiquotedText EscapedNewline = Just EscapedNewline + pruneAntiquotedText (Plain v) = pure $ Plain v + pruneAntiquotedText EscapedNewline = pure EscapedNewline + pruneAntiquotedText (Antiquoted (Just k)) = pure $ Antiquoted k pruneAntiquotedText (Antiquoted Nothing ) = Nothing - pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k) pruneAntiquoted :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc) -> Maybe (Antiquoted (NString NExprLoc) NExprLoc) - pruneAntiquoted (Plain v) = Just (Plain (pruneString v)) - pruneAntiquoted EscapedNewline = Just EscapedNewline + pruneAntiquoted (Plain v) = pure $ Plain $ pruneString v + pruneAntiquoted EscapedNewline = pure EscapedNewline + pruneAntiquoted (Antiquoted (Just k)) = pure $ Antiquoted k pruneAntiquoted (Antiquoted Nothing ) = Nothing - pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k) pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc pruneKeyName (StaticKey n) = StaticKey n @@ -384,21 +441,25 @@ pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc pruneParams (Param n) = Param n - pruneParams (ParamSet xs b n) - | reduceSets opts = ParamSet - (map (second (maybe (Just nNull) (Just . fromMaybe nNull))) xs) - b - n - | otherwise = ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n + pruneParams (ParamSet xs b n) = + ParamSet (reduceOrPassMode <$> xs) b n + where + reduceOrPassMode = + second $ + bool + fmap + ((pure .) . maybe nNull) + (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + (fromMaybe nNull) pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc) - pruneBinding (NamedVar _ Nothing _) = Nothing - pruneBinding (NamedVar xs (Just x) pos) = - Just (NamedVar (NE.map pruneKeyName xs) x pos) + pruneBinding (NamedVar _ Nothing _) = Nothing + pruneBinding (NamedVar xs (Just x) pos) = + pure $ NamedVar (NE.map pruneKeyName xs) x pos pruneBinding (Inherit _ [] _) = Nothing - pruneBinding (Inherit (join -> Nothing) _ _) = Nothing - pruneBinding (Inherit (join -> m) xs pos) = - Just (Inherit m (map pruneKeyName xs) pos) + pruneBinding (Inherit (join -> Nothing) _ _) = Nothing + pruneBinding (Inherit (join -> m) xs pos) = + pure $ Inherit m (pruneKeyName <$> xs) pos reducingEvalExpr :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m) @@ -406,13 +467,15 @@ -> Maybe FilePath -> NExprLoc -> m (NExprLoc, Either r a) -reducingEvalExpr eval mpath expr = do - expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) - eres <- catch (Right <$> foldFix (addEvalFlags eval) expr') (pure . Left) - opts :: Options <- asks (view hasLens) - expr'' <- pruneTree opts expr' - return (fromMaybe nNull expr'', eres) - where addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x +reducingEvalExpr eval mpath expr = + do + expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) + eres <- catch (pure <$> foldFix (addEvalFlags eval) expr') $ pure . Left + opts :: Options <- asks $ view hasLens + expr'' <- pruneTree opts expr' + pure (fromMaybe nNull expr'', eres) + where + addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x instance Monad m => Scoped NExprLoc (Reducer m) where currentScopes = currentScopesReader diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -13,16 +13,13 @@ import Prelude hiding ( readFile ) -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail ( MonadFail ) -#endif -import Control.Monad.Trans -import Data.ByteString ( ByteString ) +-- Please reduce Unsafe +import Relude.Unsafe ( read ) import qualified Data.ByteString as BS import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Void +import Data.List ( maximum ) +import Nix.Utils.Fix1 ( Fix1T + , MonadFix1T ) import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S @@ -70,10 +67,14 @@ doesDirectoryExist = S.doesDirectoryExist getSymbolicLinkStatus = S.getSymbolicLinkStatus + +instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) + posAndMsg :: SourcePos -> Doc a -> ParseError s Void -posAndMsg (SourcePos _ lineNo _) msg = FancyError - (unPos lineNo) - (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void]) +posAndMsg (SourcePos _ lineNo _) msg = + FancyError + (unPos lineNo) + (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void]) renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg @@ -86,22 +87,13 @@ if exist then do txt <- sourceContext file begLine begCol endLine endCol msg - return - $ vsep - [ "In file " - <> errorContext file begLine begCol endLine endCol - <> ":" - , txt - ] - else return msg -renderLocation (SrcSpan beg end) msg = - fail - $ "Don't know how to render range from " - ++ show beg - ++ " to " - ++ show end - ++ " for error: " - ++ show msg + pure $ + vsep + [ "In file " <> errorContext file begLine begCol endLine endCol <> ":" + , txt + ] + else pure msg +renderLocation (SrcSpan beg end) msg = fail $ "Don't know how to render range from " <> show beg <>" to " <> show end <>" for fail: " <> show msg errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a errorContext path bl bc _el _ec = @@ -111,22 +103,24 @@ :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a) sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg = do - let beg' = max 1 (min begLine (begLine - 3)) - end' = max endLine (endLine + 3) + let beg' = max 1 $ min begLine $ begLine - 3 + end' = max endLine $ endLine + 3 ls <- - map pretty + fmap pretty . take (end' - beg') . drop (pred beg') - . T.lines - . T.decodeUtf8 + . lines + . decodeUtf8 <$> readFile path let nums = zipWith (curry (show . fst)) [beg' ..] ls - longest = maximum (map length nums) - nums' = flip map nums $ \n -> replicate (longest - length n) ' ' ++ n - pad n | read n == begLine = "==> " ++ n - | otherwise = " " ++ n - ls' = zipWith (<+>) - (map (pretty . pad) nums') - (map ("| " <+>) ls) - pure $ vsep $ ls' ++ [msg] + longest = maximum $ length <$> nums + nums' = (\n -> replicate (longest - length n) ' ' <> n) <$> nums + pad n | read n == begLine = "==> " <> n + | otherwise = " " <> n + ls' = + zipWith + (\ a b -> a <> space <> b) + (pretty . pad <$> nums') + (("| " <>) <$> ls) + pure $ vsep $ ls' <> [msg] diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -5,7 +5,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -14,9 +13,9 @@ -- | Code for rendering/representation of the messages packaged with their context (Frames). module Nix.Render.Frame where -import Control.Monad.Reader -import Data.Fix -import Data.Typeable +import Prelude hiding ( Comparison ) +import Nix.Utils +import Data.Fix ( Fix(..) ) import Nix.Eval import Nix.Exec import Nix.Expr @@ -26,12 +25,12 @@ import Nix.Pretty import Nix.Render import Nix.Thunk -import Nix.Utils import Nix.Value -import Prettyprinter -import Text.Megaparsec.Pos +import Prettyprinter hiding ( list ) +import qualified Text.Show as Text +import Text.Megaparsec.Pos ( sourcePosPretty) #ifdef MIN_VERSION_pretty_show -import qualified Text.Show.Pretty as PS +import qualified Text.Show.Pretty as PS #endif renderFrames @@ -44,24 +43,27 @@ ) => Frames -> m (Doc ann) -renderFrames [] = pure mempty +renderFrames [] = stub renderFrames (x : xs) = do opts :: Options <- asks (view hasLens) frames <- if | verbose opts <= ErrorsOnly -> renderFrame @v @t @f x | verbose opts <= Informational -> do f <- renderFrame @v @t @f x - pure $ concatMap go (reverse xs) ++ f - | otherwise -> concat <$> mapM (renderFrame @v @t @f) (reverse (x : xs)) - pure $ case frames of - [] -> mempty - _ -> vsep frames + pure $ concatMap go (reverse xs) <> f + | otherwise -> concat <$> traverse (renderFrame @v @t @f) (reverse (x : xs)) + pure $ + list + mempty + vsep + frames where go :: NixFrame -> [Doc ann] - go f = case framePos @v @m f of - Just pos -> - ["While evaluating at " <> pretty (sourcePosPretty pos) <> colon] - Nothing -> [] + go f = + maybe + mempty + (\ pos -> ["While evaluating at " <> pretty (sourcePosPretty pos) <> colon]) + (framePos @v @m f) framePos :: forall v (m :: * -> *) @@ -70,7 +72,7 @@ -> Maybe SourcePos framePos (NixFrame _ f) | Just (e :: EvalFrame m v) <- fromException f = case e of - EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg + EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> pure beg _ -> Nothing | otherwise = Nothing @@ -85,14 +87,14 @@ => NixFrame -> m [Doc ann] renderFrame (NixFrame level f) - | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e - | Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e - | Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e - | Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e - | Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e - | Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)] - | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)] - | otherwise = error $ "Unrecognized frame: " ++ show f + | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e + | Just (e :: ThunkLoop ) <- fromException f = renderThunkLoop level e + | Just (e :: ValueFrame t f m ) <- fromException f = renderValueFrame level e + | Just (e :: NormalLoop t f m ) <- fromException f = renderNormalLoop level e + | Just (e :: ExecFrame t f m ) <- fromException f = renderExecFrame level e + | Just (e :: ErrorCall ) <- fromException f = pure [pretty (Text.show e)] + | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (Text.show e)] + | otherwise = fail $ "Unrecognized frame: " <> show f wrapExpr :: NExprF r -> NExpr wrapExpr x = Fix (Fix (NSym "") <$ x) @@ -102,43 +104,52 @@ => NixLevel -> EvalFrame m v -> m [Doc ann] -renderEvalFrame level f = do - opts :: Options <- asks (view hasLens) - case f of - EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do - let scopeInfo | scopes opts = [pretty $ show scope] - | otherwise = [] - fmap (\x -> scopeInfo ++ [x]) - $ renderLocation ann - =<< renderExpr level "While evaluating" "Expression" e +renderEvalFrame level f = + do + opts :: Options <- asks (view hasLens) + case f of + EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> + do + let + scopeInfo = + bool + mempty + [pretty $ Text.show scope] + (showScopes opts) + fmap + (\x -> scopeInfo <> [x]) + $ renderLocation ann =<< + renderExpr level "While evaluating" "Expression" e - ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts -> - fmap (: []) - $ renderLocation ann - =<< renderExpr level "While forcing thunk from" "Forcing thunk" e + ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts -> + fmap + (: mempty) + $ renderLocation ann =<< + renderExpr level "While forcing thunk from" "Forcing thunk" e - Calling name ann -> - fmap (: []) - $ renderLocation ann - $ "While calling builtins." - <> pretty name + Calling name ann -> + fmap + (: mempty) + $ renderLocation ann $ + "While calling builtins." <> pretty name - SynHole synfo -> - sequence - $ let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo - in [ renderLocation ann - =<< renderExpr level "While evaluating" "Syntactic Hole" e - , pure $ pretty $ show (_synHoleInfo_scope synfo) - ] + SynHole synfo -> + sequence $ + let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo in - ForcingExpr _ _ -> pure [] + [ renderLocation ann =<< + renderExpr level "While evaluating" "Syntactic Hole" e + , pure $ pretty $ Text.show $ _synHoleInfo_scope synfo + ] + ForcingExpr _ _ -> stub + renderExpr :: (MonadReader e m, Has e Options, MonadFile m) => NixLevel - -> String - -> String + -> Text + -> Text -> NExprLoc -> m (Doc ann) renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do @@ -152,10 +163,11 @@ #endif | verbose opts >= Chatty = prettyNix (stripAnnotation e) | otherwise = prettyNix (Fix (Fix (NSym "") <$ x)) - pure $ if verbose opts >= Chatty - then - vsep [pretty (longLabel ++ ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"] - else pretty shortLabel <> fillSep [": ", rendered] + pure $ + bool + (pretty shortLabel <> fillSep [": ", rendered]) + (vsep [pretty (longLabel <> ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"]) + (verbose opts >= Chatty) renderValueFrame :: forall e t f m ann @@ -163,7 +175,7 @@ => NixLevel -> ValueFrame t f m -> m [Doc ann] -renderValueFrame level = fmap (: []) . \case +renderValueFrame level = fmap (: mempty) . \case ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI ConcerningValue _v -> pure "ConcerningValue" Comparison _ _ -> pure "Comparing" @@ -174,58 +186,67 @@ Coercion x y -> pure $ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)] where - desc | level <= Error = "Cannot coerce " - | otherwise = "While coercing " + desc = + bool + "While coercing " + "Cannot coerce " + (level <= Error) - CoercionToJson v -> do - v' <- renderValue level "" "" v - pure $ "CoercionToJson " <> v' + CoercionToJson v -> + ("CoercionToJson " <>) <$> renderValue level "" "" v CoercionFromJson _j -> pure "CoercionFromJson" - Expectation t v -> do - v' <- renderValue @_ @t @f @m level "" "" v - pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t) + Expectation t v -> + (msg <>) <$> renderValue @_ @t @f @m level "" "" v + where + msg = "Expected " <> pretty (describeValue t) <> ", but saw " renderValue :: forall e t f m ann . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel - -> String - -> String + -> Text + -> Text -> NValue t f m -> m (Doc ann) renderValue _level _longLabel _shortLabel v = do opts :: Options <- asks (view hasLens) - (if values opts - then prettyNValueProv - else prettyNValue) <$> removeEffects v + bool + prettyNValue + prettyNValueProv + (values opts) + <$> removeEffects v renderExecFrame :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> ExecFrame t f m -> m [Doc ann] -renderExecFrame level = \case - Assertion ann v -> - fmap (: []) - $ renderLocation ann - =<< ( (\d -> fillSep ["Assertion failed:", d]) - <$> renderValue level "" "" v - ) +renderExecFrame level = + \case + Assertion ann v -> + fmap + (: mempty) + (do + d <- renderValue level "" "" v + renderLocation ann $ fillSep ["Assertion failed:", d] + ) renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) => NixLevel -> ThunkLoop -> m [Doc ann] -renderThunkLoop _level = pure . (: []) . \case - ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n +renderThunkLoop _level = pure . (: mempty) . \case + ThunkLoop n -> pretty $ "Infinite recursion in thunk " <> n renderNormalLoop :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> NormalLoop t f m -> m [Doc ann] -renderNormalLoop level = fmap (: []) . \case - NormalLoop v -> do - v' <- renderValue level "" "" v - pure $ "Infinite recursion during normalization forcing " <> v' +renderNormalLoop level = + fmap + (: mempty) + . \case + NormalLoop v -> + ("Infinite recursion during normalization forcing " <>) <$> renderValue level "" "" v diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -10,34 +10,38 @@ module Nix.Scope where -import Control.Applicative -import Control.Monad.Reader import qualified Data.HashMap.Lazy as M -import Data.Text ( Text ) +import qualified Text.Show import Lens.Family2 import Nix.Utils newtype Scope a = Scope { getScope :: AttrSet a } - deriving (Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) instance Show (Scope a) where - show (Scope m) = show (M.keys m) + show (Scope m) = show $ M.keys m newScope :: AttrSet a -> Scope a newScope = Scope scopeLookup :: Text -> [Scope a] -> Maybe a scopeLookup key = foldr go Nothing - where go (Scope m) rest = M.lookup key m <|> rest + where + go + :: Scope a + -> Maybe a + -> Maybe a + go (Scope m) rest = M.lookup key m <|> rest -data Scopes m a = Scopes +data Scopes m a = + Scopes { lexicalScopes :: [Scope a] , dynamicScopes :: [m (Scope a)] } instance Show (Scopes m a) where show (Scopes m a) = - "Scopes: " ++ show m ++ ", and " ++ show (length a) ++ " with-scopes" + "Scopes: " <> show m <> ", and " <> show (length a) <> " with-scopes" instance Semigroup (Scopes m a) where Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw) @@ -47,49 +51,90 @@ mappend = (<>) emptyScopes :: forall m a . Scopes m a -emptyScopes = Scopes [] [] +emptyScopes = Scopes mempty mempty class Scoped a m | m -> a where currentScopes :: m (Scopes m a) - clearScopes :: m r -> m r - pushScopes :: Scopes m a -> m r -> m r - lookupVar :: Text -> m (Maybe a) + clearScopes :: m r -> m r + pushScopes :: Scopes m a -> m r -> m r + lookupVar :: Text -> m (Maybe a) currentScopesReader - :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => m (Scopes m a) -currentScopesReader = asks (view hasLens) + :: forall m a e + . ( MonadReader e m + , Has e (Scopes m a) + ) + => m (Scopes m a) +currentScopesReader = asks $ view hasLens clearScopesReader - :: forall m a e r . (MonadReader e m, Has e (Scopes m a)) => m r -> m r -clearScopesReader = local (set hasLens (emptyScopes @m @a)) + :: forall m a e r + . ( MonadReader e m + , Has e (Scopes m a) + ) + => m r + -> m r +clearScopesReader = local $ set hasLens $ emptyScopes @m @a -pushScope :: Scoped a m => AttrSet a -> m r -> m r -pushScope s = pushScopes (Scopes [Scope s] []) +pushScope + :: Scoped a m + => AttrSet a + -> m r + -> m r +pushScope s = pushScopes $ Scopes [Scope s] mempty -pushWeakScope :: (Functor m, Scoped a m) => m (AttrSet a) -> m r -> m r -pushWeakScope s = pushScopes (Scopes [] [Scope <$> s]) +pushWeakScope + :: ( Functor m + , Scoped a m + ) + => m (AttrSet a) + -> m r + -> m r +pushWeakScope s = pushScopes $ Scopes mempty [Scope <$> s] pushScopesReader - :: (MonadReader e m, Has e (Scopes m a)) => Scopes m a -> m r -> m r -pushScopesReader s = local (over hasLens (s <>)) + :: ( MonadReader e m + , Has e (Scopes m a) + ) + => Scopes m a + -> m r + -> m r +pushScopesReader s = local $ over hasLens (s <>) lookupVarReader - :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => Text -> m (Maybe a) -lookupVarReader k = do - mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) - case mres of - Just sym -> pure $ Just sym - Nothing -> do - ws <- asks (dynamicScopes . view hasLens) - foldr - (\x rest -> do - mres' <- M.lookup k . getScope <$> x - case mres' of - Just sym -> pure $ Just sym - Nothing -> rest - ) - (pure Nothing) - ws + :: forall m a e + . ( MonadReader e m + , Has e (Scopes m a) + ) + => Text + -> m (Maybe a) +lookupVarReader k = + do + mres <- asks $ scopeLookup k . lexicalScopes @m . view hasLens -withScopes :: Scoped a m => Scopes m a -> m r -> m r + maybe + (do + ws <- asks $ dynamicScopes . view hasLens + + foldr + (\ x rest -> + do + mres' <- M.lookup k . getScope <$> x + + maybe + rest + (pure . pure) + mres' + ) + (pure Nothing) + ws + ) + (pure . pure) + mres + +withScopes + :: Scoped a m + => Scopes m a + -> m r + -> m r withScopes scope = clearScopes . pushScopes scope diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -1,39 +1,35 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Standard where import Control.Applicative import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) -import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Catch ( MonadThrow + , MonadCatch + , MonadMask + ) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Control.Monad.Free -import Control.Monad.Reader -import Control.Monad.Ref -import Control.Monad.State -import Data.HashMap.Lazy ( HashMap ) +import Control.Monad.Free ( Free(Pure, Free) ) +import Control.Monad.Reader ( MonadFix ) +import Control.Monad.Ref ( MonadAtomicRef ) import qualified Data.HashMap.Strict -import Data.Text ( Text ) -import Data.Typeable -import GHC.Generics +import qualified Text.Show import Nix.Cited import Nix.Cited.Basic import Nix.Context @@ -48,48 +44,14 @@ import Nix.Scope import Nix.Thunk import Nix.Thunk.Basic -import Nix.Utils.Fix1 +import Nix.Utils ( free ) +import Nix.Utils.Fix1 ( Fix1T(Fix1T) ) import Nix.Value import Nix.Value.Monad import Nix.Var +import Prelude hiding (force) --- All of the following type classes defer to the underlying 'm'. -deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t) -deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t) -deriving instance MonadEnv (t (Fix1 t)) => MonadEnv (Fix1 t) -deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t) -deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t) -deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t) -deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t) - -deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m) -deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m) -deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m) -deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m) -deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m) -deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m) -deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m) - -type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) - -instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where - type Ref (Fix1T t m) = Ref m - newRef = lift . newRef - readRef = lift . readRef - writeRef r = lift . writeRef r - -instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where - atomicModifyRef r = lift . atomicModifyRef r - -instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) - -instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where - addToStore a b c d = lift $ addToStore a b c d - addTextToStore' a b c d = lift $ addTextToStore' a b c d - ---------------------------------------------------------------------------------- - newtype StdCited m a = StdCited { _stdCited :: Cited (StdThunk m) (StdCited m) m a } deriving @@ -106,6 +68,7 @@ newtype StdThunk (m :: * -> *) = StdThunk { _stdThunk :: StdCited m (NThunkF m (StdValue m)) } +type StdValue' m = NValue' (StdThunk m) (StdCited m) m (StdValue m) type StdValue m = NValue (StdThunk m) (StdCited m) m instance Show (StdThunk m) where @@ -125,27 +88,28 @@ pushScopes = pushScopesReader lookupVar = lookupVarReader -instance ( MonadFix m - , MonadFile m - , MonadCatch m - , MonadEnv m - , MonadPaths m - , MonadExec m - , MonadHttp m - , MonadInstantiate m - , MonadIntrospect m - , MonadPlus m - , MonadPutStr m - , MonadStore m - , MonadAtomicRef m - , Typeable m - , Scoped (StdValue m) m - , MonadReader (Context m (StdValue m)) m - , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m - , MonadDataErrorContext (StdThunk m) (StdCited m) m - , MonadThunk (StdThunk m) m (StdValue m) - , MonadValue (StdValue m) m - ) +instance + ( MonadFix m + , MonadFile m + , MonadCatch m + , MonadEnv m + , MonadPaths m + , MonadExec m + , MonadHttp m + , MonadInstantiate m + , MonadIntrospect m + , MonadPlus m + , MonadPutStr m + , MonadStore m + , MonadAtomicRef m + , Typeable m + , Scoped (StdValue m) m + , MonadReader (Context m (StdValue m)) m + , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m + , MonadDataErrorContext (StdThunk m) (StdCited m) m + , MonadThunk (StdThunk m) m (StdValue m) + , MonadValue (StdValue m) m + ) => MonadEffects (StdThunk m) (StdCited m) m where makeAbsolutePath = defaultMakeAbsolutePath findEnvPath = defaultFindEnvPath @@ -155,35 +119,153 @@ derivationStrict = defaultDerivationStrict traceEffect = defaultTraceEffect -instance ( MonadAtomicRef m - , MonadCatch m - , Typeable m - , MonadReader (Context m (StdValue m)) m - , MonadThunkId m - ) +instance + ( Typeable m + , MonadThunkId m + , MonadAtomicRef m + , MonadCatch m + , MonadReader (Context m (StdValue m)) m + ) => MonadThunk (StdThunk m) m (StdValue m) where - thunk = fmap (StdThunk . StdCited) . thunk + + thunkId + :: StdThunk m + -> ThunkId m thunkId = thunkId . _stdCited . _stdThunk - queryM x b f = queryM (_stdCited (_stdThunk x)) b f - force = force . _stdCited . _stdThunk + {-# inline thunkId #-} + + thunk + :: m (StdValue m) + -> m (StdThunk m) + thunk = fmap (StdThunk . StdCited) . thunk + + queryM + :: m (StdValue m) + -> StdThunk m + -> m (StdValue m) + queryM b = queryM b . _stdCited . _stdThunk + + force + :: StdThunk m + -> m (StdValue m) + force = force . _stdCited . _stdThunk + + forceEff + :: StdThunk m + -> m (StdValue m) forceEff = forceEff . _stdCited . _stdThunk - further = (fmap (StdThunk . StdCited) .) . further . _stdCited . _stdThunk -instance ( MonadAtomicRef m - , MonadCatch m - , Typeable m - , MonadReader (Context m (StdValue m)) m - , MonadThunkId m - ) + further + :: StdThunk m + -> m (StdThunk m) + further = fmap (StdThunk . StdCited) . further . _stdCited . _stdThunk + + +-- * @instance MonadThunkF@ (Kleisli functor HOFs) + +-- Please do not use MonadThunkF instances to define MonadThunk. as MonadThunk uses specialized functions. +instance + ( Typeable m + , MonadThunkId m + , MonadAtomicRef m + , MonadCatch m + , MonadReader (Context m (StdValue m)) m + ) + => MonadThunkF (StdThunk m) m (StdValue m) where + + queryMF + :: ( StdValue m + -> m r + ) + -> m r + -> StdThunk m + -> m r + queryMF k b x = queryMF k b (_stdCited (_stdThunk x)) + + forceF + :: ( StdValue m + -> m r + ) + -> StdThunk m + -> m r + forceF k t = forceF k (_stdCited $ _stdThunk t) + + forceEffF + :: ( StdValue m + -> m r + ) + -> StdThunk m + -> m r + forceEffF k t = forceEffF k (_stdCited $ _stdThunk t) + + furtherF + :: ( m (StdValue m) + -> m (StdValue m) + ) + -> StdThunk m + -> m (StdThunk m) + furtherF k t = StdThunk . StdCited <$> furtherF k (_stdCited $ _stdThunk t) + + +-- * @instance MonadValue (StdValue m) m@ + +instance + ( MonadAtomicRef m + , MonadCatch m + , Typeable m + , MonadReader (Context m (StdValue m)) m + , MonadThunkId m + ) => MonadValue (StdValue m) m where - defer = fmap Pure . thunk + defer + :: m (StdValue m) + -> m (StdValue m) + defer = fmap pure . thunk - demand (Pure v) f = force v (flip demand f) - demand (Free v) f = f (Free v) + demand + :: StdValue m + -> m (StdValue m) + demand v = + free + (demand <=< force) + (const $ pure v) + v - inform (Pure t) f = Pure <$> further t f - inform (Free v) f = Free <$> bindNValue' id (flip inform f) v + inform + :: StdValue m + -> m (StdValue m) + inform (Pure t) = Pure <$> further t + inform (Free v) = Free <$> bindNValue' id inform v + +-- * @instance MonadValueF (StdValue m) m@ + +instance + ( MonadAtomicRef m + , MonadCatch m + , Typeable m + , MonadReader (Context m (StdValue m)) m + , MonadThunkId m + ) + => MonadValueF (StdValue m) m where + + demandF + :: ( StdValue m + -> m r + ) + -> StdValue m + -> m r + demandF f = f <=< demand + + informF + :: ( m (StdValue m) + -> m (StdValue m) + ) + -> StdValue m + -> m (StdValue m) + informF f = f . inform + + {------------------------------------------------------------------------} -- jww (2019-03-22): NYI @@ -213,14 +295,22 @@ instance MonadTrans (StandardTF r) where lift = StandardTF . lift . lift + {-# inline lift #-} -instance (MonadPutStr r, MonadPutStr m) => MonadPutStr (StandardTF r m) -instance (MonadHttp r, MonadHttp m) => MonadHttp (StandardTF r m) -instance (MonadEnv r, MonadEnv m) => MonadEnv (StandardTF r m) -instance (MonadPaths r, MonadPaths m) => MonadPaths (StandardTF r m) -instance (MonadInstantiate r, MonadInstantiate m) => MonadInstantiate (StandardTF r m) -instance (MonadExec r, MonadExec m) => MonadExec (StandardTF r m) -instance (MonadIntrospect r, MonadIntrospect m) => MonadIntrospect (StandardTF r m) +instance (MonadPutStr r, MonadPutStr m) + => MonadPutStr (StandardTF r m) +instance (MonadHttp r, MonadHttp m) + => MonadHttp (StandardTF r m) +instance (MonadEnv r, MonadEnv m) + => MonadEnv (StandardTF r m) +instance (MonadPaths r, MonadPaths m) + => MonadPaths (StandardTF r m) +instance (MonadInstantiate r, MonadInstantiate m) + => MonadInstantiate (StandardTF r m) +instance (MonadExec r, MonadExec m) + => MonadExec (StandardTF r m) +instance (MonadIntrospect r, MonadIntrospect m) + => MonadIntrospect (StandardTF r m) --------------------------------------------------------------------------------- @@ -229,27 +319,32 @@ instance MonadTrans (Fix1T StandardTF) where lift = Fix1T . lift -instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where +instance MonadThunkId m + => MonadThunkId (Fix1T StandardTF m) where + type ThunkId (Fix1T StandardTF m) = ThunkId m mkStandardT :: ReaderT - (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m) - a + (Context (StandardT m) (StdValue (StandardT m))) + (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m) + a -> StandardT m a mkStandardT = Fix1T . StandardTF runStandardT :: StandardT m a -> ReaderT - (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m) - a + (Context (StandardT m) (StdValue (StandardT m))) + (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m) + a runStandardT (Fix1T (StandardTF m)) = m runWithBasicEffects - :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a + :: (MonadIO m, MonadAtomicRef m) + => Options + -> StandardT (StdIdT m) a + -> m a runWithBasicEffects opts = go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT where diff --git a/src/Nix/String.hs b/src/Nix/String.hs --- a/src/Nix/String.hs +++ b/src/Nix/String.hs @@ -1,12 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Nix.String ( NixString - , principledGetContext - , principledMakeNixString - , principledMempty + , getContext + , makeNixString , StringContext(..) , ContextFlavor(..) , NixLikeContext(..) @@ -14,18 +12,12 @@ , toNixLikeContext , fromNixLikeContext , stringHasContext - , principledIntercalateNixString - , hackyGetStringNoContext - , principledGetStringNoContext - , principledStringIgnoreContext - , hackyStringIgnoreContext - , hackyMakeNixStringWithoutContext - , principledMakeNixStringWithoutContext - , principledMakeNixStringWithSingletonContext - , principledModifyNixContents - , principledStringMappend - , principledStringMempty - , principledStringMConcat + , intercalateNixString + , getStringNoContext + , stringIgnoreContext + , makeNixStringWithoutContext + , makeNixStringWithSingletonContext + , modifyNixContents , WithStringContext , WithStringContextT(..) , extractNixString @@ -38,187 +30,193 @@ ) where -import Control.Monad.Writer -import Data.Functor.Identity + + + +import Nix.Utils +import Control.Monad.Writer ( WriterT(..), MonadWriter(tell)) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as S -import Data.Hashable -import Data.Text ( Text ) import qualified Data.Text as Text -import GHC.Generics --- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-} --- | A 'ContextFlavor' describes the sum of possible derivations for string contexts -data ContextFlavor = - DirectPath - | AllOutputs - | DerivationOutput !Text - deriving (Show, Eq, Ord, Generic) +-- * Types -instance Hashable ContextFlavor +-- ** Context --- | A 'StringContext' ... +-- | A Nix 'StringContext' ... data StringContext = - StringContext { scPath :: !Text - , scFlavor :: !ContextFlavor - } deriving (Eq, Ord, Show, Generic) + StringContext + { scPath :: !Text + , scFlavor :: !ContextFlavor + } + deriving (Eq, Ord, Show, Generic) instance Hashable StringContext -data NixString = NixString - { nsContents :: !Text - , nsContext :: !(S.HashSet StringContext) - } deriving (Eq, Ord, Show, Generic) +-- | A 'ContextFlavor' describes the sum of possible derivations for string contexts +data ContextFlavor + = DirectPath + | AllOutputs + | DerivationOutput !Text + deriving (Show, Eq, Ord, Generic) -instance Hashable NixString +instance Hashable ContextFlavor -newtype NixLikeContext = NixLikeContext - { getNixLikeContext :: M.HashMap Text NixLikeContextValue - } deriving (Eq, Ord, Show, Generic) +newtype NixLikeContext = + NixLikeContext + { getNixLikeContext :: M.HashMap Text NixLikeContextValue + } + deriving (Eq, Ord, Show, Generic) -data NixLikeContextValue = NixLikeContextValue - { nlcvPath :: !Bool - , nlcvAllOutputs :: !Bool - , nlcvOutputs :: ![Text] - } deriving (Show, Eq, Ord, Generic) +data NixLikeContextValue = + NixLikeContextValue + { nlcvPath :: !Bool + , nlcvAllOutputs :: !Bool + , nlcvOutputs :: ![Text] + } + deriving (Show, Eq, Ord, Generic) instance Semigroup NixLikeContextValue where - a <> b = NixLikeContextValue - { nlcvPath = nlcvPath a || nlcvPath b - , nlcvAllOutputs = nlcvAllOutputs a || nlcvAllOutputs b - , nlcvOutputs = nlcvOutputs a <> nlcvOutputs b - } + a <> b = + NixLikeContextValue + { nlcvPath = nlcvPath a || nlcvPath b + , nlcvAllOutputs = nlcvAllOutputs a || nlcvAllOutputs b + , nlcvOutputs = nlcvOutputs a <> nlcvOutputs b + } instance Monoid NixLikeContextValue where - mempty = NixLikeContextValue False False [] + mempty = NixLikeContextValue False False mempty -toStringContexts :: (Text, NixLikeContextValue) -> [StringContext] -toStringContexts (path, nlcv) = case nlcv of - NixLikeContextValue True _ _ -> StringContext path DirectPath - : toStringContexts (path, nlcv { nlcvPath = False }) - NixLikeContextValue _ True _ -> StringContext path AllOutputs - : toStringContexts (path, nlcv { nlcvAllOutputs = False }) - NixLikeContextValue _ _ ls | not (null ls) -> - map (StringContext path . DerivationOutput) ls - _ -> [] -toNixLikeContextValue :: StringContext -> (Text, NixLikeContextValue) -toNixLikeContextValue sc = (,) (scPath sc) $ case scFlavor sc of - DirectPath -> NixLikeContextValue True False [] - AllOutputs -> NixLikeContextValue False True [] - DerivationOutput t -> NixLikeContextValue False False [t] +-- ** StringContext accumulator -toNixLikeContext :: S.HashSet StringContext -> NixLikeContext -toNixLikeContext stringContext = NixLikeContext - $ S.foldr go mempty stringContext - where - go sc hm = - let (t, nlcv) = toNixLikeContextValue sc in M.insertWith (<>) t nlcv hm +-- | A monad for accumulating string context while producing a result string. +newtype WithStringContextT m a = + WithStringContextT + (WriterT + (S.HashSet StringContext) + m + a + ) + deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (S.HashSet StringContext)) -fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext -fromNixLikeContext = - S.fromList . join . map toStringContexts . M.toList . getNixLikeContext +type WithStringContext = WithStringContextT Identity -principledGetContext :: NixString -> S.HashSet StringContext -principledGetContext = nsContext --- | Combine two NixStrings using mappend -principledMempty :: NixString -principledMempty = NixString "" mempty +-- ** NixString --- | Combine two NixStrings using mappend -principledStringMappend :: NixString -> NixString -> NixString -principledStringMappend (NixString s1 t1) (NixString s2 t2) = - NixString (s1 <> s2) (t1 <> t2) +data NixString = + NixString + { nsContents :: !Text + , nsContext :: !(S.HashSet StringContext) + } + deriving (Eq, Ord, Show, Generic) --- 2021-01-02: NOTE: This function is ERRADICATED from the source code. --- ERRADICATE it from the API. --- | Combine two NixStrings using mappend -hackyStringMappend :: NixString -> NixString -> NixString -hackyStringMappend (NixString s1 t1) (NixString s2 t2) = - NixString (s1 <> s2) (t1 <> t2) +instance Semigroup NixString where + NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2) --- | Combine NixStrings with a separator -principledIntercalateNixString :: NixString -> [NixString] -> NixString -principledIntercalateNixString _ [] = principledMempty -principledIntercalateNixString _ [ns] = ns -principledIntercalateNixString sep nss = NixString contents ctx - where - contents = Text.intercalate (nsContents sep) (map nsContents nss) - ctx = S.unions (nsContext sep : map nsContext nss) +instance Monoid NixString where + mempty = NixString mempty mempty --- 2021-01-02: NOTE: This function is ERRADICATED from the source code. --- ERRADICATE it from the API. --- | Combine NixStrings using mconcat -hackyStringMConcat :: [NixString] -> NixString -hackyStringMConcat = foldr principledStringMappend (NixString mempty mempty) +instance Hashable NixString --- | Empty string with empty context. -principledStringMempty :: NixString -principledStringMempty = NixString mempty mempty --- | Combine NixStrings using mconcat -principledStringMConcat :: [NixString] -> NixString -principledStringMConcat = - foldr principledStringMappend (NixString mempty mempty) +-- * Functions ---instance Semigroup NixString where - --NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2) +-- ** Makers ---instance Monoid NixString where --- mempty = NixString mempty mempty --- mappend = (<>) +-- | Constructs NixString without a context +makeNixStringWithoutContext :: Text -> NixString +makeNixStringWithoutContext = (`NixString` mempty) --- | Extract the string contents from a NixString that has no context -hackyGetStringNoContext :: NixString -> Maybe Text -hackyGetStringNoContext (NixString s c) | null c = Just s - | otherwise = Nothing +-- | Create NixString using a singleton context +makeNixStringWithSingletonContext + :: Text -> StringContext -> NixString +makeNixStringWithSingletonContext s c = NixString s $ S.singleton c --- | Extract the string contents from a NixString that has no context -principledGetStringNoContext :: NixString -> Maybe Text -principledGetStringNoContext (NixString s c) | null c = Just s - | otherwise = Nothing +-- | Create NixString from a Text and context +makeNixString :: Text -> S.HashSet StringContext -> NixString +makeNixString = NixString --- | Extract the string contents from a NixString even if the NixString has an associated context -principledStringIgnoreContext :: NixString -> Text -principledStringIgnoreContext (NixString s _) = s --- | Extract the string contents from a NixString even if the NixString has an associated context -hackyStringIgnoreContext :: NixString -> Text -hackyStringIgnoreContext (NixString s _) = s +-- ** Checkers -- | Returns True if the NixString has an associated context stringHasContext :: NixString -> Bool stringHasContext (NixString _ c) = not (null c) --- | Constructs a NixString without a context -hackyMakeNixStringWithoutContext :: Text -> NixString -hackyMakeNixStringWithoutContext = flip NixString mempty --- | Constructs a NixString without a context -principledMakeNixStringWithoutContext :: Text -> NixString -principledMakeNixStringWithoutContext = flip NixString mempty +-- ** Getters --- | Modify the string part of the NixString, leaving the context unchanged -principledModifyNixContents :: (Text -> Text) -> NixString -> NixString -principledModifyNixContents f (NixString s c) = NixString (f s) c +getContext :: NixString -> S.HashSet StringContext +getContext = nsContext --- | Create a NixString using a singleton context -principledMakeNixStringWithSingletonContext - :: Text -> StringContext -> NixString -principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c) +fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext +fromNixLikeContext = + S.fromList . (toStringContexts <=< (M.toList . getNixLikeContext)) --- | Create a NixString from a Text and context -principledMakeNixString :: Text -> S.HashSet StringContext -> NixString -principledMakeNixString = NixString +-- | Extract the string contents from a NixString that has no context +getStringNoContext :: NixString -> Maybe Text +getStringNoContext (NixString s c) + | null c = pure s + | otherwise = mempty --- | A monad for accumulating string context while producing a result string. -newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringContext) m a) - deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (S.HashSet StringContext)) +-- | Extract the string contents from a NixString even if the NixString has an associated context +stringIgnoreContext :: NixString -> Text +stringIgnoreContext (NixString s _) = s -type WithStringContext = WithStringContextT Identity +-- | Get the contents of a 'NixString' and write its context into the resulting set. +extractNixString :: Monad m => NixString -> WithStringContextT m Text +extractNixString (NixString s c) = + WithStringContextT $ + tell c $> + s + +-- ** Setters + +-- this really should be 2 args, then with @toStringContexts path@ laziness it would tail recurse. +-- for now tuple dissected internaly with laziness preservation. +toStringContexts :: (Text, NixLikeContextValue) -> [StringContext] +toStringContexts ~(path, nlcv) = + go nlcv + where + + go cv = + case cv of + NixLikeContextValue True _ _ -> + mkLstCtxFor DirectPath cv { nlcvPath = False } + NixLikeContextValue _ True _ -> + mkLstCtxFor AllOutputs cv { nlcvAllOutputs = False } + NixLikeContextValue _ _ ls | not (null ls) -> + fmap (mkCtxFor . DerivationOutput) ls + _ -> mempty + where + mkCtxFor = StringContext path + mkLstCtxFor t c = mkCtxFor t : go c + +toNixLikeContextValue :: StringContext -> (Text, NixLikeContextValue) +toNixLikeContextValue sc = + ( scPath sc + , case scFlavor sc of + DirectPath -> NixLikeContextValue True False mempty + AllOutputs -> NixLikeContextValue False True mempty + DerivationOutput t -> NixLikeContextValue False False [t] + ) + +toNixLikeContext :: S.HashSet StringContext -> NixLikeContext +toNixLikeContext stringContext = + NixLikeContext $ + S.foldr + go + mempty + stringContext + where + go sc hm = + let (t, nlcv) = toNixLikeContextValue sc in + M.insertWith (<>) t nlcv hm + -- | Add 'StringContext's into the resulting set. addStringContext :: Monad m => S.HashSet StringContext -> WithStringContextT m () @@ -228,25 +226,46 @@ addSingletonStringContext :: Monad m => StringContext -> WithStringContextT m () addSingletonStringContext = WithStringContextT . tell . S.singleton --- | Get the contents of a 'NixString' and write its context into the resulting set. -extractNixString :: Monad m => NixString -> WithStringContextT m Text -extractNixString (NixString s c) = WithStringContextT $ tell c >> pure s - -- | Run an action producing a string with a context and put those into a 'NixString'. runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString runWithStringContextT (WithStringContextT m) = uncurry NixString <$> runWriterT m +-- | Run an action producing a string with a context and put those into a 'NixString'. +runWithStringContext :: WithStringContextT Identity Text -> NixString +runWithStringContext = runIdentity . runWithStringContextT + + +-- ** Modifiers + +-- | Modify the string part of the NixString, leaving the context unchanged +modifyNixContents :: (Text -> Text) -> NixString -> NixString +modifyNixContents f (NixString s c) = NixString (f s) c + -- | Run an action that manipulates nix strings, and collect the contexts encountered. -- Warning: this may be unsafe, depending on how you handle the resulting context list. runWithStringContextT' :: Monad m => WithStringContextT m a -> m (a, S.HashSet StringContext) runWithStringContextT' (WithStringContextT m) = runWriterT m --- | Run an action producing a string with a context and put those into a 'NixString'. -runWithStringContext :: WithStringContextT Identity Text -> NixString -runWithStringContext = runIdentity . runWithStringContextT - -- | Run an action that manipulates nix strings, and collect the contexts encountered. -- Warning: this may be unsafe, depending on how you handle the resulting context list. runWithStringContext' :: WithStringContextT Identity a -> (a, S.HashSet StringContext) runWithStringContext' = runIdentity . runWithStringContextT' + +-- | Combine NixStrings with a separator +intercalateNixString :: NixString -> [NixString] -> NixString +intercalateNixString _ [] = mempty +intercalateNixString _ [ns] = ns +intercalateNixString sep nss = + uncurry NixString (mapPair intertwine unpackNss) + where + + intertwine = + ( Text.intercalate (nsContents sep) + , S.unions . (:) (nsContext sep) + ) + + unpackNss = (fnss nsContents, fnss nsContext) + where + fnss = (`fmap` nss) -- do once + diff --git a/src/Nix/String/Coerce.hs b/src/Nix/String/Coerce.hs --- a/src/Nix/String/Coerce.hs +++ b/src/Nix/String/Coerce.hs @@ -1,14 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Nix.String.Coerce where -import Control.Monad -import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Catch ( MonadThrow ) import qualified Data.HashMap.Lazy as M -import qualified Data.Text as Text import Nix.Atoms import Nix.Effects import Nix.Frames @@ -52,38 +48,75 @@ -> m NixString coerceToString call ctsm clevel = go where - go x = demand x $ \case - NVConstant (NBool b) - | - -- TODO Return a singleton for "" and "1" - b && clevel == CoerceAny -> pure - $ principledMakeNixStringWithoutContext "1" - | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext "" - NVConstant (NInt n) | clevel == CoerceAny -> - pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n - NVConstant (NFloat n) | clevel == CoerceAny -> - pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n - NVConstant NNull | clevel == CoerceAny -> - pure $ principledMakeNixStringWithoutContext "" - NVStr ns -> pure ns - NVPath p - | ctsm == CopyToStore -> storePathToNixString <$> addPath p - | otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p - NVList l | clevel == CoerceAny -> - nixStringUnwords <$> traverse (`demand` go) l + go x = + do + x' <- demand x + bool + (coerceStringy x') + (coerceAny x') + (clevel == CoerceAny) + where - v@(NVSet s _) | Just p <- M.lookup "__toString" s -> - demand p $ (`call` v) >=> go + coerceAny x' = + case x' of + -- TODO Return a singleton for "" and "1" + NVConstant (NBool b) -> + castToNixString $ + bool + "" + "1" + b + NVConstant (NInt n) -> + castToNixString $ + show n + NVConstant (NFloat n) -> + castToNixString $ + show n + NVConstant NNull -> + castToNixString "" + -- NVConstant: NAtom (NURI Text) is not matched + NVList l -> + nixStringUnwords <$> traverse (go <=< demand) l + v -> coerceStringy v - NVSet s _ | Just p <- M.lookup "outPath" s -> demand p go + coerceStringy x' = + case x' of + NVStr ns -> pure ns + NVPath p -> + bool + (castToNixString . toText) + (fmap storePathToNixString . addPath) + (ctsm == CopyToStore) + p + v@(NVSet s _) -> + maybe + (maybe + (err v) + (gosw False) + (M.lookup "outPath" s) + ) + (gosw True) + (M.lookup "__toString" s) + where + gosw b p = + do + p' <- demand p + bool + go + (go <=< (`call` v)) + b + p' - v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v + v -> err v + err v = throwError $ ErrorCall $ "Expected a string, but saw: " <> show v + castToNixString = pure . makeNixStringWithoutContext - nixStringUnwords = - principledIntercalateNixString (principledMakeNixStringWithoutContext " ") + nixStringUnwords = intercalateNixString (makeNixStringWithoutContext " ") + storePathToNixString :: StorePath -> NixString - storePathToNixString sp = principledMakeNixStringWithSingletonContext + storePathToNixString sp = makeNixStringWithSingletonContext t (StringContext t DirectPath) - where t = Text.pack $ unStorePath sp + where + t = toText $ unStorePath sp diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs --- a/src/Nix/TH.hs +++ b/src/Nix/TH.hs @@ -7,17 +7,11 @@ module Nix.TH where -import Data.Fix -import Data.Generics.Aliases -import Data.Set ( Set - , (\\) - ) +import Data.Fix ( Fix(..) ) +import Data.Generics.Aliases ( extQ ) import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( mapMaybe ) import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( liftString ) +import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH.Quote import Nix.Atoms import Nix.Expr @@ -25,83 +19,104 @@ quoteExprExp :: String -> ExpQ quoteExprExp s = do - expr <- case parseNixText (Text.pack s) of - Failure err -> fail $ show err - Success e -> pure e + expr <- + either + (fail . show) + pure + (parseNixText $ toText s) dataToExpQ - (const Nothing `extQ` metaExp (freeVars expr) `extQ` (Just . liftText)) + (const Nothing `extQ` metaExp (freeVars expr) `extQ` (pure . (TH.lift :: Text -> Q Exp))) expr - where - liftText :: Text.Text -> Q Exp - liftText txt = AppE (VarE 'Text.pack) <$> liftString (Text.unpack txt) quoteExprPat :: String -> PatQ quoteExprPat s = do - expr <- case parseNixText (Text.pack s) of - Failure err -> fail $ show err - Success e -> pure e - dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr + expr <- + either + (fail . show) + pure + (parseNixText $ toText s) + dataToPatQ + (const Nothing `extQ` metaPat (freeVars expr)) + expr freeVars :: NExpr -> Set VarName freeVars e = case unFix e of - (NConstant _ ) -> Set.empty - (NStr string ) -> foldMap freeVars string - (NSym var ) -> Set.singleton var - (NList list ) -> foldMap freeVars list - (NSet NNonRecursive bindings) -> foldMap bindFree bindings - (NSet NRecursive bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings - (NLiteralPath _ ) -> Set.empty - (NEnvPath _ ) -> Set.empty - (NUnary _ expr ) -> freeVars expr - (NBinary _ left right ) -> freeVars left `Set.union` freeVars right - (NSelect expr path orExpr) -> - freeVars expr - `Set.union` pathFree path - `Set.union` maybe Set.empty freeVars orExpr - (NHasAttr expr path) -> freeVars expr `Set.union` pathFree path + (NConstant _ ) -> mempty + (NStr string ) -> mapFreeVars string + (NSym var ) -> Set.singleton var + (NList list ) -> mapFreeVars list + (NSet NNonRecursive bindings) -> bindFreeVars bindings + (NSet NRecursive bindings) -> Set.difference (bindFreeVars bindings) (bindDefs bindings) + (NLiteralPath _ ) -> mempty + (NEnvPath _ ) -> mempty + (NUnary _ expr ) -> freeVars expr + (NBinary _ left right ) -> Set.union (freeVars left) (freeVars right) + (NSelect expr path orExpr) -> + Set.unions + [ freeVars expr + , pathFree path + , maybe mempty freeVars orExpr + ] + (NHasAttr expr path) -> Set.union (freeVars expr) (pathFree path) (NAbs (Param varname) expr) -> Set.delete varname (freeVars expr) (NAbs (ParamSet set _ varname) expr) -> - -- Include all free variables from the expression and the default arguments - freeVars expr - `Set.union` Set.unions (mapMaybe (fmap freeVars . snd) set) - -- But remove the argument name if existing, and all arguments in the parameter set - \\ maybe Set.empty Set.singleton varname - \\ Set.fromList (map fst set) - (NLet bindings expr) -> - freeVars expr - `Set.union` foldMap bindFree bindings - \\ foldMap bindDefs bindings - (NIf cond th el) -> - freeVars cond `Set.union` freeVars th `Set.union` freeVars el + Set.union + -- Include all free variables from the expression and the default arguments + (freeVars expr) + -- But remove the argument name if existing, and all arguments in the parameter set + (Set.difference + (Set.unions $ freeVars <$> mapMaybe snd set) + (Set.difference + (maybe mempty Set.singleton varname) + (Set.fromList $ fmap fst set) + ) + ) + (NLet bindings expr ) -> + Set.union + (freeVars expr) + (Set.difference + (bindFreeVars bindings) + (bindDefs bindings) + ) + (NIf cond th el ) -> Set.unions $ freeVars <$> [cond, th, el] -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it -- This also makes sense because its value can be overridden by `x: with y; x` - (NWith set expr) -> freeVars set `Set.union` freeVars expr - (NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr - (NSynHole _ ) -> Set.empty + (NWith set expr ) -> Set.union (freeVars set ) (freeVars expr) + (NAssert assertion expr ) -> Set.union (freeVars assertion) (freeVars expr) + (NSynHole _ ) -> mempty where - staticKey :: NKeyName r -> Maybe VarName - staticKey (StaticKey varname) = Just varname - staticKey (DynamicKey _ ) = Nothing + bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName + bindDefs = foldMap bind1Def + where + bind1Def :: Binding r -> Set VarName + bind1Def (Inherit Nothing _ _) = mempty + bind1Def (Inherit (Just _ ) keys _) = Set.fromList $ mapMaybe staticKey keys + bind1Def (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname + bind1Def (NamedVar (DynamicKey _ :| _) _ _) = mempty - bindDefs :: Binding r -> Set VarName - bindDefs (Inherit Nothing _ _) = Set.empty - bindDefs (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys - bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname - bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty + bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName + bindFreeVars = foldMap bind1Free + where + bind1Free :: Binding NExpr -> Set VarName + bind1Free (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys + bind1Free (Inherit (Just scope) _ _) = freeVars scope + bind1Free (NamedVar path expr _) = Set.union (pathFree path) (freeVars expr) - bindFree :: Binding NExpr -> Set VarName - bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys - bindFree (Inherit (Just scope) _ _) = freeVars scope - bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr + staticKey :: NKeyName r -> Maybe VarName + staticKey (StaticKey varname) = pure varname + staticKey (DynamicKey _ ) = mempty pathFree :: NAttrPath NExpr -> Set VarName - pathFree = foldMap (foldMap freeVars) + pathFree = foldMap mapFreeVars + mapFreeVars :: Foldable t => t NExpr -> Set VarName + mapFreeVars = foldMap freeVars + class ToExpr a where - toExpr :: a -> NExprLoc + toExpr :: a -> NExprLoc instance ToExpr NExprLoc where toExpr = id @@ -120,13 +135,15 @@ metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = - Just [| toExpr $(varE (mkName (Text.unpack x))) |] + pure [| toExpr $(varE (mkName $ toString x)) |] metaExp _ _ = Nothing metaPat :: Set VarName -> NExprLoc -> Maybe PatQ metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = - Just (varP (mkName (Text.unpack x))) + pure $ varP $ mkName $ toString x metaPat _ _ = Nothing +-- Use of @QuasiQuoter@ requires @String@. +-- After @Text -> String@ migrations done, _maybe_ think to use @QuasiText@. nix :: QuasiQuoter nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat } diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -2,65 +2,107 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Nix.Thunk where -import Control.Exception ( Exception ) -import Control.Monad.Trans.Class ( MonadTrans(..) ) -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State -import Control.Monad.Trans.Writer -import Data.Typeable ( Typeable ) +import Control.Monad.Trans.Writer ( WriterT ) +import qualified Text.Show -class ( Monad m - , Eq (ThunkId m) - , Ord (ThunkId m) - , Show (ThunkId m) - , Typeable (ThunkId m) - ) - => MonadThunkId m where + +-- ** @class MonadThunkId@ & @instances@ + +class + ( Monad m + , Eq (ThunkId m) + , Ord (ThunkId m) + , Show (ThunkId m) + , Typeable (ThunkId m) + ) + => MonadThunkId m + where type ThunkId m :: * + freshId :: m (ThunkId m) default freshId - :: ( MonadThunkId m' - , MonadTrans t - , m ~ t m' - , ThunkId m ~ ThunkId m' - ) - => m (ThunkId m) + :: ( MonadThunkId m' + , MonadTrans t + , m ~ t m' + , ThunkId m ~ ThunkId m' + ) + => m (ThunkId m) freshId = lift freshId -instance MonadThunkId m => MonadThunkId (ReaderT r m) where + +-- *** Instances + +instance + MonadThunkId m + => MonadThunkId (ReaderT r m) + where type ThunkId (ReaderT r m) = ThunkId m -instance (Monoid w, MonadThunkId m) => MonadThunkId (WriterT w m) where + +instance + ( Monoid w + , MonadThunkId m + ) + => MonadThunkId (WriterT w m) + where type ThunkId (WriterT w m) = ThunkId m -instance MonadThunkId m => MonadThunkId (ExceptT e m) where + +instance + MonadThunkId m + => MonadThunkId (ExceptT e m) + where type ThunkId (ExceptT e m) = ThunkId m -instance MonadThunkId m => MonadThunkId (StateT s m) where + +instance + MonadThunkId m + => MonadThunkId (StateT s m) + where type ThunkId (StateT s m) = ThunkId m -class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where - thunk :: m a -> m t +-- ** @class MonadThunk@ + +class + MonadThunkId m + => MonadThunk t m a | t -> m, t -> a + where + -- | Return an identifier for the thunk unless it is a pure value (i.e., -- strictly an encapsulation of some 'a' without any additional - -- structure). For pure values represented as thunks, returns Nothing. - thunkId :: t -> ThunkId m + -- structure). For pure values represented as thunks, returns mempty. + thunkId :: t -> ThunkId m - queryM :: t -> m r -> (a -> m r) -> m r - force :: t -> (a -> m r) -> m r - forceEff :: t -> (a -> m r) -> m r + thunk :: m a -> m t + queryM :: m a -> t -> m a + force :: t -> m a + forceEff :: t -> m a + -- | Modify the action to be performed by the thunk. For some implicits -- this modifies the thunk, for others it may create a new thunk. - further :: t -> (m a -> m a) -> m t + further :: t -> m t -newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId + +-- ** @class MonadThunk@ + +-- | Class of Kleisli functors for easiness of customized implementation developlemnt. +class + MonadThunkF t m a | t -> m, t -> a + where + queryMF :: (a -> m r) -> m r -> t -> m r + forceF :: (a -> m r) -> t -> m r + forceEffF :: (a -> m r) -> t -> m r + furtherF :: (m a -> m a) -> t -> m t + + +-- ** @newtype ThunkLoop@ + +newtype ThunkLoop = ThunkLoop Text -- contains rendering of ThunkId deriving Typeable instance Show ThunkLoop where - show (ThunkLoop i) = "ThunkLoop " ++ i + show (ThunkLoop i) = toString $ "ThunkLoop " <> i instance Exception ThunkLoop diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -6,99 +6,224 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where -import Control.Exception hiding ( catch ) -import Control.Monad.Catch +module Nix.Thunk.Basic + ( NThunkF(..) + , Deferred(..) + , MonadBasicThunk + ) where +import Prelude hiding ( force ) +import Relude.Extra ( dup ) +import Control.Monad.Catch ( MonadCatch(..) + , MonadThrow(throwM) + ) +import qualified Text.Show import Nix.Thunk import Nix.Var -data Deferred m v = Deferred (m v) | Computed v - deriving (Functor, Foldable, Traversable) +-- * Data type @Deferred@ + +-- | Data is computed OR in a lazy thunk state which +-- is still not evaluated. +data Deferred m v = Computed v | Deferred (m v) + deriving (Functor, Foldable, Traversable) + +-- ** Utils + +-- | @Deferred (Computed|Deferred)@ analog of @either@. +deferred :: (v -> b) -> (m v -> b) -> Deferred m v -> b +deferred f1 f2 def = + case def of + Computed v -> f1 v + Deferred action -> f2 action +{-# inline deferred #-} + + +-- * Thunk references & lock handling + +-- | Thunk resource reference (@ref-tf: Ref m@), and as such also also hold +-- a @Bool@ lock flag. +type ThunkRef m = (Var m Bool) + +-- | Reference (@ref-tf: Ref m v@) to a value that the thunk holds. +type ThunkValueRef m v = Var m (Deferred m v) + +-- | @ref-tf@ lock instruction for @Ref m@ (@ThunkRef@). +lock :: Bool -> (Bool, Bool) +lock = (True, ) + +-- | @ref-tf@ unlock instruction for @Ref m@ (@ThunkRef@). +unlock :: Bool -> (Bool, Bool) +unlock = (False, ) + +-- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation. +lockThunk + :: ( MonadBasicThunk m + , MonadCatch m + ) + => ThunkRef m + -> m Bool +lockThunk r = atomicModifyVar r lock + +-- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation. +unlockThunk + :: ( MonadBasicThunk m + , MonadCatch m + ) + => ThunkRef m + -> m Bool +unlockThunk r = atomicModifyVar r unlock + + +-- * Data type for thunks: @NThunkF@ + -- | The type of very basic thunks data NThunkF m v - = Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v)) + = Thunk (ThunkId m) (ThunkRef m) (ThunkValueRef m v) instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where Thunk x _ _ == Thunk y _ _ = x == y -instance Show v => Show (NThunkF m v) where - show (Thunk _ _ _) = "" +instance Show (NThunkF m v) where + show Thunk{} = "" type MonadBasicThunk m = (MonadThunkId m, MonadVar m) + +-- ** @instance MonadThunk NThunkF@ + instance (MonadBasicThunk m, MonadCatch m) => MonadThunk (NThunkF m v) m v where - thunk = buildThunk + + -- | Return thunk ID + thunkId :: NThunkF m v -> ThunkId m thunkId (Thunk n _ _) = n - queryM = queryThunk - force = forceThunk - forceEff = forceEffects - further = furtherThunk -buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v) -buildThunk action = do - freshThunkId <- freshId - Thunk freshThunkId <$> newVar False <*> newVar (Deferred action) + -- | Create new thunk + thunk :: m v -> m (NThunkF m v) + thunk action = + do + freshThunkId <- freshId + Thunk freshThunkId <$> newVar False <*> newVar (Deferred action) -queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a -queryThunk (Thunk _ active ref) n k = do - nowActive <- atomicModifyVar active (True, ) - if nowActive - then n - else do - eres <- readVar ref - res <- case eres of - Computed v -> k v - _ -> n - _ <- atomicModifyVar active (False, ) - pure res + -- | Non-blocking query, return value if @Computed@, + -- return first argument otherwise. + queryM :: m v -> NThunkF m v -> m v + queryM n (Thunk _ _ ref) = + do + deferred + pure + (const n) + =<< readVar ref -forceThunk - :: forall m v a - . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m)) + force :: NThunkF m v -> m v + force = forceMain + + forceEff :: NThunkF m v -> m v + forceEff = forceMain + + further :: NThunkF m v -> m (NThunkF m v) + further t@(Thunk _ _ ref) = + do + _ <- + atomicModifyVar + ref + dup + pure t + + +-- *** United body of `force*` + +-- | If @m v@ is @Computed@ - returns is +forceMain + :: ( MonadBasicThunk m + , MonadCatch m + ) => NThunkF m v - -> (v -> m a) - -> m a -forceThunk (Thunk n active ref) k = do - eres <- readVar ref - case eres of - Computed v -> k v - Deferred action -> do - nowActive <- atomicModifyVar active (True, ) - if nowActive - then throwM $ ThunkLoop $ show n - else do - v <- catch action $ \(e :: SomeException) -> do - _ <- atomicModifyVar active (False, ) - throwM e - _ <- atomicModifyVar active (False, ) - writeVar ref (Computed v) - k v + -> m v +forceMain (Thunk n thunkRef thunkValRef) = + do + deferred + pure + (\ action -> + do + lockedIt <- lockThunk thunkRef + bool + (throwM $ ThunkLoop $ show n) + (do + v <- catch action $ \(e :: SomeException) -> + do + _unlockedIt <- unlockThunk thunkRef + throwM e + writeVar thunkValRef (Computed v) + _unlockedIt <- unlockThunk thunkRef + pure v + ) + (not lockedIt) + ) + =<< readVar thunkValRef +{-# inline forceMain #-} -- it is big function, but internal, and look at its use. -forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r -forceEffects (Thunk _ active ref) k = do - nowActive <- atomicModifyVar active (True, ) - if nowActive - then pure $ error "Loop detected" - else do - eres <- readVar ref - case eres of - Computed v -> k v - Deferred action -> do - v <- action - writeVar ref (Computed v) - _ <- atomicModifyVar active (False, ) - k v -furtherThunk :: MonadVar m => NThunkF m v -> (m v -> m v) -> m (NThunkF m v) -furtherThunk t@(Thunk _ _ ref) k = do - _ <- atomicModifyVar ref $ \x -> case x of - Computed _ -> (x, x) - Deferred d -> (Deferred (k d), x) - pure t + +-- ** Kleisli functor HOFs: @instance MonadThunkF NThunkF@ + +instance (MonadBasicThunk m, MonadCatch m) + => MonadThunkF (NThunkF m v) m v where + + queryMF + :: (v -> m r) + -> m r + -> NThunkF m v + -> m r + queryMF k n (Thunk _ thunkRef thunkValRef) = + do + lockedIt <- lockThunk thunkRef + bool + n + go + (not lockedIt) + where + go = + do + eres <- readVar thunkValRef + res <- + deferred + k + (const n) + eres + _unlockedIt <- unlockThunk thunkRef + pure res + + forceF + :: (v -> m a) + -> NThunkF m v + -> m a + forceF k = k <=< force + + forceEffF + :: (v -> m r) + -> NThunkF m v + -> m r + forceEffF k = k <=< forceEff + + furtherF + :: (m v -> m v) + -> NThunkF m v + -> m (NThunkF m v) + furtherF k t@(Thunk _ _ ref) = + do + _modifiedIt <- atomicModifyVar ref $ + \x -> + deferred + (const (x, x)) + (\ d -> (Deferred (k d), x)) + x + pure t + + diff --git a/src/Nix/Type/Assumption.hs b/src/Nix/Type/Assumption.hs --- a/src/Nix/Type/Assumption.hs +++ b/src/Nix/Type/Assumption.hs @@ -11,17 +11,17 @@ ) where -import Prelude hiding ( lookup ) +import Prelude hiding ( Type + , empty + ) import Nix.Type.Type -import Data.Foldable - newtype Assumption = Assumption { assumptions :: [(Name, Type)] } deriving (Eq, Show) empty :: Assumption -empty = Assumption [] +empty = Assumption mempty extend :: Assumption -> (Name, Type) -> Assumption extend (Assumption a) (x, s) = Assumption ((x, s) : a) @@ -30,10 +30,10 @@ remove (Assumption a) var = Assumption (filter (\(n, _) -> n /= var) a) lookup :: Name -> Assumption -> [Type] -lookup key (Assumption a) = map snd (filter (\(n, _) -> n == key) a) +lookup key (Assumption a) = fmap snd (filter (\(n, _) -> n == key) a) merge :: Assumption -> Assumption -> Assumption -merge (Assumption a) (Assumption b) = Assumption (a ++ b) +merge (Assumption a) (Assumption b) = Assumption (a <> b) mergeAssumptions :: [Assumption] -> Assumption mergeAssumptions = foldl' merge empty @@ -42,4 +42,4 @@ singleton x y = Assumption [(x, y)] keys :: Assumption -> [Name] -keys (Assumption a) = map fst a +keys (Assumption a) = fmap fst a diff --git a/src/Nix/Type/Env.hs b/src/Nix/Type/Env.hs --- a/src/Nix/Type/Env.hs +++ b/src/Nix/Type/Env.hs @@ -14,22 +14,23 @@ ) where -import Prelude hiding ( lookup ) +import Prelude hiding ( empty + , toList + , fromList + ) import Nix.Type.Type -import Data.Foldable hiding ( toList ) import qualified Data.Map as Map ---------------------------------------------------------------------------------- + -- * Typing Environment ---------------------------------------------------------------------------------- newtype Env = TypeEnv { types :: Map.Map Name [Scheme] } deriving (Eq, Show) empty :: Env -empty = TypeEnv Map.empty +empty = TypeEnv mempty extend :: Env -> (Name, [Scheme]) -> Env extend env (x, s) = env { types = Map.insert x s (types env) } diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} @@ -7,14 +8,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -27,31 +27,35 @@ ) where -import Control.Applicative -import Control.Arrow -import Control.Monad.Catch -import Control.Monad.Except -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail -#endif -import Control.Monad.Logic -import Control.Monad.Reader +import Control.Monad.Catch ( MonadThrow(..) + , MonadCatch(..) + ) +import Control.Monad.Except ( MonadError(..) + ) +import Prelude hiding ( Type + , TVar + , Constraint + ) +import Nix.Utils +import Control.Monad.Logic hiding ( fail ) +import Control.Monad.Reader ( MonadFix + ) import Control.Monad.Ref -import Control.Monad.ST -import Control.Monad.State.Strict +import Control.Monad.ST ( ST + , runST + ) import Data.Fix ( foldFix ) -import Data.Foldable +import Data.Foldable ( foldrM ) import qualified Data.HashMap.Lazy as M import Data.List ( delete - , nub , intersect , (\\) + , (!!) ) -import Data.Map ( Map ) +import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe ( fromJust ) import qualified Data.Set as Set -import Data.Text ( Text ) import Nix.Atoms import Nix.Convert import Nix.Eval ( MonadEval(..) ) @@ -62,35 +66,36 @@ import Nix.String import Nix.Scope import qualified Nix.Type.Assumption as As -import Nix.Type.Env +import Nix.Type.Env hiding ( empty ) import qualified Nix.Type.Env as Env import Nix.Type.Type -import Nix.Utils import Nix.Value.Monad import Nix.Var ---------------------------------------------------------------------------------- + -- * Classes ---------------------------------------------------------------------------------- -- | Inference monad -newtype InferT s m a = InferT +newtype InferT s m a = + InferT { getInfer :: - ReaderT (Set.Set TVar, Scopes (InferT s m) (Judgment s)) - (StateT InferState (ExceptT InferError m)) a + ReaderT + (Set.Set TVar, Scopes (InferT s m) (Judgment s)) + (StateT InferState (ExceptT InferError m)) + a } deriving - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadFix - , MonadReader (Set.Set TVar, Scopes (InferT s m) (Judgment s)) - , MonadFail - , MonadState InferState - , MonadError InferError - ) + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadReader (Set.Set TVar, Scopes (InferT s m) (Judgment s)) + , MonadFail + , MonadState InferState + , MonadError InferError + ) instance MonadTrans (InferT s) where lift = InferT . lift . lift . lift @@ -106,10 +111,10 @@ initInfer = InferState { count = 0 } data Constraint - = EqConst Type Type - | ExpInstConst Type Scheme - | ImpInstConst Type (Set.Set TVar) Type - deriving (Show, Eq, Ord) + = EqConst Type Type + | ExpInstConst Type Scheme + | ImpInstConst Type (Set.Set TVar) Type + deriving (Show, Eq, Ord) newtype Subst = Subst (Map TVar Type) deriving (Eq, Ord, Show, Semigroup, Monoid) @@ -126,10 +131,10 @@ instance Substitutable Type where apply _ ( TCon a ) = TCon a apply s ( TSet b a ) = TSet b (M.map (apply s) a) - apply s ( TList a ) = TList (map (apply s) a) + apply s ( TList a ) = TList (apply s <$> a) apply (Subst s) t@(TVar a ) = Map.findWithDefault t a s apply s ( t1 :~> t2) = apply s t1 :~> apply s t2 - apply s ( TMany ts ) = TMany (map (apply s) ts) + apply s ( TMany ts ) = TMany (apply s <$> ts) instance Substitutable Scheme where apply (Subst s) (Forall as t) = Forall as $ apply s' t @@ -142,7 +147,7 @@ ImpInstConst (apply s t1) (apply s ms) (apply s t2) instance Substitutable a => Substitutable [a] where - apply = map . apply + apply = fmap . apply instance (Ord a, Substitutable a) => Substitutable (Set.Set a) where apply = Set.map . apply @@ -152,12 +157,12 @@ ftv :: a -> Set.Set TVar instance FreeTypeVars Type where - ftv TCon{} = Set.empty + ftv TCon{} = mempty ftv (TVar a ) = Set.singleton a - ftv (TSet _ a ) = Set.unions (map ftv (M.elems a)) - ftv (TList a ) = Set.unions (map ftv a) + ftv (TSet _ a ) = Set.unions (ftv <$> M.elems a) + ftv (TList a ) = Set.unions (ftv <$> a) ftv (t1 :~> t2) = ftv t1 `Set.union` ftv t2 - ftv (TMany ts ) = Set.unions (map ftv ts) + ftv (TMany ts ) = Set.unions (ftv <$> ts) instance FreeTypeVars TVar where ftv = Set.singleton @@ -166,23 +171,22 @@ ftv (Forall as t) = ftv t `Set.difference` Set.fromList as instance FreeTypeVars a => FreeTypeVars [a] where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) mempty instance (Ord a, FreeTypeVars a) => FreeTypeVars (Set.Set a) where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) mempty class ActiveTypeVars a where atv :: a -> Set.Set TVar instance ActiveTypeVars Constraint where - atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2 - atv (ImpInstConst t1 ms t2) = - ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) - atv (ExpInstConst t s) = ftv t `Set.union` ftv s + atv (EqConst t1 t2 ) = ftv t1 `Set.union` ftv t2 + atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) + atv (ExpInstConst t s ) = ftv t `Set.union` ftv s instance ActiveTypeVars a => ActiveTypeVars [a] where - atv = foldr (Set.union . atv) Set.empty + atv = foldr (Set.union . atv) mempty data TypeError = UnificationFail Type Type @@ -190,7 +194,7 @@ | UnboundVariables [Text] | Ambigious [Constraint] | UnificationMismatch [Type] [Type] - deriving (Eq, Show) + deriving (Eq, Show, Ord) data InferError = TypeInferenceErrors [TypeError] @@ -210,16 +214,15 @@ mempty = TypeInferenceAborted mappend = (<>) ---------------------------------------------------------------------------------- + -- * Inference ---------------------------------------------------------------------------------- -- | Run the inference monad runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a) runInfer' = runExceptT . (`evalStateT` initInfer) - . (`runReaderT` (Set.empty, emptyScopes)) + . (`runReaderT` (mempty, emptyScopes)) . getInfer runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a @@ -234,138 +237,133 @@ let unbounds = Set.fromList (As.keys as) `Set.difference` Set.fromList (Env.keys env) unless (Set.null unbounds) $ typeError $ UnboundVariables - (nub (Set.toList unbounds)) - let cs' = - [ ExpInstConst t s - | (x, ss) <- Env.toList env - , s <- ss - , t <- As.lookup x as - ] + (ordNub (Set.toList unbounds)) + let + cs' = + [ ExpInstConst t s + | (x, ss) <- Env.toList env + , s <- ss + , t <- As.lookup x as + ] inferState <- get - let eres = (`evalState` inferState) $ runSolver $ do - subst <- solve (cs ++ cs') - return (subst, subst `apply` t) - case eres of - Left errs -> throwError $ TypeInferenceErrors errs - Right xs -> pure xs + let + eres = (`evalState` inferState) $ runSolver $ + do + subst <- solve (cs <> cs') + pure (subst, subst `apply` t) + either + (throwError . TypeInferenceErrors) + pure + eres -- | Solve for the toplevel type of an expression in a given environment inferExpr :: Env -> NExpr -> Either InferError [Scheme] -inferExpr env ex = case runInfer (inferType env ex) of - Left err -> Left err - Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs +inferExpr env ex = + (\ (subst, ty) -> closeOver $ subst `apply` ty) <<$>> runInfer (inferType env ex) -- | Canonicalize and return the polymorphic toplevel type. closeOver :: Type -> Scheme -closeOver = normalizeScheme . generalize Set.empty +closeOver = normalizeScheme . generalize mempty extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a extendMSet x = InferT . local (first (Set.insert x)) . getInfer letters :: [String] -letters = [1 ..] >>= flip replicateM ['a' .. 'z'] +letters = + do + l <- [1 ..] + replicateM + l + ['a' .. 'z'] freshTVar :: MonadState InferState m => m TVar -freshTVar = do - s <- get - put s { count = count s + 1 } - return $ TV (letters !! count s) +freshTVar = + do + s <- get + put s { count = count s + 1 } + pure $ TV (toText (letters !! count s)) fresh :: MonadState InferState m => m Type fresh = TVar <$> freshTVar instantiate :: MonadState InferState m => Scheme -> m Type -instantiate (Forall as t) = do - as' <- mapM (const fresh) as - let s = Subst $ Map.fromList $ zip as as' - return $ apply s t +instantiate (Forall as t) = + do + as' <- traverse (const fresh) as + let s = Subst $ Map.fromList $ zip as as' + pure $ apply s t generalize :: Set.Set TVar -> Type -> Scheme generalize free t = Forall as t - where as = Set.toList $ ftv t `Set.difference` free + where + as = Set.toList $ ftv t `Set.difference` free unops :: Type -> NUnaryOp -> [Constraint] -unops u1 = \case - NNot -> [EqConst u1 (typeFun [typeBool, typeBool])] - NNeg -> - [ EqConst - u1 - (TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]]) - ] +unops u1 op = + [ EqConst u1 + (case op of + NNot -> typeFun [typeBool , typeBool ] + NNeg -> TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]] + ) + ] binops :: Type -> NBinaryOp -> [Constraint] -binops u1 = \case - NApp -> [] -- this is handled separately - - -- Equality tells you nothing about the types, because any two types are - -- allowed. - NEq -> [] - NNEq -> [] - - NGt -> inequality - NGte -> inequality - NLt -> inequality - NLte -> inequality +binops u1 op = + if + -- NApp in fact is handled separately + -- Equality tells nothing about the types, because any two types are allowed. + | op `elem` [ NApp , NEq , NNEq ] -> mempty + | op `elem` [ NGt , NGte , NLt , NLte ] -> inequality + | op `elem` [ NAnd , NOr , NImpl ] -> gate + | op == NConcat -> concatenation + | op `elem` [ NMinus, NMult, NDiv ] -> arithmetic + | op == NUpdate -> rUnion + | op == NPlus -> addition + | otherwise -> fail "GHC so far can not infer that this pattern match is full, so make it happy." - NAnd -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] - NOr -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] - NImpl -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] + where - NConcat -> [EqConst u1 (typeFun [typeList, typeList, typeList])] + gate = eqCnst [typeBool, typeBool, typeBool] + concatenation = eqCnst [typeList, typeList, typeList] - NUpdate -> - [ EqConst - u1 - (TMany - [ typeFun [typeSet, typeSet, typeSet] - , typeFun [typeSet, typeNull, typeSet] - , typeFun [typeNull, typeSet, typeSet] - ] - ) - ] + eqCnst l = [EqConst u1 (typeFun l)] - NPlus -> - [ EqConst - u1 - (TMany - [ typeFun [typeInt, typeInt, typeInt] - , typeFun [typeFloat, typeFloat, typeFloat] - , typeFun [typeInt, typeFloat, typeFloat] - , typeFun [typeFloat, typeInt, typeFloat] - , typeFun [typeString, typeString, typeString] - , typeFun [typePath, typePath, typePath] - , typeFun [typeString, typeString, typePath] - ] - ) - ] - NMinus -> arithmetic - NMult -> arithmetic - NDiv -> arithmetic - where inequality = - [ EqConst - u1 - (TMany - [ typeFun [typeInt, typeInt, typeBool] - , typeFun [typeFloat, typeFloat, typeBool] - , typeFun [typeInt, typeFloat, typeBool] - , typeFun [typeFloat, typeInt, typeBool] - ] - ) - ] + eqCnstMtx + [ [typeInt , typeInt , typeBool] + , [typeFloat, typeFloat, typeBool] + , [typeInt , typeFloat, typeBool] + , [typeFloat, typeInt , typeBool] + ] arithmetic = - [ EqConst - u1 - (TMany - [ typeFun [typeInt, typeInt, typeInt] - , typeFun [typeFloat, typeFloat, typeFloat] - , typeFun [typeInt, typeFloat, typeFloat] - , typeFun [typeFloat, typeInt, typeFloat] - ] - ) - ] + eqCnstMtx + [ [typeInt , typeInt , typeInt ] + , [typeFloat, typeFloat, typeFloat] + , [typeInt , typeFloat, typeFloat] + , [typeFloat, typeInt , typeFloat] + ] + rUnion = + eqCnstMtx + [ [typeSet , typeSet , typeSet] + , [typeSet , typeNull, typeSet] + , [typeNull, typeSet , typeSet] + ] + + addition = + eqCnstMtx + [ [typeInt , typeInt , typeInt ] + , [typeFloat , typeFloat , typeFloat ] + , [typeInt , typeFloat , typeFloat ] + , [typeFloat , typeInt , typeFloat ] + , [typeString, typeString, typeString] + , [typePath , typePath , typePath ] + , [typeString, typeString, typePath ] + ] + + eqCnstMtx mtx = [EqConst u1 (TMany (typeFun <$> mtx))] + liftInfer :: Monad m => m a -> InferT s m a liftInfer = InferT . lift . lift . lift @@ -376,10 +374,12 @@ writeRef x y = liftInfer $ writeRef x y instance MonadAtomicRef m => MonadAtomicRef (InferT s m) where - atomicModifyRef x f = liftInfer $ do - res <- snd . f <$> readRef x - _ <- modifyRef x (fst . f) - return res + atomicModifyRef x f = + liftInfer $ + do + res <- snd . f <$> readRef x + _ <- modifyRef x (fst . f) + pure res -- newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s)) @@ -387,59 +387,95 @@ throwM = throwError . EvaluationError instance Monad m => MonadCatch (InferT s m) where - catch m h = catchError m $ \case - EvaluationError e -> maybe - (error $ "Exception was not an exception: " ++ show e) - h - (fromException (toException e)) - err -> error $ "Unexpected error: " ++ show err + catch m h = + catchError m $ + \case + EvaluationError e -> + maybe + (error $ "Exception was not an exception: " <> show e) + h + (fromException (toException e)) + err -> error $ "Unexpected error: " <> show err type MonadInfer m = ({- MonadThunkId m,-} MonadVar m, MonadFix m) +-- 2021-02-22: NOTE: Seems like suporflous instance instance Monad m => MonadValue (Judgment s) (InferT s m) where + defer + :: InferT s m (Judgment s) + -> InferT s m (Judgment s) defer = id - demand = flip ($) - inform j f = f (pure j) + demand + :: Judgment s + -> InferT s m (Judgment s) + demand = pure + + inform + :: Judgment s + -> InferT s m (Judgment s) + inform = pure + + +-- 2021-02-22: NOTE: Seems like suporflous instance +instance Monad m => MonadValueF (Judgment s) (InferT s m) where + + demandF + :: ( Judgment s + -> InferT s m r) + -> Judgment s + -> InferT s m r + demandF f a = f a + + informF + :: ( InferT s m (Judgment s) + -> InferT s m (Judgment s) + ) + -> Judgment s + -> InferT s m (Judgment s) + informF f = f . pure + {- instance MonadInfer m => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where - thunk = fmap JThunk . thunk + thunkId (JThunk x) = thunkId x - queryM (JThunk x) b f = queryM x b f + thunk = fmap JThunk . thunk + queryM b (JThunk x) = queryM b x + -- If we have a thunk loop, we just don't know the type. - force (JThunk t) f = catch (force t f) + force (JThunk t) = catch (force t) $ \(_ :: ThunkLoop) -> - f =<< Judgment As.empty [] <$> fresh + f =<< Judgment As.empty mempty <$> fresh -- If we have a thunk loop, we just don't know the type. - forceEff (JThunk t) f = catch (forceEff t f) + forceEff (JThunk t) = catch (forceEff t) $ \(_ :: ThunkLoop) -> - f =<< Judgment As.empty [] <$> fresh + f =<< Judgment As.empty mempty <$> fresh -} instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where freeVariable var = do tv <- fresh - return $ Judgment (As.singleton var tv) [] tv + pure $ Judgment (As.singleton var tv) mempty tv synHole var = do tv <- fresh - return $ Judgment (As.singleton var tv) [] tv + pure $ Judgment (As.singleton var tv) mempty tv -- If we fail to look up an attribute, we just don't know the type. - attrMissing _ _ = Judgment As.empty [] <$> fresh + attrMissing _ _ = Judgment As.empty mempty <$> fresh evaledSym _ = pure - evalCurPos = return $ Judgment As.empty [] $ TSet False $ M.fromList + evalCurPos = pure $ Judgment As.empty mempty $ TSet False $ M.fromList [("file", typePath), ("line", typeInt), ("col", typeInt)] - evalConstant c = return $ Judgment As.empty [] (go c) + evalConstant c = pure $ Judgment As.empty mempty (go c) where go = \case NURI _ -> typeString @@ -448,19 +484,19 @@ NBool _ -> typeBool NNull -> typeNull - evalString = const $ return $ Judgment As.empty [] typeString - evalLiteralPath = const $ return $ Judgment As.empty [] typePath - evalEnvPath = const $ return $ Judgment As.empty [] typePath + evalString = const $ pure $ Judgment As.empty mempty typeString + evalLiteralPath = const $ pure $ Judgment As.empty mempty typePath + evalEnvPath = const $ pure $ Judgment As.empty mempty typePath evalUnary op (Judgment as1 cs1 t1) = do tv <- fresh - return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv + pure $ Judgment as1 (cs1 <> unops (t1 :~> tv) op) tv evalBinary op (Judgment as1 cs1 t1) e2 = do Judgment as2 cs2 t2 <- e2 tv <- fresh - return $ Judgment (as1 `As.merge` as2) - (cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op) + pure $ Judgment (as1 `As.merge` as2) + (cs1 <> cs2 <> binops (t1 :~> t2 :~> tv) op) tv evalWith = Eval.evalWithAttrSet @@ -468,21 +504,21 @@ evalIf (Judgment as1 cs1 t1) t f = do Judgment as2 cs2 t2 <- t Judgment as3 cs3 t3 <- f - return $ Judgment + pure $ Judgment (as1 `As.merge` as2 `As.merge` as3) - (cs1 ++ cs2 ++ cs3 ++ [EqConst t1 typeBool, EqConst t2 t3]) + (cs1 <> cs2 <> cs3 <> [EqConst t1 typeBool, EqConst t2 t3]) t2 evalAssert (Judgment as1 cs1 t1) body = do Judgment as2 cs2 t2 <- body - return - $ Judgment (as1 `As.merge` as2) (cs1 ++ cs2 ++ [EqConst t1 typeBool]) t2 + pure + $ Judgment (as1 `As.merge` as2) (cs1 <> cs2 <> [EqConst t1 typeBool]) t2 evalApp (Judgment as1 cs1 t1) e2 = do Judgment as2 cs2 t2 <- e2 tv <- fresh - return $ Judgment (as1 `As.merge` as2) - (cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)]) + pure $ Judgment (as1 `As.merge` as2) + (cs1 <> cs2 <> [EqConst t1 (t2 :~> tv)]) tv evalAbs (Param x) k = do @@ -490,94 +526,124 @@ let tv = TVar a ((), Judgment as cs t) <- extendMSet a - (k (pure (Judgment (As.singleton x tv) [] tv)) (\_ b -> ((), ) <$> b)) - return $ Judgment (as `As.remove` x) - (cs ++ [ EqConst t' tv | t' <- As.lookup x as ]) + (k (pure (Judgment (As.singleton x tv) mempty tv)) (\_ b -> ((), ) <$> b)) + pure $ Judgment (as `As.remove` x) + (cs <> [ EqConst t' tv | t' <- As.lookup x as ]) (tv :~> t) evalAbs (ParamSet ps variadic _mname) k = do - js <- fmap concat $ forM ps $ \(name, _) -> do - tv <- fresh - pure [(name, tv)] + js <- + concat <$> + traverse + (\(name, _) -> + do + tv <- fresh + pure [(name, tv)] + ) + ps - let (env, tys) = - (\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) -> - (as1 `As.merge` As.singleton k t, M.insert k t t1) - arg = pure $ Judgment env [] (TSet True tys) - call = k arg $ \args b -> (args, ) <$> b - names = map fst js + let + (env, tys) = + (\f -> foldl' f (As.empty, mempty) js) $ \(as1, t1) (k, t) -> + (as1 `As.merge` As.singleton k t, M.insert k t t1) + arg = pure $ Judgment env mempty (TSet True tys) + call = k arg $ \args b -> (args, ) <$> b + names = fst <$> js (args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js ty <- TSet variadic <$> traverse (inferredType <$>) args - return $ Judgment - (foldl' As.remove as names) - (cs ++ [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ]) - (ty :~> t) + pure $ + Judgment + (foldl' As.remove as names) + (cs <> [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ]) + (ty :~> t) evalError = throwError . EvaluationError -data Judgment s = Judgment +data Judgment s = + Judgment { assumptions :: As.Assumption , typeConstraints :: [Constraint] , inferredType :: Type } deriving Show -instance Monad m => FromValue NixString (InferT s m) (Judgment s) where - fromValueMay _ = return Nothing +instance + Monad m + => FromValue NixString (InferT s m) (Judgment s) + where + fromValueMay _ = stub fromValue _ = error "Unused" -instance MonadInfer m - => FromValue (AttrSet (Judgment s), AttrSet SourcePos) - (InferT s m) (Judgment s) where - fromValueMay (Judgment _ _ (TSet _ xs)) = do - let sing _ = Judgment As.empty [] - pure $ Just (M.mapWithKey sing xs, M.empty) - fromValueMay _ = pure Nothing - fromValue = fromValueMay >=> \case - Just v -> pure v - Nothing -> pure (M.empty, M.empty) +instance + MonadInfer m + => FromValue ( AttrSet (Judgment s) + , AttrSet SourcePos + ) (InferT s m) (Judgment s) + where + fromValueMay (Judgment _ _ (TSet _ xs)) = + do + let sing _ = Judgment As.empty mempty + pure $ pure (M.mapWithKey sing xs, mempty) + fromValueMay _ = stub + fromValue = + pure . + fromMaybe + (mempty, mempty) + <=< fromValueMay instance MonadInfer m => ToValue (AttrSet (Judgment s), AttrSet SourcePos) (InferT s m) (Judgment s) where toValue (xs, _) = - Judgment - <$> foldrM go As.empty xs - <*> (concat <$> traverse (`demand` (pure . typeConstraints)) xs) - <*> (TSet True <$> traverse (`demand` (pure . inferredType)) xs) - where go x rest = demand x $ \x' -> pure $ As.merge (assumptions x') rest + liftA3 + Judgment + (foldrM go As.empty xs) + (concat <$> traverse ((typeConstraints <$>) . demand) xs) + (TSet True <$> traverse ((inferredType <$>) . demand) xs) + where + go x rest = + do + x' <- demand x + pure $ As.merge (assumptions x') rest instance MonadInfer m => ToValue [Judgment s] (InferT s m) (Judgment s) where toValue xs = - Judgment - <$> foldrM go As.empty xs - <*> (concat <$> traverse (`demand` (pure . typeConstraints)) xs) - <*> (TList <$> traverse (`demand` (pure . inferredType)) xs) - where go x rest = demand x $ \x' -> pure $ As.merge (assumptions x') rest + liftA3 + Judgment + (foldrM go As.empty xs) + (concat <$> traverse ((typeConstraints <$>) . demand) xs) + (TList <$> traverse ((inferredType <$>) . demand) xs) + where + go x rest = + do + x' <- demand x + pure $ As.merge (assumptions x') rest instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where - toValue _ = pure $ Judgment As.empty [] typeBool + toValue _ = pure $ Judgment As.empty mempty typeBool infer :: MonadInfer m => NExpr -> InferT s m (Judgment s) infer = foldFix Eval.eval inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env -inferTop env [] = Right env -inferTop env ((name, ex) : xs) = case inferExpr env ex of - Left err -> Left err - Right ty -> inferTop (extend env (name, ty)) xs +inferTop env [] = pure env +inferTop env ((name, ex) : xs) = + either + Left + (\ ty -> inferTop (extend env (name, ty)) xs) + (inferExpr env ex) normalizeScheme :: Scheme -> Scheme -normalizeScheme (Forall _ body) = Forall (map snd ord) (normtype body) +normalizeScheme (Forall _ body) = Forall (snd <$> ord) (normtype body) where - ord = zip (nub $ fv body) (map TV letters) + ord = zip (ordNub $ fv body) (TV . toText <$> letters) fv (TVar a ) = [a] - fv (a :~> b ) = fv a ++ fv b - fv (TCon _ ) = [] + fv (a :~> b ) = fv a <> fv b + fv (TCon _ ) = mempty fv (TSet _ a) = concatMap fv (M.elems a) fv (TList a ) = concatMap fv a fv (TMany ts) = concatMap fv ts @@ -585,15 +651,16 @@ normtype (a :~> b ) = normtype a :~> normtype b normtype (TCon a ) = TCon a normtype (TSet b a) = TSet b (M.map normtype a) - normtype (TList a ) = TList (map normtype a) - normtype (TMany ts) = TMany (map normtype ts) - normtype (TVar a ) = case Prelude.lookup a ord of - Just x -> TVar x - Nothing -> error "type variable not in signature" + normtype (TList a ) = TList (normtype <$> a) + normtype (TMany ts) = TMany (normtype <$> ts) + normtype (TVar a ) = + maybe + (error "type variable not in signature") + TVar + (List.lookup a ord) ---------------------------------------------------------------------------------- + -- * Constraint Solver ---------------------------------------------------------------------------------- newtype Solver m a = Solver (LogicT (StateT [TypeError] m) a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus, @@ -603,15 +670,15 @@ lift = Solver . lift . lift instance Monad m => MonadError TypeError (Solver m) where - throwError err = Solver $ lift (modify (err :)) >> mzero + throwError err = Solver $ lift (modify (err :)) *> empty catchError _ _ = error "This is never used" runSolver :: Monad m => Solver m a -> m (Either [TypeError] [a]) runSolver (Solver s) = do - res <- runStateT (observeAllT s) [] + res <- runStateT (observeAllT s) mempty pure $ case res of - (x : xs, _ ) -> Right (x : xs) - (_ , es) -> Left (nub es) + (x : xs, _ ) -> pure (x : xs) + (_ , es) -> Left (ordNub es) -- | The empty substitution emptySubst :: Subst @@ -623,11 +690,11 @@ Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1 unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst -unifyMany [] [] = return emptySubst +unifyMany [] [] = pure emptySubst unifyMany (t1 : ts1) (t2 : ts2) = do su1 <- unifies t1 t2 su2 <- unifyMany (apply su1 ts1) (apply su1 ts2) - return (su2 `compose` su1) + pure (su2 `compose` su1) unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2 allSameType :: [Type] -> Bool @@ -636,33 +703,33 @@ allSameType (x : y : ys) = x == y && allSameType (y : ys) unifies :: Monad m => Type -> Type -> Solver m Subst -unifies t1 t2 | t1 == t2 = return emptySubst +unifies t1 t2 | t1 == t2 = pure emptySubst unifies (TVar v) t = v `bind` t unifies t (TVar v) = v `bind` t unifies (TList xs) (TList ys) | allSameType xs && allSameType ys = case (xs, ys) of (x : _, y : _) -> unifies x y - _ -> return emptySubst + _ -> pure emptySubst | length xs == length ys = unifyMany xs ys -- We assume that lists of different lengths containing various types cannot -- be unified. unifies t1@(TList _ ) t2@(TList _ ) = throwError $ UnificationFail t1 t2 -unifies ( TSet True _) ( TSet True _) = return emptySubst +unifies ( TSet True _) ( TSet True _) = pure emptySubst unifies (TSet False b) (TSet True s) - | M.keys b `intersect` M.keys s == M.keys s = return emptySubst + | M.keys b `intersect` M.keys s == M.keys s = pure emptySubst unifies (TSet True s) (TSet False b) - | M.keys b `intersect` M.keys s == M.keys b = return emptySubst + | M.keys b `intersect` M.keys s == M.keys b = pure emptySubst unifies (TSet False s) (TSet False b) | null (M.keys b \\ M.keys s) = - return emptySubst + pure emptySubst unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4] unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2 unifies t1 (TMany t2s) = considering t2s >>- unifies t1 unifies t1 t2 = throwError $ UnificationFail t1 t2 bind :: Monad m => TVar -> Type -> Solver m Subst -bind a t | t == TVar a = return emptySubst +bind a t | t == TVar a = pure emptySubst | occursCheck a t = throwError $ InfiniteType a t - | otherwise = return (Subst $ Map.singleton a t) + | otherwise = pure (Subst $ Map.singleton a t) occursCheck :: FreeTypeVars a => TVar -> a -> Bool occursCheck a t = a `Set.member` ftv t @@ -681,11 +748,11 @@ considering xs = Solver $ LogicT $ \c n -> foldr c n xs solve :: MonadState InferState m => [Constraint] -> Solver m Subst -solve [] = return emptySubst +solve [] = pure emptySubst solve cs = solve' (nextSolvable cs) where solve' (EqConst t1 t2, cs) = unifies t1 t2 - >>- \su1 -> solve (apply su1 cs) >>- \su2 -> return (su2 `compose` su1) + >>- \su1 -> solve (apply su1 cs) >>- \su2 -> pure (su2 `compose` su1) solve' (ImpInstConst t1 ms t2, cs) = solve (ExpInstConst t1 (generalize ms t2) : cs) @@ -694,7 +761,9 @@ s' <- lift $ instantiate s solve (EqConst t s' : cs) -instance Monad m => Scoped (Judgment s) (InferT s m) where +instance + Monad m + => Scoped (Judgment s) (InferT s m) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(InferT s m) @(Judgment s) pushScopes = pushScopesReader diff --git a/src/Nix/Type/Type.hs b/src/Nix/Type/Type.hs --- a/src/Nix/Type/Type.hs +++ b/src/Nix/Type/Type.hs @@ -1,17 +1,19 @@ module Nix.Type.Type where -import qualified Data.HashMap.Lazy as M -import Data.Text ( Text ) +import Prelude hiding ( Type, TVar ) +import Data.Foldable ( foldr1 ) import Nix.Utils ( AttrSet ) +type Name = Text + -- | Hindrey-Milner type interface -newtype TVar = TV String +newtype TVar = TV Text deriving (Show, Eq, Ord) data Type = TVar TVar -- type variable - | TCon String -- known type + | TCon Text -- known type | TSet Bool (AttrSet Type) -- heterogeneous map, bool if variadic | TList [Type] -- heterogeneous list | (:~>) Type Type -- type -> type @@ -23,22 +25,21 @@ -- This models a set that unifies with any other set. typeSet :: Type -typeSet = TSet True M.empty +typeSet = TSet True mempty typeList :: Type -typeList = TList [] +typeList = TList mempty infixr 1 :~> typeFun :: [Type] -> Type +-- Please, replace with safe analog to `foldr1` typeFun = foldr1 (:~>) typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type -typeInt = TCon "integer" -typeFloat = TCon "float" -typeBool = TCon "boolean" +typeInt = TCon "integer" +typeFloat = TCon "float" +typeBool = TCon "boolean" typeString = TCon "string" -typePath = TCon "path" -typeNull = TCon "null" - -type Name = Text +typePath = TCon "path" +typeNull = TCon "null" diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -12,23 +10,16 @@ module Nix.Utils (module Nix.Utils, module X) where -import Control.Arrow ( (&&&) ) -import Control.Monad ( (<=<) ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.Free ( Free(..) ) import Control.Monad.Trans.Control ( MonadTransControl(..) ) import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import Data.Fix ( Fix(..) ) -import Data.Hashable ( Hashable ) -import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M -import Data.List ( sortOn ) -import Data.Monoid ( Endo ) -import Data.Text ( Text ) import qualified Data.Text as Text import qualified Data.Vector as V -import Lens.Family2 as X +import Lens.Family2 as X hiding ((&)) import Lens.Family2.Stock ( _1 , _2 ) @@ -37,20 +28,14 @@ #if ENABLE_TRACING import Debug.Trace as X #else -import Prelude as X - hiding ( putStr - , putStrLn - , print - ) +-- Well, since it is currently CPP intermingled with Debug.Trace, required to use String here. trace :: String -> a -> a trace = const id traceM :: Monad m => String -> m () -traceM = const (pure ()) +traceM = const pass #endif -$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix) - -type DList a = Endo [a] +$(makeLensesBy (\n -> pure ("_" <> n)) ''Fix) type AttrSet = HashMap Text @@ -63,17 +48,15 @@ -- | "Transform" here means a modification of a catamorphism. type Transform f a = (Fix f -> a) -> Fix f -> a -(<&>) :: Functor f => f a -> (a -> c) -> f c -(<&>) = flip (<$>) - -(??) :: Functor f => f (a -> b) -> a -> f b -fab ?? a = fmap ($ a) fab - loeb :: Functor f => f (f a -> a) -> f a -loeb x = go where go = fmap ($ go) x +loeb x = go + where + go = ($ go) <$> x loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a) -loebM f = mfix $ \a -> mapM ($ a) f +-- Sectioning here insures optimization happening. +loebM f = mfix $ \a -> (`traverse` f) ($ a) +{-# inline loebM #-} para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a para f = f . fmap (id &&& para f) . unFix @@ -87,24 +70,31 @@ cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a cataPM f x = f x <=< traverse (cataPM f) . unFix $ x -transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g -transport f (Fix x) = Fix $ fmap (transport f) (f x) - lifted :: (MonadTransControl u, Monad (u m), Monad m) => ((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b -lifted f k = liftWith (\run -> f (run . k)) >>= restoreT . pure +lifted f k = + do + lftd <- liftWith (\run -> f (run . k)) + restoreT $ pure lftd +-- | Replace: +-- @Pure a -> a@ +-- @Free -> Fix@ freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f freeToFix f = go where - go (Pure a) = f a - go (Free v) = Fix (fmap go v) + go = + free + f + $ Fix . (go <$>) fixToFree :: Functor f => Fix f -> Free f a -fixToFree = Free . go where go (Fix f) = fmap (Free . go) f +fixToFree = Free . go + where + go (Fix f) = Free . go <$> f -- | adi is Abstracting Definitional Interpreters: -- @@ -114,7 +104,7 @@ -- representation: allows threading layers through existing structure, only -- in this case through behavior. adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a -adi f g = g (f . fmap (adi f g) . unFix) +adi f g = g $ f . (adi f g <$>) . unFix adiM :: (Traversable t, Monad m) @@ -122,10 +112,10 @@ -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a -adiM f g = g ((f <=< traverse (adiM f g)) . unFix) +adiM f g = g $ f <=< traverse (adiM f g) . unFix class Has a b where - hasLens :: Lens' a b + hasLens :: Lens' a b instance Has a a where hasLens f = f @@ -141,8 +131,8 @@ A.Object m -> A.pairs . mconcat - . fmap (\(k, v) -> A.pair k $ toEncodingSorted v) - . sortOn fst + . ((\(k, v) -> A.pair k $ toEncodingSorted v) <$>) + . sortWith fst $ M.toList m A.Array l -> A.list toEncodingSorted $ V.toList l v -> A.toEncoding v @@ -152,16 +142,14 @@ -- | @NIX_PATH@ is colon-separated, but can also contain URLs, which have a colon -- (i.e. @https://...@) uriAwareSplit :: Text -> [(Text, NixPathEntryType)] -uriAwareSplit = go where - go str = case Text.break (== ':') str of +uriAwareSplit txt = + case Text.break (== ':') txt of (e1, e2) - | Text.null e2 - -> [(e1, PathEntryPath)] - | Text.pack "://" `Text.isPrefixOf` e2 - -> let ((suffix, _) : path) = go (Text.drop 3 e2) - in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path - | otherwise - -> (e1, PathEntryPath) : go (Text.drop 1 e2) + | Text.null e2 -> [(e1, PathEntryPath)] + | "://" `Text.isPrefixOf` e2 -> + let ((suffix, _) : path) = uriAwareSplit (Text.drop 3 e2) in + (e1 <> "://" <> suffix, PathEntryURI) : path + | otherwise -> (e1, PathEntryPath) : uriAwareSplit (Text.drop 1 e2) alterF :: (Eq k, Hashable k, Functor f) @@ -169,6 +157,86 @@ -> k -> HashMap k v -> f (HashMap k v) -alterF f k m = f (M.lookup k m) <&> \case - Nothing -> M.delete k m - Just v -> M.insert k v m +alterF f k m = + maybe + (M.delete k m) + (\ v -> M.insert k v m) + <$> f (M.lookup k m) + + +-- | Analog for @bool@ or @maybe@, for list-like cons structures. +list + :: Foldable t + => b -> (t a -> b) -> t a -> b +list e f l = + bool + (f l) + e + (null l) +{-# inline list #-} + +-- | Lambda analog of @maybe@ or @either@ for Free monad. +free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b +free fP fF fr = + case fr of + Pure a -> fP a + Free fa -> fF fa +{-# inline free #-} + + +whenTrue :: (Monoid a) + => a -> Bool -> a +whenTrue = + bool + mempty +{-# inline whenTrue #-} + +whenFalse :: (Monoid a) + => a -> Bool -> a +whenFalse f = + bool + f + mempty +{-# inline whenFalse #-} + +whenFree :: (Monoid b) + => (f (Free f a) -> b) -> Free f a -> b +whenFree = + free + mempty +{-# inline whenFree #-} + +whenPure :: (Monoid b) + => (a -> b) -> Free f a -> b +whenPure f = + free + f + mempty +{-# inline whenPure #-} + + +-- | Apply a single function to both components of a pair. +-- +-- > both succ (1,2) == (2,3) +-- +-- Taken From package @extra@ +both :: (a -> b) -> (a, a) -> (b, b) +both f (x,y) = (f x, f y) +{-# inline both #-} + + +-- | Duplicates object into a tuple. +dup :: a -> (a, a) +dup x = (x, x) +{-# inline dup #-} + +-- | From @utility-ht@ for tuple laziness. +mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) +mapPair ~(f,g) ~(a,b) = (f a, g b) +{-# inline mapPair #-} + +-- After migration from the @relude@ - @relude: pass -> stub@ +-- | @pure mempty@: Short-curcuit, stub. +stub :: (Applicative f, Monoid a) => f a +stub = pure mempty +{-# inline stub #-} diff --git a/src/Nix/Utils/Fix1.hs b/src/Nix/Utils/Fix1.hs --- a/src/Nix/Utils/Fix1.hs +++ b/src/Nix/Utils/Fix1.hs @@ -1,61 +1,106 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Nix.Utils.Fix1 where -import Control.Applicative ( Alternative ) -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail -#endif -import Control.Monad ( MonadPlus ) import Control.Monad.Fix ( MonadFix ) -import Control.Monad.IO.Class ( MonadIO ) +import Control.Monad.Ref ( MonadAtomicRef(..) + , MonadRef(..) + ) import Control.Monad.Catch ( MonadCatch , MonadMask , MonadThrow ) -import Control.Monad.Reader ( MonadReader ) -import Control.Monad.State ( MonadState ) -- | The fixpoint combinator, courtesy of Gregory Malecha. -- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced newtype Fix1 (t :: (k -> *) -> k -> *) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a } -deriving instance Functor (t (Fix1 t)) => Functor (Fix1 t) -deriving instance Applicative (t (Fix1 t)) => Applicative (Fix1 t) -deriving instance Alternative (t (Fix1 t)) => Alternative (Fix1 t) -deriving instance Monad (t (Fix1 t)) => Monad (Fix1 t) -deriving instance MonadPlus (t (Fix1 t)) => MonadPlus (Fix1 t) -deriving instance MonadFix (t (Fix1 t)) => MonadFix (Fix1 t) -deriving instance MonadIO (t (Fix1 t)) => MonadIO (Fix1 t) -deriving instance MonadCatch (t (Fix1 t)) => MonadCatch (Fix1 t) -deriving instance MonadThrow (t (Fix1 t)) => MonadThrow (Fix1 t) +deriving instance Functor (t (Fix1 t)) + => Functor (Fix1 t) +deriving instance Applicative (t (Fix1 t)) + => Applicative (Fix1 t) +deriving instance Alternative (t (Fix1 t)) + => Alternative (Fix1 t) +deriving instance Monad (t (Fix1 t)) + => Monad (Fix1 t) +deriving instance MonadPlus (t (Fix1 t)) + => MonadPlus (Fix1 t) +deriving instance MonadFix (t (Fix1 t)) + => MonadFix (Fix1 t) +deriving instance MonadIO (t (Fix1 t)) + => MonadIO (Fix1 t) +deriving instance MonadCatch (t (Fix1 t)) + => MonadCatch (Fix1 t) +deriving instance MonadThrow (t (Fix1 t)) + => MonadThrow (Fix1 t) -deriving instance MonadReader e (t (Fix1 t)) => MonadReader e (Fix1 t) -deriving instance MonadState s (t (Fix1 t)) => MonadState s (Fix1 t) +deriving instance MonadReader e (t (Fix1 t)) + => MonadReader e (Fix1 t) +deriving instance MonadState s (t (Fix1 t)) + => MonadState s (Fix1 t) newtype Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k) = Fix1T { unFix1T :: t (Fix1T t m) m a } -deriving instance Functor (t (Fix1T t m) m) => Functor (Fix1T t m) -deriving instance Applicative (t (Fix1T t m) m) => Applicative (Fix1T t m) -deriving instance Alternative (t (Fix1T t m) m) => Alternative (Fix1T t m) -deriving instance Monad (t (Fix1T t m) m) => Monad (Fix1T t m) -deriving instance MonadFail (t (Fix1T t m) m) => MonadFail (Fix1T t m) -deriving instance MonadPlus (t (Fix1T t m) m) => MonadPlus (Fix1T t m) -deriving instance MonadFix (t (Fix1T t m) m) => MonadFix (Fix1T t m) -deriving instance MonadIO (t (Fix1T t m) m) => MonadIO (Fix1T t m) -deriving instance MonadCatch (t (Fix1T t m) m) => MonadCatch (Fix1T t m) -deriving instance MonadThrow (t (Fix1T t m) m) => MonadThrow (Fix1T t m) -deriving instance MonadMask (t (Fix1T t m) m) => MonadMask (Fix1T t m) +deriving instance Functor (t (Fix1T t m) m) + => Functor (Fix1T t m) +deriving instance Applicative (t (Fix1T t m) m) + => Applicative (Fix1T t m) +deriving instance Alternative (t (Fix1T t m) m) + => Alternative (Fix1T t m) +deriving instance Monad (t (Fix1T t m) m) + => Monad (Fix1T t m) +deriving instance MonadFail (t (Fix1T t m) m) + => MonadFail (Fix1T t m) +deriving instance MonadPlus (t (Fix1T t m) m) + => MonadPlus (Fix1T t m) +deriving instance MonadFix (t (Fix1T t m) m) + => MonadFix (Fix1T t m) +deriving instance MonadIO (t (Fix1T t m) m) + => MonadIO (Fix1T t m) +deriving instance MonadCatch (t (Fix1T t m) m) + => MonadCatch (Fix1T t m) +deriving instance MonadThrow (t (Fix1T t m) m) + => MonadThrow (Fix1T t m) +deriving instance MonadMask (t (Fix1T t m) m) + => MonadMask (Fix1T t m) -deriving instance MonadReader e (t (Fix1T t m) m) => MonadReader e (Fix1T t m) -deriving instance MonadState s (t (Fix1T t m) m) => MonadState s (Fix1T t m) +deriving instance MonadReader e (t (Fix1T t m) m) + => MonadReader e (Fix1T t m) +deriving instance MonadState s (t (Fix1T t m) m) + => MonadState s (Fix1T t m) + + +type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) + +instance + ( MonadFix1T t m + , MonadRef m + ) + => MonadRef (Fix1T t m) + where + type Ref (Fix1T t m) = Ref m + + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + + +instance + ( MonadFix1T t m + , MonadAtomicRef m + ) + => MonadAtomicRef (Fix1T t m) + where + atomicModifyRef r = lift . atomicModifyRef r {- diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} @@ -16,35 +17,108 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} -module Nix.Value where +-- | The core of the type system, Nix language values +module Nix.Value +where -import Control.Comonad ( Comonad, extract ) -import Control.Exception ( Exception ) -import Control.Monad ( (<=<) ) +import Prelude hiding ( force ) +import Nix.Utils +import Control.Comonad ( Comonad + , extract + ) import Control.Monad.Free ( Free(..) - , hoistFree, iter, iterM ) -import Control.Monad.Trans.Class ( MonadTrans, lift ) -import qualified Data.Aeson as A + , hoistFree + , iter + , iterM + ) +import qualified Data.Aeson as Aeson import Data.Functor.Classes ( Show1 , liftShowsPrec - , showsUnaryWith ) -import Data.HashMap.Lazy ( HashMap ) -import Data.Text ( Text ) -import Data.Typeable ( Typeable ) -import GHC.Generics ( Generic ) + , showsUnaryWith + , Eq1(liftEq) ) +import Data.Eq.Deriving +import qualified Text.Show +import Text.Show ( showsPrec + , showString + , showParen + ) import Lens.Family2.Stock ( _1 ) import Lens.Family2.TH ( makeTraversals - , makeLenses ) + , makeLenses + ) import Nix.Atoms import Nix.Expr.Types import Nix.Expr.Types.Annotated import Nix.String import Nix.Thunk -import Nix.Utils --- | 'NValue' is the most reduced form of a 'NExpr' after evaluation is --- completed. 's' is related to the type of errors that might occur during --- construction or use of a value. + +-- * @__NValueF__@: Base functor + +-- | An NValueF p m r represents all the possible types of Nix values. +-- +-- Is is the base functor to form the Free monad of nix expressions. +-- The parameter `r` represents Nix values in their final form (NValue). +-- The parameter `p` represents exactly the same type, but is kept separate +-- or it would prevent NValueF from being a proper functor. +-- It is intended to be hard-coded to the same final type as r. +-- `m` is the monad in which evaluations will run. + +-- | An NValue' t f m a is a magic layer between NValueF and the Free monad construction. +-- +-- It fixes the `p` parameter of NValueF to the final NValue type, making the +-- definition of NValue' and NValue depend on each other in a recursive +-- fashion. +-- +-- It also introduces a `f` parameter for a custom functor that can be used +-- to wrap each intermediate value in the reduced expression tree. +-- This is where expression evaluations can store annotations and other +-- useful information. +-- +-- `t` is not really used here, but is needed to type the (NValue t f m) +-- used to tie the knot of the `p` parameter in the inner NValueF. +-- +-- `a` is will be an `NValue t f m` when NValue' functor is turned into a +-- Free monad. + +-- | 'NValue t f m' is the most reduced form of a 'NExpr' after evaluation is +-- completed. It is a layer cake of NValueF base values, wrapped in the f +-- functor and into the Free recursive construction. +-- +-- Concretely, an NValue t f m can either be a thunk, representing a value +-- yet to be evaluated (Pure t), or a know value in WHNF +-- (Free (NValue' t f m (NValue t f m))) = (Free (f (NValueF NValue m NValue)) +-- That is, a base value type, wrapped into the generic `f` +-- functor, and based on other NValue's, which can in turn be either thunks, +-- or more already WHNF evaluated values. +-- +-- As an example, the value `[1]` will be represented as +-- +-- Free (f (NVListF [ +-- (Free (f (NVConstantF (NInt 1)))) +-- ])) +-- +-- Should this 1 be a laziy and yet unevaluated value, it would be represented as +-- +-- Free (f (NVListF [ (Pure t) ])) +-- +-- Where the t is evaluator dependant, and should contain anough information +-- to be evaluated to an NValue when needed. `demand` of `force` are used to +-- turn a potential thunk into a `m (NValue t f m)`. +-- +-- Of course, trees can be much bigger. +-- +-- The number of layers and type aliases for similar things is huge, so +-- this module provides ViewPatterns for each NValueF constructor. +-- +-- For example, the pattern NVStr' ns matches a NValue' containing an NVStrF, +-- and bind that NVStrF to ns, ignoring the f functor inside. +-- Similarly, the pattern NVStr ns (without prime mark) will match the inner +-- NVstrF value inside an NValue. Of course, the patterns are declined for +-- all the NValueF constructors. The non primed version also has an NVThunk t +-- pattern to account for the possibility of an NValue to no be fully +-- evaluated yet, as opposed to an NValue'. + data NValueF p m r = NVConstantF NAtom -- | A string has a value and a context, which can be used to record what a @@ -65,12 +139,46 @@ -- Note that 'm r' is being used here because effectively a function -- and its set of default arguments is "never fully evaluated". This -- enforces in the type that it must be re-evaluated for each call. - | NVBuiltinF String (p -> m r) + | NVBuiltinF Text (p -> m r) -- ^ A builtin function is itself already in normal form. Also, it may -- or may not choose to evaluate its argument in the production of a -- result. - deriving (Generic, Typeable, Functor) + deriving (Generic, Typeable, Functor) + +-- ** Eq1 + +instance Eq1 (NValueF p m) where + liftEq _ (NVConstantF x) (NVConstantF y) = x == y + liftEq _ (NVStrF x) (NVStrF y) = x == y + liftEq eq (NVListF x) (NVListF y) = liftEq eq x y + liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y + liftEq _ (NVPathF x ) (NVPathF y ) = x == y + liftEq _ _ _ = False + + +-- ** Show + +instance Show r => Show (NValueF p m r) where + showsPrec d = go + where + go :: NValueF p m r -> String -> String + go = \case + (NVConstantF atom ) -> showsCon1 "NVConstant" atom + (NVStrF ns ) -> showsCon1 "NVStr" (stringIgnoreContext ns) + (NVListF lst ) -> showsCon1 "NVList" lst + (NVSetF attrs _ ) -> showsCon1 "NVSet" attrs + (NVClosureF params _ ) -> showsCon1 "NVClosure" params + (NVPathF path ) -> showsCon1 "NVPath" path + (NVBuiltinF name _ ) -> showsCon1 "NVBuiltin" name + + showsCon1 :: Show a => String -> a -> String -> String + showsCon1 con a = + showParen (d > 10) $ showString (con <> " ") . showsPrec 11 a + + +-- ** Foldable + -- | Folds what the value is known to contain at time of fold. instance Foldable (NValueF p m) where foldMap f = \case @@ -82,43 +190,10 @@ NVClosureF _ _ -> mempty NVBuiltinF _ _ -> mempty -instance Show r => Show (NValueF p m r) where - showsPrec = flip go where - go (NVConstantF atom ) = showsCon1 "NVConstant" atom - go (NVStrF ns ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns) - go (NVListF lst ) = showsCon1 "NVList" lst - go (NVSetF attrs _) = showsCon1 "NVSet" attrs - go (NVClosureF p _) = showsCon1 "NVClosure" p - go (NVPathF p ) = showsCon1 "NVPath" p - go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name - showsCon1 :: Show a => String -> a -> Int -> String -> String - showsCon1 con a d = - showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a - -lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r -lmapNValueF f = \case - NVConstantF a -> NVConstantF a - NVStrF s -> NVStrF s - NVPathF p -> NVPathF p - NVListF l -> NVListF l - NVSetF s p -> NVSetF s p - NVClosureF p g -> NVClosureF p (g . f) - NVBuiltinF s g -> NVBuiltinF s (g . f) - -hoistNValueF - :: (forall x . m x -> n x) - -> NValueF p m a - -> NValueF p n a -hoistNValueF lft = \case - NVConstantF a -> NVConstantF a - NVStrF s -> NVStrF s - NVPathF p -> NVPathF p - NVListF l -> NVListF l - NVSetF s p -> NVSetF s p - NVClosureF p g -> NVClosureF p (lft . g) - NVBuiltinF s g -> NVBuiltinF s (lft . g) +-- ** Traversable +-- | @traverse@ sequenceNValueF :: (Functor n, Monad m, Applicative n) => (forall x . n x -> m x) @@ -129,10 +204,18 @@ NVStrF s -> pure $ NVStrF s NVPathF p -> pure $ NVPathF p NVListF l -> NVListF <$> sequenceA l - NVSetF s p -> NVSetF <$> sequenceA s <*> pure p + NVSetF s p -> + liftA2 + NVSetF + (sequenceA s) + (pure p) NVClosureF p g -> pure $ NVClosureF p (transform <=< g) NVBuiltinF s g -> pure $ NVBuiltinF s (transform <=< g) + +-- ** Monad + +-- | @bind@ bindNValueF :: (Monad m, Monad n) => (forall x . n x -> m x) @@ -144,16 +227,27 @@ NVStrF s -> pure $ NVStrF s NVPathF p -> pure $ NVPathF p NVListF l -> NVListF <$> traverse f l - NVSetF s p -> NVSetF <$> traverse f s <*> pure p + NVSetF s p -> + liftA2 + NVSetF + (traverse f s) + (pure p) NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g) NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g) + +-- *** MonadTrans + +-- | @lift@ liftNValueF :: (MonadTrans u, Monad m) => NValueF p m a -> NValueF p (u m) a liftNValueF = hoistNValueF lift +-- **** MonadTransUnlift + +-- | @unlift@ unliftNValueF :: (MonadTrans u, Monad m) => (forall x . u m x -> m x) @@ -161,55 +255,127 @@ -> NValueF p m a unliftNValueF = hoistNValueF -type MonadDataContext f (m :: * -> *) - = (Comonad f, Applicative f, Traversable f, Monad m) +-- **** Utils +-- | Back & forth hoisting in the monad stack +hoistNValueF + :: (forall x . m x -> n x) + -> NValueF p m a + -> NValueF p n a +hoistNValueF lft = + \case + -- Pass-through the: + -- [ NVConstantF a + -- , NVStrF s + -- , NVPathF p + -- , NVListF l + -- , NVSetF s p + -- ] + NVConstantF a -> NVConstantF a + NVStrF s -> NVStrF s + NVPathF p -> NVPathF p + NVListF l -> NVListF l + NVSetF s p -> NVSetF s p + NVBuiltinF s g -> NVBuiltinF s (lft . g) + NVClosureF p g -> NVClosureF p (lft . g) +{-# inline hoistNValueF #-} + +-- * @__NValue'__@: forming the (F(A)) + -- | At the time of constructor, the expected arguments to closures are values -- that may contain thunks. The type of such thunks are fixed at that time. -newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) } - deriving (Generic, Typeable, Functor, Foldable) +newtype NValue' t f m a = + NValue' + { + -- | Applying F-algebra Base functor data type (@NValueF@) to the F-algebra carrier (@NValue@), forming the \( F(A)-> A \)). + _nValue :: f (NValueF (NValue t f m) m a) + } + deriving (Generic, Typeable, Functor, Foldable) instance (Comonad f, Show a) => Show (NValue' t f m a) where - show (NValue (extract -> v)) = show v + show (NValue' (extract -> v)) = show v + +-- ** Show1 + instance Comonad f => Show1 (NValue' t f m) where liftShowsPrec sp sl p = \case NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom NVStr' ns -> - showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns) + showsUnaryWith showsPrec "NVStrF" p (stringIgnoreContext ns) NVList' lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst NVSet' attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs NVPath' path -> showsUnaryWith showsPrec "NVPathF" p path NVClosure' c _ -> showsUnaryWith showsPrec "NVClosureF" p c NVBuiltin' name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name - _ -> error "Pattern synonyms mask coverage" + +-- ** Traversable + +-- | @traverse@ sequenceNValue' :: (Functor n, Traversable f, Monad m, Applicative n) => (forall x . n x -> m x) -> NValue' t f m (n a) -> n (NValue' t f m a) -sequenceNValue' transform (NValue v) = - NValue <$> traverse (sequenceNValueF transform) v +sequenceNValue' transform (NValue' v) = + NValue' <$> traverse (sequenceNValueF transform) v -bindNValue' - :: (Traversable f, Monad m, Monad n) - => (forall x . n x -> m x) - -> (a -> n b) + +-- ** Profunctor + +-- | @lmap@ +lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r +lmapNValueF f = \case + NVConstantF a -> NVConstantF a + NVStrF s -> NVStrF s + NVPathF p -> NVPathF p + NVListF l -> NVListF l + NVSetF s p -> NVSetF s p + NVClosureF p g -> NVClosureF p (g . f) + NVBuiltinF s g -> NVBuiltinF s (g . f) + + +-- ** Free + +-- | @iter@ +iterNValue' + :: forall t f m a r + . MonadDataContext f m + => (a -> (NValue' t f m a -> r) -> r) + -> (NValue' t f m r -> r) -> NValue' t f m a - -> n (NValue' t f m b) -bindNValue' transform f (NValue v) = - NValue <$> traverse (bindNValueF transform f) v + -> r +iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f)) +-- *** Utils + +-- | @hoistFree@: Back & forth hoisting in the monad stack hoistNValue' :: (Functor m, Functor n, Functor f) => (forall x . n x -> m x) -> (forall x . m x -> n x) -> NValue' t f m a -> NValue' t f n a -hoistNValue' run lft (NValue v) = - NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF lft) v) +hoistNValue' run lft (NValue' v) = + NValue' $ lmapNValueF (hoistNValue lft run) . hoistNValueF lft <$> v +{-# inline hoistNValue' #-} +-- ** Monad + +-- |@bind@ +bindNValue' + :: (Traversable f, Monad m, Monad n) + => (forall x . n x -> m x) + -> (a -> n b) + -> NValue' t f m a + -> n (NValue' t f m b) +bindNValue' transform f (NValue' v) = + NValue' <$> traverse (bindNValueF transform f) v + +-- *** MonadTrans + +-- | @lift@ liftNValue' :: (MonadTrans u, Monad m, Functor (u m), Functor f) => (forall x . u m x -> m x) @@ -217,55 +383,138 @@ -> NValue' t f (u m) a liftNValue' run = hoistNValue' run lift +-- **** MonadTransUnlift + +-- | @unlift@ unliftNValue' :: (MonadTrans u, Monad m, Functor (u m), Functor f) - => (forall x . u m x -> m x) + => (forall x . u m x -> m x) -- aka "run" -> NValue' t f (u m) a -> NValue' t f m a -unliftNValue' run = hoistNValue' lift run +unliftNValue' = hoistNValue' lift -iterNValue' - :: forall t f m a r - . MonadDataContext f m - => (a -> (NValue' t f m a -> r) -> r) - -> (NValue' t f m r -> r) - -> NValue' t f m a - -> r -iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f)) --- | A 'NValue t f m' is --- a value in head normal form, where only the "top layer" has been --- evaluated. An action of type 'm (NValue t f m)' is a pending evaluation that --- has yet to be performed. An 't' is either a pending evaluation, or --- a value in head normal form. +-- ** Bijective Hask subcategory <-> @NValue'@ +-- *** @F: Hask subcategory → NValue'@ -- +-- #mantra# +-- $Methods @F: Hask → NValue'@ +-- +-- Since Haskell and Nix are both recursive purely functional lazy languages. +-- And since recursion-schemes. +-- It is possible to create a direct functor between the Hask and Nix categories. +-- Or make Nix a DLS language of Haskell, embed it into a Hask, if you would like. +-- Of course, we mean: pick Hask subcategory and form Nix Category from it. +-- Take subcategory of Hask, and by applying functor to it - have a Nix Category. +-- Wouldn't it be cool and fast? +-- +-- In fact - it is what we do here. +-- +-- Since it is a proper way of scientific implementation, we would eventually form a +-- lawful functor. +-- +-- Facts of which are seen below: + + +-- | Haskell constant to the Nix constant, +nvConstant' :: Applicative f + => NAtom + -> NValue' t f m r +nvConstant' = NValue' . pure . NVConstantF + + +-- | Haskell text & context to the Nix text & context, +nvStr' :: Applicative f + => NixString + -> NValue' t f m r +nvStr' = NValue' . pure . NVStrF + + +-- | Haskell @FilePath@ to the Nix path, +nvPath' :: Applicative f + => FilePath + -> NValue' t f m r +nvPath' = NValue' . pure . NVPathF + + +-- | Haskell @[]@ to the Nix @[]@, +nvList' :: Applicative f + => [r] + -> NValue' t f m r +nvList' = NValue' . pure . NVListF + + +-- | Haskell key-value to the Nix key-value, +nvSet' :: Applicative f + => HashMap Text SourcePos + -> HashMap Text r + -> NValue' t f m r +nvSet' x s = NValue' $ pure $ NVSetF s x + + +-- | Haskell closure to the Nix closure, +nvClosure' :: (Applicative f, Functor m) + => Params () + -> (NValue t f m + -> m r + ) + -> NValue' t f m r +nvClosure' x f = NValue' $ pure $ NVClosureF x f + + +-- | Haskell functions to the Nix functions! +nvBuiltin' :: (Applicative f, Functor m) + => Text + -> (NValue t f m -> m r) + -> NValue' t f m r +nvBuiltin' name f = NValue' $ pure $ NVBuiltinF name f + + +-- So above we have maps of Hask subcategory objects to Nix objects, +-- and Hask subcategory morphisms to Nix morphisms. + +-- *** @F: NValue -> NValue'@ + +-- | Module pattens use @language PatternSynonyms@: unidirectional synonyms (@<-@), +-- and @ViewPatterns@: (@->@) at the same time. +-- @ViewPatterns Control.Comonad.extract@ extracts +-- from the @NValue (Free (NValueF a))@ +-- the @NValueF a@. Which is @NValueF p m r@. Since it extracted from the +-- @NValue@, which is formed by \( (F a -> a) F a \) in the first place. +-- So @NValueF p m r@ which is extracted here, internally holds the next NValue. +pattern NVConstant' x <- NValue' (extract -> NVConstantF x) +pattern NVStr' ns <- NValue' (extract -> NVStrF ns) +pattern NVPath' x <- NValue' (extract -> NVPathF x) +pattern NVList' l <- NValue' (extract -> NVListF l) +pattern NVSet' s x <- NValue' (extract -> NVSetF s x) +pattern NVClosure' x f <- NValue' (extract -> NVClosureF x f) +pattern NVBuiltin' name f <- NValue' (extract -> NVBuiltinF name f) +{-# COMPLETE NVConstant', NVStr', NVPath', NVList', NVSet', NVClosure', NVBuiltin' #-} + + +-- * @__NValue__@: Nix language values + +-- | 'NValue t f m' is +-- a value in head normal form (it means only the tip of it has been +-- evaluated to the normal form, while the rest of it is in lazy +-- not evaluated form (thunk), this known as WHNF). +-- +-- An action 'm (NValue t f m)' is a pending evaluation that +-- has yet to be performed. +-- +-- An 't' is either: +-- * a pending evaluation. +-- * a value in head normal form. +-- -- The 'Free' structure is used here to represent the possibility that --- cycles may appear during normalization. +-- Nix language allows cycles that may appear during normalization. type NValue t f m = Free (NValue' t f m) t -hoistNValue - :: (Functor m, Functor n, Functor f) - => (forall x . n x -> m x) - -> (forall x . m x -> n x) - -> NValue t f m - -> NValue t f n -hoistNValue run lft = hoistFree (hoistNValue' run lft) -liftNValue - :: (MonadTrans u, Monad m, Functor (u m), Functor f) - => (forall x . u m x -> m x) - -> NValue t f m - -> NValue t f (u m) -liftNValue run = hoistNValue run lift - -unliftNValue - :: (MonadTrans u, Monad m, Functor (u m), Functor f) - => (forall x . u m x -> m x) - -> NValue t f (u m) - -> NValue t f m -unliftNValue run = hoistNValue lift run +-- ** Free +-- | @iter@ iterNValue :: forall t f m r . MonadDataContext f m @@ -275,6 +524,8 @@ -> r iterNValue k f = iter f . fmap (\t -> k t (iterNValue k f)) + +-- | @iter@ for monadic values iterNValueM :: (MonadDataContext f m, Monad n) => (forall x . n x -> m x) @@ -288,103 +539,163 @@ go (Pure x) = Pure <$> x go (Free fa) = Free <$> bindNValue' transform go fa -pattern NVThunk t <- Pure t +-- *** Utils -nvThunk :: Applicative f => t -> NValue t f m +-- | @hoistFree@, Back & forth hoisting in the monad stack +hoistNValue + :: (Functor m, Functor n, Functor f) + => (forall x . n x -> m x) + -> (forall x . m x -> n x) + -> NValue t f m + -> NValue t f n +hoistNValue run lft = hoistFree (hoistNValue' run lft) +{-# inline hoistNValue #-} + +-- ** MonadTrans + +-- | @lift@ +liftNValue + :: (MonadTrans u, Monad m, Functor (u m), Functor f) + => (forall x . u m x -> m x) + -> NValue t f m + -> NValue t f (u m) +liftNValue run = hoistNValue run lift + + +-- *** MonadTransUnlift +-- | @unlift@ +unliftNValue + :: (MonadTrans u, Monad m, Functor (u m), Functor f) + => (forall x . u m x -> m x) -- aka "run" + -> NValue t f (u m) + -> NValue t f m +unliftNValue = hoistNValue lift + + +-- ** Methods @F: Hask → NValue@ +-- +-- $Methods @F: Hask → NValue@ +-- +-- The morphisms of the functor @Hask → NValue@. +-- Continuation of the mantra: "Nix.Value#mantra" + + +-- | Life of a Haskell thunk to the life of a Nix thunk, +nvThunk :: Applicative f + => t + -> NValue t f m nvThunk = Pure -pattern NVConstant' x <- NValue (extract -> NVConstantF x) -pattern NVConstant x <- Free (NVConstant' x) -nvConstant' :: Applicative f => NAtom -> NValue' t f m r -nvConstant' = NValue . pure . NVConstantF -nvConstant :: Applicative f => NAtom -> NValue t f m +-- | Life of a Haskell constant to the life of a Nix constant, +nvConstant :: Applicative f + => NAtom + -> NValue t f m nvConstant = Free . nvConstant' -pattern NVStr' ns <- NValue (extract -> NVStrF ns) -pattern NVStr ns <- Free (NVStr' ns) -nvStr' :: Applicative f => NixString -> NValue' t f m r -nvStr' = NValue . pure . NVStrF -nvStr :: Applicative f => NixString -> NValue t f m +-- | Life of a Haskell sting & context to the life of a Nix string & context, +nvStr :: Applicative f + => NixString + -> NValue t f m nvStr = Free . nvStr' -pattern NVPath' x <- NValue (extract -> NVPathF x) -pattern NVPath x <- Free (NVPath' x) -nvPath' :: Applicative f => FilePath -> NValue' t f m r -nvPath' = NValue . pure . NVPathF -nvPath :: Applicative f => FilePath -> NValue t f m +-- | Life of a Haskell FilePath to the life of a Nix path +nvPath :: Applicative f + => FilePath + -> NValue t f m nvPath = Free . nvPath' -pattern NVList' l <- NValue (extract -> NVListF l) -pattern NVList l <- Free (NVList' l) -nvList' :: Applicative f => [r] -> NValue' t f m r -nvList' = NValue . pure . NVListF -nvList :: Applicative f => [NValue t f m] -> NValue t f m +nvList :: Applicative f + => [NValue t f m] + -> NValue t f m nvList = Free . nvList' -pattern NVSet' s x <- NValue (extract -> NVSetF s x) -pattern NVSet s x <- Free (NVSet' s x) -nvSet' :: Applicative f - => HashMap Text r -> HashMap Text SourcePos -> NValue' t f m r -nvSet' s x = NValue $ pure $ NVSetF s x nvSet :: Applicative f - => HashMap Text (NValue t f m) -> HashMap Text SourcePos -> NValue t f m -nvSet s x = Free $ nvSet' s x + => HashMap Text SourcePos + -> HashMap Text (NValue t f m) + -> NValue t f m +nvSet x s = Free $ nvSet' x s -pattern NVClosure' x f <- NValue (extract -> NVClosureF x f) -pattern NVClosure x f <- Free (NVClosure' x f) -nvClosure' :: (Applicative f, Functor m) - => Params () -> (NValue t f m -> m r) -> NValue' t f m r -nvClosure' x f = NValue $ pure $ NVClosureF x f nvClosure :: (Applicative f, Functor m) - => Params () -> (NValue t f m -> m (NValue t f m)) -> NValue t f m + => Params () + -> (NValue t f m + -> m (NValue t f m) + ) + -> NValue t f m nvClosure x f = Free $ nvClosure' x f -pattern NVBuiltin' name f <- NValue (extract -> NVBuiltinF name f) -pattern NVBuiltin name f <- Free (NVBuiltin' name f) -nvBuiltin' :: (Applicative f, Functor m) - => String -> (NValue t f m -> m r) -> NValue' t f m r -nvBuiltin' name f = NValue $ pure $ NVBuiltinF name f nvBuiltin :: (Applicative f, Functor m) - => String -> (NValue t f m -> m (NValue t f m)) -> NValue t f m + => Text + -> (NValue t f m + -> m (NValue t f m) + ) + -> NValue t f m nvBuiltin name f = Free $ nvBuiltin' name f + builtin :: forall m f t . (MonadThunk t m (NValue t f m), MonadDataContext f m) - => String - -> (NValue t f m -> m (NValue t f m)) + => Text + -> ( NValue t f m + -> m (NValue t f m) + ) -> m (NValue t f m) builtin name f = pure $ nvBuiltin name $ \a -> f a + builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => String - -> (NValue t f m -> NValue t f m -> m (NValue t f m)) + => Text + -> ( NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) -> m (NValue t f m) builtin2 name f = builtin name $ \a -> builtin name $ \b -> f a b + builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => String - -> ( NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) - ) + => Text + -> ( NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) -> m (NValue t f m) builtin3 name f = builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c +-- *** @F: Evaluation -> NValue@ + +pattern NVThunk t <- Pure t +pattern NVValue v <- Free v +{-# COMPLETE NVThunk, NVValue #-} +pattern NVConstant x <- Free (NVConstant' x) +pattern NVStr ns <- Free (NVStr' ns) +pattern NVPath x <- Free (NVPath' x) +pattern NVList l <- Free (NVList' l) +pattern NVSet s x <- Free (NVSet' s x) +pattern NVClosure x f <- Free (NVClosure' x f) +pattern NVBuiltin name f <- Free (NVBuiltin' name f) +{-# COMPLETE NVThunk, NVConstant, NVStr, NVPath, NVList, NVSet, NVClosure, NVBuiltin #-} + + + +-- * @TStringContext@ + data TStringContext = NoContext | HasContext deriving Show +-- * @ValueType@ + data ValueType = TInt | TFloat @@ -398,42 +709,58 @@ | TBuiltin deriving Show + +-- | Determine type of a value valueType :: NValueF a m r -> ValueType -valueType = \case - NVConstantF a -> case a of - NURI _ -> TString NoContext - NInt _ -> TInt - NFloat _ -> TFloat - NBool _ -> TBool - NNull -> TNull - NVStrF ns | stringHasContext ns -> TString HasContext - | otherwise -> TString NoContext - NVListF{} -> TList - NVSetF{} -> TSet - NVClosureF{} -> TClosure - NVPathF{} -> TPath - NVBuiltinF{} -> TBuiltin +valueType = + \case + NVConstantF a -> + case a of + NURI _ -> TString NoContext + NInt _ -> TInt + NFloat _ -> TFloat + NBool _ -> TBool + NNull -> TNull + NVStrF ns -> + TString $ + bool + NoContext + HasContext + (stringHasContext ns) + NVListF{} -> TList + NVSetF{} -> TSet + NVClosureF{} -> TClosure + NVPathF{} -> TPath + NVBuiltinF{} -> TBuiltin -describeValue :: ValueType -> String -describeValue = \case - TInt -> "an integer" - TFloat -> "a float" - TBool -> "a boolean" - TNull -> "a null" - TString NoContext -> "a string" - TString HasContext -> "a string with context" - TList -> "a list" - TSet -> "an attr set" - TClosure -> "a function" - TPath -> "a path" - TBuiltin -> "a builtin function" +-- | Describe type value +describeValue :: ValueType -> Text +describeValue = + \case + TInt -> "an integer" + TFloat -> "a float" + TBool -> "a boolean" + TNull -> "a null" + TString NoContext -> "a string" + TString HasContext -> "a string with context" + TList -> "a list" + TSet -> "an attr set" + TClosure -> "a function" + TPath -> "a path" + TBuiltin -> "a builtin function" + + showValueType :: (MonadThunk t m (NValue t f m), Comonad f) - => NValue t f m -> m String -showValueType (Pure t) = force t showValueType -showValueType (Free (NValue (extract -> v))) = + => NValue t f m + -> m Text +showValueType (Pure t) = showValueType =<< force t +showValueType (Free (NValue' (extract -> v))) = pure $ describeValue $ valueType v + +-- * @ValueFrame@ + data ValueFrame t f m = ForcingThunk t | ConcerningValue (NValue t f m) @@ -443,20 +770,42 @@ | Division (NValue t f m) (NValue t f m) | Coercion ValueType ValueType | CoercionToJson (NValue t f m) - | CoercionFromJson A.Value + | CoercionFromJson Aeson.Value | Expectation ValueType (NValue t f m) deriving Typeable deriving instance (Comonad f, Show t) => Show (ValueFrame t f m) + +-- * @MonadDataContext@ + +type MonadDataContext f (m :: * -> *) + = (Comonad f, Applicative f, Traversable f, Monad m) + +-- * @MonadDataErrorContext@ + type MonadDataErrorContext t f m - = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m) + = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m, MonadFail m) instance MonadDataErrorContext t f m => Exception (ValueFrame t f m) +-- * @instance Eq1 NValue'@ + +-- TH derivable works only after MonadDataContext +$(deriveEq1 ''NValue') + + +-- * @NValue'@ traversals, getter & setters + +-- | Make traversals for Nix traversable structures. $(makeTraversals ''NValueF) + +-- | Make lenses for the Nix values $(makeLenses ''NValue') + +-- | Lens-generated getter-setter function for a traversable NValue' key-val structures. +-- Nix value analogue of the @Data-Aeson-Lens@:@key :: AsValue t => Text -> Traversal' t Value@. key :: (Traversable f, Applicative g) => VarName diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -1,114 +1,130 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} module Nix.Value.Equal where +import Prelude hiding ( Comparison + , force + ) +import Nix.Utils import Control.Comonad -import Control.Monad import Control.Monad.Free -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Data.Align -import Data.Eq.Deriving -import Data.Functor.Classes -import Data.Functor.Identity -import qualified Data.HashMap.Lazy as M -import Data.These +import Control.Monad.Trans.Except ( throwE ) +import Data.Semialign ( Align + , Semialign(align) + ) +import qualified Data.HashMap.Lazy as HashMap.Lazy +import Data.These ( These(These) ) import Nix.Atoms import Nix.Frames import Nix.String import Nix.Thunk -import Nix.Utils import Nix.Value checkComparable - :: (Framed e m, MonadDataErrorContext t f m) + :: ( Framed e m + , MonadDataErrorContext t f m + ) => NValue t f m -> NValue t f m -> m () -checkComparable x y = case (x, y) of - (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () - (NVConstant (NInt _), NVConstant (NFloat _)) -> pure () - (NVConstant (NInt _), NVConstant (NInt _)) -> pure () - (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () - (NVStr _, NVStr _) -> pure () - (NVPath _, NVPath _) -> pure () - _ -> throwError $ Comparison x y +checkComparable x y = + case (x, y) of + (NVConstant (NFloat _), NVConstant (NInt _)) -> pass + (NVConstant (NInt _), NVConstant (NFloat _)) -> pass + (NVConstant (NInt _), NVConstant (NInt _)) -> pass + (NVConstant (NFloat _), NVConstant (NFloat _)) -> pass + (NVStr _ , NVStr _ ) -> pass + (NVPath _ , NVPath _ ) -> pass + _ -> throwError $ Comparison x y -- | Checks whether two containers are equal, using the given item equality -- predicate. If there are any item slots that don't match between the two --- containers, the result will be False. +-- containers, the result will be @False@. alignEqM :: (Align f, Traversable f, Monad m) => (a -> b -> m Bool) -> f a -> f b -> m Bool -alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do - pairs <- forM (Data.Align.align fa fb) $ \case - These a b -> pure (a, b) - _ -> throwE () - forM_ pairs $ \(a, b) -> guard =<< lift (eq a b) +alignEqM eq fa fb = + fmap + isRight + $ runExceptT $ + do + pairs <- + traverse + (\case + These a b -> pure (a, b) + _ -> throwE () + ) + (Data.Semialign.align fa fb) + traverse_ (\ (a, b) -> guard =<< lift (eq a b)) pairs alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool alignEq eq fa fb = runIdentity $ alignEqM (\x y -> Identity (eq x y)) fa fb -isDerivationM :: Monad m => (t -> m (Maybe NixString)) -> AttrSet t -> m Bool -isDerivationM f m = case M.lookup "type" m of - Nothing -> pure False - Just t -> do - mres <- f t - case mres of +isDerivationM + :: Monad m + => ( t + -> m (Maybe NixString) + ) + -> AttrSet t + -> m Bool +isDerivationM f m = + maybe + (pure False) + (\ t -> + maybe -- We should probably really make sure the context is empty here -- but the C++ implementation ignores it. - Just s -> pure $ principledStringIgnoreContext s == "derivation" - Nothing -> pure False + False + ((==) "derivation" . stringIgnoreContext) + <$> f t + ) + (HashMap.Lazy.lookup "type" m) -isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool -isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x)) +isDerivation + :: Monad m + => ( t + -> Maybe NixString + ) + -> AttrSet t + -> Bool +isDerivation f = runIdentity . isDerivationM (Identity . f) valueFEqM :: Monad n - => (AttrSet a -> AttrSet a -> n Bool) - -> (a -> a -> n Bool) + => ( AttrSet a + -> AttrSet a + -> n Bool + ) + -> ( a + -> a + -> n Bool + ) -> NValueF p m a -> NValueF p m a -> n Bool -valueFEqM attrsEq eq = curry $ \case - (NVConstantF (NFloat x), NVConstantF (NInt y) ) -> pure $ x == fromInteger y - (NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y - (NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc - (NVStrF ls, NVStrF rs) -> - pure $ principledStringIgnoreContext ls == principledStringIgnoreContext rs - (NVListF ls , NVListF rs ) -> alignEqM eq ls rs - (NVSetF lm _, NVSetF rm _) -> attrsEq lm rm - (NVPathF lp , NVPathF rp ) -> pure $ lp == rp - _ -> pure False +valueFEqM attrsEq eq = + curry $ + \case + (NVConstantF (NFloat x), NVConstantF (NInt y)) -> pure $ x == fromInteger y + (NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y + (NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc + (NVStrF ls , NVStrF rs ) -> pure $ (\ i -> i ls == i rs) stringIgnoreContext + (NVListF ls , NVListF rs ) -> alignEqM eq ls rs + (NVSetF lm _ , NVSetF rm _ ) -> attrsEq lm rm + (NVPathF lp , NVPathF rp ) -> pure $ lp == rp + _ -> pure False valueFEq :: (AttrSet a -> AttrSet a -> Bool) @@ -116,11 +132,13 @@ -> NValueF p m a -> NValueF p m a -> Bool -valueFEq attrsEq eq x y = runIdentity $ valueFEqM - (\x' y' -> Identity (attrsEq x' y')) - (\x' y' -> Identity (eq x' y')) - x - y +valueFEq attrsEq eq x y = + runIdentity $ + valueFEqM + (\x' y' -> Identity $ attrsEq x' y') + (\x' y' -> Identity $ eq x' y') + x + y compareAttrSetsM :: Monad m @@ -129,16 +147,24 @@ -> AttrSet t -> AttrSet t -> m Bool -compareAttrSetsM f eq lm rm = do - isDerivationM f lm >>= \case - True -> isDerivationM f rm >>= \case - True - | Just lp <- M.lookup "outPath" lm, Just rp <- M.lookup "outPath" rm -> eq - lp - rp - _ -> compareAttrs - _ -> compareAttrs - where compareAttrs = alignEqM eq lm rm +compareAttrSetsM f eq lm rm = + do + l <- isDerivationM f lm + bool + compareAttrs + (do + r <- isDerivationM f rm + case r of + True + | Just lp <- HashMap.Lazy.lookup "outPath" lm, Just rp <- HashMap.Lazy.lookup "outPath" rm -> + eq + lp + rp + _ -> compareAttrs + ) + l + where + compareAttrs = alignEqM eq lm rm compareAttrSets :: (t -> Maybe NixString) @@ -147,44 +173,51 @@ -> AttrSet t -> Bool compareAttrSets f eq lm rm = runIdentity - $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm + $ compareAttrSetsM (Identity . f) (\x y -> Identity (eq x y)) lm rm valueEqM - :: forall t f m - . (MonadThunk t m (NValue t f m), Comonad f) + :: (MonadThunk t m (NValue t f m), Comonad f) => NValue t f m -> NValue t f m -> m Bool valueEqM ( Pure x) ( Pure y) = thunkEqM x y valueEqM ( Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y) -valueEqM x@(Free _) ( Pure y) = thunkEqM ?? y =<< thunk (pure x) -valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) = - valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y +valueEqM x@(Free _) ( Pure y) = (`thunkEqM` y) =<< thunk (pure x) +valueEqM (Free (NValue' (extract -> x))) (Free (NValue' (extract -> y))) = + valueFEqM + (compareAttrSetsM f valueEqM) + valueEqM + x + y where - f (Pure t) = force t $ \case - NVStr s -> pure $ Just s - _ -> pure Nothing - f (Free v) = case v of - NVStr' s -> pure $ Just s - _ -> pure Nothing + f = + free + (pure . + (\case + NVStr s -> pure s + _ -> mempty + ) <=< force + ) + (pure . + \case + NVStr' s -> pure s + _ -> mempty + ) thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool -thunkEqM lt rt = force lt $ \lv -> force rt $ \rv -> - let unsafePtrEq = case (lt, rt) of - (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True - _ -> valueEqM lv rv - in case (lv, rv) of - (NVClosure _ _, NVClosure _ _) -> unsafePtrEq - (NVList _ , NVList _ ) -> unsafePtrEq - (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq - _ -> valueEqM lv rv +thunkEqM lt rt = + do + lv <- force lt + rv <- force rt -instance Eq1 (NValueF p m) where - liftEq _ (NVConstantF x) (NVConstantF y) = x == y - liftEq _ (NVStrF x) (NVStrF y) = x == y - liftEq eq (NVListF x) (NVListF y) = liftEq eq x y - liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y - liftEq _ (NVPathF x ) (NVPathF y ) = x == y - liftEq _ _ _ = False + let + unsafePtrEq = + case (lt, rt) of + (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True + _ -> valueEqM lv rv -$(deriveEq1 ''NValue') + case (lv, rv) of + (NVClosure _ _, NVClosure _ _) -> unsafePtrEq + (NVList _ , NVList _ ) -> unsafePtrEq + (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq + _ -> valueEqM lv rv diff --git a/src/Nix/Value/Monad.hs b/src/Nix/Value/Monad.hs --- a/src/Nix/Value/Monad.hs +++ b/src/Nix/Value/Monad.hs @@ -2,10 +2,19 @@ module Nix.Value.Monad where +-- * @MonadValue@ - a main implementation class + class MonadValue v m where defer :: m v -> m v - demand :: v -> (v -> m r) -> m r + demand :: v -> m v -- | If 'v' is a thunk, 'inform' allows us to modify the action to be -- performed by the thunk, perhaps by enriching it with scope info, for -- example. - inform :: v -> (m v -> m v) -> m v + inform :: v -> m v + + +-- * @MonadValueF@ - a Kleisli-able customization class + +class MonadValueF v m where + demandF :: (v -> m r) -> v -> m r + informF :: (m v -> m v) -> v -> m v diff --git a/src/Nix/Var.hs b/src/Nix/Var.hs --- a/src/Nix/Var.hs +++ b/src/Nix/Var.hs @@ -5,16 +5,15 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Var where import Control.Monad.Ref -import Data.GADT.Compare -import Data.IORef -import Data.Maybe -import Data.STRef -import Type.Reflection ((:~:)(Refl)) +import Data.GADT.Compare ( GEq(..) ) +import Data.STRef ( STRef ) +import Type.Reflection ( (:~:)(Refl) ) -import Unsafe.Coerce +import Unsafe.Coerce ( unsafeCoerce ) type Var m = Ref m @@ -36,8 +35,17 @@ atomicModifyVar = atomicModifyRef --TODO: Upstream GEq instances +-- 2021-02-25: NOTE: Currently, upstreaming would require adding a dependency on the according packages. instance GEq IORef where - a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing + a `geq` b = + bool + Nothing + (pure $ unsafeCoerce Refl) + (a == unsafeCoerce b) instance GEq (STRef s) where - a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing + a `geq` b = + bool + Nothing + (pure $ unsafeCoerce Refl) + (a == unsafeCoerce b) diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -1,77 +1,119 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Nix.XML (toXML) where +module Nix.XML + ( toXML ) +where import qualified Data.HashMap.Lazy as M -import Data.List -import Data.Ord -import qualified Data.Text as Text import Nix.Atoms import Nix.Expr.Types import Nix.String import Nix.Value -import Text.XML.Light +import Text.XML.Light ( Element(Element) + , Attr(Attr) + , Content(Elem) + , unqual + , ppElement + ) toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi where - cyc = pure $ mkElem "string" "value" "" + cyc = pure $ mkEVal "string" "" - pp = - ("\n" <>) - . (<> "\n") - . Text.pack - . ppElement - . (\e -> Element (unqual "expr") [] [Elem e] Nothing) + pp e = + heading + <> toText + (ppElement $ + mkE + "expr" + [Elem e] + ) + <> "\n" + where + heading = "\n" phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element phi = \case - NVConstant' a -> case a of - NURI t -> pure $ mkElem "string" "value" (Text.unpack t) - NInt n -> pure $ mkElem "int" "value" (show n) - NFloat f -> pure $ mkElem "float" "value" (show f) - NBool b -> pure $ mkElem "bool" "value" (if b then "true" else "false") - NNull -> pure $ Element (unqual "null") [] [] Nothing + NVConstant' a -> + pure $ + case a of + NURI t -> mkEVal "string" $ toString t + NInt n -> mkEVal "int" $ show n + NFloat f -> mkEVal "float" $ show f + NBool b -> mkEVal "bool" $ if b then "true" else "false" + NNull -> mkE "null" mempty NVStr' str -> - mkElem "string" "value" . Text.unpack <$> extractNixString str - NVList' l -> sequence l - >>= \els -> pure $ Element (unqual "list") [] (Elem <$> els) Nothing + mkEVal "string" . toString <$> extractNixString str + NVList' l -> + do + els <- sequence l + pure $ + mkE + "list" + (Elem <$> els) - NVSet' s _ -> sequence s >>= \kvs -> pure $ Element - (unqual "attrs") - [] - (map - (\(k, v) -> Elem - (Element (unqual "attr") - [Attr (unqual "name") (Text.unpack k)] - [Elem v] - Nothing - ) - ) - (sortBy (comparing fst) $ M.toList kvs) - ) - Nothing + NVSet' s _ -> + do + kvs <- sequence s + pure $ + mkE + "attrs" + ((\ (k, v) -> + Elem $ + Element + (unqual "attr") + [Attr (unqual "name") (toString k)] + [Elem v] + Nothing + ) <$> + sortWith fst (M.toList kvs) + ) NVClosure' p _ -> - pure $ Element (unqual "function") [] (paramsXML p) Nothing - NVPath' fp -> pure $ mkElem "path" "value" fp - NVBuiltin' name _ -> pure $ mkElem "function" "name" name - _ -> error "Pattern synonyms mask coverage" + pure $ + mkE + "function" + (paramsXML p) + NVPath' fp -> pure $ mkEVal "path" fp + NVBuiltin' name _ -> pure $ mkEName "function" $ toString name +mkE :: String -> [Content] -> Element +mkE n c = + Element + (unqual n) + mempty + c + Nothing + mkElem :: String -> String -> String -> Element -mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing +mkElem n a v = + Element + (unqual n) + [Attr (unqual a) v] + mempty + Nothing +mkEVal :: String -> String -> Element +mkEVal = (`mkElem` "value") + +mkEName :: String -> String -> Element +mkEName = (`mkElem` "name") + paramsXML :: Params r -> [Content] -paramsXML (Param name) = [Elem $ mkElem "varpat" "name" (Text.unpack name)] +paramsXML (Param name) = [Elem $ mkEName "varpat" (toString name)] paramsXML (ParamSet s b mname) = [Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing] where battr = [ Attr (unqual "ellipsis") "1" | b ] - nattr = maybe [] ((: []) . Attr (unqual "name") . Text.unpack) mname + nattr = + maybe + mempty + ((: mempty) . Attr (unqual "name") . toString) + mname paramSetXML :: ParamSet r -> [Content] -paramSetXML = map (\(k, _) -> Elem $ mkElem "attr" "name" (Text.unpack k)) +paramSetXML = fmap (\(k, _) -> Elem $ mkEName "attr" (toString k)) diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -1,30 +1,26 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module EvalTests (tests, genEvalCompareTests) where -import Control.Applicative ((<|>)) -import Control.Monad (when, unless) +import Prelude hiding (lookupEnv) import Control.Monad.Catch -import Control.Monad.IO.Class import Data.List ((\\)) -import Data.Maybe (isJust) import qualified Data.Set as S -import Data.Text (Text) import Data.Time import NeatInterpolation (text) import Nix import Nix.Standard import Nix.TH import Nix.Value.Equal +import Nix.Utils import qualified System.Directory as D -import System.Environment +import System.Environment (lookupEnv) import System.FilePath import Test.Tasty import Test.Tasty.HUnit @@ -373,6 +369,11 @@ freeVarsEqual "rec {inherit a; }" ["a"] freeVarsEqual "let inherit a; in { }" ["a"] +case_expression_split = + constantEqualText + "[ \"\" [ \"a\" ] \"c\" ]" + "(x: builtins.deepSeq x x) (builtins.split \"(a)b\" \"abc\")" + case_empty_string_equal_null_is_false = constantEqualText "false" "\"\" == null" @@ -440,7 +441,7 @@ let unmaskedFiles = filter ((==".nix") . takeExtension) td let files = unmaskedFiles \\ maskedFiles - pure $ testGroup "Eval comparison tests" $ map (mkTestCase testDir) files + pure $ testGroup "Eval comparison tests" $ fmap (mkTestCase testDir) files where mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td f) @@ -450,8 +451,8 @@ let opts = defaultOptions time -- putStrLn =<< lint (stripAnnotation a) (eq, expectedNF, actualNF) <- runWithBasicEffectsIO opts $ do - expectedNF <- normalForm =<< nixEvalExprLoc Nothing expected - actualNF <- normalForm =<< nixEvalExprLoc Nothing actual + expectedNF <- normalForm =<< nixEvalExprLoc mempty expected + actualNF <- normalForm =<< nixEvalExprLoc mempty actual eq <- valueEqM expectedNF actualNF pure (eq, expectedNF, actualNF) let message = @@ -461,10 +462,10 @@ assertBool message eq constantEqualText' :: Text -> Text -> Assertion -constantEqualText' expected actual = do - let Success expected' = parseNixTextLoc expected - Success actual' = parseNixTextLoc actual - constantEqual expected' actual' +constantEqualText' expected actual = + do + let (Right expected', Right actual') = both parseNixTextLoc (expected, actual) + constantEqual expected' actual' constantEqualText :: Text -> Text -> Assertion constantEqualText expected actual = do @@ -474,23 +475,30 @@ assertEvalMatchesNix actual assertNixEvalThrows :: Text -> Assertion -assertNixEvalThrows a = do - let Success a' = parseNixTextLoc a - time <- getCurrentTime - let opts = defaultOptions time - errored <- catch - (False <$ runWithBasicEffectsIO opts - (normalForm =<< nixEvalExprLoc Nothing a')) - (\(_ :: NixException) -> pure True) - unless errored $ - assertFailure "Did not catch nix exception" +assertNixEvalThrows a = + do + time <- getCurrentTime + let + opts = defaultOptions time + Right a' = parseNixTextLoc a + errored <- + catch + (False <$ + runWithBasicEffectsIO + opts + (normalForm =<< nixEvalExprLoc mempty a') + ) + (\(_ :: NixException) -> pure True) + unless errored $ assertFailure "Did not catch nix exception" freeVarsEqual :: Text -> [VarName] -> Assertion -freeVarsEqual a xs = do - let Success a' = parseNixText a +freeVarsEqual a xs = + do + let + Right a' = parseNixText a xs' = S.fromList xs - free = freeVars a' - assertEqual "" xs' free + free' = freeVars a' + assertEqual "" xs' free' maskedFiles :: [FilePath] maskedFiles = diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,18 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Main where -import Control.DeepSeq +import Prelude hiding (lookupEnv) +import Relude.Unsafe (read) import qualified Control.Exception as Exc -import Control.Applicative ((<|>)) -import Control.Monad +import GHC.Err (errorWithoutStackTrace) import Data.Fix -import Data.List (isSuffixOf) -import Data.Maybe -import Data.Text (unpack) +import Data.List (isSuffixOf, lookup) +import qualified Data.String as String import Data.Time import qualified EvalTests import NeatInterpolation (text) @@ -29,7 +27,7 @@ import qualified ReduceExprTests import qualified PrettyParseTests import System.Directory -import System.Environment +import System.Environment (setEnv, lookupEnv) import System.FilePath.Glob import System.Posix.Files import Test.Tasty @@ -39,10 +37,10 @@ ensureLangTestsPresent = do exist <- fileExist "data/nix/tests/local.mk" unless exist $ - errorWithoutStackTrace $ unlines + errorWithoutStackTrace $ String.unlines [ "Directory data/nix does not have any files." , "Did you forget to run" - ++ " \"git submodule update --init --recursive\"?" ] + <> " \"git submodule update --init --recursive\"?" ] ensureNixpkgsCanParse :: Assertion ensureNixpkgsCanParse = @@ -58,33 +56,36 @@ NVStr ns <- do time <- getCurrentTime runWithBasicEffectsIO (defaultOptions time) $ - Nix.nixEvalExprLoc Nothing expr - let dir = hackyStringIgnoreContext ns - exists <- fileExist (unpack dir) + Nix.nixEvalExprLoc mempty expr + let dir = stringIgnoreContext ns + exists <- fileExist $ toString dir unless exists $ errorWithoutStackTrace $ - "Directory " ++ show dir ++ " does not exist" - files <- globDir1 (compile "**/*.nix") (unpack dir) + "Directory " <> show dir <> " does not exist" + files <- globDir1 (compile "**/*.nix") $ toString dir when (null files) $ errorWithoutStackTrace $ - "Directory " ++ show dir ++ " does not have any files" - forM_ files $ \file -> do + "Directory " <> show dir <> " does not have any files" + for_ files $ \file -> do unless ("azure-cli/default.nix" `isSuffixOf` file || "os-specific/linux/udisks/2-default.nix" `isSuffixOf` file) $ do -- Parse and deepseq the resulting expression tree, to ensure the -- parser is fully executed. _ <- consider file (parseNixFileLoc file) $ Exc.evaluate . force - pure () - v -> error $ "Unexpected parse from default.nix: " ++ show v + pass + v -> fail $ "Unexpected parse from default.nix: " <> show v where getExpr k m = let Just (Just r) = lookup k m in r getString k m = let Fix (NStr (DoubleQuoted [Plain str])) = getExpr k m in str - consider path action k = action >>= \case - Failure err -> errorWithoutStackTrace $ - "Parsing " ++ path ++ " failed: " ++ show err - Success expr -> k expr + consider path action k = + do + x <- action + either + (\ err -> errorWithoutStackTrace $ "Parsing " <> path <> " failed: " <> show err) + k + x main :: IO () main = do @@ -95,18 +96,18 @@ prettyTestsEnv <- lookupEnv "PRETTY_TESTS" pwd <- getCurrentDirectory - setEnv "NIX_REMOTE" (pwd ++ "/real-store") - setEnv "NIX_DATA_DIR" (pwd ++ "/data") + setEnv "NIX_REMOTE" (pwd <> "/real-store") + setEnv "NIX_DATA_DIR" (pwd <> "/data") defaultMain $ testGroup "hnix" $ [ ParserTests.tests , EvalTests.tests , PrettyTests.tests - , ReduceExprTests.tests] ++ + , ReduceExprTests.tests] <> [ PrettyParseTests.tests - (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] ++ - [ evalComparisonTests ] ++ + (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] <> + [ evalComparisonTests ] <> [ testCase "Nix language tests present" ensureLangTestsPresent - , nixLanguageTests ] ++ + , nixLanguageTests ] <> [ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse | isJust nixpkgsTestsEnv ] diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -1,22 +1,15 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module NixLanguageTests (genTests) where -import Control.Arrow ( (&&&) ) import Control.Exception -import Control.Monad -import Control.Monad.IO.Class +import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.ST -import Data.List ( delete - , sort - ) +import Data.List ( delete ) import Data.List.Split ( splitOn ) -import Data.Map ( Map ) import qualified Data.Map as Map -import Data.Set ( Set ) import qualified Data.Set as Set +import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Time @@ -27,7 +20,6 @@ import Nix.Parser import Nix.Pretty import Nix.String -import Nix.Utils import Nix.XML import qualified Options.Applicative as Opts import System.Environment @@ -60,7 +52,7 @@ -} groupBy :: Ord k => (v -> k) -> [v] -> Map k [v] -groupBy key = Map.fromListWith (++) . map (key &&& pure) +groupBy key = Map.fromListWith (<>) . fmap (key &&& pure) -- | New tests, which have never yet passed. Once any of these is passing, -- please remove it from this list. Do not add tests to this list if they have @@ -85,14 +77,14 @@ <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang" let testsByName = groupBy (takeFileName . dropExtensions) testFiles let testsByType = groupBy testType (Map.toList testsByName) - let testGroups = map mkTestGroup (Map.toList testsByType) + let testGroups = fmap mkTestGroup (Map.toList testsByType) pure $ localOption (mkTimeout 2000000) $ testGroup "Nix (upstream) language tests" testGroups where testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath mkTestGroup (kind, tests) = - testGroup (unwords kind) $ map (mkTestCase kind) tests + testGroup (String.unwords kind) $ fmap (mkTestCase kind) tests mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do time <- liftIO getCurrentTime let opts = defaultOptions time @@ -101,90 +93,87 @@ ["parse", "fail"] -> assertParseFail opts $ the files ["eval" , "okay"] -> assertEval opts files ["eval" , "fail"] -> assertEvalFail $ the files - _ -> error $ "Unexpected: " ++ show kind + _ -> fail $ "Unexpected: " <> show kind assertParse :: Options -> FilePath -> Assertion -assertParse _opts file = parseNixFileLoc file >>= \case - Success _expr -> pure () -- pure $! runST $ void $ lint opts expr - Failure err -> - assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err +assertParse _opts file = + do + x <- parseNixFileLoc file + either + (\ err -> assertFailure $ "Failed to parse " <> file <> ":\n" <> show err) + (const pass) -- pure $! runST $ void $ lint opts expr + x assertParseFail :: Options -> FilePath -> Assertion assertParseFail opts file = do eres <- parseNixFileLoc file catch - (case eres of - Success expr -> do - _ <- pure $! runST $ void $ lint opts expr - assertFailure - $ "Unexpected success parsing `" - ++ file - ++ ":\nParsed value: " - ++ show expr - Failure _ -> pure () + (either + (const pass) + (\ expr -> + do + _ <- pure $! runST $ void $ lint opts expr + assertFailure $ "Unexpected success parsing `" <> file <> ":\nParsed value: " <> show expr + ) + eres ) - $ \(_ :: SomeException) -> pure () + $ \(_ :: SomeException) -> pass assertLangOk :: Options -> FilePath -> Assertion assertLangOk opts file = do - actual <- printNix <$> hnixEvalFile opts (file ++ ".nix") - expected <- Text.readFile $ file ++ ".exp" - assertEqual "" expected $ Text.pack (actual ++ "\n") + actual <- printNix <$> hnixEvalFile opts (file <> ".nix") + expected <- Text.readFile $ file <> ".exp" + assertEqual "" expected $ toText (actual <> "\n") assertLangOkXml :: Options -> FilePath -> Assertion assertLangOkXml opts file = do - actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile + actual <- stringIgnoreContext . toXML <$> hnixEvalFile opts - (file ++ ".nix") - expected <- Text.readFile $ file ++ ".exp.xml" + (file <> ".nix") + expected <- Text.readFile $ file <> ".exp.xml" assertEqual "" expected actual assertEval :: Options -> [FilePath] -> Assertion assertEval _opts files = do time <- liftIO getCurrentTime let opts = defaultOptions time - case delete ".nix" $ sort $ map takeExtensions files of - [] -> () <$ hnixEvalFile opts (name ++ ".nix") + case delete ".nix" $ sort $ fmap takeExtensions files of + [] -> () <$ hnixEvalFile opts (name <> ".nix") [".exp" ] -> assertLangOk opts name [".exp.xml" ] -> assertLangOkXml opts name - [".exp.disabled"] -> pure () - [".exp-disabled"] -> pure () + [".exp.disabled"] -> pass + [".exp-disabled"] -> pass [".exp", ".flags"] -> do liftIO $ setEnv "NIX_PATH" "lang/dir4:lang/dir5" - flags <- Text.readFile (name ++ ".flags") + flags <- Text.readFile (name <> ".flags") let flags' | Text.last flags == '\n' = Text.init flags | otherwise = flags case Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time) - (fixup (map Text.unpack (Text.splitOn " " flags'))) + (fixup (fmap toString (Text.splitOn " " flags'))) of - Opts.Failure err -> - errorWithoutStackTrace - $ "Error parsing flags from " - ++ name - ++ ".flags: " - ++ show err + Opts.Failure err -> errorWithoutStackTrace $ "Error parsing flags from " <> name <> ".flags: " <> show err Opts.Success opts' -> assertLangOk opts' name - Opts.CompletionInvoked _ -> error "unused" - _ -> assertFailure $ "Unknown test type " ++ show files + Opts.CompletionInvoked _ -> fail "unused" + _ -> assertFailure $ "Unknown test type " <> show files where name = - "data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files) + "data/nix/tests/lang/" <> the (fmap (takeFileName . dropExtensions) files) - fixup ("--arg" : x : y : rest) = "--arg" : (x ++ "=" ++ y) : fixup rest - fixup ("--argstr" : x : y : rest) = "--argstr" : (x ++ "=" ++ y) : fixup rest + fixup ("--arg" : x : y : rest) = "--arg" : (x <> "=" <> y) : fixup rest + fixup ("--argstr" : x : y : rest) = "--argstr" : (x <> "=" <> y) : fixup rest fixup (x : rest) = x : fixup rest - fixup [] = [] + fixup [] = mempty assertEvalFail :: FilePath -> Assertion -assertEvalFail file = catch ?? (\(_ :: SomeException) -> pure ()) $ do +assertEvalFail file = catch ?? (\(_ :: SomeException) -> pass) $ do time <- liftIO getCurrentTime evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file - evalResult - `seq` assertFailure - $ file - ++ " should not evaluate.\nThe evaluation result was `" - ++ evalResult - ++ "`." + evalResult `seq` + assertFailure $ + file + <> " should not evaluate.\nThe evaluation result was `" + <> evalResult + <> "`." diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -1,16 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module ParserTests (tests) where import Data.Fix -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text (Text, unpack) import NeatInterpolation (text) import Nix.Atoms import Nix.Expr @@ -82,12 +80,12 @@ [ NamedVar (mkSelector "e") (mkInt 3) nullPos , Inherit Nothing (StaticKey <$> ["a", "b"]) nullPos ] - assertParseText "{ inherit; }" $ Fix $ NSet NNonRecursive [ Inherit Nothing [] nullPos ] + assertParseText "{ inherit; }" $ Fix $ NSet NNonRecursive [ Inherit Nothing mempty nullPos ] case_set_scoped_inherit = assertParseText "{ inherit (a) b c; e = 4; inherit(a)b c; }" $ Fix $ NSet NNonRecursive - [ Inherit (Just (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos + [ Inherit (pure (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos , NamedVar (mkSelector "e") (mkInt 4) nullPos - , Inherit (Just (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos + , Inherit (pure (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos ] case_set_rec = assertParseText "rec { a = 3; b = a; }" $ Fix $ NSet NRecursive @@ -97,13 +95,13 @@ case_set_complex_keynames = do assertParseText "{ \"\" = null; }" $ Fix $ NSet NNonRecursive - [ NamedVar (DynamicKey (Plain (DoubleQuoted [])) :| []) mkNull nullPos ] + [ NamedVar (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) mkNull nullPos ] assertParseText "{ a.b = 3; a.c = 4; }" $ Fix $ NSet NNonRecursive [ NamedVar (StaticKey "a" :| [StaticKey "b"]) (mkInt 3) nullPos , NamedVar (StaticKey "a" :| [StaticKey "c"]) (mkInt 4) nullPos ] assertParseText "{ ${let a = \"b\"; in a} = 4; }" $ Fix $ NSet NNonRecursive - [ NamedVar (DynamicKey (Antiquoted letExpr) :| []) (mkInt 4) nullPos ] + [ NamedVar (DynamicKey (Antiquoted letExpr) :| mempty) (mkInt 4) nullPos ] assertParseText "{ \"a${let a = \"b\"; in a}c\".e = 4; }" $ Fix $ NSet NNonRecursive [ NamedVar (DynamicKey (Plain str) :| [StaticKey "e"]) (mkInt 4) nullPos ] where @@ -111,7 +109,7 @@ str = DoubleQuoted [Plain "a", Antiquoted letExpr, Plain "c"] case_set_inherit_direct = assertParseText "{ inherit ({a = 3;}); }" $ Fix $ NSet NNonRecursive - [ Inherit (Just $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]) [] nullPos + [ Inherit (pure $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]) mempty nullPos ] case_inherit_selector = do @@ -122,15 +120,15 @@ case_int_list = assertParseText "[1 2 3]" $ Fix $ NList [ mkInt i | i <- [1,2,3] ] -case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (map (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4])) +case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (fmap (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4])) case_mixed_list = do assertParseText "[{a = 3;}.a (if true then null else false) null false 4 [] c.d or null]" $ Fix $ NList [ Fix (NSelect (Fix (NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos])) (mkSelector "a") Nothing) , Fix (NIf (mkBool True) mkNull (mkBool False)) - , mkNull, mkBool False, mkInt 4, Fix (NList []) - , Fix (NSelect (mkSym "c") (mkSelector "d") (Just mkNull)) + , mkNull, mkBool False, mkInt 4, Fix (NList mempty) + , Fix (NSelect (mkSym "c") (mkSelector "d") (pure mkNull)) ] assertParseFail "[if true then null else null]" assertParseFail "[a ? b]" @@ -143,31 +141,31 @@ assertParseText "a :b" $ Fix $ NAbs (Param "a") (mkSym "b") assertParseText "a c:def" $ Fix $ NBinary NApp (mkSym "a") (mkStr "c:def") assertParseText "c:def: c" $ Fix $ NBinary NApp (mkStr "c:def:") (mkSym "c") - assertParseText "a:{}" $ Fix $ NAbs (Param "a") $ Fix $ NSet NNonRecursive [] + assertParseText "a:{}" $ Fix $ NAbs (Param "a") $ Fix $ NSet NNonRecursive mempty assertParseText "a:[a]" $ Fix $ NAbs (Param "a") $ Fix $ NList [mkSym "a"] assertParseFail "def:" case_lambda_pattern = do assertParseText "{b, c ? 1}: b" $ - Fix $ NAbs (fixed args Nothing) (mkSym "b") + Fix $ NAbs (fixed args mempty) (mkSym "b") assertParseText "{ b ? x: x }: b" $ - Fix $ NAbs (fixed args2 Nothing) (mkSym "b") + Fix $ NAbs (fixed args2 mempty) (mkSym "b") assertParseText "a@{b,c ? 1}: b" $ - Fix $ NAbs (fixed args (Just "a")) (mkSym "b") + Fix $ NAbs (fixed args (pure "a")) (mkSym "b") assertParseText "{b,c?1}@a: c" $ - Fix $ NAbs (fixed args (Just "a")) (mkSym "c") + Fix $ NAbs (fixed args (pure "a")) (mkSym "c") assertParseText "{b,c?1,...}@a: c" $ - Fix $ NAbs (variadic vargs (Just "a")) (mkSym "c") + Fix $ NAbs (variadic vargs (pure "a")) (mkSym "c") assertParseText "{...}: 1" $ - Fix $ NAbs (variadic mempty Nothing) (mkInt 1) + Fix $ NAbs (variadic mempty mempty) (mkInt 1) assertParseFail "a@b: a" assertParseFail "{a}@{b}: a" where fixed args = ParamSet args False variadic args = ParamSet args True - args = [("b", Nothing), ("c", Just $ mkInt 1)] - vargs = [("b", Nothing), ("c", Just $ mkInt 1)] - args2 = [("b", Just lam)] + args = [("b", Nothing), ("c", pure $ mkInt 1)] + vargs = [("b", Nothing), ("c", pure $ mkInt 1)] + args2 = [("b", pure lam)] lam = Fix $ NAbs (Param "x") (mkSym "x") case_lambda_app_int = assertParseText "(a: a) 3" $ Fix (NBinary NApp lam int) where @@ -195,7 +193,7 @@ case_let_scoped_inherit = do assertParseText "let a = null; inherit (b) c; in c" $ Fix $ NLet [ NamedVar (mkSelector "a") mkNull nullPos - , Inherit (Just $ mkSym "b") [StaticKey "c"] nullPos ] + , Inherit (pure $ mkSym "b") [StaticKey "c"] nullPos ] (mkSym "c") assertParseFail "let inherit (b) c in c" @@ -228,9 +226,9 @@ makeTextParseTest str = assertParseText ("\"" <> str <> "\"") $ mkStr str -case_simple_string = mapM_ makeTextParseTest ["abcdef", "a", "A", " a a ", ""] +case_simple_string = traverse_ makeTextParseTest ["abcdef", "a", "A", " a a ", ""] -case_string_dollar = mapM_ makeTextParseTest ["a$b", "a$$b", "$cdef", "gh$i"] +case_string_dollar = traverse_ makeTextParseTest ["a$b", "a$$b", "$cdef", "gh$i"] case_string_escape = do assertParseText "\"\\$\\n\\t\\r\\\\\"" $ mkStr "$\n\t\r\\" @@ -254,24 +252,24 @@ Nothing assertParseText "a.e . d or null" $ Fix $ NSelect (mkSym "a") (StaticKey "e" :| [StaticKey "d"]) - (Just mkNull) - assertParseText "{}.\"\"or null" $ Fix $ NSelect (Fix (NSet NNonRecursive [])) - (DynamicKey (Plain (DoubleQuoted [])) :| []) (Just mkNull) + (pure mkNull) + assertParseText "{}.\"\"or null" $ Fix $ NSelect (Fix (NSet NNonRecursive mempty)) + (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) (pure mkNull) assertParseText "{ a = [1]; }.a or [2] ++ [3]" $ Fix $ NBinary NConcat (Fix (NSelect - (Fix (NSet NNonRecursive [NamedVar (StaticKey "a" :| []) + (Fix (NSet NNonRecursive [NamedVar (StaticKey "a" :| mempty) (Fix (NList [Fix (NConstant (NInt 1))])) nullPos])) - (StaticKey "a" :| []) - (Just (Fix (NList [Fix (NConstant (NInt 2))]))))) + (StaticKey "a" :| mempty) + (pure (Fix (NList [Fix (NConstant (NInt 2))]))))) (Fix (NList [Fix (NConstant (NInt 3))])) case_select_path = do assertParseText "f ./." $ Fix $ NBinary NApp (mkSym "f") (mkPath False "./.") assertParseText "f.b ../a" $ Fix $ NBinary NApp select (mkPath False "../a") - assertParseText "{}./def" $ Fix $ NBinary NApp (Fix (NSet NNonRecursive [])) (mkPath False "./def") + assertParseText "{}./def" $ Fix $ NBinary NApp (Fix (NSet NNonRecursive mempty)) (mkPath False "./def") assertParseText "{}.\"\"./def" $ Fix $ NBinary NApp - (Fix $ NSelect (Fix (NSet NNonRecursive [])) (DynamicKey (Plain (DoubleQuoted [])) :| []) Nothing) + (Fix $ NSelect (Fix (NSet NNonRecursive mempty)) (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) Nothing) (mkPath False "./def") where select = Fix $ NSelect (mkSym "f") (mkSelector "b") Nothing @@ -281,7 +279,7 @@ case_fun_app = do assertParseText "f a b" $ Fix $ NBinary NApp (Fix $ NBinary NApp (mkSym "f") (mkSym "a")) (mkSym "b") assertParseText "f a.x or null" $ Fix $ NBinary NApp (mkSym "f") $ Fix $ - NSelect (mkSym "a") (mkSelector "x") (Just mkNull) + NSelect (mkSym "a") (mkSelector "x") (pure mkNull) assertParseFail "f if true then null else null" case_indented_string = do @@ -323,10 +321,11 @@ assertParseFail "+ 3" assertParseFail "foo +" -case_comments = do - Success expected <- parseNixFile "data/let.nix" - assertParseFile "let-comments-multiline.nix" expected - assertParseFile "let-comments.nix" expected +case_comments = + do + Right expected <- parseNixFile "data/let.nix" + assertParseFile "let-comments-multiline.nix" expected + assertParseFile "let-comments.nix" expected case_select_or_precedence = assertParsePrint [text|let @@ -364,39 +363,53 @@ --------------------------------------------------------------------------------- assertParseText :: Text -> NExpr -> Assertion -assertParseText str expected = case parseNixText str of - Success actual -> - assertEqual ("When parsing " ++ unpack str) - (stripPositionInfo expected) (stripPositionInfo actual) - Failure err -> - assertFailure $ "Unexpected error parsing `" ++ unpack str ++ "':\n" ++ show err +assertParseText str expected = + either + (\ err -> + assertFailure $ toString $ "Unexpected fail parsing `" <> str <> "':\n" <> show err + ) + (assertEqual + ("When parsing " <> toString str) + (stripPositionInfo expected) + . stripPositionInfo + ) + (parseNixText str) assertParseFile :: FilePath -> NExpr -> Assertion -assertParseFile file expected = do - res <- parseNixFile $ "data/" ++ file - case res of - Success actual -> assertEqual ("Parsing data file " ++ file) - (stripPositionInfo expected) (stripPositionInfo actual) - Failure err -> - assertFailure $ "Unexpected error parsing data file `" - ++ file ++ "':\n" ++ show err +assertParseFile file expected = + do + res <- parseNixFile $ "data/" <> file + either + (\ err -> + assertFailure $ "Unexpected fail parsing data file `" <> file <> "':\n" <> show err + ) + (assertEqual + ("Parsing data file " <> file) + (stripPositionInfo expected) + . stripPositionInfo + ) + res assertParseFail :: Text -> Assertion -assertParseFail str = case parseNixText str of - Failure _ -> pure () - Success r -> - assertFailure $ "Unexpected success parsing `" - ++ unpack str ++ ":\nParsed value: " ++ show r +assertParseFail str = + either + (const pass) + (\ r -> + assertFailure $ toString $ "Unexpected success parsing `" <> str <> ":\nParsed value: " <> show r + ) + (parseNixText str) -- assertRoundTrip :: Text -> Assertion -- assertRoundTrip src = assertParsePrint src src assertParsePrint :: Text -> Text -> Assertion assertParsePrint src expect = - let Success expr = parseNixTextLoc src - result = renderStrict - . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) - . prettyNix - . stripAnnotation - $ expr + let + Right expr = parseNixTextLoc src + result = + renderStrict + . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) + . prettyNix + . stripAnnotation $ + expr in assertEqual "" expect result diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -4,21 +4,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -Wno-orphans#-} + module PrettyParseTests where import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Char import Data.Fix -import qualified Data.List.NonEmpty as NE -import Data.Text ( Text - , pack - ) +import qualified Data.String as String import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range @@ -26,6 +21,7 @@ import Nix.Expr import Nix.Parser import Nix.Pretty +import Nix.Utils import Prettyprinter import Test.Tasty import Test.Tasty.Hedgehog @@ -36,14 +32,19 @@ asciiString = Gen.list (Range.linear 1 15) Gen.lower asciiText :: Gen Text -asciiText = pack <$> asciiString +asciiText = toText <$> asciiString -- Might want to replace this instance with a constant value genPos :: Gen Pos genPos = mkPos <$> Gen.int (Range.linear 1 256) genSourcePos :: Gen SourcePos -genSourcePos = SourcePos <$> asciiString <*> genPos <*> genPos +genSourcePos = + liftA3 + SourcePos + asciiString + genPos + genPos genKeyName :: Gen (NKeyName NExpr) genKeyName = @@ -55,38 +56,52 @@ genBinding :: Gen (Binding NExpr) genBinding = Gen.choice - [ NamedVar <$> genAttrPath <*> genExpr <*> genSourcePos - , Inherit - <$> Gen.maybe genExpr - <*> Gen.list (Range.linear 0 5) genKeyName - <*> genSourcePos + [ liftA3 + NamedVar + genAttrPath + genExpr + genSourcePos + , liftA3 + Inherit + (Gen.maybe genExpr) + (Gen.list (Range.linear 0 5) genKeyName) + genSourcePos ] genString :: Gen (NString NExpr) genString = Gen.choice [ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText) - , Indented <$> Gen.int (Range.linear 0 10) <*> Gen.list - (Range.linear 0 5) - (genAntiquoted asciiText) + , liftA2 + Indented + (Gen.int (Range.linear 0 10)) + (Gen.list + (Range.linear 0 5) + (genAntiquoted asciiText) + ) ] genAttrPath :: Gen (NAttrPath NExpr) -genAttrPath = (NE.:|) <$> genKeyName <*> Gen.list (Range.linear 0 4) genKeyName +genAttrPath = + liftA2 + (:|) + genKeyName + $ Gen.list (Range.linear 0 4) genKeyName genParams :: Gen (Params NExpr) genParams = Gen.choice [ Param <$> asciiText - , ParamSet - <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText <*> Gen.maybe genExpr) - <*> Gen.bool - <*> Gen.choice [pure Nothing, Just <$> asciiText] + , liftA3 + ParamSet + (Gen.list (Range.linear 0 10) (liftA2 (,) asciiText $ Gen.maybe genExpr)) + Gen.bool + (Gen.choice [stub, pure <$> asciiText]) ] genAtom :: Gen NAtom genAtom = Gen.choice - [ NInt <$> Gen.integral (Range.linear 0 1000) + [ NInt <$> Gen.integral (Range.linear 0 1000) , NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0) - , NBool <$> Gen.bool + , NBool <$> Gen.bool , pure NNull ] @@ -113,23 +128,23 @@ , (1, Gen.resize (Size (n `div` 2)) genAssert) ] where - genConstant = NConstant <$> genAtom - genStr = NStr <$> genString - genSym = NSym <$> asciiText - genList = NList <$> fairList genExpr - genSet = NSet NNonRecursive <$> fairList genBinding - genRecSet = NSet NRecursive <$> fairList genBinding - genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString - genEnvPath = NEnvPath <$> asciiString - genUnary = NUnary <$> Gen.enumBounded <*> genExpr - genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr - genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr - genHasAttr = NHasAttr <$> genExpr <*> genAttrPath - genAbs = NAbs <$> genParams <*> genExpr - genLet = NLet <$> fairList genBinding <*> genExpr - genIf = NIf <$> genExpr <*> genExpr <*> genExpr - genWith = NWith <$> genExpr <*> genExpr - genAssert = NAssert <$> genExpr <*> genExpr + genConstant = NConstant <$> genAtom + genStr = NStr <$> genString + genSym = NSym <$> asciiText + genList = NList <$> fairList genExpr + genSet = NSet NNonRecursive <$> fairList genBinding + genRecSet = NSet NRecursive <$> fairList genBinding + genLiteralPath = NLiteralPath . ("./" <>) <$> asciiString + genEnvPath = NEnvPath <$> asciiString + genUnary = liftA2 NUnary Gen.enumBounded genExpr + genBinary = liftA3 NBinary Gen.enumBounded genExpr genExpr + genSelect = liftA3 NSelect genExpr genAttrPath (Gen.maybe genExpr) + genHasAttr = liftA2 NHasAttr genExpr genAttrPath + genAbs = liftA2 NAbs genParams genExpr + genLet = liftA2 NLet (fairList genBinding) genExpr + genIf = liftA3 NIf genExpr genExpr genExpr + genWith = liftA2 NWith genExpr genExpr + genAssert = liftA2 NAssert genExpr genExpr -- | Useful when there are recursive positions at each element of the list as -- it divides the size by the length of the generated list. @@ -143,22 +158,22 @@ equivUpToNormalization x y = normalize x == normalize y normalize :: NExpr -> NExpr -normalize = foldFix $ \case +normalize = foldFix $ Fix . \case NConstant (NInt n) | n < 0 -> - Fix (NUnary NNeg (Fix (NConstant (NInt (negate n))))) + NUnary NNeg $ Fix $ NConstant $ NInt $ negate n NConstant (NFloat n) | n < 0 -> - Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n))))) + NUnary NNeg $ Fix $ NConstant $ NFloat $ negate n - NSet recur binds -> Fix (NSet recur (map normBinding binds)) - NLet binds r -> Fix (NLet (map normBinding binds) r) + NSet recur binds -> NSet recur $ normBinding <$> binds + NLet binds r -> NLet (normBinding <$> binds) r - NAbs params r -> Fix (NAbs (normParams params) r) + NAbs params r -> NAbs (normParams params) r - r -> Fix r + r -> r where - normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos - normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos + normBinding (NamedVar path r pos) = NamedVar (normKey <$> path) r pos + normBinding (Inherit mr names pos) = Inherit mr (normKey <$> names) pos normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted) normKey (StaticKey name ) = StaticKey name @@ -167,10 +182,11 @@ :: Antiquoted (NString NExpr) NExpr -> Antiquoted (NString NExpr) NExpr normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) = EscapedNewline normAntiquotedString (Plain (DoubleQuoted strs)) = - let strs' = map normAntiquotedText strs - in if strs == strs' - then Plain (DoubleQuoted strs) - else normAntiquotedString (Plain (DoubleQuoted strs')) + let strs' = normAntiquotedText <$> strs + in + if strs == strs' + then Plain $ DoubleQuoted strs + else normAntiquotedString $ Plain $ DoubleQuoted strs' normAntiquotedString r = r normAntiquotedText :: Antiquoted Text NExpr -> Antiquoted Text NExpr @@ -178,50 +194,59 @@ normAntiquotedText (Plain "''\n") = EscapedNewline normAntiquotedText r = r - normParams (ParamSet binds var (Just "")) = ParamSet binds var Nothing + normParams (ParamSet binds var (Just "")) = ParamSet binds var mempty normParams r = r -- | Test that parse . pretty == id up to attribute position information. prop_prettyparse :: Monad m => NExpr -> PropertyT m () prop_prettyparse p = do - let prog = show (prettyNix p) - case parse (pack prog) of - Failure s -> do + let prog = show $ prettyNix p + either + (\ s -> do footnote $ show $ vsep - [fillSep ["Parse failed:", pretty (show s)], indent 2 (prettyNix p)] + -- Remove :: Text type annotation after String -> Text migration. + [fillSep ["Parse failed:", pretty (show s :: Text)], indent 2 $ prettyNix p] discard - Success v - | equivUpToNormalization p v -> success - | otherwise -> do - let pp = normalise prog - pv = normalise (show (prettyNix v)) - footnote - $ show - $ vsep - $ [ "----------------------------------------" - , vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))] - , "----------------------------------------" - , vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))] - , "----------------------------------------" - , vsep ["Pretty before:", indent 2 (pretty prog)] - , "----------------------------------------" - , vsep ["Pretty after:", indent 2 (prettyNix v)] - , "----------------------------------------" - , vsep ["Normalised before:", indent 2 (pretty pp)] - , "----------------------------------------" - , vsep ["Normalised after:", indent 2 (pretty pv)] - , "========================================" - , vsep ["Normalised diff:", pretty (ppDiff (ldiff pp pv))] - , "========================================" - ] - assert (pp == pv) + ) + (\ v -> + bool + (do + let + pp = normalise prog + pv = normalise $ show $ prettyNix v + + footnote $ + show $ + vsep + [ "----------------------------------------" + , vsep ["Expr before:" , indent 2 $ pretty $ PS.ppShow p] + , "----------------------------------------" + , vsep ["Expr after:" , indent 2 $ pretty $ PS.ppShow v] + , "----------------------------------------" + , vsep ["Pretty before:" , indent 2 $ pretty prog] + , "----------------------------------------" + , vsep ["Pretty after:" , indent 2 $ prettyNix v] + , "----------------------------------------" + , vsep ["Normalised before:", indent 2 $ pretty pp] + , "----------------------------------------" + , vsep ["Normalised after:" , indent 2 $ pretty pv] + , "========================================" + , vsep ["Normalised diff:" , pretty $ ppDiff $ ldiff pp pv] + , "========================================" + ] + assert (pp == pv) + ) + success + (equivUpToNormalization p v) + ) + (parse $ toText prog) where parse = parseNixText - normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines + normalise s = String.unlines $ reverse . dropWhile isSpace . reverse <$> String.lines s ldiff :: String -> String -> [Diff [String]] - ldiff s1 s2 = getDiff (map (: []) (lines s1)) (map (: []) (lines s2)) + ldiff s1 s2 = getDiff ((: mempty) <$> String.lines s1) ((: mempty) <$> String.lines s2) tests :: TestLimit -> TestTree tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do diff --git a/tests/PrettyTests.hs b/tests/PrettyTests.hs --- a/tests/PrettyTests.hs +++ b/tests/PrettyTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} module PrettyTests (tests) where import Test.Tasty @@ -21,7 +20,7 @@ case_function_params :: Assertion case_function_params = - assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3" + assertPretty (mkFunction (mkParamset mempty True) (mkInt 3)) "{ ... }:\n 3" case_paths :: Assertion case_paths = do @@ -35,4 +34,4 @@ --------------------------------------------------------------------------------- assertPretty :: NExpr -> String -> Assertion assertPretty e s = - assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e + assertEqual ("When pretty-printing " <> show e) s . show $ prettyNix e diff --git a/tests/ReduceExprTests.hs b/tests/ReduceExprTests.hs --- a/tests/ReduceExprTests.hs +++ b/tests/ReduceExprTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module ReduceExprTests (tests) where import Data.Fix @@ -26,19 +25,21 @@ ] assertSucc :: Result a -> IO a -assertSucc (Success a) = pure a -assertSucc (Failure d) = assertFailure $ show d +assertSucc = + either + (assertFailure . show) + pure cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion cmpReduceResult r e = do r <- assertSucc r - r <- stripAnnotation <$> reduceExpr Nothing r + r <- stripAnnotation <$> reduceExpr mempty r r @?= e shouldntReduce :: Result NExprLoc -> Assertion shouldntReduce r = do r <- assertSucc r - rReduced <- reduceExpr Nothing r + rReduced <- reduceExpr mempty r r @?= rReduced selectBasic :: Result NExprLoc diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -5,14 +5,10 @@ module TestCommon where +import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Text ( Text - , unpack - ) import Data.Time import Nix -import Nix.Exec ( ) import Nix.Standard import Nix.Fresh.Basic import System.Environment @@ -23,33 +19,34 @@ import Test.Tasty.HUnit hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT (StdIdT IO))) -hnixEvalFile opts file = do - parseResult <- parseNixFileLoc file - case parseResult of - Failure err -> - error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err - Success expr -> do - setEnv "TEST_VAR" "foo" - runWithBasicEffects opts - $ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr) - $ \case - NixException frames -> - errorWithoutStackTrace - . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames +hnixEvalFile opts file = + do + parseResult <- parseNixFileLoc file + either + (\ err -> fail $ "Parsing failed for file `" <> file <> "`.\n" <> show err) + (\ expr -> + do + setEnv "TEST_VAR" "foo" + runWithBasicEffects opts $ + catch (evaluateExpression (pure file) nixEvalExprLoc normalForm expr) $ + \case + NixException frames -> + errorWithoutStackTrace . show + =<< renderFrames + @(StdValue (StandardT (StdIdT IO))) + @(StdThunk (StandardT (StdIdT IO))) + frames + ) + parseResult hnixEvalText :: Options -> Text -> IO (StdValue (StandardT (StdIdT IO))) -hnixEvalText opts src = case parseNixText src of - Failure err -> - error - $ "Parsing failed for expression `" - ++ unpack src - ++ "`.\n" - ++ show err - Success expr -> - runWithBasicEffects opts $ normalForm =<< nixEvalExpr Nothing expr +hnixEvalText opts src = + either + (\ err -> fail $ toString $ "Parsing failed for expression `" <> src <> "`.\n" <> show err) + (\ expr -> + runWithBasicEffects opts $ normalForm =<< nixEvalExpr mempty expr + ) + (parseNixText src) nixEvalString :: String -> IO String nixEvalString expr = do @@ -66,14 +63,15 @@ assertEvalFileMatchesNix :: FilePath -> Assertion assertEvalFileMatchesNix fp = do time <- liftIO getCurrentTime - hnixVal <- (++ "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp + hnixVal <- (<> "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp nixVal <- nixEvalFile fp assertEqual fp nixVal hnixVal assertEvalMatchesNix :: Text -> Assertion assertEvalMatchesNix expr = do time <- liftIO getCurrentTime - hnixVal <- (++ "\n") . printNix <$> hnixEvalText (defaultOptions time) expr + hnixVal <- (<> "\n") . printNix <$> hnixEvalText (defaultOptions time) expr nixVal <- nixEvalString expr' assertEqual expr' nixVal hnixVal - where expr' = unpack expr + where + expr' = toString expr