hnix 0.6.0 → 0.6.1
raw patch · 42 files changed
+2245/−2154 lines, 42 filesdep +contravariantdep ~aesondep ~basedep ~base16-bytestring
Dependencies added: contravariant
Dependency ranges changed: aeson, base, base16-bytestring, binary, bytestring, comonad, containers, cryptohash-md5, cryptohash-sha1, cryptohash-sha256, cryptohash-sha512, data-fix, deepseq, dependent-sum, directory, exceptions, filepath, free, hashing, haskeline, hnix-store-core, http-client, http-client-tls, http-types, interpolate, lens-family-th, logict, monad-control, monadlist, mtl, optparse-applicative, parser-combinators, pretty-show, prettyprinter, process, ref-tf, regex-tdfa, regex-tdfa-text, scientific, serialise, split, syb, text, these, time, transformers, transformers-base, unix, unordered-containers, vector, xml
Files
- hnix.cabal +62/−56
- main/Main.hs +30/−22
- main/Repl.hs +6/−8
- src/Nix.hs +13/−14
- src/Nix/Atoms.hs +6/−9
- src/Nix/Builtins.hs +343/−348
- src/Nix/Cited.hs +14/−14
- src/Nix/Cited/Basic.hs +5/−6
- src/Nix/Convert.hs +202/−349
- src/Nix/Effects.hs +13/−20
- src/Nix/Effects/Basic.hs +315/−0
- src/Nix/Eval.hs +114/−115
- src/Nix/Exec.hs +51/−438
- src/Nix/Expr/Strings.hs +116/−0
- src/Nix/Expr/Types.hs +0/−3
- src/Nix/Fresh.hs +0/−28
- src/Nix/Fresh/Basic.hs +4/−2
- src/Nix/Json.hs +5/−4
- src/Nix/Lint.hs +55/−47
- src/Nix/Normal.hs +45/−29
- src/Nix/Parser.hs +1/−9
- src/Nix/Pretty.hs +73/−75
- src/Nix/Reduce.hs +1/−1
- src/Nix/Render/Frame.hs +10/−15
- src/Nix/Scope.hs +26/−26
- src/Nix/Standard.hs +270/−0
- src/Nix/String/Coerce.hs +89/−0
- src/Nix/Strings.hs +0/−116
- src/Nix/Thunk.hs +29/−13
- src/Nix/Thunk/Basic.hs +14/−29
- src/Nix/Thunk/Standard.hs +0/−108
- src/Nix/Type/Infer.hs +37/−30
- src/Nix/Utils.hs +19/−8
- src/Nix/Utils/Fix1.hs +64/−0
- src/Nix/Value.hs +150/−157
- src/Nix/Value/Equal.hs +21/−28
- src/Nix/Value/Monad.hs +12/−0
- src/Nix/XML.hs +13/−13
- tests/EvalTests.hs +4/−4
- tests/Main.hs +2/−2
- tests/NixLanguageTests.hs +0/−2
- tests/TestCommon.hs +11/−6
hnix.cabal view
@@ -1,5 +1,5 @@ name: hnix-version: 0.6.0+version: 0.6.1 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix@@ -443,10 +443,12 @@ Nix.Context Nix.Convert Nix.Effects+ Nix.Effects.Basic Nix.Eval Nix.Exec Nix.Expr Nix.Expr.Shorthands+ Nix.Expr.Strings Nix.Expr.Types Nix.Expr.Types.Annotated Nix.Frames@@ -462,75 +464,78 @@ Nix.Render Nix.Render.Frame Nix.Scope+ Nix.Standard Nix.String- Nix.Strings+ Nix.String.Coerce Nix.TH Nix.Thunk Nix.Thunk.Basic- Nix.Thunk.Standard 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 hs-source-dirs: src- ghc-options: -Wall+ ghc-options: -Wall -fprint-potential-instances build-depends:- aeson+ aeson >= 1.4.2 && < 1.5 , array >=0.4 && <0.6 , base >=4.9 && <5- , binary- , bytestring- , comonad- , containers- , data-fix+ , binary >= 0.8.5 && < 0.9+ , bytestring >= 0.10.8 && < 0.11+ , comonad >= 5.0.4 && < 5.1+ , containers >= 0.5.11.0 && < 0.7+ , contravariant >= 1.5 && < 1.6+ , data-fix >= 0.2.0 && < 0.3 , deepseq >=1.4.2 && <1.5- , dependent-sum+ , dependent-sum >= 0.4 && < 0.5 , deriving-compat >=0.3 && <0.6- , directory- , exceptions- , filepath- , free- , hashing- , hnix-store-core- , http-client- , http-client-tls- , http-types- , interpolate- , lens-family-th- , logict+ , directory >= 1.3.1 && < 1.4+ , exceptions >= 0.10.0 && < 0.11+ , filepath >= 1.4.2 && < 1.5+ , free >= 5.1 && < 5.2+ , hashing >= 0.1.0 && < 0.2+ , hnix-store-core >= 0.1.0 && < 0.2+ , http-client >= 0.5.14 && < 0.6+ , http-client-tls >= 0.3.5 && < 0.4+ , http-types >= 0.12.2 && < 0.13+ , interpolate >= 0.2.0 && < 0.3+ , lens-family-th >= 0.5.0 && < 0.6+ , logict >= 0.6.0 && < 0.7 , megaparsec >=7.0 && <7.1- , monad-control- , monadlist- , mtl- , optparse-applicative- , parser-combinators- , prettyprinter- , process- , ref-tf- , regex-tdfa- , regex-tdfa-text- , scientific+ , monad-control >= 1.0.2 && < 1.1+ , monadlist >= 0.0.2 && < 0.1+ , mtl >= 2.2.2 && < 2.3+ , optparse-applicative >= 0.14.3 && < 0.15+ , parser-combinators >= 1.0.1 && < 1.1+ , prettyprinter >= 1.2.1 && < 1.3+ , process >= 1.6.3 && < 1.7+ , ref-tf >= 0.4.0 && < 0.5+ , regex-tdfa >= 1.2.3 && < 1.3+ , regex-tdfa-text >= 1.0.0 && < 1.1+ , scientific >= 0.3.6 && < 0.4 , semigroups >=0.18 && <0.19- , split- , syb+ , split >= 0.2.3 && < 0.3+ , syb >= 0.7 && < 0.8 , template-haskell- , text- , these- , time- , transformers- , transformers-base- , unix- , unordered-containers >=0.2.9 && <0.3- , vector- , xml+ , text >= 1.2.3 && < 1.3+ , these >= 0.7.5 && < 0.8+ , time >= 1.8.0 && < 1.9+ , transformers >= 0.5.5 && < 0.6+ , transformers-base >= 0.4.5 && < 0.5+ , unix >= 2.7.2 && < 2.8+ , unordered-containers >=0.2.9 && < 0.3+ , vector >= 0.12.0 && < 0.13+ , xml >= 1.3.14 && < 1.4 if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)@@ -538,12 +543,12 @@ compact if !impl(ghcjs) build-depends:- base16-bytestring- , cryptohash-md5- , cryptohash-sha1- , cryptohash-sha256- , cryptohash-sha512- , serialise+ base16-bytestring >= 0.1.1 && < 0.2+ , cryptohash-md5 >= 0.11.100 && < 0.12+ , cryptohash-sha1 >= 0.11.100 && < 0.12+ , cryptohash-sha256 >= 0.11.101 && < 0.12+ , cryptohash-sha512 >= 0.11.100 && < 0.12+ , serialise >= 0.2.1 && < 0.3 if impl(ghc < 8.1) build-depends: lens-family ==1.2.1@@ -563,8 +568,8 @@ Nix.Options.Parser build-depends: hashable >=1.2.5 && <1.3- , haskeline- , pretty-show+ , haskeline >= 0.7.4.2 && < 0.8+ , pretty-show >= 1.9.5 && < 1.10 default-language: Haskell2010 executable hnix@@ -577,14 +582,15 @@ ghc-options: -Wall -rtsopts build-depends: aeson- , base >=4.9 && <5+ , base , bytestring , comonad , containers , data-fix- , deepseq >=1.4.2 && <1.5+ , deepseq , exceptions , filepath+ , free , hashing , haskeline , hnix@@ -598,7 +604,7 @@ , text , time , transformers- , unordered-containers >=0.2.9 && <0.3+ , unordered-containers if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)
main/Main.hs view
@@ -14,6 +14,7 @@ import qualified Control.Exception as Exc import Control.Monad import Control.Monad.Catch+import Control.Monad.Free import Control.Monad.IO.Class -- import Control.Monad.ST import qualified Data.Aeson.Text as A@@ -30,15 +31,17 @@ import Nix import Nix.Convert import qualified Nix.Eval as Eval+import Nix.Fresh.Basic import Nix.Json -- import Nix.Lint import Nix.Options.Parser+import Nix.Standard import Nix.Thunk.Basic-import Nix.Thunk.Standard 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 qualified Repl import System.FilePath@@ -49,7 +52,7 @@ main = do time <- getCurrentTime opts <- execParser (nixOptionsInfo time)- runStandardIO opts $ case readFrom opts of+ runWithBasicEffectsIO opts $ case readFrom opts of Just path -> do let file = addExtension (dropExtension path) "nixc" process opts (Just file) =<< liftIO (readCache path)@@ -95,9 +98,11 @@ NixException frames -> errorWithoutStackTrace . show- =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames+ =<< renderFrames @(StdValue (StandardT (StdIdT IO)))+ @(StdThunk (StandardT (StdIdT IO)))+ frames - when (repl opts) $ withNixContext Nothing $ Repl.main+ when (repl opts) $ withNixContext Nothing Repl.main process opts mpath expr | evaluate opts@@ -132,7 +137,7 @@ where printer | finder opts- = fromValue @(AttrSet (StandardThunk IO)) >=> findAttrs+ = fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) >=> findAttrs | xml opts = liftIO . putStrLn@@ -146,27 +151,28 @@ . principledStringIgnoreContext <=< nvalueToJSONNixString | strict opts- = liftIO . print . prettyNValueNF <=< normalForm+ = liftIO . print . prettyNValue <=< normalForm | values opts- = liftIO . print <=< prettyNValueProv+ = liftIO . print . prettyNValueProv <=< removeEffects | otherwise- = liftIO . print <=< prettyNValue+ = liftIO . print . prettyNValue <=< removeEffects where+ findAttrs+ :: AttrSet (StdValue (StandardT (StdIdT IO)))+ -> StandardT (StdIdT IO) () findAttrs = go "" where go prefix s = do- xs <-- forM (sortOn fst (M.toList s))- $ \(k, nv@(StdThunk (extract -> t))) -> case t of- Value v -> pure (k, Just v)- Thunk _ _ ref -> do- let path = prefix ++ Text.unpack k- (_, descend) = filterEntry path k- val <- readVar @(StandardT IO) ref- case val of- Computed _ -> pure (k, Nothing)- _ | descend -> (k, ) <$> forceEntry path nv- | otherwise -> pure (k, Nothing)+ 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) forM_ xs $ \(k, mv) -> do let path = prefix ++ Text.unpack k@@ -197,14 +203,16 @@ _ -> (True, True) forceEntry k v =- catch (Just <$> force v pure) $ \(NixException frames) -> do+ catch (Just <$> demand v pure) $ \(NixException frames) -> do liftIO . putStrLn . ("Exception forcing " ++) . (k ++) . (": " ++) . show- =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames+ =<< renderFrames @(StdValue (StandardT (StdIdT IO)))+ @(StdThunk (StandardT (StdIdT IO)))+ frames return Nothing reduction path mp x = do
main/Repl.hs view
@@ -115,7 +115,7 @@ -- tyctx' <- hoistErr $ inferTop (tyctx st) expr -- TODO: track scope with (tmctx st)- mVal <- lift $ lift $ try $ pushScope @t M.empty (evalExprLoc expr)+ mVal <- lift $ lift $ try $ pushScope M.empty (evalExprLoc expr) case mVal of Left (NixException frames) -> do@@ -138,9 +138,9 @@ lift $ lift $ do opts :: Nix.Options <- asks (view hasLens) if- | strict opts -> liftIO . print . prettyNValueNF =<< normalForm val- | values opts -> liftIO . print =<< prettyNValueProv val- | otherwise -> liftIO . print =<< prettyNValue val+ | strict opts -> liftIO . print . prettyNValue =<< normalForm val+ | values opts -> liftIO . print . prettyNValueProv =<< removeEffects val+ | otherwise -> liftIO . print . prettyNValue =<< removeEffects val ------------------------------------------------------------------------------- -- Commands -------------------------------------------------------------------------------@@ -171,7 +171,8 @@ val <- case M.lookup line (tmctx st) of Just val -> return val Nothing -> exec False line- liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val+ str <- lift $ lift $ showValueType val+ liftIO $ putStrLn str where line = Text.pack (unwords args) -- :quit command@@ -224,6 +225,3 @@ :: (MonadNix e t f m, MonadIO m) => CompleterStyle (StateT (IState t f m) m) completer = Prefix (wordCompleter comp) defaultMatcher---
src/Nix.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Nix@@ -51,6 +51,7 @@ import Nix.Thunk import Nix.Utils import Nix.Value+import Nix.Value.Monad import Nix.XML -- | This is the entry point for all evaluations, whatever the expression tree@@ -82,7 +83,7 @@ -> m (NValue t f m) nixEvalExprLoc mpath = nixEval mpath- (Eval.addStackFrames @t . Eval.addSourcePositions)+ (Eval.addStackFrames . Eval.addSourcePositions) (Eval.eval . annotated . getCompose) -- | Evaluate a nix expression with tracing in the default context. Note that@@ -117,13 +118,11 @@ eval' = (normalForm =<<) . nixEvalExpr mpath - argmap args = pure $ nvSet (M.fromList args') mempty- where args' = map (fmap (wrapValue . nValueFromNF)) args+ argmap args = nvSet (M.fromList args) mempty - compute ev x args p = do- f :: NValue t f m <- ev mpath x- processResult p =<< case f of- NVClosure _ g -> force ?? pure =<< g args+ compute ev x args p = ev mpath x >>= \f -> demand f $ \f' ->+ processResult p =<< case f' of+ NVClosure _ g -> g args _ -> pure f processResult@@ -140,17 +139,17 @@ where go :: [Text.Text] -> NValue t f m -> m a go [] v = h v- go ((Text.decimal -> Right (n,"")) : ks) v = case v of+ go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case NVList xs -> case ks of- [] -> force @t @m @(NValue t f m) (xs !! n) h- _ -> force (xs !! n) (go ks)+ [] -> h (xs !! n)+ _ -> go ks (xs !! n) _ -> errorWithoutStackTrace $ "Expected a list for selector '" ++ show n ++ "', but got: " ++ show v- go (k : ks) v = case v of+ go (k : ks) v = demand v $ \case NVSet xs _ -> case M.lookup k xs of Nothing -> errorWithoutStackTrace@@ -158,8 +157,8 @@ ++ Text.unpack k ++ "'" Just v' -> case ks of- [] -> force v' h- _ -> force v' (go ks)+ [] -> h v'+ _ -> go ks v' _ -> errorWithoutStackTrace $ "Expected a set for selector '"
src/Nix/Atoms.hs view
@@ -11,6 +11,7 @@ #endif import Control.DeepSeq import Data.Data+import Data.Fixed (mod') import Data.Hashable import Data.Text ( Text , pack@@ -40,14 +41,10 @@ -- | Translate an atom into its nix representation. atomText :: NAtom -> Text atomText (NInt i) = pack (show i)-atomText (NFloat f) = pack (show f)+atomText (NFloat f) = pack (showNixFloat f)+ where+ showNixFloat x+ | x `mod'` 1 /= 0 = show x+ | otherwise = show (truncate x :: Int) atomText (NBool b) = if b then "true" else "false" atomText NNull = "null"--------
src/Nix/Builtins.hs view
@@ -4,7 +4,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}@@ -29,7 +31,7 @@ import Control.Monad.ListM ( sortByM ) import Control.Monad.Reader ( asks ) --- Using package imports here because there is a bug in cabal2nix that forces+-- Using package imports here because there is a bug in cabal2nix that demands -- us to put the hashing package in the unconditional dependency list. -- See https://github.com/NixOS/cabal2nix/issues/348 for more info #if MIN_VERSION_hashing(0, 1, 0)@@ -53,7 +55,7 @@ import qualified Data.ByteString as B import Data.ByteString.Base16 as Base16 import Data.Char ( isDigit )-import Data.Fix+import Data.Fix ( cata ) import Data.Foldable ( foldrM ) import qualified Data.HashMap.Lazy as M import Data.List@@ -76,6 +78,7 @@ 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@@ -88,12 +91,13 @@ import Nix.Render import Nix.Scope import Nix.String-import Nix.Thunk+import Nix.String.Coerce import Nix.Utils import Nix.Value import Nix.Value.Equal+import Nix.Value.Monad import Nix.XML-import System.Nix.Internal.Hash ( printHashBytes32 )+import System.Nix.Base32 as Base32 import System.FilePath import System.Posix.Files ( isRegularFile , isDirectory@@ -112,9 +116,8 @@ withNixContext mpath action = do base <- builtins opts :: Options <- asks (view hasLens)- let i = wrapValue @t @m @(NValue t f m) $ nvList $ map- ( wrapValue @t @m @(NValue t f m)- . nvStr+ let i = nvList $ map+ ( nvStr . hackyMakeNixStringWithoutContext . Text.pack )@@ -123,12 +126,13 @@ Nothing -> action Just path -> do traceM $ "Setting __cur_file = " ++ show path- let ref = wrapValue @t @m @(NValue t f m) $ nvPath path+ let ref = nvPath path pushScope (M.singleton "__cur_file" ref) action -builtins :: (MonadNix e t f m, Scoped t m) => m (Scopes m t)+builtins :: (MonadNix e t f m, Scoped (NValue t f m) m)+ => m (Scopes m (NValue t f m)) builtins = do- ref <- thunk $ flip nvSet M.empty <$> buildMap+ ref <- defer $ flip nvSet M.empty <$> buildMap lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins pushScope (M.fromList lst) currentScopes where@@ -142,25 +146,19 @@ Builtin TopLevel ("__" <> name, builtin) data BuiltinType = Normal | TopLevel-data Builtin t = Builtin+data Builtin v = Builtin { _kind :: BuiltinType- , mapping :: (Text, t)+ , mapping :: (Text, v) } -valueThunk :: forall e t f m . MonadNix e t f m => NValue t f m -> t-valueThunk = wrapValue @_ @m--force' :: forall e t f m . MonadNix e t f m => t -> m (NValue t f m)-force' = force ?? pure--builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin t]+builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] builtinsList = sequence [ do version <- toValue (principledMakeNixStringWithoutContext "2.0")- pure $ Builtin Normal ("nixVersion", wrapValue version)+ pure $ Builtin Normal ("nixVersion", version) , do version <- toValue (5 :: Int)- pure $ Builtin Normal ("langVersion", wrapValue version)+ pure $ Builtin Normal ("langVersion", version) , add0 Normal "nixPath" nixPath , add TopLevel "abort" throw_ -- for now@@ -177,6 +175,7 @@ , 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_@@ -232,7 +231,7 @@ , add Normal "getEnv" getEnv_ , add2 Normal "hasAttr" hasAttr , add Normal "hasContext" hasContext- , add' Normal "hashString" hashString+ , add' Normal "hashString" (hashString @e @t @f @m) , add Normal "head" head_ , add TopLevel "import" import_ , add2 Normal "intersectAttrs" intersectAttrs@@ -269,7 +268,7 @@ , add0 Normal "storeDir" (return $ nvStr $ principledMakeNixStringWithoutContext "/nix/store") , add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext) , add' Normal "sub" (arity2 ((-) @Integer))- , add' Normal "substring" substring+ , add' Normal "substring" (substring @e @t @f @m) , add Normal "tail" tail_ , add0 Normal "true" (return $ nvConstant $ NBool True) , add TopLevel "throw" throw_@@ -289,21 +288,25 @@ , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext ] 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 = thunk . withFrame+ 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)+ 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' :: ToBuiltin t f m a => BuiltinType -> Text -> a -> m (Builtin t)+ 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@@ -318,7 +321,7 @@ mres <- lookupVar "__includes" dirs <- case mres of Nothing -> return []- Just v -> force v fromNix+ Just v -> demand v $ fromValue . Deeper menv <- getEnvVar "NIX_PATH" foldrM go z $ map (fromInclude . principledStringIgnoreContext) dirs@@ -336,62 +339,60 @@ nixPath :: MonadNix e t f m => m (NValue t f m) nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest -> pure- $ valueThunk- (flip nvSet mempty $ M.fromList- [ case ty of- PathEntryPath -> ("path", valueThunk $ nvPath p)- PathEntryURI ->- ( "uri"- , valueThunk- $ nvStr (hackyMakeNixStringWithoutContext (Text.pack p))- )- , ( "prefix"- , valueThunk $ nvStr- (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn))+ $ (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 => m (NValue t f m) -> m (NValue t f m)-toString str = str >>= coerceToString DontCopyToStore CoerceAny >>= toNix+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- => m (NValue t f m)- -> m (NValue 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 t, AttrSet SourcePos) y- >>= \(aset, _) -> toNix $ M.member key aset+ fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y+ >>= \(aset, _) -> toValue $ M.member key aset -attrsetGet :: MonadNix e t f m => Text -> AttrSet t -> m t+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 => m (NValue t f m) -> m (NValue t f m)-hasContext = toNix . stringHasContext <=< fromValue+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- => m (NValue t f m)- -> m (NValue 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 t, AttrSet SourcePos) y- >>= \(aset, _) -> attrsetGet key aset >>= force'+ fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y+ >>= \(aset, _) -> attrsetGet key aset unsafeGetAttrPos :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of+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@@ -405,46 +406,46 @@ -- 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 => m (NValue t f m) -> m (NValue t f m)-length_ = toValue . (length :: [t] -> Int) <=< fromValue+ :: 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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-add_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of- (NVConstant (NInt x), NVConstant (NInt y) ) -> toNix (x + y :: Integer)- (NVConstant (NFloat x), NVConstant (NInt y) ) -> toNix (x + fromInteger y)- (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x + y)- (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x + y)+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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-mul_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of- (NVConstant (NInt x), NVConstant (NInt y) ) -> toNix (x * y :: Integer)- (NVConstant (NFloat x), NVConstant (NInt y) ) -> toNix (x * fromInteger y)- (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x * y)- (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x * y)+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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of+div_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 ->- toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer)+ toValue (floor (fromInteger x / fromInteger y :: Double) :: Integer) (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 ->- toNix (x / fromInteger y)+ toValue (x / fromInteger y) (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 ->- toNix (fromInteger x / y)- (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toNix (x / y)+ 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@@ -455,11 +456,10 @@ any_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-any_ fun xs = fun >>= \f ->- toNix <=< anyM fromValue <=< mapM ((f `callFunc`) . force') <=< fromValue $ xs+any_ f = toValue <=< anyM fromValue <=< mapM (f `callFunc`) <=< fromValue allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM _ [] = return True@@ -469,28 +469,27 @@ all_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-all_ fun xs = fun >>= \f ->- toNix <=< allM fromValue <=< mapM ((f `callFunc`) . force') <=< fromValue $ xs+all_ f = toValue <=< allM fromValue <=< mapM (f `callFunc`) <=< fromValue foldl'_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m+ -> NValue t f m -> m (NValue t f m)-foldl'_ fun z xs = fun >>= \f -> fromValue @[t] xs >>= foldl' (go f) z- where go f b a = f `callFunc` b >>= (`callFunc` force' a)+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 => m (NValue t f m) -> m (NValue t f m)+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 : _ -> force' h+ h : _ -> pure h -tail_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+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 -> return $ nvList t@@ -535,13 +534,12 @@ x -> VersionComponent_String x in thisComponent : splitVersion rest -splitVersion_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+splitVersion_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) splitVersion_ = fromValue >=> fromStringNoContext >=> \s -> return $ nvList $ flip map (splitVersion s)- $ valueThunk- . nvStr+ $ nvStr . principledMakeNixStringWithoutContext . versionComponentToString @@ -554,8 +552,8 @@ compareVersions_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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 ->@@ -584,24 +582,23 @@ (Text.intercalate sep namePieces, Text.intercalate sep versionPieces) parseDrvName- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: 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- -- jww (2018-04-15): There should be an easier way to write this.- (toValue =<<) $ sequence $ M.fromList+ toValue @(AttrSet (NValue t f m)) $ M.fromList [ ( "name" :: Text- , thunk @t (toValue $ principledMakeNixStringWithoutContext name)+ , nvStr $ principledMakeNixStringWithoutContext name ) , ( "version"- , thunk @t (toValue $ principledMakeNixStringWithoutContext version)+ , nvStr $ principledMakeNixStringWithoutContext version ) ] match_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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@@ -619,15 +616,15 @@ case matchOnceText re (encodeUtf8 s) of Just ("", sarr, "") -> do let s = map fst (elems sarr)- nvList <$> traverse (fmap wrapValue . mkMatch . decodeUtf8)+ 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- => m (NValue t f m)- -> m (NValue 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@@ -648,7 +645,7 @@ => Int -> [[(ByteString, (Int, Int))]] -> ByteString- -> [t]+ -> [NValue t f m] splitMatches _ [] haystack = [thunkStr haystack] splitMatches _ ([] : _) _ = error "Error in splitMatches: this should never happen!"@@ -659,13 +656,12 @@ where relStart = max 0 start - numDropped (before, rest) = B.splitAt relStart haystack- caps = valueThunk $ nvList (map f captures)- f (a, (s, _)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a+ caps = nvList (map f captures)+ f (a, (s, _)) = if s < 0 then nvConstant NNull else thunkStr a -thunkStr s =- valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)))+thunkStr s = nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)) -substring :: MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString+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 --NOTE: negative values of 'len' are OK then throwError@@ -675,116 +671,113 @@ else pure $ principledModifyNixContents (Text.take len . Text.drop start) str attrNames- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) attrNames =- fromValue @(AttrSet t)- >=> toNix+ 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 => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) attrValues =- fromValue @(AttrSet t)+ fromValue @(AttrSet (NValue t f m)) >=> toValue . fmap snd- . sortOn (fst @Text @t)+ . sortOn (fst @Text @(NValue t f m)) . M.toList map_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-map_ fun xs = fun >>= \f ->+map_ f = toValue <=< traverse- ( thunk @t+ ( defer @(NValue t f m) . withFrame Debug (ErrorCall "While applying f in map:\n") . (f `callFunc`)- . force' )- <=< fromValue @[t]- $ xs+ <=< fromValue @[NValue t f m] mapAttrs_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-mapAttrs_ fun xs = fun >>= \f -> fromValue @(AttrSet t) xs >>= \aset -> do+mapAttrs_ f xs = fromValue @(AttrSet (NValue t f m)) xs >>= \aset -> do let pairs = M.toList aset values <- for pairs $ \(key, value) ->- thunk @t+ defer @(NValue t f m) $ withFrame Debug (ErrorCall "While applying f in mapAttrs:\n")- $ callFunc- ?? force' value- =<< callFunc f (pure (nvStr (principledMakeNixStringWithoutContext key)))+ $ 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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-filter_ fun xs = fun >>= \f ->+filter_ f = toValue- <=< filterM (fromValue <=< callFunc f . force')- <=< fromValue @[t]- $ xs+ <=< filterM (fromValue <=< callFunc f)+ <=< fromValue catAttrs :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m) catAttrs attrName xs = fromValue attrName >>= fromStringNoContext >>= \n ->- fromValue @[t] xs >>= \l ->+ fromValue @[NValue t f m] xs >>= \l -> fmap (nvList . catMaybes) $ forM l $ fmap (M.lookup n)- . flip force fromValue+ . flip demand fromValue -baseNameOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+baseNameOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) baseNameOf x = do- ns <- coerceToString DontCopyToStore CoerceStringy =<< x+ 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- => m (NValue t f m)- -> m (NValue 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 -> toNix (a .&. b)+ fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .&. b) bitOr :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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 -> toNix (a .|. b)+ fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .|. b) bitXor :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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 -> toNix (a `xor` b)+ >>= \a -> fromValue @Integer y >>= \b -> toValue (a `xor` b) -dirOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-dirOf x = x >>= \case+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@@ -793,41 +786,34 @@ -- jww (2018-04-28): This should only be a string argument, and not coerced? unsafeDiscardStringContext- :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) unsafeDiscardStringContext mnv = do ns <- fromValue mnv- toNix $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext+ toValue $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext ns seq_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-seq_ a b = a >> b+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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-deepSeq a b = do- -- We evaluate 'a' only for its effects, so data cycles are ignored.- normalForm_ =<< a-- -- Then we evaluate the other argument to deepseq, thus this function- -- should always produce a result (unlike applying 'deepseq' on infinitely- -- recursive data structures in Haskell).- b+deepSeq a b = b <$ normalForm_ a elem_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-elem_ x xs = x >>= \x' ->- toValue <=< anyM (valueEqM x' <=< force') <=< fromValue @[t] $ xs+elem_ x = toValue <=< anyM (valueEqM x) <=< fromValue elemAt :: [a] -> Int -> Maybe a elemAt ls i = case drop i ls of@@ -836,12 +822,12 @@ elemAt_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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 -> force' a+ Just a -> pure a Nothing -> throwError $ ErrorCall@@ -853,12 +839,11 @@ genList :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-genList generator = fromValue @Integer >=> \n -> if n >= 0- then generator >>= \f ->- toValue =<< forM [0 .. n - 1] (\i -> thunk @t $ f `callFunc` toNix i)+genList f = fromValue @Integer >=> \n -> if n >= 0+ then toValue =<< forM [0 .. n - 1] (\i -> defer $ (f `callFunc`) =<< toValue i) else throwError $ ErrorCall@@ -866,12 +851,12 @@ ++ show n -- We wrap values solely to provide an Ord instance for genericClosure-newtype WValue t f m a = WValue (NValue' t f m a)+newtype WValue t f m = WValue (NValue t f m) -instance Comonad f => Eq (WValue t f m a) where+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)) =+ 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@@ -880,10 +865,10 @@ hackyStringIgnoreContext x == hackyStringIgnoreContext y _ == _ = False -instance Comonad f => Ord (WValue t f m a) where+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)) =+ 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@@ -893,8 +878,8 @@ _ <= _ = False genericClosure- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-genericClosure = fromValue @(AttrSet t) >=> \s ->+ :: 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@@ -910,22 +895,22 @@ $ ErrorCall $ "builtins.genericClosure: Attribute 'operator' required" (Just startSet, Just operator) ->- force startSet $ fromValue @[t] >=> \ss ->- force operator $ \op -> toValue @[t] =<< snd <$> go op ss S.empty+ 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- -> [t]- -> Set (WValue t f m t)- -> m (Set (WValue t f m t), [t])+ -> [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 = force t $ \v -> fromValue @(AttrSet t) v >>= \s -> do+ go op (t : ts) ks = demand t $ \v -> fromValue @(AttrSet (NValue t f m)) v >>= \s -> do k <- attrsetGet "key" s- force k $ \k' -> do+ demand k $ \k' -> do if S.member (WValue k') ks then go op ts ks else do- ys <- fromValue @[t] =<< (op `callFunc` pure v)+ ys <- fromValue @[NValue t f m] =<< (op `callFunc` v) case S.toList ks of [] -> checkComparable k' k' WValue j : _ -> checkComparable k' j@@ -933,12 +918,12 @@ replaceStrings :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m+ -> NValue t f m -> m (NValue t f m)-replaceStrings tfrom tto ts = fromNix tfrom >>= \(nsFrom :: [NixString]) ->- fromNix tto >>= \(nsTo :: [NixString]) ->+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)@@ -978,38 +963,38 @@ _ -> go rest (result <> Builder.fromText replacement) (ctx <> newCtx)- toNix+ toValue $ go (principledStringIgnoreContext ns) mempty $ principledGetContext ns removeAttrs :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-removeAttrs set = fromNix >=> \(nsToRemove :: [NixString]) ->- fromValue @(AttrSet t, AttrSet SourcePos) set >>= \(m, p) -> do+removeAttrs set = fromValue . Deeper >=> \(nsToRemove :: [NixString]) ->+ fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set >>= \(m, p) -> do toRemove <- mapM fromStringNoContext nsToRemove- toNix (go m toRemove, go p toRemove)+ toValue (go m toRemove, go p toRemove) where go = foldl' (flip M.delete) intersectAttrs :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m) intersectAttrs set1 set2 =- fromValue @(AttrSet t, AttrSet SourcePos) set1 >>= \(s1, p1) ->- fromValue @(AttrSet t, AttrSet SourcePos) set2 >>= \(s2, p2) ->+ fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 >>= \(s1, p1) ->+ fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 >>= \(s2, p2) -> return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) functionArgs- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-functionArgs fun = fun >>= \case+ :: 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 t) $ valueThunk . nvConstant . NBool <$> case p of+ toValue @(AttrSet (NValue t f m)) $ nvConstant . NBool <$> case p of Param name -> M.singleton name False ParamSet s _ _ -> isJust <$> M.fromList s v ->@@ -1020,8 +1005,8 @@ toFile :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m) toFile name s = do name' <- fromStringNoContext =<< fromValue name@@ -1033,15 +1018,15 @@ (Text.unpack $ hackyStringIgnoreContext s') let t = Text.pack $ unStorePath mres sc = StringContext t DirectPath- toNix $ principledMakeNixStringWithSingletonContext t sc+ toValue $ principledMakeNixStringWithSingletonContext t sc -toPath :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-toPath = fromValue @Path >=> toNix @Path+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 => m (NValue t f m) -> m (NValue t f m)-pathExists_ path = path >>= \case- NVPath p -> toNix =<< pathExists p- NVStr ns -> toNix =<< pathExists (Text.unpack (hackyStringIgnoreContext ns))+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@@ -1051,61 +1036,61 @@ hasKind :: forall a e t f m . (MonadNix e t f m, FromValue a m (NValue t f m))- => m (NValue t f m)+ => NValue t f m -> m (NValue t f m)-hasKind = fromValueMay >=> toNix . \case+hasKind = fromValueMay >=> toValue . \case Just (_ :: a) -> True _ -> False isAttrs- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-isAttrs = hasKind @(AttrSet t)+ :: 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 => m (NValue t f m) -> m (NValue t f m)-isList = hasKind @[t]+ :: 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] isString- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isString = hasKind @NixString isInt- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: 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 => m (NValue t f m) -> m (NValue t f m)+ :: 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 => m (NValue t f m) -> m (NValue t f m)+ :: 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 => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isNull = hasKind @() -isFunction :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-isFunction func = func >>= \case+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 => m (NValue t f m) -> m (NValue t f m)+throw_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) throw_ mnv = do- ns <- coerceToString CopyToStore CoerceStringy =<< mnv+ ns <- coerceToString callFunc CopyToStore CoerceStringy mnv throwError . ErrorCall . Text.unpack $ principledStringIgnoreContext ns import_- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-import_ = scopedImport (pure (nvSet M.empty M.empty))+ :: 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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-scopedImport asetArg pathArg = fromValue @(AttrSet t) asetArg >>= \s ->+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"@@ -1113,45 +1098,44 @@ Nothing -> do traceM "No known current directory" return path- Just p -> force p $ fromValue >=> \(Path p') -> do+ Just p -> demand p $ fromValue >=> \(Path p') -> do traceM $ "Current file being evaluated is: " ++ show p' return $ takeDirectory p' </> path- clearScopes @t+ clearScopes @(NValue t f m) $ withNixContext (Just path') $ pushScope s $ importPath @t @f @m path' -getEnv_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+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)- toNix $ principledMakeNixStringWithoutContext $ case mres of+ toValue $ principledMakeNixStringWithoutContext $ case mres of Nothing -> "" Just v -> Text.pack v sort_ :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-sort_ comparator xs = comparator- >>= \comp -> fromValue xs >>= sortByM (cmp comp) >>= toValue+sort_ comp = fromValue >=> sortByM (cmp comp) >=> toValue where cmp f a b = do- isLessThan <- f `callFunc` force' a >>= (`callFunc` force' b)+ isLessThan <- f `callFunc` a >>= (`callFunc` b) fromValue isLessThan >>= \case True -> pure LT False -> do- isGreaterThan <- f `callFunc` force' b >>= (`callFunc` force' a)+ isGreaterThan <- f `callFunc` b >>= (`callFunc` a) fromValue isGreaterThan <&> \case True -> GT False -> EQ lessThan :: MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-lessThan ta tb = ta >>= \va -> tb >>= \vb -> do+lessThan ta tb = demand ta $ \va -> demand tb $ \vb -> do let badType = throwError $ ErrorCall@@ -1172,23 +1156,37 @@ _ -> badType concatLists- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) concatLists =- fromValue @[t]- >=> mapM (flip force $ fromValue @[t] >=> pure)+ 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 => m (NValue t f m) -> m (NValue t f m)-listToAttrs = fromValue @[t] >=> \l ->+ :: 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 force- $ fromValue @(AttrSet t)+ $ flip demand+ $ fromValue @(AttrSet (NValue t f m)) >=> \s -> do t <- attrsetGet "name" s- force t $ fromValue >=> \n -> do+ demand t $ fromValue >=> \n -> do name <- fromStringNoContext n val <- attrsetGet "value" s pure (name, val)@@ -1197,7 +1195,7 @@ -- fail if context in the algo arg -- propagate context from the s arg hashString- :: MonadNix e t f m => NixString -> NixString -> Prim m NixString+ :: 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@@ -1237,16 +1235,16 @@ ++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo -placeHolder :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+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)) )- toNix+ toValue $ principledMakeNixStringWithoutContext $ Text.cons '/'- $ printHashBytes32+ $ Base32.encode $ fst -- The result coming out of hashString is base16 encoded $ Base16.decode $ encodeUtf8@@ -1266,17 +1264,17 @@ NVPath path -> pure path v -> throwError $ ErrorCall $ "expected a path, got " ++ show v -readFile_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-readFile_ path =- path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix+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- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-findFile_ aset filePath = aset >>= \aset' -> filePath >>= \filePath' ->+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))@@ -1295,17 +1293,17 @@ | FileTypeUnknown deriving (Show, Read, Eq, Ord) -instance Convertible e t f m => ToNix FileType m (NValue t f m) where- toNix = toNix . principledMakeNixStringWithoutContext . \case+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 => m (NValue t f m) -> m (NValue t f m)-readDir_ pathThunk = do- path <- absolutePathFromValue =<< pathThunk+ :: 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@@ -1315,41 +1313,34 @@ | isSymbolicLink s -> FileTypeSymlink | otherwise -> FileTypeUnknown pure (Text.pack item, t)- toNix (M.fromList itemsWithTypes)+ getDeeper <$> toValue (M.fromList itemsWithTypes) fromJSON- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->+ :: 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 (thunk . jsonToNValue) m- A.Array l -> nvList <$> traverse- (\x ->- thunk @t @m @(NValue t f m)- . whileForcingThunk @t @f (CoercionFromJson @t @f @m x)- . jsonToNValue- $ x- )- (V.toList l)+ 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+ A.Bool b -> pure $ nvConstant $ NBool b+ A.Null -> pure $ nvConstant NNull -prim_toJSON :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-prim_toJSON x = x >>= nvalueToJSONNixString >>= pure . nvStr+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 => m (NValue t f m) -> m (NValue t f m)-toXML_ v = v >>= normalForm >>= pure . nvStr . toXML+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 => m (NValue t f m) -> m (NValue t f m)-typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case+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 NInt _ -> "int" NFloat _ -> "float"@@ -1364,54 +1355,54 @@ _ -> error "Pattern synonyms obscure complete patterns" tryEval- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-tryEval e = catch (onSuccess <$> e) (pure . onError)+ :: 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", valueThunk (nvConstant (NBool True))), ("value", valueThunk v)]+ [("success", nvConstant (NBool True)), ("value", v)] onError :: SomeException -> NValue t f m onError _ = flip nvSet M.empty $ M.fromList- [ ("success", valueThunk (nvConstant (NBool False)))- , ("value" , valueThunk (nvConstant (NBool False)))+ [ ("success", nvConstant (NBool False))+ , ("value" , nvConstant (NBool False)) ] trace_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue 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- action+ pure action -- TODO: remember error context addErrorContext :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-addErrorContext _ action = action+addErrorContext _ action = pure action exec_- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) exec_ xs = do- ls <- fromValue @[t] xs- xs <- traverse (coerceToString DontCopyToStore CoerceStringy <=< force') ls+ 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 => m (NValue t f m) -> m (NValue t f m)-fetchurl v = v >>= \case- NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s))+ :: 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@@ -1419,7 +1410,7 @@ $ "builtins.fetchurl: Expected URI or set, got " ++ show v where- go :: Maybe t -> NValue t f m -> m (NValue t f m)+ 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@@ -1438,15 +1429,15 @@ partition_ :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-partition_ fun xs = fun >>= \f -> fromValue @[t] xs >>= \l -> do- let match t = f `callFunc` force' t >>= fmap (, t) . fromValue+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 = valueThunk . nvList . map snd- toValue @(AttrSet t)+ 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)@@ -1458,42 +1449,45 @@ currentTime_ :: MonadNix e t f m => m (NValue t f m) currentTime_ = do opts :: Options <- asks (view hasLens)- toNix @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts)+ toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) -derivationStrict_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-derivationStrict_ = (>>= derivationStrict)+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 => m (NValue t f m) -> m (NValue t f m)-getContext x = x >>= \x' -> case x' of+ :: 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 $ flip nvSet M.empty $ M.map wrapValue valued+ pure $ flip nvSet M.empty $ valued x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " ++ show x appendContext :: forall e t f m . MonadNix e t f m- => m (NValue t f m)- -> m (NValue t f m)+ => NValue t f m+ -> NValue t f m -> m (NValue t f m)-appendContext x y = x >>= \x' -> y >>= \y' -> case (x', y') of+appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVStr ns, NVSet attrs _) -> do- newContextValues <- forM attrs $ force' >=> \case+ newContextValues <- forM attrs $ \attr -> demand attr $ \case NVSet attrs _ -> do -- TODO: Fail for unexpected keys.- path <- maybe (return False) (force ?? fromValue)+ path <- maybe (return False) (demand ?? fromValue) $ M.lookup "path" attrs- allOutputs <- maybe (return False) (force ?? fromValue)+ allOutputs <- maybe (return False) (demand ?? fromValue) $ M.lookup "allOutputs" attrs outputs <- case M.lookup "outputs" attrs of Nothing -> return []- Just os -> force' os >>= \case+ Just os -> demand os $ \case NVList vs ->- forM vs $ fmap principledStringIgnoreContext . fromNix . force'+ forM vs $ fmap principledStringIgnoreContext . fromValue x -> throwError $ ErrorCall@@ -1525,13 +1519,14 @@ class ToBuiltin t f m a | a -> m where toBuiltin :: String -> a -> m (NValue t f m) -instance (MonadNix e t f m, ToNix 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 = toNix =<< runPrim p+ toBuiltin _ p = toValue =<< runPrim p instance ( MonadNix e t f m- , FromNix a m (NValue t f m)- , ToBuiltin t f m b)+ , FromValue a m (Deeper (NValue t f m))+ , ToBuiltin t f m b+ ) => ToBuiltin t f m (a -> b) where toBuiltin name f =- return $ nvBuiltin name (fromNix >=> fmap wrapValue . toBuiltin name . f)+ return $ nvBuiltin name (fromValue . Deeper >=> toBuiltin name . f)
src/Nix/Cited.hs view
@@ -21,8 +21,8 @@ import Nix.Expr.Types.Annotated import Nix.Scope -data Provenance t m v = Provenance- { _lexicalScope :: Scopes m t+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 -- 'originExpr' for the resulting value will be 3 + 2, while the@@ -31,34 +31,34 @@ } deriving (Generic, Typeable, Show) -data NCited t m v a = NCited- { _provenance :: [Provenance t m v]+data NCited m v a = NCited+ { _provenance :: [Provenance m v] , _cited :: a } deriving (Generic, Typeable, Functor, Foldable, Traversable, Show) -instance Applicative (NCited t m v) where+instance Applicative (NCited m v) where pure = NCited [] NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) -instance Comonad (NCited t m v) where+instance Comonad (NCited m v) where duplicate p = NCited (_provenance p) p extract = _cited -instance ComonadEnv [Provenance t m v] (NCited t m v) where+instance ComonadEnv [Provenance m v] (NCited m v) where ask = _provenance $(makeLenses ''Provenance) $(makeLenses ''NCited) -class HasCitations t m v a where- citations :: a -> [Provenance t m v]- addProvenance :: Provenance t m v -> a -> a+class HasCitations m v a where+ citations :: a -> [Provenance m v]+ addProvenance :: Provenance m v -> a -> a -instance HasCitations t m v (NCited t m v a) where+instance HasCitations m v (NCited m v a) where citations = _provenance addProvenance x (NCited p v) = (NCited (x : p) v) -class HasCitations1 t m v f where- citations1 :: f a -> [Provenance t m v]- addProvenance1 :: Provenance t m v -> f a -> f a+class HasCitations1 m v f where+ citations1 :: f a -> [Provenance m v]+ addProvenance1 :: Provenance m v -> f a -> f a
src/Nix/Cited/Basic.hs view
@@ -29,7 +29,7 @@ import Nix.Utils import Nix.Value -newtype Cited t f m a = Cited { getCited :: NCited t m (NValue t f m) a }+newtype Cited t f m a = Cited { getCited :: NCited m (NValue t f m) a } deriving ( Generic , Typeable@@ -38,10 +38,10 @@ , Foldable , Traversable , Comonad- , ComonadEnv [Provenance t m (NValue t f m)]+ , ComonadEnv [Provenance m (NValue t f m)] ) -instance HasCitations1 t m (NValue t f m) (Cited t f m) where+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) @@ -49,6 +49,7 @@ , Framed e m , MonadThunk t m v , Typeable m+ , Typeable f , Typeable u , MonadCatch m )@@ -75,7 +76,6 @@ thunkId (Cited (NCited _ t)) = thunkId @_ @m t - query (Cited (NCited _ t)) = query t queryM (Cited (NCited _ t)) = queryM t -- | The ThunkLoop exception is thrown as an exception with MonadThrow,@@ -99,5 +99,4 @@ Provenance scope e@(Compose (Ann s _)) : _ -> withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f) - wrapValue = Cited . NCited [] . wrapValue- getValue (Cited (NCited _ v)) = getValue v+ further (Cited (NCited ps t)) f = Cited . NCited ps <$> further t f
src/Nix/Convert.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}@@ -12,7 +15,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}@@ -27,10 +29,8 @@ module Nix.Convert where -import Control.Monad-import Control.Monad.Catch+import Control.Monad.Free import Data.ByteString-import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.Maybe import Data.Text ( Text )@@ -44,9 +44,14 @@ import Nix.Expr.Types.Annotated import Nix.Frames import Nix.String-import Nix.Thunk import Nix.Value+import Nix.Value.Monad+import Nix.Thunk+import Nix.Utils +newtype Deeper a = Deeper { getDeeper :: a }+ deriving (Typeable, Functor, Foldable, Traversable)+ {- IMPORTANT NOTE@@ -60,337 +65,297 @@ -} +{-----------------------------------------------------------------------+ FromValue+ -----------------------------------------------------------------------}+ class FromValue a m v where fromValue :: v -> m a fromValueMay :: v -> m (Maybe a) type Convertible e t f m- = (Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)--instance Convertible e t f m => FromValue () m (NValueNF t f m) where- fromValueMay = \case- NVConstantNF NNull -> pure $ Just ()- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ ExpectationNF TNull v--instance Convertible e t f m => FromValue () 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 TNull v--instance Convertible e t f m => FromValue Bool m (NValueNF t f m) where- fromValueMay = \case- NVConstantNF (NBool b) -> pure $ Just b- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ ExpectationNF TBool v+ = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) -instance Convertible e t f m => FromValue Bool 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 TBool v+instance ( Convertible e t f m+ , MonadValue (NValue t f m) m+ , 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 -instance Convertible e t f m => FromValue Int m (NValueNF t f m) where- fromValueMay = \case- NVConstantNF (NInt b) -> pure $ Just (fromInteger b)- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ ExpectationNF TInt v+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) -instance Convertible e t f m => FromValue Int m (NValue t f m) where+instance Convertible e t f m+ => FromValue () m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVConstant (NInt b) -> pure $ Just (fromInteger b)- _ -> pure Nothing+ NVConstant' NNull -> pure $ Just ()+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation TInt v+ _ -> throwError $ Expectation @t @f @m TNull (Free v) -instance Convertible e t f m => FromValue Integer m (NValueNF t f m) where+instance Convertible e t f m+ => FromValue Bool m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVConstantNF (NInt b) -> pure $ Just b+ NVConstant' (NBool b) -> pure $ Just b _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ ExpectationNF TInt v+ _ -> throwError $ Expectation @t @f @m TBool (Free v) -instance Convertible e t f m => FromValue Integer m (NValue t f m) where+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 b- _ -> pure Nothing+ NVConstant' (NInt b) -> pure $ Just (fromInteger b)+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation TInt v+ _ -> throwError $ Expectation @t @f @m TInt (Free v) -instance Convertible e t f m => FromValue Float m (NValueNF t f m) where+instance Convertible e t f m+ => FromValue Integer m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVConstantNF (NFloat b) -> pure $ Just b- NVConstantNF (NInt i) -> pure $ Just (fromInteger i)- _ -> pure Nothing+ NVConstant' (NInt b) -> pure $ Just b+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ ExpectationNF TFloat v+ _ -> throwError $ Expectation @t @f @m TInt (Free v) -instance Convertible e t f m => FromValue Float m (NValue t f m) where+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+ 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 TFloat v+ _ -> throwError $ Expectation @t @f @m TFloat (Free v) -instance (Convertible e t f m, MonadEffects t f m)- => FromValue NixString m (NValueNF t f m) where+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- NVStrNF ns -> pure $ Just ns- NVPathNF p ->+ NVStr' ns -> pure $ Just ns+ NVPath' p -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p- NVSetNF s _ -> case M.lookup "outPath" s of+ 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 $ ExpectationNF (TString NoContext) v--instance (Convertible e t f m, MonadEffects t f m)- => FromValue NixString m (NValue t f m) where- fromValueMay = \case- NVStr ns -> pure $ Just ns- NVPath p ->- Just- . hackyMakeNixStringWithoutContext- . Text.pack- . unStorePath- <$> addPath p- NVSet s _ -> case M.lookup "outPath" s of- Nothing -> pure Nothing- Just p -> force p fromValueMay- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ Expectation (TString NoContext) v--instance Convertible e t f m- => FromValue ByteString m (NValueNF t f m) where- fromValueMay = \case- NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ ExpectationNF (TString NoContext) v+ _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) instance Convertible e t f m- => FromValue ByteString m (NValue t f m) where+ => FromValue ByteString m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns- _ -> pure Nothing+ NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation (TString NoContext) v+ _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) newtype Path = Path { getPath :: FilePath } deriving Show -instance Convertible e t f m => FromValue Path m (NValueNF t f m) where+instance ( Convertible e t f m+ , MonadValue (NValue t f m) m+ )+ => FromValue Path m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVPathNF p -> pure $ Just (Path p)- NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns- NVSetNF s _ -> case M.lookup "outPath" s of+ 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 $ ExpectationNF TPath v--instance Convertible e t f m => FromValue Path 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 -> force p $ fromValueMay @Path- _ -> pure Nothing- fromValue v = fromValueMay v >>= \case- Just b -> pure b- _ -> throwError $ Expectation TPath v+ _ -> throwError $ Expectation @t @f @m TPath (Free v) -instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)- => FromValue [a] m (NValueNF t f m) where+instance Convertible e t f m+ => FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVListNF l -> sequence <$> traverse fromValueMay l- _ -> pure Nothing+ NVList' l -> pure $ Just l+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ ExpectationNF TList v+ _ -> throwError $ Expectation @t @f @m TList (Free v) -instance Convertible e t f m => FromValue [t] m (NValue t f m) where+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- NVList l -> pure $ Just l- _ -> pure Nothing+ Deeper (NVList' l) -> sequence <$> traverse fromValueMay l+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation TList v+ _ -> throwError $ Expectation @t @f @m TList (Free (getDeeper v)) instance Convertible e t f m- => FromValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where+ => FromValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVSetNF s _ -> pure $ Just s- _ -> pure Nothing+ NVSet' s _ -> pure $ Just s+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ ExpectationNF TSet v+ _ -> throwError $ Expectation @t @f @m TSet (Free v) -instance Convertible e t f m- => FromValue (HashMap Text t) m (NValue t f m) where+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- NVSet s _ -> pure $ Just s- _ -> pure Nothing+ Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation TSet v+ _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) instance Convertible e t f m- => FromValue (HashMap Text (NValueNF t f m),- HashMap Text SourcePos) m (NValueNF t f m) where+ => FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m+ (NValue' t f m (NValue t f m)) where fromValueMay = \case- NVSetNF s p -> pure $ Just (s, p)- _ -> pure Nothing+ NVSet' s p -> pure $ Just (s, p)+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ ExpectationNF TSet v+ _ -> throwError $ Expectation @t @f @m TSet (Free v) -instance Convertible e t f m- => FromValue (HashMap Text t,- HashMap Text SourcePos) m (NValue t f m) where+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- NVSet s p -> pure $ Just (s, p)- _ -> pure Nothing+ Deeper (NVSet' s p) -> fmap (, p) <$> sequence <$> traverse fromValueMay s+ _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b- _ -> throwError $ Expectation TSet v+ _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) -instance (Monad m, FromValue a m v) => FromValue a m (m v) where- fromValueMay = (>>= fromValueMay)- fromValue = (>>= fromValue)+-- 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))+ )+ => FromValue a m (Deeper (NValue' t f m (NValue t f m))) where+ fromValueMay = fromValueMay . getDeeper+ fromValue = fromValue . getDeeper +{-----------------------------------------------------------------------+ ToValue+ -----------------------------------------------------------------------}+ class ToValue a m v where toValue :: a -> m v -instance Convertible e t f m => ToValue () m (NValueNF t f m) where- toValue _ = pure . nvConstantNF $ NNull--instance Convertible e t f m => ToValue () m (NValue t f m) where- toValue _ = pure . nvConstant $ NNull--instance Convertible e t f m => ToValue Bool m (NValueNF t f m) where- toValue = pure . nvConstantNF . NBool--instance Convertible e t f m => ToValue Bool m (NValue t f m) where- toValue = pure . nvConstant . NBool--instance Convertible e t f m => ToValue Int m (NValueNF t f m) where- toValue = pure . nvConstantNF . NInt . toInteger--instance Convertible e t f m => ToValue Int m (NValue t f m) where- toValue = pure . nvConstant . NInt . toInteger--instance Convertible e t f m => ToValue Integer m (NValueNF t f m) where- toValue = pure . nvConstantNF . NInt--instance Convertible e t f m => ToValue Integer m (NValue t f m) where- toValue = pure . nvConstant . NInt+instance (Convertible e t f m, ToValue a m (NValue' t f m (NValue t f m)))+ => ToValue a m (NValue t f m) where+ toValue = fmap Free . toValue -instance Convertible e t f m => ToValue Float m (NValueNF t f m) where- toValue = pure . nvConstantNF . NFloat+instance ( Convertible e t f m+ , ToValue a m (Deeper (NValue' t f m (NValue t f m)))+ )+ => ToValue a m (Deeper (NValue t f m)) where+ toValue = fmap (fmap Free) . toValue -instance Convertible e t f m => ToValue Float m (NValue t f m) where- toValue = pure . nvConstant . NFloat+instance Convertible e t f m+ => ToValue () m (NValue' t f m (NValue t f m)) where+ toValue _ = pure . nvConstant' $ NNull -instance Convertible e t f m => ToValue NixString m (NValueNF t f m) where- toValue = pure . nvStrNF+instance Convertible e t f m+ => ToValue Bool m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvConstant' . NBool -instance Convertible e t f m => ToValue NixString m (NValue t f m) where- toValue = pure . nvStr+instance Convertible e t f m+ => ToValue Int m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvConstant' . NInt . toInteger -instance Convertible e t f m => ToValue ByteString m (NValueNF t f m) where- toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8+instance Convertible e t f m+ => ToValue Integer m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvConstant' . NInt -instance Convertible e t f m => ToValue ByteString m (NValue t f m) where- toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8+instance Convertible e t f m+ => ToValue Float m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvConstant' . NFloat -instance Convertible e t f m => ToValue Path m (NValueNF t f m) where- toValue = pure . nvPathNF . getPath+instance Convertible e t f m+ => ToValue NixString m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvStr' -instance Convertible e t f m => ToValue Path m (NValue t f m) where- toValue = pure . nvPath . getPath+instance Convertible e t f m+ => ToValue ByteString m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvStr' . hackyMakeNixStringWithoutContext . decodeUtf8 -instance Convertible e t f m => ToValue StorePath m (NValueNF t f m) where- toValue = toValue . Path . unStorePath+instance Convertible e t f m+ => ToValue Path m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvPath' . getPath -instance Convertible e t f m => ToValue StorePath m (NValue t f m) where+instance Convertible e t f m+ => ToValue StorePath m (NValue' t f m (NValue t f m)) where toValue = toValue . Path . unStorePath -instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where+instance ( Convertible e t f m+ )+ => ToValue SourcePos m (NValue' t f m (NValue t f m)) where toValue (SourcePos f l c) = do- f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f)+ f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f)) l' <- toValue (unPos l) c' <- toValue (unPos c)- let pos = M.fromList- [ ("file" :: Text, wrapValue f')- , ("line" , wrapValue l')- , ("column" , wrapValue c')- ]- pure $ nvSet pos mempty--instance (Convertible e t f m, ToValue a m (NValueNF t f m))- => ToValue [a] m (NValueNF t f m) where- toValue = fmap nvListNF . traverse toValue--instance Convertible e t f m => ToValue [t] m (NValue t f m) where- toValue = pure . nvList+ let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')]+ pure $ nvSet' pos mempty +-- | With 'ToValue', we can always act recursively instance Convertible e t f m- => ToValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where- toValue = pure . flip nvSetNF M.empty+ => ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where+ toValue = pure . nvList' -instance Convertible e t f m => ToValue (HashMap Text t) m (NValue t f m) where- toValue = pure . flip nvSet M.empty+instance (Convertible e t f m, ToValue a m (NValue t f m))+ => ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where+ toValue = fmap (Deeper . nvList') . traverse toValue -instance Convertible e t f m => ToValue (HashMap Text (NValueNF t f m),- HashMap Text SourcePos) m (NValueNF t f m) where- toValue (s, p) = pure $ nvSetNF s p+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 -instance Convertible e t f m => ToValue (HashMap Text t,- HashMap Text SourcePos) m (NValue t f m) where- toValue (s, p) = pure $ nvSet s p+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 -instance Convertible e t f m => ToValue Bool m (NExprF r) where- toValue = pure . NConstant . NBool+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 -instance Convertible e t f m => ToValue () m (NExprF r) where- toValue _ = pure . NConstant $ NNull+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 -instance ( MonadThunk t m (NValue t f m)- , MonadDataErrorContext t f m- , Framed e m- )- => ToValue NixLikeContextValue m (NValue t f m) where+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 return Nothing allOutputs <- if nlcvAllOutputs nlcv@@ -399,130 +364,18 @@ outputs <- do let outputs = fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv- outputsM :: [NValue t f m] <- traverse toValue outputs- let ts :: [t] = fmap wrapValue outputsM+ ts :: [NValue t f m] <- traverse toValue outputs case ts of [] -> return Nothing _ -> Just <$> toValue ts- pure $ flip nvSet M.empty $ M.fromList $ catMaybes- [ (\p -> ("path", wrapValue p)) <$> path- , (\ao -> ("allOutputs", wrapValue ao)) <$> allOutputs- , (\os -> ("outputs", wrapValue os)) <$> outputs+ pure $ flip nvSet' M.empty $ M.fromList $ catMaybes+ [ (\p -> ("path", p)) <$> path+ , (\ao -> ("allOutputs", ao)) <$> allOutputs+ , (\os -> ("outputs", os)) <$> outputs ] -whileForcingThunk- :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r-whileForcingThunk frame =- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame--class FromNix a m v where- fromNix :: v -> m a- default fromNix :: FromValue a m v => v -> m a- fromNix = fromValue-- fromNixMay :: v -> m (Maybe a)- default fromNixMay :: FromValue a m v => v -> m (Maybe a)- fromNixMay = fromValueMay--instance (Convertible e t f m, FromNix a m (NValue t f m))- => FromNix [a] m (NValue t f m) where- fromNixMay = \case- NVList l -> sequence <$> traverse (`force` fromNixMay) l- _ -> pure Nothing- fromNix v = fromNixMay v >>= \case- Just b -> pure b- _ -> throwError $ Expectation TList v--instance (Convertible e t f m, FromNix a m (NValue t f m))- => FromNix (HashMap Text a) m (NValue t f m) where- fromNixMay = \case- NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s- _ -> pure Nothing- fromNix v = fromNixMay v >>= \case- Just b -> pure b- _ -> throwError $ Expectation TSet v--instance Convertible e t f m => FromNix () m (NValueNF t f m) where-instance Convertible e t f m => FromNix () m (NValue t f m) where-instance Convertible e t f m => FromNix Bool m (NValueNF t f m) where-instance Convertible e t f m => FromNix Bool m (NValue t f m) where-instance Convertible e t f m => FromNix Int m (NValueNF t f m) where-instance Convertible e t f m => FromNix Int m (NValue t f m) where-instance Convertible e t f m => FromNix Integer m (NValueNF t f m) where-instance Convertible e t f m => FromNix Integer m (NValue t f m) where-instance Convertible e t f m => FromNix Float m (NValueNF t f m) where-instance Convertible e t f m => FromNix Float m (NValue t f m) where-instance (Convertible e t f m, MonadEffects t f m)- => FromNix NixString m (NValueNF t f m) where-instance (Convertible e t f m, MonadEffects t f m)- => FromNix NixString m (NValue t f m) where-instance Convertible e t f m => FromNix ByteString m (NValueNF t f m) where-instance Convertible e t f m => FromNix ByteString m (NValue t f m) where-instance Convertible e t f m => FromNix Path m (NValueNF t f m) where-instance Convertible e t f m => FromNix Path m (NValue t f m) where-instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)- => FromNix [a] m (NValueNF t f m) where-instance Convertible e t f m- => FromNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where-instance Convertible e t f m- => FromNix (HashMap Text (NValueNF t f m),- HashMap Text SourcePos) m (NValueNF t f m) where-instance Convertible e t f m- => FromNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where--instance (Monad m, FromNix a m v) => FromNix a m (m v) where- fromNixMay = (>>= fromNixMay)- fromNix = (>>= fromNix)--class ToNix a m v where- toNix :: a -> m v- default toNix :: ToValue a m v => a -> m v- toNix = toValue--instance (Convertible e t f m, ToNix a m (NValue t f m))- => ToNix [a] m (NValue t f m) where- toNix = fmap nvList . traverse (thunk . go)- where- go =- (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix--instance (Convertible e t f m, ToNix a m (NValue t f m))- => ToNix (HashMap Text a) m (NValue t f m) where- toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)- where- go =- (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix--instance Convertible e t f m => ToNix () m (NValueNF t f m) where-instance Convertible e t f m => ToNix () m (NValue t f m) where-instance Convertible e t f m => ToNix Bool m (NValueNF t f m) where-instance Convertible e t f m => ToNix Bool m (NValue t f m) where-instance Convertible e t f m => ToNix Int m (NValueNF t f m) where-instance Convertible e t f m => ToNix Int m (NValue t f m) where-instance Convertible e t f m => ToNix Integer m (NValueNF t f m) where-instance Convertible e t f m => ToNix Integer m (NValue t f m) where-instance Convertible e t f m => ToNix Float m (NValueNF t f m) where-instance Convertible e t f m => ToNix Float m (NValue t f m) where-instance Convertible e t f m => ToNix NixString m (NValueNF t f m) where-instance Convertible e t f m => ToNix NixString m (NValue t f m) where-instance Convertible e t f m => ToNix ByteString m (NValueNF t f m) where-instance Convertible e t f m => ToNix ByteString m (NValue t f m) where-instance Convertible e t f m => ToNix Path m (NValueNF t f m) where-instance Convertible e t f m => ToNix Path m (NValue t f m) where-instance Convertible e t f m- => ToNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where-instance Convertible e t f m- => ToNix (HashMap Text (NValueNF t f m),- HashMap Text SourcePos) m (NValueNF t f m) where-instance Convertible e t f m- => ToNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where--instance Convertible e t f m => ToNix Bool m (NExprF r) where- toNix = pure . NConstant . NBool--instance Convertible e t f m => ToNix () m (NExprF r) where- toNix _ = pure $ NConstant NNull+instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where+ toValue _ = pure . NConstant $ NNull -instance (Convertible e t f m, ToNix a m (NValueNF t f m))- => ToNix [a] m (NValueNF t f m) where- toNix = fmap nvListNF . traverse toNix+instance Convertible e t f m => ToValue Bool m (NExprF (NValue t f m)) where+ toValue = pure . NConstant . NBool
src/Nix/Effects.hs view
@@ -45,25 +45,25 @@ 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+ -- | Determine the absolute path of relative path in the current context+ makeAbsolutePath :: FilePath -> m FilePath+ findEnvPath :: String -> m FilePath - -- | Having an explicit list of sets corresponding to the NIX_PATH- -- and a file path try to find an existing path- findPath :: [t] -> FilePath -> m FilePath+ -- | Having an explicit list of sets corresponding to the NIX_PATH+ -- and a file path try to find an existing path+ findPath :: [NValue t f m] -> FilePath -> m FilePath - importPath :: FilePath -> m (NValue t f m)- pathToDefaultNix :: FilePath -> m FilePath+ importPath :: FilePath -> m (NValue t f m)+ pathToDefaultNix :: FilePath -> m FilePath - derivationStrict :: NValue t f m -> m (NValue t f m)+ derivationStrict :: NValue t f m -> m (NValue t f m) - traceEffect :: String -> m ()+ traceEffect :: String -> 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+ recursiveSize :: a -> m Word+ default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word+ recursiveSize = lift . recursiveSize instance MonadIntrospect IO where recursiveSize =@@ -249,10 +249,3 @@ toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath toFile_ p contents = either throwError return =<< toFile_' p contents-------
+ src/Nix/Effects/Basic.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Nix.Effects.Basic where++import Control.Monad+import Control.Monad.State.Strict+import Data.HashMap.Lazy ( HashMap )+import qualified Data.HashMap.Lazy as M+import Data.List+import Data.List.Split+import Data.Maybe ( maybeToList )+import Data.Text ( Text )+import qualified Data.Text as Text+import Data.Text.Prettyprint.Doc+import Nix.Atoms+import Nix.Convert+import Nix.Effects+import Nix.Exec ( MonadNix+ , callFunc+ , evalExprLoc+ , nixInstantiateExpr+ )+import Nix.Expr+import Nix.Frames+import Nix.Normal+import Nix.Parser+import Nix.Pretty+import Nix.Render+import Nix.Scope+import Nix.String+import Nix.String.Coerce+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) && __GLASGOW_HASKELL__ >= 804+import GHC.DataSize+#endif+#endif++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 -> return $ takeDirectory s+ v ->+ throwError+ $ ErrorCall+ $ "when resolving relative path,"+ ++ " __cur_file is in scope,"+ ++ " but is not a path; it is: "+ ++ show v+ pure $ cwd <///> origPathExpanded+ removeDotDotIndirections <$> canonicalizePath absPath++expandHomePath :: MonadFile m => FilePath -> m FilePath+expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory+expandHomePath p = return p++-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.+-- This is incorrect on POSIX systems, because if @b@ is a symlink, its+-- 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 "/"+ where+ go s [] = reverse s+ go (_ : s) (".." : rest) = go s rest+ go s (this : rest) = go (this : s) rest++infixr 9 <///>+(<///>) :: FilePath -> FilePath -> FilePath+x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y+ | otherwise = joinByLargestOverlap x y+ where+ joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =+ joinPath $ head+ [ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ]++defaultFindEnvPath :: MonadNix e t f m => String -> m FilePath+defaultFindEnvPath = findEnvPathM++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+ where+ nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)+ nixFilePath path = do+ path <- makeAbsolutePath @t @f path+ exists <- doesDirectoryExist path+ path' <- if exists+ then makeAbsolutePath @t @f $ path </> "default.nix"+ else return path+ exists <- doesFileExist path'+ return $ if exists then Just path' else Nothing++findPathBy+ :: forall e t f m+ . MonadNix e t f m+ => (FilePath -> m (Maybe FilePath))+ -> [NValue t f m]+ -> FilePath+ -> m FilePath+findPathBy finder l name = do+ mpath <- foldM go Nothing l+ case mpath of+ Nothing ->+ throwError+ $ ErrorCall+ $ "file '"+ ++ name+ ++ "' was not found in the Nix search path"+ ++ " (add it using $NIX_PATH or -I)"+ Just path -> return path+ 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++ 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 -> return 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 saw: "+ ++ show 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+ 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++{- 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+ ".tgz" -> undefined+ ".gz" -> undefined+ ".bz2" -> undefined+ ".xz" -> undefined+ ".tar" -> undefined+ ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"+ ++ 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+ ++ "\"; }"++defaultFindPath :: MonadNix e t f m => [NValue t f m] -> FilePath -> m FilePath+defaultFindPath = findPathM++findPathM+ :: forall e t f m+ . MonadNix e t f m+ => [NValue t f m]+ -> FilePath+ -> m FilePath+findPathM l name = findPathBy path l name+ where+ path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)+ path path = do+ path <- makeAbsolutePath @t @f path+ exists <- doesPathExist path+ return $ if exists then Just path else Nothing++defaultImportPath+ :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)+ => FilePath+ -> m (NValue t f m)+defaultImportPath path = do+ traceM $ "Importing file " ++ path+ withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do+ imports <- get+ 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 (M.insert path expr)+ pure expr++defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath+defaultPathToDefaultNix = pathToDefaultNixFile++-- Given a path, determine the nix file to load+pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath+pathToDefaultNixFile p = do+ isDir <- doesDirectoryExist p+ pure $ if isDir then p </> "default.nix" else p++defaultDerivationStrict+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)+defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do+ nn <- maybe (pure False) (demand ?? fromValue) (M.lookup "__ignoreNulls" s)+ s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)+ v' <- normalForm =<< toValue @(AttrSet (NValue t f m)) @_ @(NValue t f m) s'+ nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v')+ where+ mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]+ mapMaybeM op = foldr f (return [])+ where f x xs = op x >>= (<$> xs) . (++) . maybeToList++ handleEntry :: Bool -> (Text, NValue t f m) -> m (Maybe (Text, NValue t f m))+ handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of+ -- The `args' attribute is special: it supplies the command-line+ -- arguments to the builder.+ -- TODO This use of coerceToString is probably not right and may+ -- not have the right arguments.+ "args" -> demand v $ fmap Just . coerceNixList+ "__ignoreNulls" -> pure Nothing+ _ -> demand v $ \case+ NVConstant NNull | ignoreNulls -> pure Nothing+ v' -> Just <$> coerceNix v'+ where+ coerceNix :: NValue t f m -> m (NValue t f m)+ coerceNix = toValue <=< coerceToString callFunc CopyToStore CoerceAny++ coerceNixList :: NValue t f m -> m (NValue t f m)+ coerceNixList v = do+ xs <- fromValue @[NValue t f m] v+ ys <- traverse (\x -> demand x coerceNix) xs+ toValue @[NValue t f m] ys++defaultTraceEffect :: MonadPutStr m => String -> m ()+defaultTraceEffect = Nix.Effects.putStrLn
src/Nix/Eval.hs view
@@ -34,85 +34,91 @@ import Nix.Atoms import Nix.Convert import Nix.Expr+import Nix.Expr.Strings ( runAntiquoted ) import Nix.Frames import Nix.String import Nix.Scope-import Nix.Strings ( runAntiquoted )-import Nix.Thunk import Nix.Utils+import Nix.Value.Monad class (Show v, Monad m) => MonadEval v m where- freeVariable :: Text -> m v- synHole :: Text -> m v- attrMissing :: NonEmpty Text -> Maybe v -> m v- evaledSym :: Text -> v -> m v- evalCurPos :: m v- evalConstant :: NAtom -> m v- evalString :: NString (m v) -> m v- evalLiteralPath :: FilePath -> m v- evalEnvPath :: FilePath -> m v- evalUnary :: NUnaryOp -> v -> m v- evalBinary :: NBinaryOp -> v -> m v -> m v- -- ^ The second argument is an action because operators such as boolean &&- -- and || may not evaluate the second argument.- evalWith :: m v -> m v -> m v- evalIf :: v -> m v -> m v -> m v- 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))- -> m v+ freeVariable :: Text -> m v+ synHole :: Text -> m v+ attrMissing :: NonEmpty Text -> Maybe v -> m v+ evaledSym :: Text -> v -> m v+ evalCurPos :: m v+ evalConstant :: NAtom -> m v+ evalString :: NString (m v) -> m v+ evalLiteralPath :: FilePath -> m v+ evalEnvPath :: FilePath -> m v+ evalUnary :: NUnaryOp -> v -> m v+ evalBinary :: NBinaryOp -> v -> m v -> m v+ -- ^ The second argument is an action because operators such as boolean &&+ -- and || may not evaluate the second argument.+ evalWith :: m v -> m v -> m v+ evalIf :: v -> m v -> m v -> m v+ 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))+ -> m v {-- evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v- evalHasAttr :: v -> NonEmpty Text -> m v+ evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v+ evalHasAttr :: v -> NonEmpty Text -> m v - -- | This and the following methods are intended to allow things like- -- adding provenance information.- evalListElem :: [m v] -> Int -> m v -> m v- evalList :: [t] -> m v- evalSetElem :: AttrSet (m v) -> Text -> m v -> m v- evalSet :: AttrSet t -> AttrSet SourcePos -> m v- evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v- evalRecSet :: AttrSet t -> AttrSet SourcePos -> m v- evalLetElem :: Text -> m v -> m v- evalLet :: m v -> m v+ -- | This and the following methods are intended to allow things like+ -- adding provenance information.+ evalListElem :: [m v] -> Int -> m v -> m v+ evalList :: [v] -> m v+ evalSetElem :: AttrSet (m v) -> Text -> m v -> m v+ evalSet :: AttrSet v -> AttrSet SourcePos -> m v+ evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v+ evalRecSet :: AttrSet v -> AttrSet SourcePos -> m v+ evalLetElem :: Text -> m v -> m v+ evalLet :: m v -> m v -}- evalError :: Exception s => s -> m a+ evalError :: Exception s => s -> m a -type MonadNixEval v t m+type MonadNixEval v m = ( MonadEval v m- , Scoped t m- , MonadThunk t m v+ , Scoped v m+ , MonadValue v m , MonadFix m , ToValue Bool m v- , ToValue [t] m v+ , ToValue [v] m v , FromValue NixString m v- , ToValue (AttrSet t, AttrSet SourcePos) m v- , FromValue (AttrSet t, AttrSet SourcePos) m v+ , ToValue (AttrSet v, AttrSet SourcePos) m v+ , FromValue (AttrSet v, AttrSet SourcePos) m v ) -data EvalFrame m t- = EvaluatingExpr (Scopes m t) NExprLoc- | ForcingExpr (Scopes m t) NExprLoc+data EvalFrame m v+ = EvaluatingExpr (Scopes m v) NExprLoc+ | ForcingExpr (Scopes m v) NExprLoc | Calling String SrcSpan- | SynHole (SynHoleInfo m t)+ | SynHole (SynHoleInfo m v) deriving (Show, Typeable) -instance (Typeable m, Typeable t) => Exception (EvalFrame m t)+instance (Typeable m, Typeable v) => Exception (EvalFrame m v) -data SynHoleInfo m t = SynHoleInfo+data SynHoleInfo m v = SynHoleInfo { _synHoleInfo_expr :: NExprLoc- , _synHoleInfo_scope :: Scopes m t+ , _synHoleInfo_scope :: Scopes m v } deriving (Show, Typeable) -instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t)+instance (Typeable m, Typeable v) => Exception (SynHoleInfo m v) -eval :: forall v t m . MonadNixEval v t m => NExprF (m v) -> m v+-- jww (2019-03-18): By deferring only those things which must wait until+-- context of us, this can be written as:+-- eval :: forall v m . MonadNixEval v m => NExprF v -> m v+eval :: forall v m . MonadNixEval v m => NExprF (m v) -> m v eval (NSym "__curPos") = evalCurPos -eval (NSym var ) = (lookupVar var :: m (Maybe t))- >>= maybe (freeVariable var) (force ?? evaledSym var)+eval (NSym var ) = do+ mres <- lookupVar var+ case mres of+ Just x -> demand x $ evaledSym var+ Nothing -> freeVariable var eval (NConstant x ) = evalConstant x eval (NStr str ) = evalString str@@ -121,7 +127,7 @@ eval (NUnary op arg ) = evalUnary op =<< arg eval (NBinary NApp fun arg) = do- scope <- currentScopes :: m (Scopes m t)+ scope <- currentScopes :: m (Scopes m v) fun >>= (`evalApp` withScopes scope arg) eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg@@ -133,7 +139,7 @@ eval (NList l ) = do scope <- currentScopes- for l (thunk @t @m @v . withScopes @t scope) >>= toValue+ for l (defer @v @m . withScopes @v scope) >>= toValue eval (NSet binds) = evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue@@ -150,36 +156,33 @@ eval (NAssert cond body) = cond >>= evalAssert ?? body eval (NAbs params body) = do- -- It is the environment at the definition site, not the call site, that- -- needs to be used when evaluating the body and default arguments, hence- -- we defer here so the present scope is restored when the parameters and- -- body are forced during application.- scope <- currentScopes :: m (Scopes m t)+ -- It is the environment at the definition site, not the call site, that+ -- needs to be used when evaluating the body and default arguments, hence we+ -- defer here so the present scope is restored when the parameters and body+ -- are forced during application.+ scope <- currentScopes :: m (Scopes m v) evalAbs params $ \arg k -> withScopes scope $ do args <- buildArgument params arg- pushScope args (k (M.map (`force` pure) args) body)+ pushScope args (k (fmap (inform ?? withScopes scope) args) body) eval (NSynHole name) = synHole name --- | If you know that the 'scope' action will result in an 'AttrSet t', then+-- | If you know that the 'scope' action will result in an 'AttrSet v', then -- this implementation may be used as an implementation for 'evalWith'.-evalWithAttrSet :: forall v t m . MonadNixEval v t m => m v -> m v -> m v+evalWithAttrSet :: forall v m . MonadNixEval v m => m v -> m v -> m v evalWithAttrSet aset body = do- -- The scope is deliberately wrapped in a thunk here, since it is- -- evaluated 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.- scope <- currentScopes :: m (Scopes m t)- s <- thunk @t @m @v $ withScopes scope aset- pushWeakScope- ?? body- $ force s- $ fmap fst- . fromValue @(AttrSet t, AttrSet SourcePos)+ -- The scope is deliberately wrapped in a thunk here, since it is demanded+ -- 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.+ scope <- currentScopes :: m (Scopes m v)+ s <- defer $ withScopes scope aset+ let s' = demand s $ fmap fst . fromValue @(AttrSet v, AttrSet SourcePos)+ pushWeakScope s' body attrSetAlter- :: forall v t m- . MonadNixEval v t m+ :: forall v m+ . MonadNixEval v m => [Text] -> SourcePos -> AttrSet (m v)@@ -196,19 +199,15 @@ | null ks -> go | otherwise- -> x >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(st, sp) ->- recurse (force ?? pure <$> st) sp+ -> x >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(st, sp) ->+ recurse (demand ?? pure <$> st) sp where go = return (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 t, AttrSet SourcePos)- =<< (, mempty)- . fmap wrapValue- <$> sequence st'- )+ (toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st') st , M.insert k pos sp )@@ -240,13 +239,13 @@ Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p evalBinds- :: forall v t m- . MonadNixEval v t m+ :: forall v m+ . MonadNixEval v m => Bool -> [Binding (m v)]- -> m (AttrSet t, AttrSet SourcePos)+ -> m (AttrSet v, AttrSet SourcePos) evalBinds recursive binds = do- scope <- currentScopes :: m (Scopes m t)+ scope <- currentScopes :: m (Scopes m v) buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) where moveOverridesLast = uncurry (++) . partition@@ -255,12 +254,12 @@ _ -> True ) - go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]+ 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? return $ map- (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure))+ (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand v pure)) (M.toList o') go _ (NamedVar pathExpr finalValue pos) = do@@ -271,7 +270,7 @@ pure ( [] , nullPos- , toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)+ , toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty) ) Just k -> case t of [] -> pure ([k], pos, finalValue)@@ -294,31 +293,31 @@ mv <- case ms of Nothing -> withScopes scope $ lookupVar key Just s ->- s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) ->- clearScopes @t $ pushScope s $ lookupVar key+ s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(s, _) ->+ clearScopes @v $ pushScope s $ lookupVar key case mv of Nothing -> attrMissing (key :| []) Nothing- Just v -> force v pure+ Just v -> demand v pure ) buildResult- :: Scopes m t+ :: Scopes m v -> [([Text], SourcePos, m v)]- -> m (AttrSet t, AttrSet SourcePos)+ -> 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 return (res, p) where- mkThunk = thunk . withScopes scope+ mkThunk = defer . withScopes scope encapsulate f attrs = mkThunk . pushScope attrs $ f insert (m, p) (path, pos, value) = attrSetAlter path pos m p value evalSelect- :: forall v t m- . MonadNixEval v t m+ :: forall v m+ . MonadNixEval v m => m v -> NAttrPath (m v) -> m (Either (v, NonEmpty Text) (m v))@@ -328,10 +327,10 @@ extract s path where extract x path@(k :| ks) = fromValueMay x >>= \case- Just (s :: AttrSet t, p :: AttrSet SourcePos)+ Just (s :: AttrSet v, p :: AttrSet SourcePos) | Just t <- M.lookup k s -> case ks of- [] -> pure $ Right $ force t pure- y : ys -> force t $ extract ?? (y :| ys)+ [] -> pure $ Right $ demand t pure+ y : ys -> demand t $ extract ?? (y :| ys) | otherwise -> Left . (, path) <$> toValue (s, p) Nothing -> return $ Left (x, path) @@ -376,16 +375,16 @@ (>>= fromValueMay) buildArgument- :: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t)+ :: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v) buildArgument params arg = do- scope <- currentScopes :: m (Scopes m t)+ scope <- currentScopes :: m (Scopes m v) case params of- Param name -> M.singleton name <$> thunk (withScopes scope arg)+ Param name -> M.singleton name <$> defer (withScopes scope arg) ParamSet s isVariadic m ->- arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do+ arg >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(args, _) -> do let inject = case m of Nothing -> id- Just n -> M.insert n $ const $ thunk (withScopes scope arg)+ Just n -> M.insert n $ const $ defer (withScopes scope arg) loebM (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic) args@@ -393,11 +392,11 @@ ) where assemble- :: Scopes m t+ :: Scopes m v -> Bool -> Text- -> These t (Maybe (m v))- -> Maybe (AttrSet t -> m t)+ -> These v (Maybe (m v))+ -> Maybe (AttrSet v -> m v) assemble scope isVariadic k = \case That Nothing -> Just@@ -407,7 +406,7 @@ $ "Missing value for parameter: " ++ show k That (Just f) ->- Just $ \args -> thunk $ withScopes scope $ pushScope args f+ Just $ \args -> defer $ withScopes scope $ pushScope args f This _ | isVariadic -> Nothing@@ -426,17 +425,17 @@ local (set hasLens ann) (f v) addStackFrames- :: forall t e m a- . (Scoped t m, Framed e m, Typeable t, Typeable m)+ :: 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 t)+ scopes <- currentScopes :: m (Scopes m v) withFrame Info (EvaluatingExpr scopes v) (f v) framedEvalExprLoc- :: forall t e v m- . (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m)+ :: 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 @t . addSourcePositions)+ adi (eval . annotated . getCompose) (addStackFrames @v . addSourcePositions)
src/Nix/Exec.hs view
@@ -36,45 +36,33 @@ import Control.Monad.Catch hiding ( catchJust ) import Control.Monad.Fix import Control.Monad.Reader-import Control.Monad.Ref-import Control.Monad.State.Strict import Control.Monad.Trans.Reader ( ReaderT(..) )-import Control.Monad.Trans.State.Strict- ( StateT(..) ) import Data.Fix-import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.List import qualified Data.List.NonEmpty as NE-import Data.List.Split-import Data.Maybe ( maybeToList ) import Data.Text ( Text ) import qualified Data.Text as Text import Data.Text.Prettyprint.Doc import Data.Typeable import Nix.Atoms import Nix.Cited-import Nix.Context import Nix.Convert import Nix.Effects import Nix.Eval as Eval import Nix.Expr import Nix.Frames-import Nix.Normal import Nix.Options-import Nix.Parser import Nix.Pretty import Nix.Render import Nix.Scope import Nix.String+import Nix.String.Coerce import Nix.Thunk import Nix.Utils import Nix.Value import Nix.Value.Equal-#ifdef MIN_VERSION_haskeline-import System.Console.Haskeline.MonadException hiding(catch)-#endif-import System.FilePath+import Nix.Value.Monad #ifdef MIN_VERSION_pretty_show import qualified Text.Show.Pretty as PS #endif@@ -86,64 +74,68 @@ #endif type MonadCited t f m- = (HasCitations1 t m (NValue t f m) f, MonadDataContext 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 t 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 :: MonadCited t f m- => Provenance t m (NValue t f m)+ => Provenance m (NValue t f m) -> NixString -> NValue t f m nvStrP p ns = addProvenance p (nvStr ns) nvPathP- :: MonadCited t f m- => Provenance t 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- :: MonadCited t f m => Provenance t m (NValue t f m) -> [t] -> NValue t f m+ :: MonadCited t f m+ => Provenance m (NValue t f m)+ -> [NValue t f m]+ -> NValue t f m nvListP p l = addProvenance p (nvList l) nvSetP :: MonadCited t f m- => Provenance t m (NValue t f m)- -> AttrSet t+ => Provenance m (NValue t f m)+ -> AttrSet (NValue t f m) -> AttrSet SourcePos -> NValue t f m nvSetP p s x = addProvenance p (nvSet s x) nvClosureP :: MonadCited t f m- => Provenance t m (NValue t f m)+ => Provenance m (NValue t f m) -> Params ()- -> (m (NValue t f m) -> m t)+ -> (NValue t f m -> m (NValue t f m)) -> NValue t f m nvClosureP p x f = addProvenance p (nvClosure x f) nvBuiltinP :: MonadCited t f m- => Provenance t m (NValue t f m)+ => Provenance m (NValue t f m) -> String- -> (m (NValue t f m) -> m t)+ -> (NValue t f m -> m (NValue t f m)) -> NValue t f m nvBuiltinP p name f = addProvenance p (nvBuiltin name f) type MonadCitedThunks t f m = ( MonadThunk t m (NValue t f m) , MonadDataErrorContext t f m- , HasCitations1 t m (NValue t f m) f+ , HasCitations m (NValue t f m) t+ , HasCitations1 m (NValue t f m) f ) type MonadNix e t f m = ( Has e SrcSpan , Has e Options- , Scoped t m+ , Scoped (NValue t f m) m , Framed e m , MonadFix m , MonadCatch m@@ -151,6 +143,7 @@ , Alternative m , MonadEffects t f m , MonadCitedThunks t f m+ , MonadValue (NValue t f m) m ) data ExecFrame t f m = Assertion SrcSpan (NValue t f m)@@ -189,14 +182,13 @@ $ "Inheriting unknown attribute: " ++ intercalate "." (map Text.unpack (NE.toList ks)) - attrMissing ks (Just s) = do- s' <- prettyNValue s+ attrMissing ks (Just s) = evalError @(NValue t f m) $ ErrorCall $ "Could not look up attribute " ++ intercalate "." (map Text.unpack (NE.toList ks)) ++ " in "- ++ show s'+ ++ show (prettyNValue s) evalCurPos = do scope <- currentScopes@@ -288,15 +280,14 @@ scope <- currentScopes span <- currentPos addProvenance (Provenance scope (NBinary_ span NApp (Just f) Nothing))- <$> callFunc f x+ <$> (callFunc f =<< defer x) evalAbs p k = do scope <- currentScopes span <- currentPos- pure $ nvClosureP- (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))- (void p)- (\arg -> wrapValue . snd <$> k arg (\_ b -> ((), ) <$> b))+ pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))+ (void p)+ (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) evalError = throwError @@ -305,27 +296,27 @@ :: forall e t f m . MonadNix e t f m => NValue t f m- -> m (NValue t f m)+ -> NValue t f m -> m (NValue t f m)-callFunc fun arg = do+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+ case fun' of NVClosure params f -> do traceM $ "callFunc:NVFunction taking " ++ show params- force ?? pure =<< f arg+ f arg NVBuiltin name f -> do span <- currentPos- force ?? pure =<< withFrame Info (Calling @m @t name span) (f arg)+ withFrame Info (Calling @m @t name span) (f arg) s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do traceM "callFunc:__functor"- force f $ (`callFunc` pure s) >=> (`callFunc` arg)+ demand f $ (`callFunc` s) >=> (`callFunc` arg) x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x execUnaryOp :: (Framed e m, MonadCited t f m, Show t)- => Scopes m t+ => Scopes m (NValue t f m) -> SrcSpan -> NUnaryOp -> NValue t f m@@ -354,23 +345,23 @@ execBinaryOp :: forall e t f m . (MonadNix e t f m, MonadEval (NValue t f m) m)- => Scopes m t+ => Scopes m (NValue t f m) -> SrcSpan -> NBinaryOp -> NValue t f m -> m (NValue t f m) -> m (NValue t f m) -execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> if l+execBinaryOp scope span NOr larg rarg = fromValue larg >>= \l -> if l then orOp Nothing True- else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)+ else rarg >>= \rval -> fromValue @Bool rval >>= orOp (Just rval) where orOp r b = pure $ nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b) -execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l- then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)+execBinaryOp scope span NAnd larg rarg = fromValue larg >>= \l -> if l+ then rarg >>= \rval -> fromValue @Bool rval >>= andOp (Just rval) else andOp Nothing False where andOp r b = pure $ nvConstantP@@ -379,7 +370,7 @@ execBinaryOp scope span op lval rarg = do rval <- rarg- let bin :: (Provenance t m (NValue t f m) -> a) -> a+ let bin :: (Provenance m (NValue t f m) -> a) -> a bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval))) toBool = pure . bin nvConstantP . NBool case (lval, rval) of@@ -442,7 +433,7 @@ (ls@NVSet{}, NVStr rs) -> case op of NPlus -> (\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))- <$> coerceToString DontCopyToStore CoerceStringy ls+ <$> coerceToString callFunc DontCopyToStore CoerceStringy ls NEq -> toBool =<< valueEqM lval rval NNEq -> toBool . not =<< valueEqM lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval@@ -450,7 +441,7 @@ (NVStr ls, rs@NVSet{}) -> case op of NPlus -> (\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))- <$> coerceToString DontCopyToStore CoerceStringy rs+ <$> coerceToString callFunc DontCopyToStore CoerceStringy rs NEq -> toBool =<< valueEqM lval rval NNEq -> toBool . not =<< valueEqM lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval@@ -499,7 +490,7 @@ ++ show rval numBinOp- :: (forall r . (Provenance t m (NValue t f m) -> r) -> r)+ :: (forall r . (Provenance m (NValue t f m) -> r) -> r) -> (forall a . Num a => a -> a -> a) -> NAtom -> NAtom@@ -507,7 +498,7 @@ numBinOp bin f = numBinOp' bin f f numBinOp'- :: (forall r . (Provenance t m (NValue t f m) -> r) -> r)+ :: (forall r . (Provenance m (NValue t f m) -> r) -> r) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> NAtom@@ -523,329 +514,13 @@ toInt = pure . bin nvConstantP . NInt toFloat = pure . bin nvConstantP . NFloat --- | Data type to avoid boolean blindness on what used to be called coerceMore-data CoercionLevel- = CoerceStringy- -- ^ Coerce only stringlike types: strings, paths, and appropriate sets- | CoerceAny- -- ^ Coerce everything but functions- deriving (Eq,Ord,Enum,Bounded)---- | Data type to avoid boolean blindness on what used to be called copyToStore-data CopyToStoreMode- = CopyToStore- -- ^ Add paths to the store as they are encountered- | DontCopyToStore- -- ^ Add paths to the store as they are encountered- deriving (Eq,Ord,Enum,Bounded)--coerceToString- :: MonadNix e t f m- => CopyToStoreMode- -> CoercionLevel- -> NValue t f m- -> m NixString-coerceToString ctsm clevel = go- where- go = \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 (`force` go) l-- v@(NVSet s _) | Just p <- M.lookup "__toString" s ->- force p $ (`callFunc` pure v) >=> go-- NVSet s _ | Just p <- M.lookup "outPath" s -> force p go-- v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v-- nixStringUnwords =- principledIntercalateNixString (principledMakeNixStringWithoutContext " ")- storePathToNixString :: StorePath -> NixString- storePathToNixString sp = principledMakeNixStringWithSingletonContext- t- (StringContext t DirectPath)- where t = Text.pack $ unStorePath sp--fromStringNoContext :: MonadNix e t f m => NixString -> m Text+-- 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 -> return str Nothing -> throwError $ ErrorCall "expected string with no context" -newtype Lazy t (f :: * -> *) m a = Lazy- { runLazy :: ReaderT (Context (Lazy t f m) t)- (StateT (HashMap FilePath NExprLoc) m) a }- deriving- ( Functor- , Applicative- , Alternative- , Monad- , MonadPlus- , MonadFix- , MonadIO- , MonadCatch- , MonadThrow- , MonadReader (Context (Lazy t f m) t)- )--instance MonadTrans (Lazy t f) where- lift = Lazy . lift . lift--instance MonadRef m => MonadRef (Lazy t f m) where- type Ref (Lazy t f m) = Ref m- newRef = lift . newRef- readRef = lift . readRef- writeRef r = lift . writeRef r--instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where- atomicModifyRef r = lift . atomicModifyRef r--instance (MonadFile m, Monad m) => MonadFile (Lazy t f m)--#ifdef MIN_VERSION_haskeline-instance MonadException m => MonadException (Lazy t f m) where- controlIO f = Lazy $ controlIO $ \(RunIO run) ->- let run' = RunIO (fmap Lazy . run . runLazy)- in runLazy <$> f run'-#endif--instance MonadStore m => MonadStore (Lazy t f m) where- addPath' = lift . addPath'- toFile_' n = lift . toFile_' n--instance MonadPutStr m => MonadPutStr (Lazy t f m)-instance MonadHttp m => MonadHttp (Lazy t f m)-instance MonadEnv m => MonadEnv (Lazy t f m)-instance MonadInstantiate m => MonadInstantiate (Lazy t f m)-instance MonadExec m => MonadExec (Lazy t f m)-instance MonadIntrospect m => MonadIntrospect (Lazy t f m)--instance MonadThunkId m => MonadThunkId (Lazy t f m) where- type ThunkId (Lazy t f m) = ThunkId m--instance ( MonadFix m- , MonadCatch m- , MonadFile m- , MonadStore m- , MonadPutStr m- , MonadHttp m- , MonadEnv m- , MonadInstantiate m- , MonadExec m- , MonadIntrospect m- , Alternative m- , MonadPlus m- , MonadCitedThunks t f (Lazy t f m)- )- => MonadEffects t f (Lazy t f m) where- makeAbsolutePath 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 -> force v $ \case- NVPath s -> return $ takeDirectory s- v ->- throwError- $ ErrorCall- $ "when resolving relative path,"- ++ " __cur_file is in scope,"- ++ " but is not a path; it is: "- ++ show v- pure $ cwd <///> origPathExpanded- removeDotDotIndirections <$> canonicalizePath absPath---- Given a path, determine the nix file to load- pathToDefaultNix = pathToDefaultNixFile-- findEnvPath = findEnvPathM- findPath = findPathM-- importPath path = do- traceM $ "Importing file " ++ path- withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do- imports <- Lazy $ ReaderT $ const get- 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- Lazy $ ReaderT $ const $ modify (M.insert path expr)- pure expr-- derivationStrict = fromValue @(AttrSet t) >=> \s -> do- nn <- maybe (pure False) (force ?? fromNix) (M.lookup "__ignoreNulls" s)- s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)- v' <- normalForm =<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'- nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')- where- mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b]- mapMaybeM op = foldr f (return [])- where f x xs = op x >>= (<$> xs) . (++) . maybeToList-- handleEntry :: Bool -> (Text, t) -> Lazy t f m (Maybe (Text, t))- handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of- -- The `args' attribute is special: it supplies the command-line- -- arguments to the builder.- -- TODO This use of coerceToString is probably not right and may- -- not have the right arguments.- "args" -> force v $ fmap Just . coerceNixList- "__ignoreNulls" -> pure Nothing- _ -> force v $ \case- NVConstant NNull | ignoreNulls -> pure Nothing- v' -> Just <$> coerceNix v'- where- coerceNix :: NValue t f (Lazy t f m) -> Lazy t f m t- coerceNix =- fmap wrapValue . toNix <=< coerceToString CopyToStore CoerceAny-- coerceNixList :: NValue t f (Lazy t f m) -> Lazy t f m t- coerceNixList v = do- xs :: [t] <- fromValue @[t] v- ys :: [t] <- traverse (\x -> force x coerceNix) xs- v' :: NValue t f (Lazy t f m) <- toValue @[t] ys- return $ wrapValue v'-- traceEffect = putStrLn--getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m)-getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize--runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a-runLazyM opts =- (`evalStateT` M.empty) . (`runReaderT` newContext opts) . runLazy---- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.--- This is incorrect on POSIX systems, because if @b@ is a symlink, its--- 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 "/"- where- go s [] = reverse s- go (_ : s) (".." : rest) = go s rest- go s (this : rest) = go (this : s) rest--expandHomePath :: MonadFile m => FilePath -> m FilePath-expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory-expandHomePath p = return p---- Given a path, determine the nix file to load-pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath-pathToDefaultNixFile p = do- isDir <- doesDirectoryExist p- pure $ if isDir then p </> "default.nix" else p--infixr 9 <///>-(<///>) :: FilePath -> FilePath -> FilePath-x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y- | otherwise = joinByLargestOverlap x y- where- joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =- joinPath $ head- [ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ]--findPathBy- :: forall e t f m- . MonadNix e t f m- => (FilePath -> m (Maybe FilePath))- -> [t]- -> FilePath- -> m FilePath-findPathBy finder l name = do- mpath <- foldM go Nothing l- case mpath of- Nothing ->- throwError- $ ErrorCall- $ "file '"- ++ name- ++ "' was not found in the Nix search path"- ++ " (add it using $NIX_PATH or -I)"- Just path -> return path- where- go :: Maybe FilePath -> t -> m (Maybe FilePath)- go p@(Just _) _ = pure p- go Nothing l = force l $ fromValue >=> \(s :: HashMap Text t) -> do- p <- resolvePath s- force p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of- Nothing -> tryPath path Nothing- Just pf -> force 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-- 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 -> return t- Nothing -> case M.lookup "uri" s of- Just ut -> thunk $ fetchTarball (force ut pure)- Nothing ->- throwError- $ ErrorCall- $ "__nixPath must be a list of attr sets"- ++ " with 'path' elements, but saw: "- ++ show s--findPathM :: forall e t f m . MonadNix e t f m => [t] -> FilePath -> m FilePath-findPathM l name = findPathBy path l name- where- path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)- path path = do- path <- makeAbsolutePath @t @f path- exists <- doesPathExist path- return $ if exists then Just path else Nothing--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 ->- force x $ fromValue >=> \(l :: [t]) -> findPathBy nixFilePath l name- where- nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)- nixFilePath path = do- path <- makeAbsolutePath @t @f path- exists <- doesDirectoryExist path- path' <- if exists- then makeAbsolutePath @t @f $ path </> "default.nix"- else return path- exists <- doesFileExist path'- return $ if exists then Just path' else Nothing- addTracing :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) => Alg NExprLocF (m a)@@ -877,78 +552,16 @@ if tracing opts then join . (`runReaderT` (0 :: Int)) $ adi (addTracing phi)- (raise (addStackFrames @t . addSourcePositions))+ (raise (addStackFrames @(NValue t f m) . addSourcePositions)) expr- else adi phi (addStackFrames @t . addSourcePositions) expr+ else adi phi (addStackFrames @(NValue t f m) . addSourcePositions) expr where phi = Eval.eval . annotated . getCompose raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x -fetchTarball- :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)-fetchTarball v = v >>= \case- NVSet s _ -> case M.lookup "url" s of- Nothing ->- throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute"- Just url -> force url $ go (M.lookup "sha256" s)- v@NVStr{} -> go Nothing v- v ->- throwError- $ ErrorCall- $ "builtins.fetchTarball: Expected URI or set, got "- ++ show v- where- go :: Maybe t -> 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--{- 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- ".tgz" -> undefined- ".gz" -> undefined- ".bz2" -> undefined- ".xz" -> undefined- ".tar" -> undefined- ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"- ++ ext ++ "'"--}-- fetch :: Text -> Maybe t -> m (NValue t f m)- fetch uri Nothing =- nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\""- fetch url (Just t) = force t $ fromValue >=> \nsSha ->- let sha = hackyStringIgnoreContext nsSha- in nixInstantiateExpr- $ "builtins.fetchTarball { "- ++ "url = \""- ++ Text.unpack url- ++ "\"; "- ++ "sha256 = \""- ++ Text.unpack sha- ++ "\"; }"- exec :: (MonadNix e t f m, MonadInstantiate m) => [String] -> 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) nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s--instance Monad m => Scoped t (Lazy t f m) where- currentScopes = currentScopesReader- clearScopes = clearScopesReader @(Lazy t f m) @t- pushScopes = pushScopesReader- lookupVar = lookupVarReader-------
+ src/Nix/Expr/Strings.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Functions for manipulating nix strings.+module Nix.Expr.Strings where++import Data.List ( intercalate+ , dropWhileEnd+ , inits+ )+import Data.Monoid ( (<>) )+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Tuple ( swap )+import Nix.Expr++-- | Merge adjacent 'Plain' values with 'mappend'.+mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r]+mergePlain [] = []+mergePlain (Plain a : EscapedNewline : Plain b : xs) =+ mergePlain (Plain (a <> "\n" <> b) : xs)+mergePlain (Plain a : Plain b : xs) = mergePlain (Plain (a <> b) : xs)+mergePlain (x : xs) = x : mergePlain xs++-- | Remove 'Plain' values equal to 'mempty', as they don't have any+-- informational content.+removePlainEmpty :: [Antiquoted Text r] -> [Antiquoted Text r]+removePlainEmpty = filter f where+ f (Plain x) = x /= mempty+ f _ = True++ -- trimEnd xs+ -- | null xs = xs+ -- | otherwise = case last xs of+ -- Plain x -> init xs ++ [Plain (T.dropWhileEnd (== ' ') x)]+ -- _ -> xs++-- | Equivalent to case splitting on 'Antiquoted' strings.+runAntiquoted :: v -> (v -> a) -> (r -> a) -> Antiquoted v r -> a+runAntiquoted _ f _ (Plain v) = f v+runAntiquoted nl f _ EscapedNewline = f nl+runAntiquoted _ _ k (Antiquoted r) = k r++-- | Split a stream representing a string with antiquotes on line breaks.+splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]]+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, [])+ go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs+ go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs+ go [] = ([], [])++-- | Join a stream of strings containing antiquotes again. This is the inverse+-- of 'splitLines'.+unsplitLines :: [[Antiquoted Text r]] -> [Antiquoted Text r]+unsplitLines = intercalate [Plain "\n"]++-- | Form an indented string by stripping spaces equal to the minimal indent.+stripIndent :: [Antiquoted Text r] -> NString r+stripIndent [] = Indented 0 []+stripIndent xs =+ Indented minIndent+ . removePlainEmpty+ . mergePlain+ . map snd+ . dropWhileEnd cleanup+ . (\ys -> zip+ (map+ (\case+ [] -> Nothing+ x -> Just (last x)+ )+ (inits ys)+ )+ ys+ )+ . unsplitLines+ $ ls'+ where+ ls = stripEmptyOpening $ splitLines xs+ ls' = map (dropSpaces minIndent) ls++ minIndent = case stripEmptyLines ls of+ [] -> 0+ nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs++ stripEmptyLines = filter $ \case+ [Plain t] -> not $ T.null $ T.strip t+ _ -> True++ stripEmptyOpening ([Plain t] : ts) | T.null (T.strip t) = ts+ stripEmptyOpening ts = ts++ countSpaces (Antiquoted _ : _) = 0+ countSpaces (EscapedNewline : _) = 0+ countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t+ countSpaces [] = 0++ dropSpaces 0 x = x+ dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs+ dropSpaces _ _ = error "stripIndent: impossible"++ cleanup (Nothing, Plain y) = T.all (== ' ') y+ cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y+ cleanup _ = False++escapeCodes :: [(Char, Char)]+escapeCodes =+ [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')]++fromEscapeCode :: Char -> Maybe Char+fromEscapeCode = (`lookup` map swap escapeCodes)++toEscapeCode :: Char -> Maybe Char+toEscapeCode = (`lookup` escapeCodes)
src/Nix/Expr/Types.hs view
@@ -573,6 +573,3 @@ nullPos :: SourcePos nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)---
src/Nix/Fresh.hs view
@@ -21,8 +21,6 @@ import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.ST-import Control.Monad.State.Strict-import Control.Monad.Writer import Data.Typeable #ifdef MIN_VERSION_haskeline import System.Console.Haskeline.MonadException hiding(catch)@@ -55,16 +53,6 @@ instance MonadBase b m => MonadBase b (FreshIdT i m) where liftBase = FreshIdT . liftBase --- instance MonadTransControl (FreshIdT i) where--- type StT (FreshIdT i) a = StT (ReaderT (Var m i)) a--- liftWith = defaultLiftWith FreshIdT unFreshIdT--- restoreT = defaultRestoreT FreshIdT---- instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where--- type StM (FreshIdT i m) a = ComposeSt (FreshIdT i) m a--- liftBaseWith = defaultLiftBaseWith--- restoreM = defaultRestoreM- instance ( MonadVar m , Eq i , Ord i@@ -81,15 +69,6 @@ runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a runFreshIdT i m = runReaderT (unFreshIdT m) i -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- type ThunkId (WriterT w m) = ThunkId m-instance MonadThunkId m => MonadThunkId (ExceptT e m) where- type ThunkId (ExceptT e m) = ThunkId m-instance MonadThunkId m => MonadThunkId (StateT s m) where- type ThunkId (StateT s m) = ThunkId m- -- Orphan instance needed by Infer.hs and Lint.hs -- Since there's no forking, it's automatically atomic.@@ -104,10 +83,3 @@ let (a, b) = f v writeRef r $! a return b-------
src/Nix/Fresh/Basic.hs view
@@ -31,7 +31,10 @@ => MonadEffects t f (StdIdT m) where makeAbsolutePath = lift . makeAbsolutePath @t @f @m findEnvPath = lift . findEnvPath @t @f @m- findPath = (lift .) . findPath @t @f @m+ findPath vs path = do+ i <- FreshIdT ask+ let vs' = map (unliftNValue (runFreshIdT i)) vs+ lift $ findPath @t @f @m vs' path importPath path = do i <- FreshIdT ask p <- lift $ importPath @t @f @m path@@ -42,4 +45,3 @@ p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v) return $ liftNValue (runFreshIdT i) p traceEffect = lift . traceEffect @t @f @m-
src/Nix/Json.hs view
@@ -18,9 +18,9 @@ import Nix.Exec import Nix.Frames import Nix.String-import Nix.Thunk import Nix.Utils import Nix.Value+import Nix.Value.Monad nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString nvalueToJSONNixString =@@ -43,11 +43,12 @@ NVList l -> A.Array . V.fromList- <$> traverse (join . lift . flip force (return . nvalueToJSON)) l+ <$> traverse (join . lift . flip demand (return . nvalueToJSON)) l NVSet m _ -> case HM.lookup "outPath" m of Nothing ->- A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m- Just outPath -> join $ lift $ force outPath (return . nvalueToJSON)+ A.Object+ <$> traverse (join . lift . flip demand (return . nvalueToJSON)) m+ Just outPath -> join $ lift $ demand outPath (return . nvalueToJSON) NVPath p -> do fp <- lift $ unStorePath <$> addPath p addSingletonStringContext $ StringContext (Text.pack fp) DirectPath
src/Nix/Lint.hs view
@@ -31,7 +31,6 @@ import Control.Monad.Ref import Control.Monad.ST import Control.Monad.Trans.Reader-import Data.Coerce import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.List@@ -53,6 +52,7 @@ import Nix.Thunk.Basic import Nix.Utils import Nix.Var+import Nix.Value.Monad data TAtom = TInt@@ -68,7 +68,7 @@ | TSet (Maybe (HashMap Text r)) | TClosure (Params ()) | TPath- | TBuiltin String (SThunk m -> m (Symbolic m))+ | TBuiltin String (Symbolic m -> m r) deriving Functor compareTypes :: NTypeF m r -> NTypeF m r -> Ordering@@ -97,29 +97,38 @@ | NMany [r] deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -newtype SThunk m = SThunk { getSThunk :: NThunkF m (Symbolic m) }+type SThunk (m :: * -> *) = NThunkF m (Symbolic m) -newtype Symbolic m =- Symbolic { getSymbolic :: Var m (NSymbolicF (NTypeF m (SThunk m))) }+type SValue (m :: * -> *) = Var m (NSymbolicF (NTypeF m (Symbolic m))) +data Symbolic m = SV { getSV :: SValue m } | ST { getST :: SThunk m }+ instance Show (Symbolic m) where show _ = "<symbolic>" everyPossible :: MonadVar m => m (Symbolic m) everyPossible = packSymbolic NAny -mkSymbolic :: MonadVar m => [NTypeF m (SThunk 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 (SThunk m)) -> m (Symbolic m)-packSymbolic = fmap coerce . newVar+packSymbolic+ :: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)+packSymbolic = fmap SV . newVar unpackSymbolic- :: MonadVar m => Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))-unpackSymbolic = readVar . coerce+ :: (MonadVar m, MonadThunkId m, MonadCatch m)+ => Symbolic m+ -> m (NSymbolicF (NTypeF m (Symbolic m)))+unpackSymbolic = flip demand $ readVar . getSV type MonadLint e m- = (Scoped (SThunk m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId 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@@ -135,11 +144,11 @@ TNull -> return "null" TStr -> return "string" TList r -> do- x <- force r renderSymbolic+ x <- demand r renderSymbolic return $ "[" ++ x ++ "]" TSet Nothing -> return "<any set>" TSet (Just s) -> do- x <- traverse (`force` renderSymbolic) s+ x <- traverse (`demand` renderSymbolic) s return $ "{" ++ show x ++ "}" f@(TClosure p) -> do (args, sym) <- do@@ -156,13 +165,15 @@ :: forall e m . MonadLint e m => NExprF ()- -> [NTypeF m (SThunk m)]- -> [NTypeF m (SThunk m)]- -> m [NTypeF m (SThunk m)]+ -> [NTypeF m (Symbolic m)]+ -> [NTypeF m (Symbolic m)]+ -> m [NTypeF m (Symbolic m)] merge context = go where go- :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] -> m [NTypeF m (SThunk m)]+ :: [NTypeF m (Symbolic m)]+ -> [NTypeF m (Symbolic m)]+ -> m [NTypeF m (Symbolic m)] go [] _ = return [] go _ [] = return [] go (x : xs) (y : ys) = case (x, y) of@@ -170,8 +181,8 @@ (TPath, TPath) -> (TPath :) <$> go xs ys (TConstant ls, TConstant rs) -> (TConstant (ls `intersect` rs) :) <$> go xs ys- (TList l, TList r) -> force l $ \l' -> force r $ \r' -> do- m <- thunk $ unify context l' r'+ (TList l, TList r) -> demand l $ \l' -> demand r $ \r' -> do+ m <- defer $ unify context l' r' (TList m :) <$> go xs ys (TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys (TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys@@ -179,8 +190,8 @@ m <- sequenceA $ M.intersectionWith (\i j -> i >>= \i' -> j- >>= \j' -> force i'- $ \i'' -> force j' $ \j'' -> thunk $ unify context i'' j''+ >>= \j' -> demand i'+ $ \i'' -> demand j' $ \j'' -> defer $ unify context i'' j'' ) (return <$> l) (return <$> r)@@ -220,16 +231,16 @@ -> Symbolic m -> Symbolic m -> m (Symbolic m)-unify context (Symbolic x) (Symbolic y) = do+unify context (SV x) (SV y) = do x' <- readVar x y' <- readVar y case (x', y') of (NAny, _) -> do writeVar x y'- return $ Symbolic y+ return $ SV y (_, NAny) -> do writeVar y x'- return $ Symbolic x+ return $ SV x (NMany xs, NMany ys) -> do m <- merge context xs ys if null m@@ -243,29 +254,26 @@ writeVar x (NMany m) writeVar y (NMany m) packSymbolic (NMany m)+unify _ _ _ = error "The unexpected hath transpired!" -- These aren't worth defining yet, because once we move to Hindley-Milner, -- we're not going to be managing Symbolic values this way anymore. instance ToValue Bool m (Symbolic m) where -instance ToValue [SThunk m] m (Symbolic m) where+instance ToValue [Symbolic m] m (Symbolic m) where instance FromValue NixString m (Symbolic m) where -instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where+instance FromValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where -instance ToValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where+instance ToValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where -instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where- thunk = fmap SThunk . thunk- thunkId = thunkId . getSThunk- query x b f = query (getSThunk x) b f- queryM x b f = queryM (getSThunk x) b f- force = force . getSThunk- forceEff = forceEff . getSThunk- wrapValue = SThunk . wrapValue- getValue = getValue . getSThunk+instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)+ => MonadValue (Symbolic m) m where+ 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 ++ "'"@@ -285,9 +293,9 @@ ++ show s evalCurPos = do- f <- wrapValue <$> mkSymbolic [TPath]- l <- wrapValue <$> mkSymbolic [TConstant [TInt]]- c <- wrapValue <$> mkSymbolic [TConstant [TInt]]+ 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 =@@ -315,8 +323,8 @@ -- sure the action it evaluates is to force a thunk, so its value is only -- computed once. evalWith scope body = do- s <- thunk @(SThunk m) @m @(Symbolic m) scope- pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case+ s <- defer scope+ pushWeakScope ?? body $ demand s $ unpackSymbolic >=> \case NMany [TSet (Just s')] -> return s' NMany [TSet Nothing] -> error "NYI: with unknown" _ -> throwError $ ErrorCall "scope must be a set in with statement"@@ -348,7 +356,7 @@ -> m (Symbolic m) lintBinaryOp op lsym rarg = do rsym <- rarg- y <- thunk everyPossible+ 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]@@ -409,13 +417,13 @@ (head args, ) <$> foldM (unify context) y ys newtype Lint s a = Lint- { runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (FreshIdT Int (ST s)) a }+ { runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a } deriving ( Functor , Applicative , Monad , MonadFix- , MonadReader (Context (Lint s) (SThunk (Lint s)))+ , MonadReader (Context (Lint s) (Symbolic (Lint s))) , MonadThunkId , MonadRef , MonadAtomicRef@@ -432,7 +440,7 @@ i <- newVar (1 :: Int) runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action -symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))+symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m)) symbolicBaseEnv = return emptyScopes lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))@@ -444,8 +452,8 @@ expr ) -instance Scoped (SThunk (Lint s)) (Lint s) where+instance Scoped (Symbolic (Lint s)) (Lint s) where currentScopes = currentScopesReader- clearScopes = clearScopesReader @(Lint s) @(SThunk (Lint s))+ clearScopes = clearScopesReader @(Lint s) @(Symbolic (Lint s)) pushScopes = pushScopesReader lookupVar = lookupVarReader
src/Nix/Normal.hs view
@@ -13,21 +13,25 @@ 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 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 instance MonadDataErrorContext t f m => Exception (NormalLoop t f m) -normalForm'+-- | Normalize the value as much as possible, leaving only detected cycles.+normalizeValue :: forall e t m f . ( Framed e m , MonadThunk t m (NValue t f m)@@ -36,8 +40,8 @@ ) => (forall r . t -> (NValue t f m -> m r) -> m r) -> NValue t f m- -> m (NValueNF t f m)-normalForm' f = run . nValueToNFM run go+ -> m (NValue t f m)+normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run) where start = 0 :: Int table = mempty@@ -48,39 +52,37 @@ go :: t -> ( NValue t f m- -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)+ -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) )- -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)+ -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) go t k = do b <- seen t if b- then return $ pure t+ then return $ Pure t else do i <- ask when (i > 2000) $ error "Exceeded maximum normalization depth of 2000 levels"- s <- lift get- (res, s') <- lift $ lift $ f t $ \v ->- (`runStateT` s) . (`runReaderT` i) $ local succ $ k v- lift $ put s'- return res+ lifted (lifted (f t)) $ local succ . k - seen t = case thunkId t of- Just tid -> lift $ do+ seen t = do+ let tid = thunkId t+ lift $ do res <- gets (member tid) unless res $ modify (insert tid) return res- Nothing -> return False normalForm :: ( Framed e m , MonadThunk t m (NValue t f m) , MonadDataErrorContext t f m+ , HasCitations m (NValue t f m) t+ , HasCitations1 m (NValue t f m) f , Ord (ThunkId m) ) => NValue t f m- -> m (NValueNF t f m)-normalForm = normalForm' force+ -> m (NValue t f m)+normalForm = fmap stubCycles . normalizeValue force normalForm_ :: ( Framed e m@@ -90,26 +92,40 @@ ) => NValue t f m -> m ()-normalForm_ = void <$> normalForm' forceEff+normalForm_ = void <$> normalizeValue forceEff -removeEffects- :: (MonadThunk t m (NValue t f m), MonadDataContext f m)+stubCycles+ :: forall t f m+ . ( MonadDataContext f m+ , HasCitations m (NValue t f m) t+ , HasCitations1 m (NValue t f m) f+ ) => NValue t f m- -> NValueNF t f m-removeEffects = nValueToNF (flip query opaque)+ -> 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+ where+ Free (NValue cyc) = opaque -removeEffectsM+removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValue t f m- -> m (NValueNF t f m)-removeEffectsM = nValueToNFM id (flip queryM (pure opaque))+ -> m (NValue t f m)+removeEffects =+ iterNValueM+ id+ (flip queryM (pure opaque))+ (fmap Free . sequenceNValue' id) -opaque- :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m-opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"+opaque :: Applicative f => NValue t f m+opaque = nvStr $ principledMakeNixStringWithoutContext "<CYCLE>" dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => t- -> m (NValueNF t f m)-dethunk t = queryM t (pure opaque) removeEffectsM+ -> m (NValue t f m)+dethunk t = queryM t (pure opaque) removeEffects
src/Nix/Parser.hs view
@@ -81,8 +81,8 @@ import Data.Void import GHC.Generics hiding ( Prefix ) import Nix.Expr hiding ( ($>) )+import Nix.Expr.Strings import Nix.Render-import Nix.Strings import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L@@ -664,11 +664,3 @@ buildEntry i = concatMap $ \case (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] _ -> []--------
src/Nix/Pretty.hs view
@@ -18,6 +18,7 @@ import Control.Applicative ( (<|>) ) import Control.Comonad+import Control.Monad.Free import Data.Fix import Data.HashMap.Lazy ( toList ) import qualified Data.HashMap.Lazy as M@@ -40,10 +41,10 @@ import Nix.Atoms import Nix.Cited import Nix.Expr+import Nix.Expr.Strings import Nix.Normal import Nix.Parser import Nix.String-import Nix.Strings import Nix.Thunk #if ENABLE_TRACING import Nix.Utils@@ -192,14 +193,21 @@ prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . cata exprFNixDoc -instance HasCitations1 t m v f- => HasCitations t m v (NValue' t f m a) where+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 t m (NValue t f m) f+ . HasCitations1 m (NValue t f m) f => NExprLocF (Maybe (NValue t f m)) -> Doc ann prettyOriginExpr = withoutParens . go@@ -208,7 +216,7 @@ render :: Maybe (NValue t f m) -> NixDoc ann render Nothing = simpleExpr $ "_"- render (Just (reverse . citations @t @m -> p:_)) = go (_originExpr p)+ render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p) render _ = simpleExpr "?" -- render (Just (NValue (citations -> ps))) = -- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens@@ -313,97 +321,66 @@ NSynHole name -> simpleExpr $ pretty ("^" <> unpack name) where recPrefix = "rec" <> space -valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr-valueToExpr = iterNValueNF- (const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))- phi+valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr+valueToExpr = iterNValue (\_ _ -> thk) phi where+ thk = Fix . NSym . pack $ "<CYCLE>"+ 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+ phi (NVConstant' a ) = Fix $ NConstant a+ phi (NVStr' ns) = mkStr ns+ phi (NVList' l ) = Fix $ NList l+ phi (NVSet' s p ) = Fix $ NSet [ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p)) | (k, v) <- toList s ]- phi (NVClosure _ _ ) = Fix . NSym . pack $ "<closure>"- phi (NVPath p ) = Fix $ NLiteralPath p- phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name- phi _ = error "Pattern synonyms foil completeness check"+ phi (NVClosure' _ _ ) = Fix . NSym . pack $ "<closure>"+ 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)] -prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann-prettyNValueNF = prettyNix . valueToExpr--printNix :: forall t f m . MonadDataContext f m => NValueNF t f m -> String-printNix = iterNValueNF (const "<CYCLE>") phi- where- 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 (NVSet s _) =- "{ "- ++ concat- [ check (unpack 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 ++ "\""- phi NVClosure{} = "<<lambda>>"- phi (NVPath fp ) = fp- phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"- phi _ = error "Pattern synonyms foil completeness check"- prettyNValue- :: (MonadThunk t m (NValue t f m), MonadDataContext f m)- => NValue t f m- -> m (Doc ann)-prettyNValue = fmap prettyNValueNF . removeEffectsM+ :: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann+prettyNValue = prettyNix . valueToExpr prettyNValueProv :: forall t f m ann- . ( HasCitations1 t m (NValue t f m) f+ . ( HasCitations m (NValue t f m) t+ , HasCitations1 m (NValue t f m) f , MonadThunk t m (NValue t f m) , MonadDataContext f m ) => NValue t f m- -> m (Doc ann)-prettyNValueProv v@(NValue nv) = do- let ps = citations1 @t @m @(NValue t f m) @f nv+ -> Doc ann+prettyNValueProv v = do+ let ps = citations @m @(NValue t f m) v case ps of [] -> prettyNValue v- ps -> do- v' <- prettyNValue v- pure- $ fillSep- $ [ v'- , indent 2- $ parens- $ mconcat- $ "from: "- : map (prettyOriginExpr . _originExpr) ps- ]+ ps ->+ let v' = prettyNValue v in+ fillSep+ [ v'+ , indent 2+ $ parens+ $ mconcat+ $ "from: "+ : map (prettyOriginExpr . _originExpr) ps+ ] prettyNThunk :: forall t f m ann- . ( HasCitations t m (NValue t f m) t- , HasCitations1 t m (NValue t f m) f+ . ( HasCitations m (NValue t f m) t+ , HasCitations1 m (NValue t f m) f , MonadThunk t m (NValue t f m) , MonadDataContext f m ) => t -> m (Doc ann) prettyNThunk t = do- let ps = citations @t @m @(NValue t f m) @t t- v' <- prettyNValueNF <$> dethunk t+ let ps = citations @m @(NValue t f m) @t t+ v' <- prettyNValue <$> dethunk t pure $ fillSep $ [ v'@@ -414,10 +391,31 @@ : map (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+printNix = iterNValue (\_ _ -> thk) phi+ where+ thk = "<thunk>" + 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 (NVSet' s _) =+ "{ "+ ++ concat+ [ check (unpack 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 ++ "\""+ phi NVClosure'{} = "<<lambda>>"+ phi (NVPath' fp ) = fp+ phi (NVBuiltin' name _) = "<<builtin " ++ name ++ ">>"+ phi _ = error "Pattern synonyms foil completeness check"
src/Nix/Reduce.hs view
@@ -58,7 +58,7 @@ ) import Data.Text ( Text ) import Nix.Atoms-import Nix.Exec+import Nix.Effects.Basic ( pathToDefaultNixFile ) import Nix.Expr import Nix.Frames import Nix.Options ( Options
src/Nix/Render/Frame.hs view
@@ -158,12 +158,13 @@ else pretty shortLabel <> fillSep [": ", rendered] renderValueFrame- :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)+ :: forall e t f m ann+ . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> ValueFrame t f m -> m [Doc ann] renderValueFrame level = fmap (: []) . \case- ForcingThunk -> pure "ForcingThunk"+ ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI ConcerningValue _v -> pure "ConcerningValue" Comparison _ _ -> pure "Comparing" Addition _ _ -> pure "Adding"@@ -180,13 +181,13 @@ v' <- renderValue level "" "" v pure $ "CoercionToJson " <> v' CoercionFromJson _j -> pure "CoercionFromJson"- ExpectationNF _t _v -> pure "ExpectationNF"- Expectation t v -> do- v' <- renderValue level "" "" v+ Expectation t v -> do+ v' <- renderValue @_ @t @f @m level "" "" v pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t) renderValue- :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)+ :: forall e t f m ann+ . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> String -> String@@ -194,7 +195,9 @@ -> m (Doc ann) renderValue _level _longLabel _shortLabel v = do opts :: Options <- asks (view hasLens)- if values opts then prettyNValueProv v else prettyNValue v+ (if values opts+ then prettyNValueProv+ else prettyNValue) <$> removeEffects v renderExecFrame :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)@@ -226,11 +229,3 @@ NormalLoop v -> do v' <- renderValue level "" "" v pure $ "Infinite recursion during normalization forcing " <> v'--------
src/Nix/Scope.hs view
@@ -20,64 +20,64 @@ import Lens.Family2 import Nix.Utils -newtype Scope t = Scope { getScope :: AttrSet t }+newtype Scope a = Scope { getScope :: AttrSet a } deriving (Functor, Foldable, Traversable, Eq) -instance Show (Scope t) where+instance Show (Scope a) where show (Scope m) = show (M.keys m) -newScope :: AttrSet t -> Scope t+newScope :: AttrSet a -> Scope a newScope = Scope -scopeLookup :: Text -> [Scope t] -> Maybe t+scopeLookup :: Text -> [Scope a] -> Maybe a scopeLookup key = foldr go Nothing where go (Scope m) rest = M.lookup key m <|> rest -data Scopes m t = Scopes- { lexicalScopes :: [Scope t]- , dynamicScopes :: [m (Scope t)]+data Scopes m a = Scopes+ { lexicalScopes :: [Scope a]+ , dynamicScopes :: [m (Scope a)] } -instance Show (Scopes m t) where- show (Scopes m t) =- "Scopes: " ++ show m ++ ", and " ++ show (length t) ++ " with-scopes"+instance Show (Scopes m a) where+ show (Scopes m a) =+ "Scopes: " ++ show m ++ ", and " ++ show (length a) ++ " with-scopes" -instance Semigroup (Scopes m t) where+instance Semigroup (Scopes m a) where Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw) -instance Monoid (Scopes m t) where+instance Monoid (Scopes m a) where mempty = emptyScopes mappend = (<>) -emptyScopes :: forall m t . Scopes m t+emptyScopes :: forall m a . Scopes m a emptyScopes = Scopes [] [] -class Scoped t m | m -> t where- currentScopes :: m (Scopes m t)- clearScopes :: m a -> m a- pushScopes :: Scopes m t -> m a -> m a- lookupVar :: Text -> m (Maybe t)+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) currentScopesReader- :: forall m t e . (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)+ :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => m (Scopes m a) currentScopesReader = asks (view hasLens) clearScopesReader- :: forall m t e a . (MonadReader e m, Has e (Scopes m t)) => m a -> m a-clearScopesReader = local (set hasLens (emptyScopes @m @t))+ :: 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 t m => AttrSet t -> m a -> m a+pushScope :: Scoped a m => AttrSet a -> m r -> m r pushScope s = pushScopes (Scopes [Scope s] []) -pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a+pushWeakScope :: (Functor m, Scoped a m) => m (AttrSet a) -> m r -> m r pushWeakScope s = pushScopes (Scopes [] [Scope <$> s]) pushScopesReader- :: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a+ :: (MonadReader e m, Has e (Scopes m a)) => Scopes m a -> m r -> m r pushScopesReader s = local (over hasLens (s <>)) lookupVarReader- :: forall m t e . (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)+ :: 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@@ -94,5 +94,5 @@ (return Nothing) ws -withScopes :: Scoped t m => Scopes m t -> m a -> m a+withScopes :: Scoped a m => Scopes m a -> m r -> m r withScopes scope = clearScopes . pushScopes scope
+ src/Nix/Standard.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# 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.Free+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State+import Data.HashMap.Lazy ( HashMap )+import Data.Typeable+import GHC.Generics+import Nix.Cited+import Nix.Cited.Basic+import Nix.Context+import Nix.Effects+import Nix.Effects.Basic+import Nix.Expr.Types.Annotated+import Nix.Fresh+import Nix.Fresh.Basic+import Nix.Options+import Nix.Render+import Nix.Scope+import Nix.Thunk+import Nix.Thunk.Basic+import Nix.Utils.Fix1+import Nix.Value+import Nix.Value.Monad+import Nix.Var+#ifdef MIN_VERSION_haskeline+import System.Console.Haskeline.MonadException hiding(catch)+#endif++-- 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 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 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)++#ifdef MIN_VERSION_haskeline+-- For whatever reason, using the default StateT instance provided by+-- haskeline does not work.+instance MonadException m+ => MonadException(StateT(HashMap FilePath NExprLoc) m) where+ controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let+ run' = RunIO(fmap(StateT . const) . run . flip runStateT s)+ in fmap(flip runStateT s) $ f run'++instance MonadException m => MonadException(Fix1T StandardTF m) where+ controlIO f = mkStandardT $ controlIO $ \(RunIO run) ->+ let run' = RunIO(fmap mkStandardT . run . runStandardT)+ in runStandardT <$> f run'+#endif++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, MonadFile m) => MonadFile (Fix1T t m)++instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where+ addPath' = lift . addPath'+ toFile_' n = lift . toFile_' n++{------------------------------------------------------------------------}++newtype StdCited m a = StdCited+ { _stdCited :: Cited (StdThunk m) (StdCited m) m a }+ deriving+ ( Generic+ , Typeable+ , Functor+ , Applicative+ , Foldable+ , Traversable+ , Comonad+ , ComonadEnv [Provenance m (StdValue m)]+ )++newtype StdThunk (m :: * -> *) = StdThunk+ { _stdThunk :: StdCited m (NThunkF m (StdValue m)) }++type StdValue m = NValue (StdThunk m) (StdCited m) m++instance Show (StdThunk m) where+ show _ = "<thunk>"++instance HasCitations1 m (StdValue m) (StdCited m) where+ citations1 (StdCited c) = citations1 c+ addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)++instance HasCitations m (StdValue m) (StdThunk m) where+ citations (StdThunk c) = citations1 c+ addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c)++instance MonadReader (Context m (StdValue m)) m => Scoped (StdValue m) m where+ currentScopes = currentScopesReader+ clearScopes = clearScopesReader @m @(StdValue m)+ pushScopes = pushScopesReader+ lookupVar = lookupVarReader++instance ( MonadFix m+ , MonadFile m+ , MonadCatch m+ , MonadEnv 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) 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+ findPath = defaultFindPath+ importPath = defaultImportPath+ pathToDefaultNix = defaultPathToDefaultNix+ derivationStrict = defaultDerivationStrict+ traceEffect = defaultTraceEffect++instance ( MonadAtomicRef m+ , MonadCatch m+ , Typeable m+ , MonadReader (Context m (StdValue m)) m+ , MonadThunkId m+ )+ => MonadThunk (StdThunk m) m (StdValue m) where+ thunk = fmap (StdThunk . StdCited) . thunk+ thunkId = thunkId . _stdCited . _stdThunk+ queryM x b f = queryM (_stdCited (_stdThunk x)) b f+ force = force . _stdCited . _stdThunk+ 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+ )+ => MonadValue (StdValue m) m where+ defer = fmap Pure . thunk++ demand (Pure v) f = force v (flip demand f)+ demand (Free v) f = f (Free v)++ inform (Pure t) f = Pure <$> further t f+ inform (Free v) f = Free <$> bindNValue' id (flip inform f) v++{------------------------------------------------------------------------}++-- jww (2019-03-22): NYI+-- whileForcingThunk+-- :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r+-- whileForcingThunk frame =+-- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame++newtype StandardTF r m a+ = StandardTF (ReaderT (Context r (StdValue r))+ (StateT (HashMap FilePath NExprLoc) m) a)+ deriving+ ( Functor+ , Applicative+ , Alternative+ , Monad+ , MonadPlus+ , MonadFix+ , MonadIO+ , MonadCatch+ , MonadThrow+ , MonadReader (Context r (StdValue r))+ , MonadState (HashMap FilePath NExprLoc)+ )++instance MonadTrans (StandardTF r) where+ lift = StandardTF . lift . 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 (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)++{------------------------------------------------------------------------}++type StandardT m = Fix1T StandardTF m++instance MonadTrans (Fix1T StandardTF) where+ lift = Fix1T . lift++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) m)+ a+ -> StandardT m a+mkStandardT = Fix1T . StandardTF++runStandardT+ :: StandardT m a+ -> ReaderT+ (Context (StandardT m) (StdValue (StandardT m)))+ (StateT (HashMap FilePath NExprLoc) m)+ a+runStandardT (Fix1T (StandardTF m)) = m++runWithBasicEffects+ :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a+runWithBasicEffects opts =+ go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT+ where+ go action = do+ i <- newVar (1 :: Int)+ runFreshIdT i action++runWithBasicEffectsIO :: Options -> StandardT (StdIdT IO) a -> IO a+runWithBasicEffectsIO = runWithBasicEffects
+ src/Nix/String/Coerce.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Nix.String.Coerce where++import Control.Monad+import Control.Monad.Catch hiding ( catchJust )+import qualified Data.HashMap.Lazy as M+import qualified Data.Text as Text+import Nix.Atoms+import Nix.Effects+import Nix.Frames+import Nix.String+import Nix.Value+import Nix.Value.Monad++#ifdef MIN_VERSION_ghc_datasize+#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804+import GHC.DataSize+#endif+#endif++-- | Data type to avoid boolean blindness on what used to be called coerceMore+data CoercionLevel+ = CoerceStringy+ -- ^ Coerce only stringlike types: strings, paths, and appropriate sets+ | CoerceAny+ -- ^ Coerce everything but functions+ deriving (Eq,Ord,Enum,Bounded)++-- | Data type to avoid boolean blindness on what used to be called copyToStore+data CopyToStoreMode+ = CopyToStore+ -- ^ Add paths to the store as they are encountered+ | DontCopyToStore+ -- ^ Add paths to the store as they are encountered+ deriving (Eq,Ord,Enum,Bounded)++coerceToString+ :: ( Framed e m+ , MonadStore m+ , MonadThrow m+ , MonadDataErrorContext t f m+ , MonadValue (NValue t f m) m+ )+ => (NValue t f m -> NValue t f m -> m (NValue t f m))+ -> CopyToStoreMode+ -> CoercionLevel+ -> NValue t f m+ -> 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++ v@(NVSet s _) | Just p <- M.lookup "__toString" s ->+ demand p $ (`call` v) >=> go++ NVSet s _ | Just p <- M.lookup "outPath" s -> demand p go++ v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v++ nixStringUnwords =+ principledIntercalateNixString (principledMakeNixStringWithoutContext " ")+ storePathToNixString :: StorePath -> NixString+ storePathToNixString sp = principledMakeNixStringWithSingletonContext+ t+ (StringContext t DirectPath)+ where t = Text.pack $ unStorePath sp+
− src/Nix/Strings.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}---- | Functions for manipulating nix strings.-module Nix.Strings where--import Data.List ( intercalate- , dropWhileEnd- , inits- )-import Data.Monoid ( (<>) )-import Data.Text ( Text )-import qualified Data.Text as T-import Data.Tuple ( swap )-import Nix.Expr---- | Merge adjacent 'Plain' values with 'mappend'.-mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r]-mergePlain [] = []-mergePlain (Plain a : EscapedNewline : Plain b : xs) =- mergePlain (Plain (a <> "\n" <> b) : xs)-mergePlain (Plain a : Plain b : xs) = mergePlain (Plain (a <> b) : xs)-mergePlain (x : xs) = x : mergePlain xs---- | Remove 'Plain' values equal to 'mempty', as they don't have any--- informational content.-removePlainEmpty :: [Antiquoted Text r] -> [Antiquoted Text r]-removePlainEmpty = filter f where- f (Plain x) = x /= mempty- f _ = True-- -- trimEnd xs- -- | null xs = xs- -- | otherwise = case last xs of- -- Plain x -> init xs ++ [Plain (T.dropWhileEnd (== ' ') x)]- -- _ -> xs---- | Equivalent to case splitting on 'Antiquoted' strings.-runAntiquoted :: v -> (v -> a) -> (r -> a) -> Antiquoted v r -> a-runAntiquoted _ f _ (Plain v) = f v-runAntiquoted nl f _ EscapedNewline = f nl-runAntiquoted _ _ k (Antiquoted r) = k r---- | Split a stream representing a string with antiquotes on line breaks.-splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]]-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, [])- go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs- go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs- go [] = ([], [])---- | Join a stream of strings containing antiquotes again. This is the inverse--- of 'splitLines'.-unsplitLines :: [[Antiquoted Text r]] -> [Antiquoted Text r]-unsplitLines = intercalate [Plain "\n"]---- | Form an indented string by stripping spaces equal to the minimal indent.-stripIndent :: [Antiquoted Text r] -> NString r-stripIndent [] = Indented 0 []-stripIndent xs =- Indented minIndent- . removePlainEmpty- . mergePlain- . map snd- . dropWhileEnd cleanup- . (\ys -> zip- (map- (\case- [] -> Nothing- x -> Just (last x)- )- (inits ys)- )- ys- )- . unsplitLines- $ ls'- where- ls = stripEmptyOpening $ splitLines xs- ls' = map (dropSpaces minIndent) ls-- minIndent = case stripEmptyLines ls of- [] -> 0- nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs-- stripEmptyLines = filter $ \case- [Plain t] -> not $ T.null $ T.strip t- _ -> True-- stripEmptyOpening ([Plain t] : ts) | T.null (T.strip t) = ts- stripEmptyOpening ts = ts-- countSpaces (Antiquoted _ : _) = 0- countSpaces (EscapedNewline : _) = 0- countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t- countSpaces [] = 0-- dropSpaces 0 x = x- dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs- dropSpaces _ _ = error "stripIndent: impossible"-- cleanup (Nothing, Plain y) = T.all (== ' ') y- cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y- cleanup _ = False--escapeCodes :: [(Char, Char)]-escapeCodes =- [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')]--fromEscapeCode :: Char -> Maybe Char-fromEscapeCode = (`lookup` map swap escapeCodes)--toEscapeCode :: Char -> Maybe Char-toEscapeCode = (`lookup` escapeCodes)
src/Nix/Thunk.hs view
@@ -9,6 +9,10 @@ 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 ) class ( Monad m@@ -29,21 +33,33 @@ => m (ThunkId m) freshId = lift freshId -class MonadThunkId m => MonadThunk t m v | t -> m, t -> v where- thunk :: m v -> m t- -- | Return an identifier for the thunk unless it is a pure value (i.e.,- -- strictly an encapsulation of some 'v' without any additional- -- structure). For pure values represented as thunks, returns Nothing.- thunkId :: t -> Maybe (ThunkId m)- query :: t -> r -> (v -> r) -> r- queryM :: t -> m r -> (v -> m r) -> m r- force :: t -> (v -> m r) -> m r- forceEff :: t -> (v -> m r) -> m r- wrapValue :: v -> t- getValue :: t -> Maybe v+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+ type ThunkId (WriterT w m) = ThunkId m+instance MonadThunkId m => MonadThunkId (ExceptT e m) where+ type ThunkId (ExceptT e m) = ThunkId m+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++ -- | 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++ queryM :: t -> m r -> (a -> m r) -> m r+ force :: t -> (a -> m r) -> m r+ forceEff :: t -> (a -> m r) -> m r++ -- | 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+ newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId- deriving Typeable+ deriving Typeable instance Show ThunkLoop where show (ThunkLoop i) = "ThunkLoop " ++ i
src/Nix/Thunk/Basic.hs view
@@ -27,51 +27,31 @@ -- | The type of very basic thunks data NThunkF m v- = Value v- | Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))+ = Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v)) instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where- Value x == Value y = x == y Thunk x _ _ == Thunk y _ _ = x == y- _ == _ = False -- jww (2019-03-16): not accurate... instance Show v => Show (NThunkF m v) where- show (Value v ) = show v show (Thunk _ _ _) = "<thunk>" type MonadBasicThunk m = (MonadThunkId m, MonadVar m) instance (MonadBasicThunk m, MonadCatch m) => MonadThunk (NThunkF m v) m v where- thunk = buildThunk- thunkId = \case- Value _ -> Nothing- Thunk n _ _ -> Just n- query = queryValue- queryM = queryThunk- force = forceThunk- forceEff = forceEffects- wrapValue = valueRef- getValue = thunkValue--valueRef :: v -> NThunkF m v-valueRef = Value--thunkValue :: NThunkF m v -> Maybe v-thunkValue (Value v) = Just v-thunkValue _ = Nothing+ thunk = buildThunk+ 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) -queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a-queryValue (Value v) _ k = k v-queryValue _ n _ = n- queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a-queryThunk (Value v ) _ k = k v queryThunk (Thunk _ active ref) n k = do nowActive <- atomicModifyVar active (True, ) if nowActive@@ -90,7 +70,6 @@ => NThunkF m v -> (v -> m a) -> m a-forceThunk (Value v ) k = k v forceThunk (Thunk n active ref) k = do eres <- readVar ref case eres of@@ -109,7 +88,6 @@ k v forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r-forceEffects (Value v ) k = k v forceEffects (Thunk _ active ref) k = do nowActive <- atomicModifyVar active (True, ) if nowActive@@ -123,3 +101,10 @@ 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)+ return t
− src/Nix/Thunk/Standard.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module Nix.Thunk.Standard where--import Control.Comonad ( Comonad )-import Control.Comonad.Env ( ComonadEnv )-import Control.Monad.Catch hiding ( catchJust )-import Control.Monad.Reader-import Control.Monad.Ref-import Data.Typeable-import GHC.Generics-import Nix.Cited-import Nix.Cited.Basic-import Nix.Exec-import Nix.Fresh-import Nix.Fresh.Basic-import Nix.Options-import Nix.Thunk-import Nix.Thunk.Basic-import Nix.Value-import Nix.Var--newtype StdThunk (u :: (* -> *) -> * -> *) (m :: * -> *) = StdThunk- { _stdThunk :: StdCited u m (NThunkF (StdLazy u m) (StdValue u m)) }--newtype StdCited u m a = StdCited- { _stdCited :: Cited (StdThunk u m) (StdCited u m) (StdLazy u m) a }- deriving- ( Generic- , Typeable- , Functor- , Applicative- , Foldable- , Traversable- , Comonad- , ComonadEnv [Provenance (StdThunk u m) (StdLazy u m) (StdValue u m)]- )--type StdValue u m = NValue (StdThunk u m) (StdCited u m) (StdLazy u m)-type StdValueNF u m = NValueNF (StdThunk u m) (StdCited u m) (StdLazy u m)--- type StdIdT m = FreshIdT Int m--type StdLazy u m = Lazy (StdThunk u m) (StdCited u m) (u m)--instance Show (StdThunk u m) where- show _ = "<thunk>" -- jww (2019-03-15): NYI--type MonadStdThunk m- = (MonadVar m, MonadCatch m, MonadThrow m, Typeable m, MonadAtomicRef m)--instance ( MonadStdThunk (u m)- , MonadThunkId (u m)- , MonadTrans u- , Typeable u- , Typeable m- )- => MonadThunk (StdThunk u m) (StdLazy u m) (StdValue u m) where- thunk = fmap (StdThunk . StdCited) . thunk- thunkId = thunkId . _stdCited . _stdThunk- query x b f = query (_stdCited (_stdThunk x)) b f- queryM x b f = queryM (_stdCited (_stdThunk x)) b f- force = force . _stdCited . _stdThunk- forceEff = forceEff . _stdCited . _stdThunk- wrapValue = StdThunk . StdCited . wrapValue- getValue = getValue . _stdCited . _stdThunk--instance HasCitations1 (StdThunk u m) (StdLazy u m) (StdValue u m) (StdCited u m) where- citations1 (StdCited c) = citations1 c- addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)--runStdLazyM- :: (MonadVar m, MonadIO m, MonadIO (u m))- => Options- -> (u m a -> m a)- -> StdLazy u m a- -> m a-runStdLazyM opts run action = run $ runLazyM opts action--type StandardThunk m = StdThunk StdIdT m-type StandardValue m = StdValue StdIdT m-type StandardValueNF m = StdValueNF StdIdT m-type StandardT m = StdLazy StdIdT m--runStandard :: (MonadVar m, MonadIO m) => Options -> StdLazy StdIdT m a -> m a-runStandard opts action = do- i <- newVar (1 :: Int)- runStdLazyM opts (runFreshIdT i) action--runStandardIO :: Options -> StdLazy StdIdT IO a -> IO a-runStandardIO = runStandard
src/Nix/Type/Infer.hs view
@@ -36,7 +36,7 @@ import Control.Monad.Ref import Control.Monad.ST import Control.Monad.State.Strict-import Data.Fix+import Data.Fix ( cata ) import Data.Foldable import qualified Data.HashMap.Lazy as M import Data.List ( delete@@ -59,13 +59,14 @@ import Nix.Fresh import Nix.String import Nix.Scope-import Nix.Thunk-import Nix.Thunk.Basic+-- import Nix.Thunk+-- import Nix.Thunk.Basic import qualified Nix.Type.Assumption as As import Nix.Type.Env import qualified Nix.Type.Env as Env import Nix.Type.Type import Nix.Utils+import Nix.Value.Monad import Nix.Var -------------------------------------------------------------------------------@@ -75,7 +76,7 @@ -- | Inference monad newtype InferT s m a = InferT { getInfer ::- ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))+ ReaderT (Set.Set TVar, Scopes (InferT s m) (Judgment s)) (StateT InferState (ExceptT InferError m)) a } deriving@@ -85,7 +86,7 @@ , Monad , MonadPlus , MonadFix- , MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))+ , MonadReader (Set.Set TVar, Scopes (InferT s m) (Judgment s)) , MonadFail , MonadState InferState , MonadError InferError@@ -94,8 +95,8 @@ instance MonadTrans (InferT s) where lift = InferT . lift . lift . lift -instance MonadThunkId m => MonadThunkId (InferT s m) where- type ThunkId (InferT s m) = ThunkId m+-- instance MonadThunkId m => MonadThunkId (InferT s m) where+-- type ThunkId (InferT s m) = ThunkId m -- | Inference state newtype InferState = InferState { count :: Int }@@ -256,7 +257,7 @@ -- | Canonicalize and return the polymorphic toplevel type. closeOver :: Type -> Scheme-closeOver = normalize . generalize Set.empty+closeOver = normalizeScheme . generalize Set.empty extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a extendMSet x = InferT . local (first (Set.insert x)) . getInfer@@ -389,7 +390,7 @@ _ <- modifyRef x (fst . f) return res -newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s))+-- newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s)) instance Monad m => MonadThrow (InferT s m) where throwM = throwError . EvaluationError@@ -402,27 +403,33 @@ (fromException (toException e)) err -> error $ "Unexpected error: " ++ show err -type MonadInfer m = (MonadThunkId m, MonadVar m, MonadFix m)+type MonadInfer m+ = ({- MonadThunkId m,-}+ MonadVar m, MonadFix m) +instance Monad m => MonadValue (Judgment s) (InferT s m) where+ defer = id+ demand = flip ($)+ inform j f = f (pure j)++{- instance MonadInfer m => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where thunk = fmap JThunk . thunk thunkId (JThunk x) = thunkId x - query (JThunk x) b f = query x b f queryM (JThunk x) b f = queryM x b f + -- If we have a thunk loop, we just don't know the type. force (JThunk t) f = catch (force t f) $ \(_ :: ThunkLoop) ->--- If we have a thunk loop, we just don't know the type. f =<< Judgment As.empty [] <$> fresh++ -- If we have a thunk loop, we just don't know the type. forceEff (JThunk t) f = catch (forceEff t f) $ \(_ :: ThunkLoop) ->--- If we have a thunk loop, we just don't know the type. f =<< Judgment As.empty [] <$> fresh-- wrapValue = JThunk . wrapValue- getValue (JThunk x) = getValue x+-} instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where freeVariable var = do@@ -531,33 +538,33 @@ fromValue _ = error "Unused" instance MonadInfer m- => FromValue (AttrSet (JThunkT s m), AttrSet SourcePos)+ => 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 (\k v -> wrapValue (sing k v)) xs, M.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- => ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)+ => ToValue (AttrSet (Judgment s), AttrSet SourcePos) (InferT s m) (Judgment s) where toValue (xs, _) = Judgment <$> foldrM go As.empty xs- <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)- <*> (TSet True <$> traverse (`force` (pure . inferredType)) xs)- where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest+ <*> (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 -instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where+instance MonadInfer m => ToValue [Judgment s] (InferT s m) (Judgment s) where toValue xs = Judgment <$> foldrM go As.empty xs- <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)- <*> (TList <$> traverse (`force` (pure . inferredType)) xs)- where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest+ <*> (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 instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where toValue _ = pure $ Judgment As.empty [] typeBool@@ -571,8 +578,8 @@ Left err -> Left err Right ty -> inferTop (extend env (name, ty)) xs -normalize :: Scheme -> Scheme-normalize (Forall _ body) = Forall (map snd ord) (normtype body)+normalizeScheme :: Scheme -> Scheme+normalizeScheme (Forall _ body) = Forall (map snd ord) (normtype body) where ord = zip (nub $ fv body) (map TV letters) @@ -695,8 +702,8 @@ s' <- lift $ instantiate s solve (EqConst t s' : cs) -instance Monad m => Scoped (JThunkT s m) (InferT s m) where+instance Monad m => Scoped (Judgment s) (InferT s m) where currentScopes = currentScopesReader- clearScopes = clearScopesReader @(InferT s m) @(JThunkT s m)+ clearScopes = clearScopesReader @(InferT s m) @(Judgment s) pushScopes = pushScopesReader lookupVar = lookupVarReader
src/Nix/Utils.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -15,6 +16,8 @@ import Control.Arrow ( (&&&) ) import Control.Monad import Control.Monad.Fix+import Control.Monad.Free+import Control.Monad.Trans.Control ( MonadTransControl(..) ) import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import Data.Fix@@ -90,6 +93,22 @@ 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 . return++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)++fixToFree :: Functor f => Fix f -> Free f a+fixToFree = Free . go where go (Fix f) = fmap (Free . go) f+ -- | adi is Abstracting Definitional Interpreters: -- -- https://arxiv.org/abs/1707.04755@@ -156,11 +175,3 @@ alterF f k m = f (M.lookup k m) <&> \case Nothing -> M.delete k m Just v -> M.insert k v m--------
+ src/Nix/Utils/Fix1.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Nix.Utils.Fix1 where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Reader+import Control.Monad.State++-- | 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 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 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 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)++{-++newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a }++-- | Natural Transformations (Included from+-- [compdata](https://hackage.haskell.org/package/compdata))+type (:->) f g = forall a. f a -> g a++class HFunctor f where+ hfmap :: a :-> b -> f a :-> f b++-}
src/Nix/Value.hs view
@@ -62,7 +62,7 @@ | NVPathF FilePath | NVListF [r] | NVSetF (AttrSet r) (AttrSet SourcePos)- | NVClosureF (Params ()) (m p -> m r)+ | NVClosureF (Params ()) (p -> m r) -- ^ A function is a closed set of parameters representing the "call -- signature", used at application time to check the type of arguments -- passed to the function. Since it supports default values which may@@ -74,7 +74,7 @@ -- 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 (m p -> m r)+ | NVBuiltinF String (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.@@ -92,6 +92,20 @@ 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@@ -99,22 +113,21 @@ NVPathF p -> NVPathF p NVListF l -> NVListF l NVSetF s p -> NVSetF s p- NVClosureF p g -> NVClosureF p (g . fmap f)- NVBuiltinF s g -> NVBuiltinF s (g . fmap f)+ NVClosureF p g -> NVClosureF p (g . f)+ NVBuiltinF s g -> NVBuiltinF s (g . f) hoistNValueF- :: (forall x . n x -> m x)- -> (forall x . m x -> n x)+ :: (forall x . m x -> n x) -> NValueF p m a -> NValueF p n a-hoistNValueF run lft = \case+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 . run)- NVBuiltinF s g -> NVBuiltinF s (lft . g . run)+ NVClosureF p g -> NVClosureF p (lft . g)+ NVBuiltinF s g -> NVBuiltinF s (lft . g) sequenceNValueF :: (Functor n, Monad m, Applicative n)@@ -147,17 +160,16 @@ liftNValueF :: (MonadTrans u, Monad m)- => (forall x . u m x -> m x)- -> NValueF p m a+ => NValueF p m a -> NValueF p (u m) a-liftNValueF run = hoistNValueF run lift+liftNValueF = hoistNValueF lift unliftNValueF :: (MonadTrans u, Monad m) => (forall x . u m x -> m x) -> NValueF p (u m) a -> NValueF p m a-unliftNValueF run = hoistNValueF lift run+unliftNValueF = hoistNValueF type MonadDataContext f (m :: * -> *) = (Comonad f, Applicative f, Traversable f, Monad m)@@ -167,77 +179,70 @@ newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) } deriving (Generic, Typeable, Functor, Foldable) -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- instance (Comonad f, Show a) => Show (NValue' t f m a) where show (NValue (extract -> v)) = show v instance Comonad f => Show1 (NValue' t f m) where liftShowsPrec sp sl p = \case- NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom- NVStr ns ->+ NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom+ NVStr' ns -> showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext 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"--type NValue t f m = NValue' t f m t+ 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" -sequenceNValue+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) =+sequenceNValue' transform (NValue v) = NValue <$> traverse (sequenceNValueF transform) v -bindNValue+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) =+bindNValue' transform f (NValue v) = NValue <$> traverse (bindNValueF transform f) v -hoistNValue+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 run lft) v)+hoistNValue' run lft (NValue v) =+ NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF lft) v) -liftNValue+liftNValue' :: (MonadTrans u, Monad m, Functor (u m), Functor f) => (forall x . u m x -> m x) -> NValue' t f m a -> NValue' t f (u m) a-liftNValue run = hoistNValue run lift+liftNValue' run = hoistNValue' run lift -unliftNValue+unliftNValue' :: (MonadTrans u, Monad m, Functor (u m), Functor f) => (forall x . u m x -> m x) -> NValue' t f (u m) a -> NValue' t f m a-unliftNValue run = hoistNValue lift run+unliftNValue' run = hoistNValue' lift run +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))+ -- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is -- a value in head normal form, where only the "top layer" has been -- evaluated. An action of type 'm (NValue f t m)' is a pending evualation that@@ -248,166 +253,147 @@ -- The 'Free' structure is used here to represent the possibility that -- cycles may appear during normalization. -type NValueNF t f m = Free (NValue' t f m) t+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+ iterNValue- :: forall t f m a r+ :: forall t f m r . MonadDataContext f m- => (a -> (NValue' t f m a -> r) -> r)+ => (t -> (NValue t f m -> r) -> r) -> (NValue' t f m r -> r)- -> NValue' t f m a+ -> NValue t f m -> r-iterNValue k f = f . fmap (\a -> k a (iterNValue k f))+iterNValue k f = iter f . fmap (\t -> k t (iterNValue k f)) iterNValueM :: (MonadDataContext f m, Monad n) => (forall x . n x -> m x)- -> (a -> (NValue' t f m a -> n r) -> n r)- -> (NValue' t f m r -> n r)- -> NValue' t f m a- -> n r-iterNValueM transform k f =- f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))--iterNValueNF- :: MonadDataContext f m- => (t -> r)- -> (NValue' t f m r -> r)- -> NValueNF t f m- -> r-iterNValueNF k f = iter f . fmap k--iterNValueNFM- :: forall f m n t r- . (MonadDataContext f m, Monad n)- => (forall x . n x -> m x)- -> (t -> n r)+ -> (t -> (NValue t f m -> n r) -> n r) -> (NValue' t f m (n r) -> n r)- -> NValueNF t f m+ -> NValue t f m -> n r-iterNValueNFM transform k f v =- iterM f =<< go (fmap k v)+iterNValueM transform k f =+ iterM f <=< go . fmap (\t -> k t (iterNValueM transform k f)) where- go (Pure a ) = Pure <$> a- go (Free fa) = Free <$> bindNValue transform go fa--nValueFromNF- :: (MonadThunk t m (NValue t f m), MonadDataContext f m)- => NValueNF t f m- -> NValue t f m-nValueFromNF = iterNValueNF f (fmap wrapValue)- where- f t = query t cyc id- cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")+ go (Pure x) = Pure <$> x+ go (Free fa) = Free <$> bindNValue' transform go fa -nValueToNF- :: (MonadThunk t m (NValue t f m), MonadDataContext f m)- => (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)- -> NValue t f m- -> NValueNF t f m-nValueToNF k = iterNValue k Free+pattern NVThunk t <- Pure t -nValueToNFM- :: (MonadDataContext f m, Monad n)- => (forall x . n x -> m x)- -> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))- -> NValue t f m- -> n (NValueNF t f m)-nValueToNFM transform k = iterNValueM transform k $ pure . Free+nvThunk :: Applicative f => t -> NValue t f m+nvThunk = Pure -pattern NVConstant x <- NValue (extract -> NVConstantF x)-pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))+pattern NVConstant' x <- NValue (extract -> NVConstantF x)+pattern NVConstant x <- Free (NVConstant' x) +nvConstant' :: Applicative f => NAtom -> NValue' t f m r+nvConstant' x = NValue (pure (NVConstantF x)) nvConstant :: Applicative f => NAtom -> NValue t f m-nvConstant x = NValue (pure (NVConstantF x))-nvConstantNF :: Applicative f => NAtom -> NValueNF t f m-nvConstantNF x = Free (NValue (pure (NVConstantF x)))+nvConstant x = Free (NValue (pure (NVConstantF x))) -pattern NVStr ns <- NValue (extract -> NVStrF ns)-pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))+pattern NVStr' ns <- NValue (extract -> NVStrF ns)+pattern NVStr ns <- Free (NVStr' ns) +nvStr' :: Applicative f => NixString -> NValue' t f m r+nvStr' ns = NValue (pure (NVStrF ns)) nvStr :: Applicative f => NixString -> NValue t f m-nvStr ns = NValue (pure (NVStrF ns))-nvStrNF :: Applicative f => NixString -> NValueNF t f m-nvStrNF ns = Free (NValue (pure (NVStrF ns)))+nvStr ns = Free (NValue (pure (NVStrF ns))) -pattern NVPath x <- NValue (extract -> NVPathF x)-pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))+pattern NVPath' x <- NValue (extract -> NVPathF x)+pattern NVPath x <- Free (NVPath' x) +nvPath' :: Applicative f => FilePath -> NValue' t f m r+nvPath' x = NValue (pure (NVPathF x)) nvPath :: Applicative f => FilePath -> NValue t f m-nvPath x = NValue (pure (NVPathF x))-nvPathNF :: Applicative f => FilePath -> NValueNF t f m-nvPathNF x = Free (NValue (pure (NVPathF x)))+nvPath x = Free (NValue (pure (NVPathF x))) -pattern NVList l <- NValue (extract -> NVListF l)-pattern NVListNF l <- Free (NValue (extract -> NVListF l))+pattern NVList' l <- NValue (extract -> NVListF l)+pattern NVList l <- Free (NVList' l) -nvList :: Applicative f => [t] -> NValue t f m-nvList l = NValue (pure (NVListF l))-nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m-nvListNF l = Free (NValue (pure (NVListF l)))+nvList' :: Applicative f => [r] -> NValue' t f m r+nvList' l = NValue (pure (NVListF l))+nvList :: Applicative f => [NValue t f m] -> NValue t f m+nvList l = Free (NValue (pure (NVListF l))) -pattern NVSet s x <- NValue (extract -> NVSetF s x)-pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))+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 t -> HashMap Text SourcePos -> NValue t f m-nvSet s x = NValue (pure (NVSetF s x))-nvSetNF :: Applicative f- => HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m-nvSetNF s x = Free (NValue (pure (NVSetF s x)))+ => HashMap Text (NValue t f m) -> HashMap Text SourcePos -> NValue t f m+nvSet s x = Free (NValue (pure (NVSetF s x))) -pattern NVClosure x f <- NValue (extract -> NVClosureF x f)-pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))+pattern NVClosure' x f <- NValue (extract -> NVClosureF x f)+pattern NVClosure x f <- Free (NVClosure' x f) -nvClosure :: Applicative f- => Params () -> (m (NValue t f m) -> m t) -> NValue t f m-nvClosure x f = NValue (pure (NVClosureF x f))-nvClosureNF :: Applicative f- => Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m-nvClosureNF x f = Free (NValue (pure (NVClosureF 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+nvClosure x f = Free (NValue (pure (NVClosureF x f))) -pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)-pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))+pattern NVBuiltin' name f <- NValue (extract -> NVBuiltinF name f)+pattern NVBuiltin name f <- Free (NVBuiltin' name f) -nvBuiltin :: Applicative f- => String -> (m (NValue t f m) -> m t) -> NValue t f m-nvBuiltin name f = NValue (pure (NVBuiltinF name f))-nvBuiltinNF :: Applicative f- => String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m-nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF 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+nvBuiltin name f =+ Free (NValue (pure (NVBuiltinF name f))) builtin :: forall m f t . (MonadThunk t m (NValue t f m), MonadDataContext f m) => String- -> (m (NValue t f m) -> m (NValue t f m))+ -> (NValue t f m -> m (NValue t f m)) -> m (NValue t f m)-builtin name f = return $ nvBuiltin name $ \a -> thunk $ f a+builtin name f = return $ nvBuiltin name $ \a -> f a builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => String- -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))+ -> (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- -> ( m (NValue t f m)- -> m (NValue t f m)- -> m (NValue t f m)+ -> ( 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 -isClosureNF :: Comonad f => NValueNF t f m -> Bool-isClosureNF NVClosureNF{} = True-isClosureNF _ = False- data TStringContext = NoContext | HasContext deriving Show @@ -453,8 +439,14 @@ 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))) =+ pure $ describeValue $ valueType $ v+ data ValueFrame t f m- = ForcingThunk+ = ForcingThunk t | ConcerningValue (NValue t f m) | Comparison (NValue t f m) (NValue t f m) | Addition (NValue t f m) (NValue t f m)@@ -463,9 +455,10 @@ | Coercion ValueType ValueType | CoercionToJson (NValue t f m) | CoercionFromJson A.Value- | ExpectationNF ValueType (NValueNF t f m) | Expectation ValueType (NValue t f m)- deriving (Show, Typeable)+ deriving Typeable++deriving instance (Comonad f, Show t) => Show (ValueFrame t f m) type MonadDataErrorContext t f m = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
src/Nix/Value/Equal.hs view
@@ -63,17 +63,6 @@ (NVPath _, NVPath _) -> pure () _ -> throwError $ Comparison x y -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 -> return True- _ -> valueEqM lv rv- in case (lv, rv) of- (NVClosure _ _, NVClosure _ _) -> unsafePtrEq- (NVList _ , NVList _ ) -> unsafePtrEq- (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq- _ -> valueEqM lv rv- -- | 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.@@ -164,30 +153,34 @@ $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm valueEqM- :: (MonadThunk t m (NValue t f m), Comonad f)+ :: forall t f m+ . (MonadThunk t m (NValue t f m), Comonad f) => NValue t f m -> NValue t f m -> m Bool-valueEqM (NValue (extract -> x)) (NValue (extract -> y)) = valueFEqM- (compareAttrSetsM f thunkEqM)- thunkEqM- x- y+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 where- f t = force t $ \case+ 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 -valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool-valueNFEq (Pure _) (Pure _) = False-valueNFEq (Pure _) (Free _) = False-valueNFEq (Free _) (Pure _) = False-valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =- valueFEq (compareAttrSets f valueNFEq) valueNFEq x y- where- f (Pure _ ) = Nothing- f (Free (NVStr s)) = Just s- f _ = Nothing+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 -> return True+ _ -> valueEqM lv rv+ in case (lv, rv) of+ (NVClosure _ _, NVClosure _ _) -> unsafePtrEq+ (NVList _ , NVList _ ) -> unsafePtrEq+ (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq+ _ -> valueEqM lv rv instance Eq1 (NValueF p m) where liftEq _ (NVConstantF x) (NVConstantF y) = x == y
+ src/Nix/Value/Monad.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Nix.Value.Monad where++class MonadValue v m where+ defer :: m v -> m v+ demand :: v -> (v -> m r) -> m r+ -- | If 'v' is a thunk, 'inform' allows us to modify the action to be+ -- peformed by the thunk, perhaps by enriching it with scpoe info, for+ -- example.+ inform :: v -> (m v -> m v) -> m v
src/Nix/XML.hs view
@@ -15,12 +15,11 @@ import Nix.Value import Text.XML.Light -toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString-toXML =- runWithStringContext- . fmap pp- . iterNValueNF (const (pure (mkElem "cycle" "value" ""))) phi+toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString+toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi where+ cyc = return $ mkElem "string" "value" "<CYCLE>"+ pp = ("<?xml version='1.0' encoding='utf-8'?>\n" <>) . (<> "\n")@@ -30,17 +29,18 @@ phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element phi = \case- NVConstant a -> case a of+ NVConstant' a -> case a of NInt n -> return $ mkElem "int" "value" (show n) NFloat f -> return $ mkElem "float" "value" (show f) NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false") NNull -> return $ Element (unqual "null") [] [] Nothing - NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str- NVList l -> sequence l+ NVStr' str ->+ mkElem "string" "value" . Text.unpack <$> extractNixString str+ NVList' l -> sequence l >>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing - NVSet s _ -> sequence s >>= \kvs -> return $ Element+ NVSet' s _ -> sequence s >>= \kvs -> return $ Element (unqual "attrs") [] (map@@ -55,11 +55,11 @@ ) Nothing - NVClosure p _ ->+ NVClosure' p _ -> return $ Element (unqual "function") [] (paramsXML p) Nothing- NVPath fp -> return $ mkElem "path" "value" fp- NVBuiltin name _ -> return $ mkElem "function" "name" name- _ -> error "Pattern synonyms mask coverage"+ NVPath' fp -> return $ mkElem "path" "value" fp+ NVBuiltin' name _ -> return $ mkElem "function" "name" name+ _ -> error "Pattern synonyms mask coverage" mkElem :: String -> String -> String -> Element mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing
tests/EvalTests.hs view
@@ -21,8 +21,8 @@ import Data.Text (Text) import Data.Time import Nix+import Nix.Standard import Nix.TH-import Nix.Thunk.Standard import Nix.Value.Equal import qualified System.Directory as D import System.Environment@@ -424,10 +424,10 @@ time <- getCurrentTime let opts = defaultOptions time -- putStrLn =<< lint (stripAnnotation a)- res <- runStandardIO opts $ do+ res <- runWithBasicEffectsIO opts $ do a' <- normalForm =<< nixEvalExprLoc Nothing a b' <- normalForm =<< nixEvalExprLoc Nothing b- return $ valueNFEq a' b'+ valueEqM a' b' assertBool "" res constantEqualText' :: Text -> Text -> Assertion@@ -449,7 +449,7 @@ time <- getCurrentTime let opts = defaultOptions time errored <- catch- (False <$ runStandardIO opts+ (False <$ runWithBasicEffectsIO opts (normalForm =<< nixEvalExprLoc Nothing a')) (\(_ :: NixException) -> pure True) unless errored $
tests/Main.hs view
@@ -21,7 +21,7 @@ import Nix.String import Nix.Options import Nix.Parser-import Nix.Thunk.Standard+import Nix.Standard import Nix.Value import qualified NixLanguageTests import qualified ParserTests@@ -57,7 +57,7 @@ }|]) $ \expr -> do NVStr ns <- do time <- getCurrentTime- runStandardIO (defaultOptions time) $+ runWithBasicEffectsIO (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr let dir = hackyStringIgnoreContext ns exists <- fileExist (unpack dir)
tests/NixLanguageTests.hs view
@@ -70,8 +70,6 @@ [ "eval-okay-path" , "eval-okay-fromTOML" , "eval-okay-context-introspection"- , "eval-okay-concatmap"- , "eval-okay-builtins-add" ] genTests :: IO TestTree
tests/TestCommon.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,7 +13,8 @@ import Data.Time import Nix import Nix.Exec ( )-import Nix.Thunk.Standard+import Nix.Standard+import Nix.Fresh.Basic import System.Environment import System.IO import System.Posix.Files@@ -20,7 +22,7 @@ import System.Process import Test.Tasty.HUnit -hnixEvalFile :: Options -> FilePath -> IO (StandardValueNF IO)+hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT (StdIdT IO))) hnixEvalFile opts file = do parseResult <- parseNixFileLoc file case parseResult of@@ -28,15 +30,17 @@ error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err Success expr -> do setEnv "TEST_VAR" "foo"- runStandardIO opts+ runWithBasicEffects opts $ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr) $ \case NixException frames -> errorWithoutStackTrace . show- =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames+ =<< renderFrames @(StdValue (StandardT (StdIdT IO)))+ @(StdThunk (StandardT (StdIdT IO)))+ frames -hnixEvalText :: Options -> Text -> IO (StandardValueNF IO)+hnixEvalText :: Options -> Text -> IO (StdValue (StandardT (StdIdT IO))) hnixEvalText opts src = case parseNixText src of Failure err -> error@@ -44,7 +48,8 @@ ++ unpack src ++ "`.\n" ++ show err- Success expr -> runStandardIO opts $ normalForm =<< nixEvalExpr Nothing expr+ Success expr ->+ runWithBasicEffects opts $ normalForm =<< nixEvalExpr Nothing expr nixEvalString :: String -> IO String nixEvalString expr = do