diff --git a/hnix.cabal b/hnix.cabal index cfb872f82..873e6c396 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -362,8 +362,9 @@ library Nix.Frames Nix.Fresh Nix.Fresh.Basic + Nix.Fresh.Stable Nix.Json - Nix.Lint + -- Nix.Lint Nix.Normal Nix.Options Nix.Parser @@ -372,12 +373,14 @@ library Nix.Render Nix.Render.Frame Nix.Scope + Nix.Scope.Basic Nix.Standard Nix.String Nix.String.Coerce Nix.TH Nix.Thunk Nix.Thunk.Basic + Nix.Thunk.StableId Nix.Type.Assumption Nix.Type.Env Nix.Type.Infer @@ -406,11 +409,13 @@ library , deepseq >= 1.4.3 && <1.5 , deriving-compat >= 0.3 && < 0.6 , directory >= 1.3.1 && < 1.4 + , exception-transformers >= 0.4 && <0.5 , exceptions >= 0.10.0 && < 0.11 , filepath >= 1.4.2 && < 1.5 , free >= 5.1 && < 5.2 , gitrev >= 1.1.0 && < 1.4 , hashable >= 1.2.5 && < 1.4 + , ghc-prim >= 0.5 && <0.7 , hashing >= 0.1.0 && < 0.2 , hnix-store-core >= 0.4.0 && < 0.5 , hnix-store-remote >= 0.4.0 && < 0.5 diff --git a/main/Main.hs b/main/Main.hs index a3116754c..7c768c0cb 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -26,7 +26,7 @@ import qualified Data.Text.IO as Text import Nix import Nix.Convert import qualified Nix.Eval as Eval -import Nix.Fresh.Basic +import Nix.Fresh.Stable import Nix.Json import Nix.Options.Parser import Nix.Standard @@ -34,6 +34,7 @@ import Nix.Thunk.Basic import qualified Nix.Type.Env as Env import qualified Nix.Type.Infer as HM import Nix.Utils +import Nix.Utils.Fix1 import Nix.Var import Nix.Value.Monad import Options.Applicative hiding ( ParserResult(..) ) @@ -94,8 +95,9 @@ main = do NixException frames -> errorWithoutStackTrace . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) + =<< renderFrames + @(StdValue (StandardT IO)) + @(StdThunk (StandardT IO) IO) frames when (repl opts) $ @@ -138,7 +140,7 @@ main = do where printer | finder opts - = fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) >=> findAttrs + = fromValue @(AttrSet (StdValue (StandardT IO))) >=> findAttrs | xml opts = liftIO . putStrLn @@ -159,17 +161,17 @@ main = do = liftIO . print . prettyNValue <=< removeEffects where findAttrs - :: AttrSet (StdValue (StandardT (StdIdT IO))) - -> StandardT (StdIdT IO) () + :: AttrSet (StdValue (StandardT IO)) + -> StandardT IO () findAttrs = go "" where go prefix s = do xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of Free v -> pure (k, Just (Free v)) - Pure (StdThunk (extract -> Thunk _ _ ref)) -> do + Pure (StdThunk (Thunk _ _ ref)) -> do let path = prefix ++ Text.unpack k (_, descend) = filterEntry path k - val <- readVar @(StandardT (StdIdT IO)) ref + val <- readVar @(StandardT IO) ref case val of Computed _ -> pure (k, Nothing) _ | descend -> (k, ) <$> forceEntry path nv @@ -211,8 +213,9 @@ main = do . (k ++) . (": " ++) . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) + =<< renderFrames + @(StdValue (StandardT IO)) + @(StdThunk (StandardT IO) IO) frames pure Nothing @@ -224,8 +227,8 @@ main = do handleReduced :: (MonadThrow m, MonadIO m) => FilePath - -> (NExprLoc, Either SomeException (NValue t f m)) - -> m (NValue t f m) + -> (NExprLoc, Either SomeException (NValue f m)) + -> m (NValue f m) handleReduced path (expr', eres) = do liftIO $ do putStrLn $ "Wrote winnowed expression tree to " ++ path diff --git a/main/Repl.hs b/main/Repl.hs index a35946d33..129e4f872 100644 --- a/main/Repl.hs +++ b/main/Repl.hs @@ -10,12 +10,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Repl ( main @@ -29,6 +32,8 @@ import Nix.Scope import Nix.Utils import Nix.Value.Monad (demand) +import Control.Comonad +import Data.Functor.Classes import qualified Data.List import qualified Data.Maybe import qualified Data.HashMap.Lazy @@ -64,13 +69,13 @@ import qualified System.Exit import qualified System.IO.Error -- | Repl entry point -main :: (MonadNix e t f m, MonadIO m, MonadMask m) => m () +main :: (MonadNix e f m, MonadIO m, MonadMask m) => m () main = main' Nothing -- | Principled version allowing to pass initial value for context. -- -- Passed value is stored in context with "input" key. -main' :: (MonadNix e t f m, MonadIO m, MonadMask m) => Maybe (NValue t f m) -> m () +main' :: (MonadNix e f m, MonadIO m, MonadMask m) => Maybe (NValue f m) -> m () main' iniVal = initState iniVal >>= \s -> flip evalStateT s $ System.Console.Repline.evalRepl banner @@ -128,11 +133,14 @@ main' iniVal = initState iniVal >>= \s -> flip evalStateT s -- * Types --------------------------------------------------------------------------------- -data IState t f m = IState +data IState f m = IState { replIt :: Maybe NExprLoc -- ^ Last expression entered - , replCtx :: AttrSet (NValue t f m) -- ^ Value environment + , replCtx :: AttrSet (NValue f m) -- ^ Value environment , replCfg :: ReplConfig -- ^ REPL configuration - } deriving (Eq, Show) + } + +deriving instance (Eq1 f, Eq1 m, Eq (Thunk m)) => Eq (IState f m) +deriving instance (Comonad f, Show (Thunk m)) => Show (IState f m) data ReplConfig = ReplConfig { cfgDebug :: Bool @@ -148,7 +156,7 @@ defReplConfig = ReplConfig } -- | Create initial IState for REPL -initState :: MonadNix e t f m => Maybe (NValue t f m) -> m (IState t f m) +initState :: MonadNix e f m => Maybe (NValue f m) -> m (IState f m) initState mIni = do builtins <- evalText "builtins" @@ -164,23 +172,23 @@ initState mIni = do , cfgValues = values opts } where - evalText :: (MonadNix e t f m) => Text -> m (NValue t f m) + evalText :: (MonadNix e f m) => Text -> m (NValue f m) evalText expr = case parseNixTextLoc expr of Failure e -> error $ "Impossible happened: Unable to parse expression - '" ++ Data.Text.unpack expr ++ "' error was " ++ show e Success e -> do evalExprLoc e -type Repl e t f m = HaskelineT (StateT (IState t f m) m) +type Repl e f m = HaskelineT (StateT (IState f m) m) --------------------------------------------------------------------------------- -- * Execution --------------------------------------------------------------------------------- exec - :: forall e t f m - . (MonadNix e t f m, MonadIO m) + :: forall e f m + . (MonadNix e f m, MonadIO m) => Bool -> Text - -> Repl e t f m (Maybe (NValue t f m)) + -> Repl e f m (Maybe (NValue f m)) exec update source = do -- Get the current interpreter state st <- get @@ -206,7 +214,7 @@ exec update source = do case mVal of Left (NixException frames) -> do - lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames + lift $ lift $ liftIO . print =<< renderFrames @(NValue f m) frames pure Nothing Right val -> do -- Update the interpreter state @@ -237,18 +245,18 @@ exec update source = do toAttrSet i = "{" <> i <> (if Data.Text.isSuffixOf ";" i then mempty else ";") <> "}" cmd - :: (MonadNix e t f m, MonadIO m) + :: (MonadNix e f m, MonadIO m) => String - -> Repl e t f m () + -> Repl e f m () cmd source = do mVal <- exec True (Data.Text.pack source) case mVal of Nothing -> pure () Just val -> printValue val -printValue :: (MonadNix e t f m, MonadIO m) - => NValue t f m - -> Repl e t f m () +printValue :: (MonadNix e f m, MonadIO m) + => NValue f m + -> Repl e f m () printValue val = do cfg <- replCfg <$> get lift $ lift $ do @@ -262,9 +270,9 @@ printValue val = do --------------------------------------------------------------------------------- -- :browse command -browse :: (MonadNix e t f m, MonadIO m) +browse :: (MonadNix e f m, MonadIO m) => String - -> Repl e t f m () + -> Repl e f m () browse _ = do st <- get forM_ (Data.HashMap.Lazy.toList $ replCtx st) $ \(k, v) -> do @@ -273,9 +281,9 @@ browse _ = do -- :load command load - :: (MonadNix e t f m, MonadIO m) + :: (MonadNix e f m, MonadIO m) => String - -> Repl e t f m () + -> Repl e f m () load args = do contents <- liftIO $ Data.Text.IO.readFile @@ -286,9 +294,9 @@ load args = do -- :type command typeof - :: (MonadNix e t f m, MonadIO m) + :: (MonadNix e f m, MonadIO m) => String - -> Repl e t f m () + -> Repl e f m () typeof args = do st <- get mVal <- case Data.HashMap.Lazy.lookup line (replCtx st) of @@ -303,11 +311,11 @@ typeof args = do where line = Data.Text.pack args -- :quit command -quit :: (MonadNix e t f m, MonadIO m) => a -> Repl e t f m () +quit :: (MonadNix e f m, MonadIO m) => a -> Repl e f m () quit _ = liftIO System.Exit.exitSuccess -- :set command -setConfig :: (MonadNix e t f m, MonadIO m) => String -> Repl e t f m () +setConfig :: (MonadNix e f m, MonadIO m) => String -> Repl e f m () setConfig args = case words args of [] -> liftIO $ putStrLn "No option to set specified" (x:_xs) -> @@ -326,8 +334,8 @@ defaultMatcher = ] completion - :: (MonadNix e t f m, MonadIO m) - => CompleterStyle (StateT (IState t f m) m) + :: (MonadNix e f m, MonadIO m) + => CompleterStyle (StateT (IState f m) m) completion = System.Console.Repline.Prefix (completeWordWithPrev (Just '\\') separators completeFunc) defaultMatcher @@ -340,15 +348,15 @@ completion = System.Console.Repline.Prefix -- Heavily inspired by Dhall Repl, with `algebraicComplete` -- adjusted to monadic variant able to `demand` thunks. completeFunc - :: forall e t f m . (MonadNix e t f m, MonadIO m) + :: forall e f m . (MonadNix e f m, MonadIO m) => String -> String - -> (StateT (IState t f m) m) [Completion] + -> (StateT (IState f m) m) [Completion] completeFunc reversedPrev word -- Commands | reversedPrev == ":" = pure . listCompletion - $ fmap helpOptionName (helpOptions :: HelpOptions e t f m) + $ fmap helpOptionName (helpOptions :: HelpOptions e f m) -- Files | any (`Data.List.isPrefixOf` word) [ "/", "./", "../", "~/" ] @@ -383,9 +391,9 @@ completeFunc reversedPrev word notFinished x = x { isFinished = False } - algebraicComplete :: (MonadNix e t f m) + algebraicComplete :: (MonadNix e f m) => [Text] - -> NValue t f m + -> NValue f m -> m [Text] algebraicComplete subFields val = let keys = fmap ("." <>) . Data.HashMap.Lazy.keys @@ -407,16 +415,16 @@ completeFunc reversedPrev word -- HelpOption inspired by Dhall Repl -- with `Doc` instead of String for syntax and doc -data HelpOption e t f m = HelpOption +data HelpOption e f m = HelpOption { helpOptionName :: String , helpOptionSyntax :: Doc () , helpOptionDoc :: Doc () - , helpOptionFunction :: Cmd (Repl e t f m) + , helpOptionFunction :: Cmd (Repl e f m) } -type HelpOptions e t f m = [HelpOption e t f m] +type HelpOptions e f m = [HelpOption e f m] -helpOptions :: (MonadNix e t f m, MonadIO m) => HelpOptions e t f m +helpOptions :: (MonadNix e f m, MonadIO m) => HelpOptions e f m helpOptions = [ HelpOption "help" @@ -513,10 +521,10 @@ renderSetOptions so = <> Prettyprinter.line <> Prettyprinter.indent 4 (helpSetOptionDoc h) -help :: (MonadNix e t f m, MonadIO m) - => HelpOptions e t f m +help :: (MonadNix e f m, MonadIO m) + => HelpOptions e f m -> String - -> Repl e t f m () + -> Repl e f m () help hs _ = do liftIO $ putStrLn "Available commands:\n" forM_ hs $ \h -> @@ -532,6 +540,6 @@ help hs _ = do <> Prettyprinter.indent 4 (helpOptionDoc h) options - :: (MonadNix e t f m, MonadIO m) - => System.Console.Repline.Options (Repl e t f m) + :: (MonadNix e f m, MonadIO m) + => System.Console.Repline.Options (Repl e f m) options = (\h -> (helpOptionName h, helpOptionFunction h)) <$> helpOptions diff --git a/src/Nix.hs b/src/Nix.hs index bc94c8e48..226dcdeff 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Nix @@ -58,7 +59,7 @@ import Nix.XML -- type. It sets up the common Nix environment and applies the -- transformations, allowing them to be easily composed. nixEval - :: (MonadNix e t f m, Has e Options, Functor g) + :: (MonadNix e f m, Has e Options, Functor g) => Maybe FilePath -> Transform g (m a) -> Alg g (m a) @@ -68,19 +69,20 @@ nixEval mpath xform alg = withNixContext mpath . adi alg xform -- | Evaluate a nix expression in the default context nixEvalExpr - :: (MonadNix e t f m, Has e Options) + :: forall e f m. + (MonadNix e f m, Has e Options) => Maybe FilePath -> NExpr - -> m (NValue t f m) + -> m (NValue f m) nixEvalExpr mpath = nixEval mpath id Eval.eval -- | Evaluate a nix expression in the default context nixEvalExprLoc - :: forall e t f m - . (MonadNix e t f m, Has e Options) + :: forall e f m + . (MonadNix e f m, Has e Options) => Maybe FilePath -> NExprLoc - -> m (NValue t f m) + -> m (NValue f m) nixEvalExprLoc mpath = nixEval mpath (Eval.addStackFrames . Eval.addSourcePositions) @@ -92,17 +94,17 @@ nixEvalExprLoc mpath = nixEval -- 'MonadNix'). All this function does is provide the right type class -- context. nixTracingEvalExprLoc - :: (MonadNix e t f m, Has e Options, MonadIO m, Alternative m) + :: (MonadNix e f m, Has e Options, MonadIO m, Alternative m) => Maybe FilePath -> NExprLoc - -> m (NValue t f m) + -> m (NValue f m) nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc evaluateExpression - :: (MonadNix e t f m, Has e Options) + :: (MonadNix e f m, Has e Options) => Maybe FilePath - -> (Maybe FilePath -> NExprLoc -> m (NValue t f m)) - -> (NValue t f m -> m a) + -> (Maybe FilePath -> NExprLoc -> m (NValue f m)) + -> (NValue f m -> m a) -> NExprLoc -> m a evaluateExpression mpath evaluator handler expr = do @@ -124,10 +126,10 @@ evaluateExpression mpath evaluator handler expr = do argmap args = nvSet (M.fromList args) mempty processResult - :: forall e t f m a - . (MonadNix e t f m, Has e Options) - => (NValue t f m -> m a) - -> NValue t f m + :: forall e f m a + . (MonadNix e f m, Has e Options) + => (NValue f m -> m a) + -> NValue f m -> m a processResult h val = do opts :: Options <- asks (view hasLens) @@ -135,7 +137,7 @@ processResult h val = do Nothing -> h val Just (Text.splitOn "." -> keys) -> go keys val where - go :: [Text.Text] -> NValue t f m -> m a + go :: [Text.Text] -> NValue f m -> m a go [] v = h v go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case NVList xs -> case ks of diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 48ba12e6b..ed8c60065 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -18,6 +18,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -27,6 +29,7 @@ module Nix.Builtins (withNixContext, builtins) where import Control.Comonad import Control.Monad import Control.Monad.Catch +import Control.Monad.Free import Control.Monad.ListM ( sortByM ) import Control.Monad.Reader ( asks ) import Crypto.Hash @@ -78,6 +81,7 @@ import Nix.Scope import Nix.String hiding (getContext) import qualified Nix.String as NixString import Nix.String.Coerce +import Nix.Thunk import Nix.Utils import Nix.Value import Nix.Value.Equal @@ -94,8 +98,8 @@ import Text.Regex.TDFA -- | Evaluate a nix expression in the default context withNixContext - :: forall e t f m r - . (MonadNix e t f m, Has e Options) + :: forall e f m r + . (MonadNix e f m, Has e Options) => Maybe FilePath -> m r -> m r @@ -115,12 +119,14 @@ withNixContext mpath action = do let ref = nvPath path pushScope (M.singleton "__cur_file" ref) action -builtins :: (MonadNix e t f m, Scoped (NValue t f m) m) - => m (Scopes m (NValue t f m)) +builtins :: (MonadNix e f m, Scoped m (NValue f m) m) + => m (Scopes m (NValue f m)) builtins = do - ref <- defer $ flip nvSet M.empty <$> buildMap - lst <- ([("builtins", ref)] <>) <$> topLevelBuiltins - pushScope (M.fromList lst) currentScopes + rec lst <- pushScope s $ do + ref <- defer $ flip nvSet M.empty <$> buildMap + ([("builtins", ref)] <>) <$> topLevelBuiltins + let s = M.fromList lst + pushScope s currentScopes where buildMap = M.fromList . fmap mapping <$> builtinsList topLevelBuiltins = fmap mapping <$> fullBuiltinsList @@ -137,7 +143,7 @@ data Builtin v = Builtin , mapping :: (Text, v) } -builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] +builtinsList :: forall e f m . MonadNix e f m => m [Builtin (NValue f m)] builtinsList = sequence [ do version <- toValue (makeNixStringWithoutContext "2.3") @@ -193,7 +199,7 @@ builtinsList = sequence , add Normal "getEnv" getEnv_ , add2 Normal "hasAttr" hasAttr , add Normal "hasContext" hasContext - , add' Normal "hashString" (hashString @e @t @f @m) + , add' Normal "hashString" (hashString @e @f @m) , add Normal "head" head_ , add TopLevel "import" import_ , add2 Normal "intersectAttrs" intersectAttrs @@ -267,15 +273,15 @@ builtinsList = sequence add2 t n v = wrap t n <$> mkThunk n (builtin2 (Text.unpack n) v) add3 t n v = wrap t n <$> mkThunk n (builtin3 (Text.unpack n) v) - add' :: forall a. ToBuiltin t f m a - => BuiltinType -> Text -> a -> m (Builtin (NValue t f m)) + add' :: forall a. ToBuiltin f m a + => BuiltinType -> Text -> a -> m (Builtin (NValue f m)) add' t n v = wrap t n <$> mkThunk n (toBuiltin (Text.unpack n) v) -- Primops derivation - :: forall e t f m. (MonadNix e t f m, Scoped (NValue t f m) m) - => m (NValue t f m) + :: forall e f m. (MonadNix e f m, Scoped m (NValue f m) m) + => m (NValue f m) derivation = foldFix Eval.eval $$(do -- This is compiled in so that we only parse it once at compile-time. let Success expr = parseNixText [text| @@ -308,8 +314,8 @@ derivation = foldFix Eval.eval $$(do ) foldNixPath - :: forall e t f m r - . MonadNix e t f m + :: forall e f m r + . MonadNix e f m => (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) -> r -> m r @@ -335,7 +341,7 @@ foldNixPath f z = do [n, p] -> f (Text.unpack p) (Just (Text.unpack n)) ty rest _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " <> show x -nixPath :: MonadNix e t f m => m (NValue t f m) +nixPath :: MonadNix e f m => m (NValue f m) nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest -> pure $ flip nvSet mempty ( M.fromList @@ -354,44 +360,44 @@ nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest -> ) : rest -toString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toString :: MonadNix e f m => NValue f m -> m (NValue f m) toString = coerceToString callFunc DontCopyToStore CoerceAny >=> toValue hasAttr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) hasAttr x y = fromValue x >>= fromStringNoContext >>= \key -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y + fromValue @(AttrSet (NValue f m), AttrSet SourcePos) y >>= \(aset, _) -> toValue $ M.member key aset -attrsetGet :: MonadNix e t f m => Text -> AttrSet (NValue t f m) -> m (NValue t f m) +attrsetGet :: MonadNix e f m => Text -> AttrSet (NValue f m) -> m (NValue f m) attrsetGet k s = case M.lookup k s of Just v -> pure v Nothing -> throwError $ ErrorCall $ "Attribute '" <> Text.unpack k <> "' required" -hasContext :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +hasContext :: MonadNix e f m => NValue f m -> m (NValue f m) hasContext = toValue . stringHasContext <=< fromValue getAttr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) getAttr x y = fromValue x >>= fromStringNoContext >>= \key -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y + fromValue @(AttrSet (NValue f m), AttrSet SourcePos) y >>= \(aset, _) -> attrsetGet key aset unsafeGetAttrPos - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) unsafeGetAttrPos x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVStr ns, NVSet _ apos) -> case M.lookup (stringIgnoreContext ns) apos of @@ -406,14 +412,14 @@ unsafeGetAttrPos x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of -- This function is a bit special in that it doesn't care about the contents -- of the list. length_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -length_ = toValue . (length :: [NValue t f m] -> Int) <=< fromValue + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) +length_ = toValue . (length :: [NValue f m] -> Int) <=< fromValue add_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) add_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x + y :: Integer) (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x + fromInteger y) @@ -422,10 +428,10 @@ add_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (_ , _ ) -> throwError $ Addition x' y' mul_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) mul_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x * y :: Integer) (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x * fromInteger y) @@ -434,10 +440,10 @@ mul_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (_, _) -> throwError $ Multiplication x' y' div_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) div_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue (floor (fromInteger x / fromInteger y :: Double) :: Integer) @@ -455,10 +461,10 @@ anyM p (x : xs) = do if q then pure True else anyM p xs any_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) any_ f = toValue <=< anyM fromValue <=< mapM (f `callFunc`) <=< fromValue allM :: Monad m => (a -> m Bool) -> [a] -> m Bool @@ -468,28 +474,28 @@ allM p (x : xs) = do if q then allM p xs else pure False all_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) all_ f = toValue <=< allM fromValue <=< mapM (f `callFunc`) <=< fromValue foldl'_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) -foldl'_ f z xs = fromValue @[NValue t f m] xs >>= foldM go z + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> NValue f m + -> m (NValue f m) +foldl'_ f z xs = fromValue @[NValue f m] xs >>= foldM go z where go b a = f `callFunc` b >>= (`callFunc` a) -head_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +head_ :: MonadNix e f m => NValue f m -> m (NValue f m) head_ = fromValue >=> \case [] -> throwError $ ErrorCall "builtins.head: empty list" h : _ -> pure h -tail_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +tail_ :: MonadNix e f m => NValue f m -> m (NValue f m) tail_ = fromValue >=> \case [] -> throwError $ ErrorCall "builtins.tail: empty list" _ : t -> pure $ nvList t @@ -534,7 +540,7 @@ splitVersion s = case Text.uncons s of x -> VersionComponent_String x in thisComponent : splitVersion rest -splitVersion_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +splitVersion_ :: MonadNix e f m => NValue f m -> m (NValue f m) splitVersion_ = fromValue >=> fromStringNoContext >=> \s -> pure $ nvList @@ -551,10 +557,10 @@ compareVersions s1 s2 = mconcat f = uncurry compare . fromThese z z compareVersions_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) compareVersions_ t1 t2 = fromValue t1 >>= fromStringNoContext >>= \s1 -> fromValue t2 >>= fromStringNoContext >>= \s2 -> pure $ nvConstant $ NInt $ case compareVersions s1 s2 of @@ -582,10 +588,10 @@ splitDrvName s = (Text.intercalate sep namePieces, Text.intercalate sep versionPieces) parseDrvName - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do let (name :: Text, version :: Text) = splitDrvName s - toValue @(AttrSet (NValue t f m)) $ M.fromList + toValue @(AttrSet (NValue f m)) $ M.fromList [ ( "name" :: Text , nvStr $ makeNixStringWithoutContext name ) @@ -595,11 +601,11 @@ parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do ] match_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) match_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> fromValue str >>= \ns -> do -- NOTE: Currently prim_match in nix/src/libexpr/primops.cc ignores the @@ -621,11 +627,11 @@ match_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> _ -> pure $ nvConstant NNull split_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) split_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> fromValue str >>= \ns -> do -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the @@ -640,12 +646,12 @@ split_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> haystack splitMatches - :: forall e t f m - . MonadNix e t f m + :: forall e f m + . MonadNix e f m => Int -> [[(ByteString, (Int, Int))]] -> ByteString - -> [NValue t f m] + -> [NValue f m] splitMatches _ [] haystack = [thunkStr haystack] splitMatches _ ([] : _) _ = error "Error in splitMatches: this should never happen!" @@ -659,10 +665,10 @@ splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = caps = nvList (fmap f captures) f (a, (s, _)) = if s < 0 then nvConstant NNull else thunkStr a -thunkStr :: Applicative f => ByteString -> NValue t f m +thunkStr :: Applicative f => ByteString -> NValue f m thunkStr s = nvStr (makeNixStringWithoutContext (decodeUtf8 s)) -substring :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString +substring :: forall e f m. MonadNix e f m => Int -> Int -> NixString -> Prim m NixString substring start len str = Prim $ if start < 0 then throwError $ ErrorCall $ "builtins.substring: negative start position: " <> show start @@ -672,9 +678,9 @@ substring start len str = Prim $ take = if len < 0 then id else Text.take len attrNames - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) attrNames = - fromValue @(AttrSet (NValue t f m)) + fromValue @(AttrSet (NValue f m)) >=> fmap getDeeper . toValue . fmap makeNixStringWithoutContext @@ -682,108 +688,108 @@ attrNames = . M.keys attrValues - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) attrValues = - fromValue @(AttrSet (NValue t f m)) + fromValue @(AttrSet (NValue f m)) >=> toValue . fmap snd - . sortOn (fst @Text @(NValue t f m)) + . sortOn (fst @Text @(NValue f m)) . M.toList map_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) map_ f = toValue <=< traverse - ( defer @(NValue t f m) + ( defer @(NValue f m) . withFrame Debug (ErrorCall "While applying f in map:\n") . (f `callFunc`) ) - <=< fromValue @[NValue t f m] + <=< fromValue @[NValue f m] mapAttrs_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mapAttrs_ f xs = fromValue @(AttrSet (NValue t f m)) xs >>= \aset -> do + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) +mapAttrs_ f xs = fromValue @(AttrSet (NValue f m)) xs >>= \aset -> do let pairs = M.toList aset values <- for pairs $ \(key, value) -> - defer @(NValue t f m) + defer @(NValue f m) $ withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $ callFunc ?? value =<< callFunc f (nvStr (makeNixStringWithoutContext key)) toValue . M.fromList . zip (fmap fst pairs) $ values filter_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) filter_ f = toValue <=< filterM (fromValue <=< callFunc f) <=< fromValue catAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) catAttrs attrName xs = fromValue attrName >>= fromStringNoContext >>= \n -> - fromValue @[NValue t f m] xs >>= \l -> + fromValue @[NValue f m] xs >>= \l -> fmap (nvList . catMaybes) $ forM l $ fmap (M.lookup n) . flip demand fromValue -baseNameOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +baseNameOf :: MonadNix e f m => NValue f m -> m (NValue f m) baseNameOf x = do ns <- coerceToString callFunc DontCopyToStore CoerceStringy x pure $ nvStr (modifyNixContents (Text.pack . takeFileName . Text.unpack) ns) bitAnd - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) bitAnd x y = fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .&. b) bitOr - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) bitOr x y = fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a .|. b) bitXor - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) bitXor x y = fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a `xor` b) builtinsBuiltin - :: forall e t f m - . MonadNix e t f m - => m (NValue t f m) + :: forall e f m + . MonadNix e f m + => m (NValue f m) builtinsBuiltin = (throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred") -dirOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +dirOf :: MonadNix e f m => NValue f m -> m (NValue f m) dirOf x = demand x $ \case NVStr ns -> pure $ nvStr (modifyNixContents (Text.pack . takeDirectory . Text.unpack) ns) @@ -793,33 +799,33 @@ dirOf x = demand x $ \case -- jww (2018-04-28): This should only be a string argument, and not coerced? unsafeDiscardStringContext - :: MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: MonadNix e f m => NValue f m -> m (NValue f m) unsafeDiscardStringContext mnv = do ns <- fromValue mnv toValue $ makeNixStringWithoutContext $ stringIgnoreContext ns seq_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) seq_ a b = demand a $ \_ -> pure b -- | We evaluate 'a' only for its effects, so data cycles are ignored. deepSeq - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) deepSeq a b = b <$ normalForm_ a elem_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) elem_ x = toValue <=< anyM (valueEqM x) <=< fromValue elemAt :: [a] -> Int -> Maybe a @@ -828,10 +834,10 @@ elemAt ls i = case drop i ls of a : _ -> Just a elemAt_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' -> case elemAt xs' n' of Just a -> pure a @@ -844,11 +850,11 @@ elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' -> <> show (length xs') genList - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) genList f = fromValue @Integer >=> \n -> if n >= 0 then toValue =<< forM [0 .. n - 1] (\i -> defer $ (f `callFunc`) =<< toValue i) else @@ -858,9 +864,9 @@ genList f = fromValue @Integer >=> \n -> if n >= 0 <> show n -- We wrap values solely to provide an Ord instance for genericClosure -newtype WValue t f m = WValue (NValue t f m) +newtype WValue f m = WValue (NValue f m) -instance Comonad f => Eq (WValue t f m) where +instance Comonad f => Eq (WValue f m) where WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = x == fromInteger y WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = @@ -872,7 +878,7 @@ instance Comonad f => Eq (WValue t f m) where stringIgnoreContext x == stringIgnoreContext y _ == _ = False -instance Comonad f => Ord (WValue t f m) where +instance Comonad f => Ord (WValue f m) where WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = x <= fromInteger y WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = @@ -885,8 +891,8 @@ instance Comonad f => Ord (WValue t f m) where _ <= _ = False genericClosure - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -genericClosure = fromValue @(AttrSet (NValue t f m)) >=> \s -> + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) +genericClosure = fromValue @(AttrSet (NValue f m)) >=> \s -> case (M.lookup "startSet" s, M.lookup "operator" s) of (Nothing, Nothing) -> throwError @@ -902,33 +908,33 @@ genericClosure = fromValue @(AttrSet (NValue t f m)) >=> \s -> $ ErrorCall $ "builtins.genericClosure: Attribute 'operator' required" (Just startSet, Just operator) -> - demand startSet $ fromValue @[NValue t f m] >=> \ss -> - demand operator $ \op -> toValue @[NValue t f m] =<< snd <$> go op ss S.empty + demand startSet $ fromValue @[NValue f m] >=> \ss -> + demand operator $ \op -> toValue @[NValue f m] =<< snd <$> go op ss S.empty where go - :: NValue t f m - -> [NValue t f m] - -> Set (WValue t f m) - -> m (Set (WValue t f m), [NValue t f m]) + :: NValue f m + -> [NValue f m] + -> Set (WValue f m) + -> m (Set (WValue f m), [NValue f m]) go _ [] ks = pure (ks, []) - go op (t : ts) ks = demand t $ \v -> fromValue @(AttrSet (NValue t f m)) v >>= \s -> do + go op (t : ts) ks = demand t $ \v -> fromValue @(AttrSet (NValue f m)) v >>= \s -> do k <- attrsetGet "key" s demand k $ \k' -> do if S.member (WValue k') ks then go op ts ks else do - ys <- fromValue @[NValue t f m] =<< (op `callFunc` v) + ys <- fromValue @[NValue f m] =<< (op `callFunc` v) case S.toList ks of [] -> checkComparable k' k' WValue j : _ -> checkComparable k' j fmap (t :) <$> go op (ts <> ys) (S.insert (WValue k') ks) replaceStrings - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> NValue f m + -> m (NValue f m) replaceStrings tfrom tto ts = fromValue (Deeper tfrom) >>= \(nsFrom :: [NixString]) -> fromValue (Deeper tto) >>= \(nsTo :: [NixString]) -> fromValue ts >>= \(ns :: NixString) -> do @@ -975,33 +981,33 @@ replaceStrings tfrom tto ts = fromValue (Deeper tfrom) >>= \(nsFrom :: [NixStrin $ NixString.getContext ns removeAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) removeAttrs set = fromValue . Deeper >=> \(nsToRemove :: [NixString]) -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set >>= \(m, p) -> do + fromValue @(AttrSet (NValue f m), AttrSet SourcePos) set >>= \(m, p) -> do toRemove <- mapM fromStringNoContext nsToRemove toValue (go m toRemove, go p toRemove) where go = foldl' (flip M.delete) intersectAttrs - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) intersectAttrs set1 set2 = - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 >>= \(s1, p1) -> - fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 >>= \(s2, p2) -> + fromValue @(AttrSet (NValue f m), AttrSet SourcePos) set1 >>= \(s1, p1) -> + fromValue @(AttrSet (NValue f m), AttrSet SourcePos) set2 >>= \(s2, p2) -> pure $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) functionArgs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) functionArgs fun = demand fun $ \case NVClosure p _ -> - toValue @(AttrSet (NValue t f m)) $ nvConstant . NBool <$> case p of + toValue @(AttrSet (NValue f m)) $ nvConstant . NBool <$> case p of Param name -> M.singleton name False ParamSet s _ _ -> isJust <$> M.fromList s v -> @@ -1011,10 +1017,10 @@ functionArgs fun = demand fun $ \case <> show v toFile - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) toFile name s = do name' <- fromStringNoContext =<< fromValue name s' <- fromValue s @@ -1024,10 +1030,10 @@ toFile name s = do sc = StringContext t DirectPath toValue $ makeNixStringWithSingletonContext t sc -toPath :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toPath :: MonadNix e f m => NValue f m -> m (NValue f m) toPath = fromValue @Path >=> toValue @Path -pathExists_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +pathExists_ :: MonadNix e f m => NValue f m -> m (NValue f m) pathExists_ path = demand path $ \case NVPath p -> toValue =<< pathExists p NVStr ns -> toValue =<< pathExists (Text.unpack (stringIgnoreContext ns)) @@ -1038,67 +1044,67 @@ pathExists_ path = demand path $ \case <> show v hasKind - :: forall a e t f m - . (MonadNix e t f m, FromValue a m (NValue t f m)) - => NValue t f m - -> m (NValue t f m) + :: forall a e f m + . (MonadNix e f m, FromValue a m (NValue f m)) + => NValue f m + -> m (NValue f m) hasKind = fromValueMay >=> toValue . \case Just (_ :: a) -> True _ -> False isAttrs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isAttrs = hasKind @(AttrSet (NValue t f m)) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) +isAttrs = hasKind @(AttrSet (NValue f m)) isList - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isList = hasKind @[NValue t f m] + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) +isList = hasKind @[NValue f m] isInt - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) isInt = hasKind @Int isFloat - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) isFloat = hasKind @Float isBool - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) isBool = hasKind @Bool isNull - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) isNull = hasKind @() -- isString cannot use `hasKind` because it coerces derivations to strings. -isString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isString :: MonadNix e f m => NValue f m -> m (NValue f m) isString v = demand v $ \case NVStr{} -> toValue True _ -> toValue False -isFunction :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isFunction :: MonadNix e f m => NValue f m -> m (NValue f m) isFunction func = demand func $ \case NVClosure{} -> toValue True _ -> toValue False -throw_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +throw_ :: MonadNix e f m => NValue f m -> m (NValue f m) throw_ mnv = do ns <- coerceToString callFunc CopyToStore CoerceStringy mnv throwError . ErrorCall . Text.unpack $ stringIgnoreContext ns import_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) import_ = scopedImport (nvSet M.empty M.empty) scopedImport - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -scopedImport asetArg pathArg = fromValue @(AttrSet (NValue t f m)) asetArg >>= \s -> + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) +scopedImport asetArg pathArg = fromValue @(AttrSet (NValue f m)) asetArg >>= \s -> fromValue pathArg >>= \(Path p) -> do - path <- pathToDefaultNix @t @f @m p + path <- pathToDefaultNix @f @m p mres <- lookupVar "__cur_file" path' <- case mres of Nothing -> do @@ -1107,21 +1113,21 @@ scopedImport asetArg pathArg = fromValue @(AttrSet (NValue t f m)) asetArg >>= \ Just p -> demand p $ fromValue >=> \(Path p') -> do traceM $ "Current file being evaluated is: " <> show p' pure $ takeDirectory p' path - clearScopes @(NValue t f m) + clearScopes $ withNixContext (Just path') $ pushScope s - $ importPath @t @f @m path' + $ importPath @f @m path' -getEnv_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +getEnv_ :: MonadNix e f m => NValue f m -> m (NValue f m) getEnv_ = fromValue >=> fromStringNoContext >=> \s -> do mres <- getEnvVar (Text.unpack s) toValue $ makeNixStringWithoutContext $ maybe "" Text.pack mres sort_ - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) sort_ comp = fromValue >=> sortByM (cmp comp) >=> toValue where cmp f a b = do @@ -1135,10 +1141,10 @@ sort_ comp = fromValue >=> sortByM (cmp comp) >=> toValue False -> EQ lessThan - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) lessThan ta tb = demand ta $ \va -> demand tb $ \vb -> do let badType = throwError @@ -1160,34 +1166,34 @@ lessThan ta tb = demand ta $ \va -> demand tb $ \vb -> do _ -> badType concatLists - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) concatLists = - fromValue @[NValue t f m] - >=> mapM (flip demand $ fromValue @[NValue t f m] >=> pure) + fromValue @[NValue f m] + >=> mapM (flip demand $ fromValue @[NValue 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) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) concatMap_ f = - fromValue @[NValue t f m] + fromValue @[NValue f m] >=> traverse applyFunc >=> toValue . concat where - applyFunc :: NValue t f m -> m [NValue t f m] + applyFunc :: NValue f m -> m [NValue f m] applyFunc = (f `callFunc`) >=> fromValue listToAttrs - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -listToAttrs = fromValue @[NValue t f m] >=> \l -> + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) +listToAttrs = fromValue @[NValue f m] >=> \l -> fmap (flip nvSet M.empty . M.fromList . reverse) $ forM l $ flip demand - $ fromValue @(AttrSet (NValue t f m)) + $ fromValue @(AttrSet (NValue f m)) >=> \s -> do t <- attrsetGet "name" s demand t $ fromValue >=> \n -> do @@ -1200,7 +1206,7 @@ listToAttrs = fromValue @[NValue t f m] >=> \l -> -- propagate context from the s arg -- | The result coming out of hashString is base16 encoded hashString - :: forall e t f m. MonadNix e t f m => NixString -> NixString -> Prim m NixString + :: forall e f m. MonadNix e f m => NixString -> NixString -> Prim m NixString hashString nsAlgo ns = Prim $ do algo <- fromStringNoContext nsAlgo let f g = pure $ modifyNixContents g ns @@ -1224,7 +1230,7 @@ hashString nsAlgo ns = Prim $ do <> "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " <> show algo -placeHolder :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +placeHolder :: MonadNix e f m => NValue f m -> m (NValue f m) placeHolder = fromValue >=> fromStringNoContext >=> \t -> do h <- runPrim (hashString (makeNixStringWithoutContext "sha256") @@ -1245,7 +1251,7 @@ placeHolder = fromValue >=> fromStringNoContext >=> \t -> do where text h = encodeUtf8 $ stringIgnoreContext h -absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m FilePath +absolutePathFromValue :: MonadNix e f m => NValue f m -> m FilePath absolutePathFromValue = \case NVStr ns -> do let path = Text.unpack $ stringIgnoreContext ns @@ -1259,20 +1265,20 @@ absolutePathFromValue = \case NVPath path -> pure path v -> throwError $ ErrorCall $ "expected a path, got " <> show v -readFile_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +readFile_ :: MonadNix e f m => NValue f m -> m (NValue f m) readFile_ path = demand path $ absolutePathFromValue >=> Nix.Render.readFile >=> toValue findFile_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) findFile_ aset filePath = demand aset $ \aset' -> demand filePath $ \filePath' -> case (aset', filePath') of (NVList x, NVStr ns) -> do - mres <- findPath @t @f @m x (Text.unpack (stringIgnoreContext ns)) + mres <- findPath @f @m x (Text.unpack (stringIgnoreContext ns)) pure $ nvPath mres (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " <> show y @@ -1288,7 +1294,7 @@ data FileType | FileTypeUnknown deriving (Show, Read, Eq, Ord) -instance Convertible e t f m => ToValue FileType m (NValue t f m) where +instance (Convertible e t f m, t ~ Thunk m) => ToValue FileType m (Free (NValue' f m) t) where toValue = toValue . makeNixStringWithoutContext . \case FileTypeRegular -> "regular" :: Text FileTypeDirectory -> "directory" @@ -1296,7 +1302,7 @@ instance Convertible e t f m => ToValue FileType m (NValue t f m) where FileTypeUnknown -> "unknown" readDir_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) readDir_ p = demand p $ \path' -> do path <- absolutePathFromValue path' items <- listDirectory path @@ -1311,7 +1317,7 @@ readDir_ p = demand p $ \path' -> do getDeeper <$> toValue (M.fromList itemsWithTypes) fromJSON - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) fromJSON arg = demand arg $ fromValue >=> fromStringNoContext >=> \encoded -> case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of Left jsonError -> @@ -1328,13 +1334,13 @@ fromJSON arg = demand arg $ fromValue >=> fromStringNoContext >=> \encoded -> A.Bool b -> pure $ nvConstant $ NBool b A.Null -> pure $ nvConstant NNull -prim_toJSON :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +prim_toJSON :: MonadNix e f m => NValue f m -> m (NValue f m) prim_toJSON x = demand x $ fmap nvStr . nvalueToJSONNixString -toXML_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toXML_ :: MonadNix e f m => NValue f m -> m (NValue f m) toXML_ v = demand v $ fmap (nvStr . toXML) . normalForm -typeOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +typeOf :: MonadNix e f m => NValue f m -> m (NValue f m) typeOf v = demand v $ toValue . makeNixStringWithoutContext . \case NVConstant a -> case a of NURI _ -> "string" @@ -1351,26 +1357,26 @@ typeOf v = demand v $ toValue . makeNixStringWithoutContext . \case _ -> error "Pattern synonyms obscure complete patterns" tryEval - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) tryEval e = catch (demand e (pure . onSuccess)) (pure . onError) where onSuccess v = flip nvSet M.empty $ M.fromList [("success", nvConstant (NBool True)), ("value", v)] - onError :: SomeException -> NValue t f m + onError :: SomeException -> NValue f m onError _ = flip nvSet M.empty $ M.fromList [ ("success", nvConstant (NBool False)) , ("value" , nvConstant (NBool False)) ] trace_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) trace_ msg action = do - traceEffect @t @f @m + traceEffect @f @m . Text.unpack . stringIgnoreContext =<< fromValue msg @@ -1378,17 +1384,17 @@ trace_ msg action = do -- TODO: remember error context addErrorContext - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) addErrorContext _ action = pure action exec_ - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) exec_ xs = do - ls <- fromValue @[NValue t f m] xs + ls <- fromValue @[NValue 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 @@ -1396,7 +1402,7 @@ exec_ xs = do exec (fmap (Text.unpack . stringIgnoreContext) xs) fetchurl - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) fetchurl v = demand v $ \case NVSet s _ -> attrsetGet "url" s >>= demand ?? go (M.lookup "sha256" s) v@NVStr{} -> go Nothing v @@ -1406,7 +1412,7 @@ fetchurl v = demand v $ \case $ "builtins.fetchurl: Expected URI or set, got " <> show v where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) + go :: Maybe (NValue f m) -> NValue f m -> m (NValue f m) go _msha = \case NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha Left e -> throwError e @@ -1423,53 +1429,53 @@ fetchurl v = demand v $ \case Just t -> pure t partition_ - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -partition_ f = fromValue @[NValue t f m] >=> \l -> do + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) +partition_ f = fromValue @[NValue f m] >=> \l -> do let match t = f `callFunc` t >>= fmap (, t) . fromValue selection <- traverse match l let (right, wrong) = partition fst selection let makeSide = nvList . fmap snd - toValue @(AttrSet (NValue t f m)) + toValue @(AttrSet (NValue f m)) $ M.fromList [("right", makeSide right), ("wrong", makeSide wrong)] -currentSystem :: MonadNix e t f m => m (NValue t f m) +currentSystem :: MonadNix e f m => m (NValue f m) currentSystem = do os <- getCurrentSystemOS arch <- getCurrentSystemArch pure $ nvStr $ makeNixStringWithoutContext (arch <> "-" <> os) -currentTime_ :: MonadNix e t f m => m (NValue t f m) +currentTime_ :: MonadNix e f m => m (NValue f m) currentTime_ = do opts :: Options <- asks (view hasLens) toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) -derivationStrict_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +derivationStrict_ :: MonadNix e f m => NValue f m -> m (NValue f m) derivationStrict_ = derivationStrict -getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) +getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue f m) getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize getContext - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) getContext x = demand x $ \case (NVStr ns) -> do let context = getNixLikeContext $ toNixLikeContext $ NixString.getContext ns - valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context + valued :: M.HashMap Text (NValue f m) <- sequenceA $ M.map toValue context pure $ nvSet valued M.empty x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x appendContext - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of (NVStr ns, NVSet attrs _) -> do newContextValues <- forM attrs $ \attr -> demand attr $ \case @@ -1512,17 +1518,17 @@ appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of newtype Prim m a = Prim { runPrim :: m a } -- | Types that support conversion to nix in a particular monad -class ToBuiltin t f m a | a -> m where - toBuiltin :: String -> a -> m (NValue t f m) +class ToBuiltin f m a | a -> m where + toBuiltin :: String -> a -> m (NValue f m) -instance (MonadNix e t f m, ToValue a m (NValue t f m)) - => ToBuiltin t f m (Prim m a) where +instance (MonadNix e f m, ToValue a m (NValue f m)) + => ToBuiltin f m (Prim m a) where toBuiltin _ p = toValue =<< runPrim p -instance ( MonadNix e t f m - , FromValue a m (Deeper (NValue t f m)) - , ToBuiltin t f m b +instance ( MonadNix e f m + , FromValue a m (Deeper (NValue f m)) + , ToBuiltin f m b ) - => ToBuiltin t f m (a -> b) where + => ToBuiltin f m (a -> b) where toBuiltin name f = pure $ nvBuiltin name (fromValue . Deeper >=> toBuiltin name . f) diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs index 90855df83..3f4860293 100644 --- a/src/Nix/Cited.hs +++ b/src/Nix/Cited.hs @@ -18,7 +18,7 @@ import Lens.Family2.TH import Nix.Expr.Types.Annotated import Nix.Scope -import Nix.Value ( NValue, NValue'(NValue) ) +import Nix.Value import Control.Monad.Free ( Free(Pure, Free) ) data Provenance m v = Provenance @@ -51,6 +51,7 @@ instance ComonadEnv [Provenance m v] (NCited m v) where $(makeLenses ''Provenance) $(makeLenses ''NCited) + class HasCitations m v a where citations :: a -> [Provenance m v] addProvenance :: Provenance m v -> a -> a @@ -59,17 +60,18 @@ instance HasCitations m v (NCited m v a) where citations = _provenance addProvenance x (NCited p v) = NCited (x : p) v + class HasCitations1 m v f where citations1 :: f a -> [Provenance m v] addProvenance1 :: Provenance m v -> f a -> f a instance HasCitations1 m v f - => HasCitations m v (NValue' t f m a) where + => HasCitations m v (NValue' 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 + => HasCitations m v (Free (NValue' f m) t) where citations (Pure t) = citations t citations (Free v) = citations v addProvenance x (Pure t) = Pure (addProvenance x t) diff --git a/src/Nix/Cited/Basic.hs b/src/Nix/Cited/Basic.hs index 91569d345..17def4b4e 100644 --- a/src/Nix/Cited/Basic.hs +++ b/src/Nix/Cited/Basic.hs @@ -5,29 +5,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} module Nix.Cited.Basic where import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) -import Control.Monad.Catch hiding ( catchJust ) -import Control.Monad.Reader -import Data.Fix +import Control.Monad.Free import GHC.Generics import Nix.Cited -import Nix.Eval as Eval -import Nix.Exec -import Nix.Expr import Nix.Frames -import Nix.Options import Nix.Thunk -import Nix.Utils import Nix.Value -newtype Cited t f m a = Cited { getCited :: NCited m (NValue t f m) a } +newtype CitedT (f :: * -> *) m a = CitedT { unCitedT :: m a } + +newtype Cited f m a = Cited { getCited :: NCited m (NValue f m) a } deriving ( Generic , Typeable @@ -36,25 +31,29 @@ newtype Cited t f m a = Cited { getCited :: NCited m (NValue t f m) a } , Foldable , Traversable , Comonad - , ComonadEnv [Provenance m (NValue t f m)] ) -instance HasCitations1 m (NValue t f m) (Cited t f m) where +deriving instance t ~ Thunk m => ComonadEnv [Provenance m (Free (NValue' f m) t)] (Cited f m) + +instance t ~ Thunk m => HasCitations1 m (Free (NValue' f m) t) (Cited f m) where citations1 (Cited c) = citations c addProvenance1 x (Cited c) = Cited (addProvenance x c) +{- instance ( Has e Options , Framed e m - , MonadThunk t m v + , MonadThunk m , Typeable m , Typeable f - , Typeable u , MonadCatch m ) - => MonadThunk (Cited u f m t) m v where + => MonadThunk (CitedT f m) where + type Thunk (CitedT f m) = Cited f m (Thunk m) + type ThunkValue (CitedT f m) = ThunkValue m thunk mv = do opts :: Options <- asks (view hasLens) + --TODO: Can we handle `thunks opts == false` by not using CitedT at all? if thunks opts then do frames :: Frames <- asks (view hasLens) @@ -69,11 +68,9 @@ instance ( Has e Options go _ = [] ps = concatMap (go . frame) frames - fmap (Cited . NCited ps) . thunk $ mv + lift $ fmap (Cited . NCited ps) . thunk $ mv else fmap (Cited . NCited []) . thunk $ mv - thunkId (Cited (NCited _ t)) = thunkId @_ @m t - queryM (Cited (NCited _ t)) = queryM t -- | The ThunkLoop exception is thrown as an exception with MonadThrow, @@ -98,3 +95,4 @@ instance ( Has e Options withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f) further (Cited (NCited ps t)) f = Cited . NCited ps <$> further t f +-} diff --git a/src/Nix/Context.hs b/src/Nix/Context.hs index 5d14677e2..70e2bd4c1 100644 --- a/src/Nix/Context.hs +++ b/src/Nix/Context.hs @@ -5,31 +5,27 @@ module Nix.Context where import Nix.Options -import Nix.Scope import Nix.Frames import Nix.Utils import Nix.Expr.Types.Annotated ( SrcSpan , nullSpan ) -data Context m t = Context - { scopes :: Scopes m t - , source :: SrcSpan - , frames :: Frames - , options :: Options +data Context = Context + { source :: SrcSpan -- Should we capture? + , frames :: Frames -- Don't capture (should change) + , options :: Options -- Don't capture (never changes) } -instance Has (Context m t) (Scopes m t) where - hasLens f a = (\x -> a { scopes = x }) <$> f (scopes a) -instance Has (Context m t) SrcSpan where +instance Has Context SrcSpan where hasLens f a = (\x -> a { source = x }) <$> f (source a) -instance Has (Context m t) Frames where +instance Has Context Frames where hasLens f a = (\x -> a { frames = x }) <$> f (frames a) -instance Has (Context m t) Options where +instance Has Context Options where hasLens f a = (\x -> a { options = x }) <$> f (options a) -newContext :: Options -> Context m t -newContext = Context emptyScopes nullSpan [] +newContext :: Options -> Context +newContext = Context nullSpan [] diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index 7fe84cfac..60f819ffa 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -69,13 +69,13 @@ class FromValue a m v where fromValueMay :: v -> m (Maybe a) type Convertible e t f m - = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) + = (Framed e m, MonadDataErrorContext f m, MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m) instance ( Convertible e t f m - , MonadValue (NValue t f m) m - , FromValue a m (NValue' t f m (NValue t f m)) + , MonadValue (NValue f m) m + , FromValue a m (NValue' f m (NValue f m)) ) - => FromValue a m (NValue t f m) where + => FromValue a m (Free (NValue' f m) t) where fromValueMay = flip demand $ \case Pure t -> force t fromValueMay Free v -> fromValueMay v @@ -84,10 +84,10 @@ instance ( Convertible e t f m Free v -> fromValue 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))) + , MonadValue (NValue f m) m + , FromValue a m (Deeper (NValue' f m (NValue f m))) ) - => FromValue a m (Deeper (NValue t f m)) where + => FromValue a m (Deeper (Free (NValue' f m) t)) where fromValueMay (Deeper v) = demand v $ \case Pure t -> force t (fromValueMay . Deeper) Free v -> fromValueMay (Deeper v) @@ -96,56 +96,56 @@ instance ( Convertible e t f m Free v -> fromValue (Deeper v) instance Convertible e t f m - => FromValue () m (NValue' t f m (NValue t f m)) where + => FromValue () m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVConstant' NNull -> pure $ Just () _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TNull (Free v) + _ -> throwError $ Expectation @f @m TNull (Free v) instance Convertible e t f m - => FromValue Bool m (NValue' t f m (NValue t f m)) where + => FromValue Bool m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVConstant' (NBool b) -> pure $ Just b _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TBool (Free v) + _ -> throwError $ Expectation @f @m TBool (Free v) instance Convertible e t f m - => FromValue Int m (NValue' t f m (NValue t f m)) where + => FromValue Int m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVConstant' (NInt b) -> pure $ Just (fromInteger b) _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TInt (Free v) + _ -> throwError $ Expectation @f @m TInt (Free v) instance Convertible e t f m - => FromValue Integer m (NValue' t f m (NValue t f m)) where + => FromValue Integer m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVConstant' (NInt b) -> pure $ Just b _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TInt (Free v) + _ -> throwError $ Expectation @f @m TInt (Free v) instance Convertible e t f m - => FromValue Float m (NValue' t f m (NValue t f m)) where + => FromValue Float m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVConstant' (NFloat b) -> pure $ Just b NVConstant' (NInt i) -> pure $ Just (fromInteger i) _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TFloat (Free v) + _ -> throwError $ Expectation @f @m TFloat (Free v) instance ( Convertible e t f m - , MonadValue (NValue t f m) m - , MonadEffects t f m + , MonadValue (NValue f m) m + , MonadEffects f m ) - => FromValue NixString m (NValue' t f m (NValue t f m)) where + => FromValue NixString m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVStr' ns -> pure $ Just ns NVPath' p -> @@ -160,24 +160,24 @@ instance ( Convertible e t f m _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) + _ -> throwError $ Expectation @f @m (TString NoContext) (Free v) instance Convertible e t f m - => FromValue ByteString m (NValue' t f m (NValue t f m)) where + => FromValue ByteString m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVStr' ns -> pure $ encodeUtf8 <$> getStringNoContext ns _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v) + _ -> throwError $ Expectation @f @m (TString NoContext) (Free v) newtype Path = Path { getPath :: FilePath } deriving Show instance ( Convertible e t f m - , MonadValue (NValue t f m) m + , MonadValue (NValue f m) m ) - => FromValue Path m (NValue' t f m (NValue t f m)) where + => FromValue Path m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVPath' p -> pure $ Just (Path p) NVStr' ns -> pure $ Path . Text.unpack <$> getStringNoContext ns @@ -187,75 +187,75 @@ instance ( Convertible e t f m _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TPath (Free v) + _ -> throwError $ Expectation @f @m TPath (Free v) instance Convertible e t f m - => FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where + => FromValue [Free (NValue' f m) t] m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVList' l -> pure $ Just l _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TList (Free v) + _ -> throwError $ Expectation @f @m TList (Free v) instance ( Convertible e t f m - , FromValue a m (NValue t f m) + , FromValue a m (NValue f m) ) - => FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where + => FromValue [a] m (Deeper (NValue' f m (Free (NValue' f m) t))) where fromValueMay = \case Deeper (NVList' l) -> sequence <$> traverse fromValueMay l _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TList (Free (getDeeper v)) + _ -> throwError $ Expectation @f @m TList (Free (getDeeper v)) instance Convertible e t f m - => FromValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where + => FromValue (AttrSet (Free (NValue' f m) t)) m (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVSet' s _ -> pure $ Just s _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free v) + _ -> throwError $ Expectation @f @m TSet (Free v) instance ( Convertible e t f m - , FromValue a m (NValue t f m) + , FromValue a m (NValue f m) ) - => FromValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where + => FromValue (AttrSet a) m (Deeper (NValue' f m (Free (NValue' f m) t))) where fromValueMay = \case Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) + _ -> throwError $ Expectation @f @m TSet (Free (getDeeper v)) instance Convertible e t f m - => FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m - (NValue' t f m (NValue t f m)) where + => FromValue (AttrSet (Free (NValue' f m) t), AttrSet SourcePos) m + (NValue' f m (Free (NValue' f m) t)) where fromValueMay = \case NVSet' s p -> pure $ Just (s, p) _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free v) + _ -> throwError $ Expectation @f @m TSet (Free v) instance ( Convertible e t f m - , FromValue a m (NValue t f m) + , FromValue a m (NValue f m) ) => FromValue (AttrSet a, AttrSet SourcePos) m - (Deeper (NValue' t f m (NValue t f m))) where + (Deeper (NValue' f m (Free (NValue' f m) t))) where fromValueMay = \case Deeper (NVSet' s p) -> fmap (, p) . sequence <$> traverse fromValueMay s _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v)) + _ -> throwError $ Expectation @f @m TSet (Free (getDeeper v)) -- 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 (NValue' f m (NValue f m)) ) - => FromValue a m (Deeper (NValue' t f m (NValue t f m))) where + => FromValue a m (Deeper (NValue' f m (Free (NValue' f m) t))) where fromValueMay = fromValueMay . getDeeper fromValue = fromValue . getDeeper @@ -266,55 +266,55 @@ instance ( Convertible e t f m class ToValue a m v where toValue :: a -> m v -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 +instance (Convertible e t f m, ToValue a m (NValue' f m (NValue f m))) + => ToValue a m (Free (NValue' f m) t) where toValue = fmap Free . toValue instance ( Convertible e t f m - , ToValue a m (Deeper (NValue' t f m (NValue t f m))) + , ToValue a m (Deeper (NValue' f m (NValue f m))) ) - => ToValue a m (Deeper (NValue t f m)) where + => ToValue a m (Deeper (Free (NValue' f m) t)) where toValue = fmap (fmap Free) . toValue instance Convertible e t f m - => ToValue () m (NValue' t f m (NValue t f m)) where + => ToValue () m (NValue' f m (Free (NValue' f m) t)) where toValue _ = pure . nvConstant' $ NNull instance Convertible e t f m - => ToValue Bool m (NValue' t f m (NValue t f m)) where + => ToValue Bool m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvConstant' . NBool instance Convertible e t f m - => ToValue Int m (NValue' t f m (NValue t f m)) where + => ToValue Int m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvConstant' . NInt . toInteger instance Convertible e t f m - => ToValue Integer m (NValue' t f m (NValue t f m)) where + => ToValue Integer m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvConstant' . NInt instance Convertible e t f m - => ToValue Float m (NValue' t f m (NValue t f m)) where + => ToValue Float m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvConstant' . NFloat instance Convertible e t f m - => ToValue NixString m (NValue' t f m (NValue t f m)) where + => ToValue NixString m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvStr' instance Convertible e t f m - => ToValue ByteString m (NValue' t f m (NValue t f m)) where + => ToValue ByteString m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvStr' . makeNixStringWithoutContext . decodeUtf8 instance Convertible e t f m - => ToValue Path m (NValue' t f m (NValue t f m)) where + => ToValue Path m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvPath' . getPath instance Convertible e t f m - => ToValue StorePath m (NValue' t f m (NValue t f m)) where + => ToValue StorePath m (NValue' f m (Free (NValue' f m) t)) where toValue = toValue . Path . unStorePath instance ( Convertible e t f m ) - => ToValue SourcePos m (NValue' t f m (NValue t f m)) where + => ToValue SourcePos m (NValue' f m (Free (NValue' f m) t)) where toValue (SourcePos f l c) = do f' <- toValue (makeNixStringWithoutContext (Text.pack f)) l' <- toValue (unPos l) @@ -324,33 +324,33 @@ instance ( Convertible e t f m -- | With 'ToValue', we can always act recursively instance Convertible e t f m - => ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where + => ToValue [Free (NValue' f m) t] m (NValue' f m (Free (NValue' f m) t)) where toValue = pure . nvList' -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 +instance (Convertible e t f m, ToValue a m (NValue f m)) + => ToValue [a] m (Deeper (NValue' f m (Free (NValue' f m) t))) where toValue = fmap (Deeper . nvList') . traverse toValue instance Convertible e t f m - => ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where + => ToValue (AttrSet (Free (NValue' f m) t)) m (NValue' f m (Free (NValue' f m) t)) where toValue s = pure $ nvSet' s mempty -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 +instance (Convertible e t f m, ToValue a m (NValue f m)) + => ToValue (AttrSet a) m (Deeper (NValue' f m (Free (NValue' f m) t))) where toValue s = (Deeper .) . nvSet' <$> traverse toValue s <*> pure mempty 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 (AttrSet (Free (NValue' f m) t), AttrSet SourcePos) m + (NValue' f m (Free (NValue' f m) t)) where toValue (s, p) = pure $ nvSet' s p -instance (Convertible e t f m, ToValue a m (NValue t f m)) +instance (Convertible e t f m, ToValue a m (NValue f m)) => ToValue (AttrSet a, AttrSet SourcePos) m - (Deeper (NValue' t f m (NValue t f m))) where + (Deeper (NValue' f m (Free (NValue' f m) t))) where toValue (s, p) = (Deeper .) . nvSet' <$> traverse toValue s <*> pure p instance Convertible e t f m - => ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where + => ToValue NixLikeContextValue m (NValue' f m (Free (NValue' f m) t)) where toValue nlcv = do path <- if nlcvPath nlcv then Just <$> toValue True else pure Nothing allOutputs <- if nlcvAllOutputs nlcv @@ -359,7 +359,7 @@ instance Convertible e t f m outputs <- do let outputs = makeNixStringWithoutContext <$> nlcvOutputs nlcv - ts :: [NValue t f m] <- traverse toValue outputs + ts :: [NValue f m] <- traverse toValue outputs case ts of [] -> pure Nothing _ -> Just <$> toValue ts @@ -369,8 +369,8 @@ instance Convertible e t f m , ("outputs",) <$> outputs ] -instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where +instance Convertible e t f m => ToValue () m (NExprF (Free (NValue' f m) t)) where toValue _ = pure . NConstant $ NNull -instance Convertible e t f m => ToValue Bool m (NExprF (NValue t f m)) where +instance Convertible e t f m => ToValue Bool m (NExprF (Free (NValue' f m) t)) where toValue = pure . NConstant . NBool diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs index b44d914b3..51a45de81 100644 --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -24,6 +24,8 @@ import Prelude hiding ( putStr ) import qualified Prelude +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State import Control.Monad.Trans import qualified Data.HashSet as HS import Data.Text ( Text ) @@ -37,6 +39,7 @@ import Nix.Expr import Nix.Frames hiding ( Proxy ) import Nix.Parser import Nix.Render +import Nix.Scope.Basic import Nix.Utils import Nix.Value import qualified Paths_hnix @@ -61,25 +64,22 @@ class (MonadFile m, MonadPaths m, MonadInstantiate m, MonadExec m, - MonadIntrospect m) => MonadEffects t f m where + MonadIntrospect m) => MonadEffects f m where -- | 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 :: [NValue t f m] -> FilePath -> m FilePath + findPath :: [NValue f m] -> FilePath -> m FilePath - importPath :: FilePath -> m (NValue t f m) + importPath :: FilePath -> m (NValue f m) pathToDefaultNix :: FilePath -> m FilePath - derivationStrict :: NValue t f m -> m (NValue t f m) + derivationStrict :: NValue f m -> m (NValue f m) traceEffect :: String -> m () -instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where - addToStore a b c d = lift $ addToStore a b c d - addTextToStore' a b c d = lift $ addTextToStore' a b c d class Monad m => MonadIntrospect m where recursiveSize :: a -> m Word @@ -298,7 +298,11 @@ addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False --- All of the following type classes defer to the underlying 'm'. +-- | All of the following type classes defer to the underlying 'm'. + +instance MonadStore m => MonadStore (ReaderT r m) +deriving instance MonadStore m => MonadStore (ScopeT binding r m) +instance MonadStore m => MonadStore (StateT s m) deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t) deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t) @@ -308,10 +312,11 @@ deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t) deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t) deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t) -deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m) -deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m) deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m) -deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m) -deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m) deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m) +deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m) +deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m) deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m) +deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m) +deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m) +deriving instance MonadStore (t (Fix1T t m) m) => MonadStore (Fix1T t m) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index b647e9260..d5273af56 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -42,7 +43,7 @@ import GHC.DataSize #endif #endif -defaultMakeAbsolutePath :: MonadNix e t f m => FilePath -> m FilePath +defaultMakeAbsolutePath :: MonadNix e f m => FilePath -> m FilePath defaultMakeAbsolutePath origPath = do origPathExpanded <- expandHomePath origPath absPath <- if isAbsolute origPathExpanded @@ -88,32 +89,32 @@ x y | isAbsolute y || "." `isPrefixOf` y = x y joinPath $ head [ xs <> drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ] -defaultFindEnvPath :: MonadNix e t f m => String -> m FilePath +defaultFindEnvPath :: MonadNix e f m => String -> m FilePath defaultFindEnvPath = findEnvPathM -findEnvPathM :: forall e t f m . MonadNix e t f m => FilePath -> m FilePath +findEnvPathM :: forall e f m . MonadNix e 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]) -> + Just x -> demand x $ fromValue >=> \(l :: [NValue f m]) -> findPathBy nixFilePath l name where - nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + nixFilePath :: MonadEffects f m => FilePath -> m (Maybe FilePath) nixFilePath path = do - absPath <- makeAbsolutePath @t @f path + absPath <- makeAbsolutePath @f path isDir <- doesDirectoryExist absPath absFile <- if isDir - then makeAbsolutePath @t @f $ absPath "default.nix" + then makeAbsolutePath @f $ absPath "default.nix" else return absPath exists <- doesFileExist absFile pure $ if exists then Just absFile else Nothing findPathBy - :: forall e t f m - . MonadNix e t f m + :: forall e f m + . MonadNix e f m => (FilePath -> m (Maybe FilePath)) - -> [NValue t f m] + -> [NValue f m] -> FilePath -> m FilePath findPathBy finder ls name = do @@ -128,10 +129,10 @@ findPathBy finder ls name = do <> " (add it's using $NIX_PATH or -I)" Just path -> pure path where - go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath) + go :: Maybe FilePath -> NValue f m -> m (Maybe FilePath) go p@(Just _) _ = pure p go Nothing l = - demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do + demand l $ fromValue >=> \(s :: HashMap Text (NValue f m)) -> do p <- resolvePath s demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of Nothing -> tryPath path Nothing @@ -159,7 +160,7 @@ findPathBy finder ls name = do <> show s fetchTarball - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e f m . MonadNix e f m => NValue f m -> m (NValue f m) fetchTarball = flip demand $ \case NVSet s _ -> case M.lookup "url" s of Nothing -> @@ -172,7 +173,7 @@ fetchTarball = flip demand $ \case $ "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 :: Maybe (NValue f m) -> NValue f m -> m (NValue f m) go msha = \case NVStr ns -> fetch (stringIgnoreContext ns) msha v -> @@ -182,7 +183,7 @@ fetchTarball = flip demand $ \case <> 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 :: Text -> Maybe (NThunk m) -> m (NValue f m) fetch uri msha = case takeExtension (Text.unpack uri) of ".tgz" -> undefined ".gz" -> undefined @@ -193,7 +194,7 @@ fetchTarball = flip demand $ \case <> ext <> "'" -} - fetch :: Text -> Maybe (NValue t f m) -> m (NValue t f m) + fetch :: Text -> Maybe (NValue f m) -> m (NValue f m) fetch uri Nothing = nixInstantiateExpr $ "builtins.fetchTarball \"" <> Text.unpack uri <> "\"" fetch url (Just t) = demand t $ fromValue >=> \nsSha -> @@ -207,27 +208,27 @@ fetchTarball = flip demand $ \case <> Text.unpack sha <> "\"; }" -defaultFindPath :: MonadNix e t f m => [NValue t f m] -> FilePath -> m FilePath +defaultFindPath :: MonadNix e f m => [NValue f m] -> FilePath -> m FilePath defaultFindPath = findPathM findPathM - :: forall e t f m - . MonadNix e t f m - => [NValue t f m] + :: forall e f m + . MonadNix e f m + => [NValue f m] -> FilePath -> m FilePath findPathM = findPathBy existingPath where - existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + existingPath :: MonadEffects f m => FilePath -> m (Maybe FilePath) existingPath path = do - apath <- makeAbsolutePath @t @f path + apath <- makeAbsolutePath @f path exists <- doesPathExist apath pure $ if exists then Just apath else Nothing defaultImportPath - :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m) + :: (MonadNix e f m, MonadState (HashMap FilePath NExprLoc, b) m) => FilePath - -> m (NValue t f m) + -> m (NValue f m) defaultImportPath path = do traceM $ "Importing file " <> path withFrame Info (ErrorCall $ "While importing file " <> show path) $ do @@ -245,7 +246,7 @@ defaultImportPath path = do modify (\(a, b) -> (M.insert path expr a, b)) pure expr -defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath +defaultPathToDefaultNix :: MonadNix e f m => FilePath -> m FilePath defaultPathToDefaultNix = pathToDefaultNixFile -- Given a path, determine the nix file to load diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs index 7d7b234f6..66977b16e 100644 --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -5,9 +5,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - +{-# LANGUAGE TypeFamilies #-} + module Nix.Effects.Derivation ( defaultDerivationStrict ) where @@ -15,6 +15,7 @@ import Prelude hiding ( readFile ) import Control.Arrow ( first, second ) import Control.Monad ( (>=>), forM, when ) +import Control.Monad.Catch import Control.Monad.Writer ( join, lift ) import Control.Monad.State ( MonadState, gets, modify ) @@ -102,7 +103,7 @@ writeDerivation (drv@Derivation {inputs, name}) = do -- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash. -- this avoids propagating changes to their .drv when the output hash stays the same. -hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256) +hashDerivationModulo :: (MonadNix e f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256) hashDerivationModulo (Derivation { mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)), outputs, @@ -226,8 +227,8 @@ derivationParser = do _ -> (Nothing, Flat) -defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m) -defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do +defaultDerivationStrict :: forall e f m b. (MonadNix e f m, MonadState (b, MS.HashMap Text Text) m) => NValue f m -> m (NValue f m) +defaultDerivationStrict = fromValue @(AttrSet (NValue f m)) >=> \s -> do (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s drvName <- makeStorePathName $ name drv let inputs = toStorePaths ctx @@ -288,10 +289,10 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do -- | Build a derivation in a context collecting string contexts. -- This is complex from a typing standpoint, but it allows to perform the -- full computation without worrying too much about all the string's contexts. -buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => AttrSet (NValue t f m) -> WithStringContextT m Derivation +buildDerivationWithContext :: forall e f m. (MonadNix e f m) => AttrSet (NValue f m) -> WithStringContextT m Derivation buildDerivationWithContext drvAttrs = do -- Parse name first, so we can add an informative frame - drvName <- getAttr "name" $ extractNixString >=> assertDrvStoreName + drvName <- getAttr "name" $ extractNixString >=> assertDrvStoreName withFrame' Info (ErrorCall $ "While evaluating derivation " <> show drvName) $ do useJson <- getAttrOr "__structuredAttrs" False $ return @@ -338,10 +339,10 @@ buildDerivationWithContext drvAttrs = do where -- common functions, lifted to WithStringContextT - demand' :: NValue t f m -> (NValue t f m -> WithStringContextT m a) -> WithStringContextT m a + demand' :: NValue f m -> (NValue f m -> WithStringContextT m a) -> WithStringContextT m a demand' v f = join $ lift $ demand v (return . f) - fromValue' :: (FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) => NValue t f m -> WithStringContextT m a + fromValue' :: (FromValue a m (NValue' f m (NValue f m)), MonadNix e f m) => NValue f m -> WithStringContextT m a fromValue' = lift . fromValue withFrame' :: (Framed e m, Exception s) => NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a @@ -349,20 +350,22 @@ buildDerivationWithContext drvAttrs = do -- shortcuts to get the (forced) value of an AttrSet field - getAttrOr' :: forall v a. (MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) + getAttrOr' :: forall v a. (MonadNix e f m, FromValue v m (NValue' f m (NValue f m))) => Text -> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a getAttrOr' n d f = case M.lookup n drvAttrs of Nothing -> lift d Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" <> show n <> "'") $ fromValue' v >>= f + getAttrOr :: forall v a. (MonadNix e f m, FromValue v m (NValue' f m (NValue f m))) + => Text -> a -> (v -> WithStringContextT m a) -> WithStringContextT m a getAttrOr n d f = getAttrOr' n (return d) f getAttr n = getAttrOr' n (throwError $ ErrorCall $ "Required attribute '" <> show n <> "' not found.") -- Test validity for fields - assertDrvStoreName :: MonadNix e t f m => Text -> WithStringContextT m Text + assertDrvStoreName :: MonadNix e f m => Text -> WithStringContextT m Text assertDrvStoreName name = lift $ do let invalid c = not $ isAscii c && (isAlphaNum c || c `elem` ("+-._?=" :: String)) -- isAlphaNum allows non-ascii chars. let failWith reason = throwError $ ErrorCall $ "Store name " <> show name <> " " <> reason @@ -372,17 +375,17 @@ buildDerivationWithContext drvAttrs = do when (".drv" `Text.isSuffixOf` name) $ failWith "is not allowed to end in '.drv'" return name - extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text + extractNoCtx :: MonadNix e f m => NixString -> WithStringContextT m Text extractNoCtx ns = case getStringNoContext ns of Nothing -> lift $ throwError $ ErrorCall $ "The string " <> show ns <> " is not allowed to have a context." Just v -> return v - assertNonNull :: MonadNix e t f m => Text -> WithStringContextT m Text + assertNonNull :: MonadNix e f m => Text -> WithStringContextT m Text assertNonNull t = do when (Text.null t) $ lift $ throwError $ ErrorCall "Value must not be empty" return t - parseHashMode :: MonadNix e t f m => Text -> WithStringContextT m HashMode + parseHashMode :: MonadNix e f m => Text -> WithStringContextT m HashMode parseHashMode = \case "flat" -> return Flat "recursive" -> return Recursive diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index f445724c0..8f5aaeb1a 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -80,7 +81,7 @@ class (Show v, Monad m) => MonadEval v m where type MonadNixEval v m = ( MonadEval v m - , Scoped v m + , Scoped m v m , MonadValue v m , MonadFix m , ToValue Bool m v @@ -126,8 +127,8 @@ eval (NEnvPath p ) = evalEnvPath p eval (NUnary op arg ) = evalUnary op =<< arg eval (NBinary NApp fun arg) = do - scope <- currentScopes :: m (Scopes m v) - fun >>= (`evalApp` withScopes scope arg) + argD <- defer arg + fun >>= (`evalApp` pure argD) eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg @@ -137,8 +138,7 @@ eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight eval (NList l ) = do - scope <- currentScopes - for l (defer @v @m . withScopes @v scope) >>= toValue + for l defer >>= toValue eval (NSet NNonRecursive binds) = evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue @@ -174,8 +174,7 @@ evalWithAttrSet aset body = do -- 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 + s <- defer aset let s' = demand s $ fmap fst . fromValue @(AttrSet v, AttrSet SourcePos) pushWeakScope s' body @@ -244,8 +243,8 @@ evalBinds -> [Binding (m v)] -> m (AttrSet v, AttrSet SourcePos) evalBinds recursive binds = do - scope <- currentScopes :: m (Scopes m v) - buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) + rec result <- buildResult . concat =<< mapM (go $ fst result) (moveOverridesLast binds) + pure result where moveOverridesLast = uncurry (<>) . partition (\case @@ -253,7 +252,7 @@ evalBinds recursive binds = do _ -> True ) - go :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] + go :: AttrSet 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? @@ -282,35 +281,36 @@ evalBinds recursive binds = do ([], _, _) -> [] result -> [result] - go scope (Inherit ms names pos) = + go scope (Inherit ms names pos) = do fmap catMaybes $ forM names $ evalSetterKeyName >=> \case Nothing -> pure Nothing - Just key -> pure $ Just - ( [key] - , pos - , do + Just key -> do + x <- defer $ do mv <- case ms of - Nothing -> withScopes scope $ lookupVar key + Nothing -> lookupVar key Just s -> - s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(s, _) -> - clearScopes @v $ pushScope s $ lookupVar key + -- The inherit source expression is evaluated in the recursive context + -- if this is a recursive record + pushScope scope s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(s, _) -> + lookupVarScopes key (Scopes [Scope s] []) case mv of Nothing -> attrMissing (key :| []) Nothing Just v -> demand v pure - ) + pure $ Just + ( [key] + , pos + , pure x + ) buildResult - :: Scopes m v - -> [([Text], SourcePos, m v)] + :: [([Text], SourcePos, m v)] -> m (AttrSet v, AttrSet SourcePos) - buildResult scope bindings = do + buildResult bindings = do (s, p) <- foldM insert (M.empty, M.empty) bindings - res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s - pure (res, p) + res <- if recursive then loebM (encapsulate <$> s) else traverse defer s + return (res, p) where - mkThunk = defer . withScopes scope - - encapsulate f attrs = mkThunk . pushScope attrs $ f + encapsulate f attrs = defer . pushScope attrs $ f insert (m, p) (path, pos, value) = attrSetAlter path pos m p value @@ -376,27 +376,26 @@ assembleString = \case buildArgument :: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v) buildArgument params arg = do - scope <- currentScopes :: m (Scopes m v) + argD <- defer arg case params of - Param name -> M.singleton name <$> defer (withScopes scope arg) + Param name -> pure $ M.singleton name argD ParamSet s isVariadic m -> arg >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(args, _) -> do let inject = case m of Nothing -> id - Just n -> M.insert n $ const $ defer (withScopes scope arg) + Just n -> M.insert n $ const $ pure argD loebM - (inject $ M.mapMaybe id $ ialignWith (assemble scope isVariadic) + (inject $ M.mapMaybe id $ ialignWith (assemble isVariadic) args (M.fromList s) ) where assemble - :: Scopes m v - -> Bool + :: Bool -> Text -> These v (Maybe (m v)) -> Maybe (AttrSet v -> m v) - assemble scope isVariadic k = \case + assemble isVariadic k = \case That Nothing -> Just $ const @@ -405,7 +404,7 @@ buildArgument params arg = do $ "Missing value for parameter: " <> show k That (Just f) -> - Just $ \args -> defer $ withScopes scope $ pushScope args f + Just $ \args -> defer $ pushScope args f This _ | isVariadic -> Nothing @@ -425,7 +424,7 @@ addSourcePositions f v@(Fix (Compose (Ann ann _))) = addStackFrames :: forall v e m a - . (Scoped v m, Framed e m, Typeable v, Typeable m) + . (Scoped m v m, Framed e m, Typeable v, Typeable m) => Transform NExprLocF (m a) addStackFrames f v = do scopes <- currentScopes :: m (Scopes m v) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index f3417347f..6b90696d8 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -10,6 +10,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -27,9 +28,11 @@ import Prelude hiding ( putStr ) import Control.Applicative +import Control.Comonad import Control.Monad import Control.Monad.Catch hiding ( catchJust ) import Control.Monad.Fix +import Control.Monad.Free import Control.Monad.Reader import Data.Fix import qualified Data.HashMap.Lazy as M @@ -67,86 +70,88 @@ import GHC.DataSize #endif #endif -type MonadCited t f m - = ( HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f +type MonadCited f m + = ( HasCitations m (NValue f m) (Thunk m) + , HasCitations1 m (NValue f m) f , MonadDataContext f m ) nvConstantP - :: MonadCited t f m => Provenance m (NValue t f m) -> NAtom -> NValue t f m + :: MonadCited f m => Provenance m (NValue f m) -> NAtom -> NValue f m nvConstantP p x = addProvenance p (nvConstant x) nvStrP - :: MonadCited t f m - => Provenance m (NValue t f m) + :: MonadCited f m + => Provenance m (NValue f m) -> NixString - -> NValue t f m + -> NValue f m nvStrP p ns = addProvenance p (nvStr ns) nvPathP - :: MonadCited t f m => Provenance m (NValue t f m) -> FilePath -> NValue t f m + :: MonadCited f m => Provenance m (NValue f m) -> FilePath -> NValue f m nvPathP p x = addProvenance p (nvPath x) nvListP - :: MonadCited t f m - => Provenance m (NValue t f m) - -> [NValue t f m] - -> NValue t f m + :: MonadCited f m + => Provenance m (NValue f m) + -> [NValue f m] + -> NValue f m nvListP p l = addProvenance p (nvList l) nvSetP - :: MonadCited t f m - => Provenance m (NValue t f m) - -> AttrSet (NValue t f m) + :: MonadCited f m + => Provenance m (NValue f m) + -> AttrSet (NValue f m) -> AttrSet SourcePos - -> NValue t f m + -> NValue f m nvSetP p s x = addProvenance p (nvSet s x) nvClosureP - :: MonadCited t f m - => Provenance m (NValue t f m) + :: MonadCited f m + => Provenance m (NValue f m) -> Params () - -> (NValue t f m -> m (NValue t f m)) - -> NValue t f m + -> (NValue f m -> m (NValue f m)) + -> NValue f m nvClosureP p x f = addProvenance p (nvClosure x f) nvBuiltinP - :: MonadCited t f m - => Provenance m (NValue t f m) + :: MonadCited f m + => Provenance m (NValue f m) -> String - -> (NValue t f m -> m (NValue t f m)) - -> NValue t f m + -> (NValue f m -> m (NValue f m)) + -> NValue 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 - , HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f + = ( MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m + , MonadDataErrorContext f m + , HasCitations m (NValue f m) t + , HasCitations1 m (NValue f m) f ) -type MonadNix e t f m +type MonadNix e f m = ( Has e SrcSpan , Has e Options - , Scoped (NValue t f m) m + , Scoped m (NValue f m) m , Framed e m , MonadFix m , MonadCatch m , MonadThrow m , Alternative m - , MonadEffects t f m - , MonadCitedThunks t f m - , MonadValue (NValue t f m) m + , MonadEffects f m + , MonadCitedThunks (Thunk m) f m + , MonadValue (NValue f m) m ) -data ExecFrame t f m = Assertion SrcSpan (NValue t f m) - deriving (Show, Typeable) +data ExecFrame f m = Assertion SrcSpan (NValue f m) + deriving (Typeable) -instance MonadDataErrorContext t f m => Exception (ExecFrame t f m) +deriving instance (Show (Thunk m), Comonad f) => Show (ExecFrame f m) -nverr :: forall e t f s m a . (MonadNix e t f m, Exception s) => s -> m a -nverr = evalError @(NValue t f m) +instance MonadDataErrorContext f m => Exception (ExecFrame f m) + +nverr :: forall e f s m a . (MonadNix e f m, Exception s) => s -> m a +nverr = evalError @(NValue f m) currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan currentPos = asks (view hasLens) @@ -154,11 +159,9 @@ currentPos = asks (view hasLens) wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc wrapExprLoc span x = Fix (Fix (NSym_ span "") <$ x) --- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class. --- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`. -instance MonadNix e t f m => MonadEval (NValue t f m) m where +instance (MonadNix e f m, t ~ Thunk m) => MonadEval (Free (NValue' f m) t) m where freeVariable var = - nverr @e @t @f + nverr @e @f $ ErrorCall $ "Undefined variable '" <> Text.unpack var @@ -167,19 +170,19 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where synHole name = do span <- currentPos scope <- currentScopes - evalError @(NValue t f m) $ SynHole $ SynHoleInfo + evalError @(Free (NValue' f m) t) $ SynHole $ SynHoleInfo { _synHoleInfo_expr = Fix $ NSynHole_ span name , _synHoleInfo_scope = scope } attrMissing ks Nothing = - evalError @(NValue t f m) + evalError @(Free (NValue' f m) t) $ ErrorCall $ "Inheriting unknown attribute: " <> intercalate "." (fmap Text.unpack (NE.toList ks)) attrMissing ks (Just s) = - evalError @(NValue t f m) + evalError @(Free (NValue' f m) t) $ ErrorCall $ "Could not look up attribute " <> intercalate "." (fmap Text.unpack (NE.toList ks)) @@ -189,14 +192,14 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where evalCurPos = do scope <- currentScopes span@(SrcSpan delta _) <- currentPos - addProvenance @_ @_ @(NValue t f m) + addProvenance (Provenance scope (NSym_ span "__curPos")) <$> toValue delta evaledSym name val = do scope <- currentScopes span <- currentPos - pure $ addProvenance @_ @_ @(NValue t f m) + pure $ addProvenance @_ @_ @(Free (NValue' f m) t) (Provenance scope (NSym_ span name)) val @@ -221,12 +224,12 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where scope <- currentScopes span <- currentPos nvPathP (Provenance scope (NLiteralPath_ span p)) - <$> makeAbsolutePath @t @f @m p + <$> makeAbsolutePath @f @m p evalEnvPath p = do scope <- currentScopes span <- currentPos - nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath @t @f @m p + nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath @f @m p evalUnary op arg = do scope <- currentScopes @@ -289,11 +292,11 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where infixl 1 `callFunc` callFunc - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) + :: forall e f m + . MonadNix e f m + => NValue f m + -> NValue f m + -> m (NValue f m) callFunc fun arg = demand fun $ \fun' -> do frames :: Frames <- asks (view hasLens) when (length frames > 2000) $ throwError $ ErrorCall @@ -303,18 +306,18 @@ callFunc fun arg = demand fun $ \fun' -> do f arg NVBuiltin name f -> do span <- currentPos - withFrame Info (Calling @m @(NValue t f m) name span) (f arg) + withFrame Info (Calling @m @(Thunk m) name span) (f arg) s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do demand f $ (`callFunc` s) >=> (`callFunc` arg) x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x execUnaryOp - :: (Framed e m, MonadCited t f m, Show t) - => Scopes m (NValue t f m) + :: (Framed e m, MonadCited f m, Show (Thunk m)) + => Scopes m (NValue f m) -> SrcSpan -> NUnaryOp - -> NValue t f m - -> m (NValue t f m) + -> NValue f m + -> m (NValue f m) execUnaryOp scope span op arg = do case arg of NVConstant c -> case (op, c) of @@ -336,14 +339,14 @@ execUnaryOp scope span op arg = do unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg))) execBinaryOp - :: forall e t f m - . (MonadNix e t f m, MonadEval (NValue t f m) m) - => Scopes m (NValue t f m) + :: forall e f m + . (MonadNix e f m, MonadEval (NValue f m) m) + => Scopes m (NValue f m) -> SrcSpan -> NBinaryOp - -> NValue t f m - -> m (NValue t f m) - -> m (NValue t f m) + -> NValue f m + -> m (NValue f m) + -> m (NValue f m) execBinaryOp scope span op lval rarg = case op of NEq -> rarg >>= \rval -> valueEqM lval rval >>= boolOp rval @@ -363,7 +366,7 @@ execBinaryOp scope span op lval rarg = case op of execBinaryOpForced scope span op lval' rval' where - toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) + toBoolOp :: Maybe (NValue f m) -> Bool -> m (NValue f m) toBoolOp r b = pure $ nvConstantP (Provenance scope (NBinary_ span op (Just lval) r)) (NBool b) @@ -372,14 +375,14 @@ execBinaryOp scope span op lval rarg = case op of execBinaryOpForced - :: forall e t f m - . (MonadNix e t f m, MonadEval (NValue t f m) m) - => Scopes m (NValue t f m) + :: forall e f m + . (MonadNix e f m, MonadEval (NValue f m) m) + => Scopes m (NValue f m) -> SrcSpan -> NBinaryOp - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) + -> NValue f m + -> NValue f m + -> m (NValue f m) execBinaryOpForced scope span op lval rval = case op of NLt -> compare (<) @@ -407,11 +410,11 @@ execBinaryOpForced scope span op lval rval = case op of (\rs2 -> nvStrP prov (ls `mappend` rs2)) <$> coerceToString callFunc CopyToStore CoerceStringy rs (NVPath ls, NVStr rs) -> case getStringNoContext rs of - Just rs2 -> nvPathP prov <$> makeAbsolutePath @t @f (ls `mappend` Text.unpack rs2) + Just rs2 -> nvPathP prov <$> makeAbsolutePath @f (ls `mappend` Text.unpack rs2) Nothing -> throwError $ ErrorCall $ -- data/nix/src/libexpr/eval.cc:1412 "A string that refers to a store path cannot be appended to a path." - (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs) + (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @f (ls <> rs) (ls@NVSet{}, NVStr rs) -> (\ls2 -> nvStrP prov (ls2 `mappend` rs)) @@ -429,11 +432,11 @@ execBinaryOpForced scope span op lval rval = case op of NApp -> throwError $ ErrorCall $ "NApp should be handled by evalApp" where - prov :: Provenance m (NValue t f m) + prov :: Provenance m (NValue f m) prov = Provenance scope (NBinary_ span op (Just lval) (Just rval)) toBool = pure . nvConstantP prov . NBool - compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m) + compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue f m) compare op = case (lval, rval) of (NVConstant l, NVConstant r) -> toBool $ l `op` r (NVStr l, NVStr r) -> toBool $ l `op` r @@ -442,13 +445,13 @@ execBinaryOpForced scope span op lval rval = case op of toInt = pure . nvConstantP prov . NInt toFloat = pure . nvConstantP prov . NFloat - numBinOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m) + numBinOp :: (forall a. Num a => a -> a -> a) -> m (NValue f m) numBinOp op = numBinOp' op op numBinOp' :: (Integer -> Integer -> Integer) -> (Float -> Float -> Float) - -> m (NValue t f m) + -> m (NValue f m) numBinOp' intOp floatOp = case (lval, rval) of (NVConstant l, NVConstant r) -> case (l, r) of @@ -480,7 +483,7 @@ fromStringNoContext ns = case getStringNoContext ns of Nothing -> throwError $ ErrorCall $ "expected string with no context, but got " <> show ns addTracing - :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) + :: (MonadNix e f m, Has e Options, MonadReader Int n, Alternative n) => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a)) addTracing k v = do @@ -504,22 +507,22 @@ addTracing k v = do print $ msg rendered <> " ...done" pure res -evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m) +evalExprLoc :: forall e f m . MonadNix e f m => NExprLoc -> m (NValue f m) evalExprLoc expr = do opts :: Options <- asks (view hasLens) if tracing opts then join . (`runReaderT` (0 :: Int)) $ adi (addTracing phi) - (raise (addStackFrames @(NValue t f m) . addSourcePositions)) + (raise (addStackFrames @(NValue f m) . addSourcePositions)) expr - else adi phi (addStackFrames @(NValue t f m) . addSourcePositions) expr + else adi phi (addStackFrames @(NValue f m) . addSourcePositions) expr where phi = Eval.eval . annotated . getCompose raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x -exec :: (MonadNix e t f m, MonadInstantiate m) => [String] -> m (NValue t f m) +exec :: (MonadNix e f m, MonadInstantiate m) => [String] -> m (NValue f m) exec args = either throwError evalExprLoc =<< exec' args nixInstantiateExpr - :: (MonadNix e t f m, MonadInstantiate m) => String -> m (NValue t f m) + :: (MonadNix e f m, MonadInstantiate m) => String -> m (NValue f m) nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs index 8aed021a6..46d63baaa 100644 --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -23,10 +23,8 @@ import Control.Monad.Fail import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.ST -import Data.Typeable import Nix.Var -import Nix.Thunk newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a } deriving @@ -51,20 +49,10 @@ instance MonadTrans (FreshIdT i) where instance MonadBase b m => MonadBase b (FreshIdT i m) where liftBase = FreshIdT . liftBase -instance - ( MonadVar m - , Eq i - , Ord i - , Show i - , Enum i - , Typeable i - ) - => MonadThunkId (FreshIdT i m) - where - type ThunkId (FreshIdT i m) = i - freshId = FreshIdT $ do - v <- ask - atomicModifyVar v (\i -> (succ i, i)) +freshId :: (Monad m, MonadAtomicRef m, Enum i) => FreshIdT i m i +freshId = FreshIdT $ do + v <- ask + atomicModifyVar v (\i -> (succ i, i)) runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a runFreshIdT i m = runReaderT (unFreshIdT m) i diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs index e60aa0f34..e220d8810 100644 --- a/src/Nix/Fresh/Basic.hs +++ b/src/Nix/Fresh/Basic.hs @@ -1,52 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - - module Nix.Fresh.Basic where -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail ( MonadFail ) -#endif -import Control.Monad.Reader -import Nix.Effects -import Nix.Render -import Nix.Fresh -import Nix.Value - -type StdIdT = FreshIdT Int - --- NOTE: These would be removed by: https://github.com/haskell-nix/hnix/pull/804 -instance (MonadFail m, MonadFile m) => MonadFile (StdIdT m) -instance MonadIntrospect m => MonadIntrospect (StdIdT m) -instance MonadStore m => MonadStore (StdIdT m) -instance MonadPutStr m => MonadPutStr (StdIdT m) -instance MonadHttp m => MonadHttp (StdIdT m) -instance MonadEnv m => MonadEnv (StdIdT m) -instance MonadPaths m => MonadPaths (StdIdT m) -instance MonadInstantiate m => MonadInstantiate (StdIdT m) -instance MonadExec m => MonadExec (StdIdT m) +import Nix.Fresh.Stable -instance (MonadEffects t f m, MonadDataContext f m) - => MonadEffects t f (StdIdT m) where - makeAbsolutePath = lift . makeAbsolutePath @t @f @m - findEnvPath = lift . findEnvPath @t @f @m - findPath vs path = do - i <- FreshIdT ask - let vs' = fmap (unliftNValue (runFreshIdT i)) vs - lift $ findPath @t @f @m vs' path - importPath path = do - i <- FreshIdT ask - p <- lift $ importPath @t @f @m path - return $ liftNValue (runFreshIdT i) p - pathToDefaultNix = lift . pathToDefaultNix @t @f @m - derivationStrict v = do - i <- FreshIdT ask - p <- lift $ derivationStrict @t @f @m $ unliftNValue (runFreshIdT i) v - return $ liftNValue (runFreshIdT i) p - traceEffect = lift . traceEffect @t @f @m +type StdIdT = FreshStableIdT diff --git a/src/Nix/Fresh/Stable.hs b/src/Nix/Fresh/Stable.hs new file mode 100644 index 000000000..fe67ac8ae --- /dev/null +++ b/src/Nix/Fresh/Stable.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# options_ghc -fno-warn-orphans #-} -- TODO MonadTransWrap StateT orphan + +module Nix.Fresh.Stable (FreshStableIdT, runFreshStableIdT, freshId) where + +import Nix.Effects +import Nix.Render +import Nix.Thunk +import Nix.Thunk.StableId +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Ref +import Control.Monad.Catch +import Control.Applicative +#ifdef MIN_VERSION_haskeline +import System.Console.Haskeline.MonadException (MonadException) +#endif + +newtype FreshStableIdT m a = FreshStableIdT (ReaderT StableId (StateT Int m) a) + deriving + ( Functor + , Applicative + , Monad + , MonadRef + , MonadAtomicRef + , MonadCatch + , MonadThrow + , MonadIO + , MonadFix + , MonadPlus + , Alternative +#ifdef MIN_VERSION_haskeline + , MonadException +#endif + , MonadMask + ) + +instance MonadState s m => MonadState s (FreshStableIdT m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadTrans FreshStableIdT where + lift = FreshStableIdT . lift . lift + +instance MonadTransWrap (StateT s) where + liftWrap f a = do + old <- get + (result, new) <- lift $ f $ runStateT a old + put new + pure result + +instance MonadTransWrap FreshStableIdT where + liftWrap f (FreshStableIdT a) = FreshStableIdT $ liftWrap (liftWrap f) a + +runFreshStableIdT :: Monad m => StableId -> FreshStableIdT m a -> m a +runFreshStableIdT root (FreshStableIdT a) = evalStateT (runReaderT a root) 0 + +freshId :: Monad m => FreshStableIdT m StableId +freshId = FreshStableIdT $ do + root <- ask + n <- get + put $ succ n + pure $ cons n root + +instance MonadFile m => MonadFile (FreshStableIdT m) +instance MonadIntrospect m => MonadIntrospect (FreshStableIdT m) +instance MonadStore m => MonadStore (FreshStableIdT m) +instance MonadPutStr m => MonadPutStr (FreshStableIdT m) +instance MonadHttp m => MonadHttp (FreshStableIdT m) +instance MonadEnv m => MonadEnv (FreshStableIdT m) +instance MonadInstantiate m => MonadInstantiate (FreshStableIdT m) +instance MonadExec m => MonadExec (FreshStableIdT m) +deriving instance MonadFail m => MonadFail (FreshStableIdT m) + +{- +instance (MonadEffects t f m, MonadDataContext f m) + => MonadEffects t f (FreshStableIdT m) where + makeAbsolutePath = lift . makeAbsolutePath @t @f @m + findEnvPath = lift . findEnvPath @t @f @m + findPath vs path = do + root <- freshId + let vs' = map (unliftNValue (runFreshStableIdT root)) vs + lift $ findPath @t @f @m vs' path + importPath path = do + root <- freshId + p <- lift $ importPath @t @f @m path + pure $ liftNValue (runFreshStableIdT root) p + pathToDefaultNix = lift . pathToDefaultNix @t @f @m + derivationStrict v = do + root <- freshId + p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshStableIdT root) v) + pure $ liftNValue (runFreshStableIdT root) p + traceEffect = lift . traceEffect @t @f @m +-} diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs index 67ab77019..a43e10416 100644 --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} module Nix.Json where @@ -22,7 +23,7 @@ import Nix.Utils import Nix.Value import Nix.Value.Monad -nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString +nvalueToJSONNixString :: MonadNix e f m => NValue f m -> m NixString nvalueToJSONNixString = runWithStringContextT . fmap @@ -33,7 +34,7 @@ nvalueToJSONNixString = ) . nvalueToJSON -nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value +nvalueToJSON :: MonadNix e f m => NValue f m -> WithStringContextT m A.Value nvalueToJSON = \case NVConstant (NInt n) -> pure $ A.toJSON n NVConstant (NFloat n) -> pure $ A.toJSON n diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index 3293db960..68047018b 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -38,11 +38,13 @@ import Nix.Eval ( MonadEval(..) ) import qualified Nix.Eval as Eval import Nix.Expr import Nix.Frames -import Nix.Fresh +import Nix.Fresh () import Nix.String import Nix.Options import Nix.Scope import Nix.Thunk +import Nix.Thunk.StableId +import Nix.Fresh.Stable import Nix.Thunk.Basic import Nix.Utils import Nix.Var @@ -412,7 +414,7 @@ lintApp context fun arg = unpackSymbolic fun >>= \case (head args, ) <$> foldM (unify context) y ys newtype Lint s a = Lint - { runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a } + { runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshStableIdT (ST s)) a } deriving ( Functor , Applicative @@ -432,8 +434,7 @@ instance MonadCatch (Lint s) where runLintM :: Options -> Lint s a -> ST s a runLintM opts action = do - i <- newVar (1 :: Int) - runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action + runFreshStableIdT nil $ flip runReaderT (newContext opts) $ runLint action symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m)) symbolicBaseEnv = pure emptyScopes diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs index 7ac490674..47ca978f4 100644 --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -6,14 +6,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | Code for normalization (reduction into a normal form) of Nix expressions. -- Nix language allows recursion, so some expressions do not converge. -- And so do not converge into a normal form. module Nix.Normal where +import Control.Comonad import Control.Monad import Control.Monad.Free import Control.Monad.Trans.Class @@ -27,36 +31,37 @@ import Nix.Thunk import Nix.Value import Nix.Utils -newtype NormalLoop t f m = NormalLoop (NValue t f m) - deriving Show +newtype NormalLoop f m = NormalLoop (NValue f m) -instance MonadDataErrorContext t f m => Exception (NormalLoop t f m) +deriving instance (Comonad f, Show (Thunk m)) => Show (NormalLoop f m) + +instance MonadDataErrorContext f m => Exception (NormalLoop f m) -- | 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) - , MonadDataErrorContext t f m - , Ord (ThunkId m) + , MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m + , MonadDataErrorContext f m + , Ord (Thunk m) ) - => (forall r . t -> (NValue t f m -> m r) -> m r) - -> NValue t f m - -> m (NValue t f m) + => (forall r . t -> (NValue f m -> m r) -> m r) + -> NValue f m + -> m (NValue f m) normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run) where start = 0 :: Int table = mempty - run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r + run :: ReaderT Int (StateT (Set (Thunk m)) m) r -> m r run = (`evalStateT` table) . (`runReaderT` start) go :: t - -> ( NValue t f m - -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) + -> ( NValue f m + -> ReaderT Int (StateT (Set (Thunk m)) m) (NValue f m) ) - -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) + -> ReaderT Int (StateT (Set (Thunk m)) m) (NValue f m) go t k = do b <- seen t if b @@ -68,66 +73,65 @@ normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run) lifted (lifted (f t)) $ local succ . k seen t = do - let tid = thunkId t lift $ do - res <- gets (member tid) - unless res $ modify (insert tid) + res <- gets (member t) + unless res $ modify (insert t) pure res 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) + , MonadThunk m, ThunkValue m ~ NValue f m + , MonadDataErrorContext f m + , HasCitations m (NValue f m) (Thunk m) + , HasCitations1 m (NValue f m) f + , Ord (Thunk m) ) - => NValue t f m - -> m (NValue t f m) + => NValue f m + -> m (NValue f m) normalForm = fmap stubCycles . normalizeValue force normalForm_ :: ( Framed e m - , MonadThunk t m (NValue t f m) - , MonadDataErrorContext t f m - , Ord (ThunkId m) + , MonadThunk m, ThunkValue m ~ NValue f m + , MonadDataErrorContext f m + , Ord (Thunk m) ) - => NValue t f m + => NValue f m -> m () normalForm_ = void <$> normalizeValue forceEff stubCycles - :: forall t f m + :: forall f m . ( MonadDataContext f m - , HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f + , HasCitations m (NValue f m) (Thunk m) + , HasCitations1 m (NValue f m) f ) - => NValue t f m - -> NValue t f m + => NValue f m + -> NValue f m stubCycles = flip iterNValue Free $ \t _ -> Free $ NValue - $ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc + $ Prelude.foldr (addProvenance1 @m @(NValue f m)) cyc $ reverse - $ citations @m @(NValue t f m) t + $ citations @m @(NValue f m) t where Free (NValue cyc) = opaque removeEffects - :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => NValue t f m - -> m (NValue t f m) + :: (MonadThunk m, ThunkValue m ~ NValue f m, MonadDataContext f m) + => NValue f m + -> m (NValue f m) removeEffects = iterNValueM id (`queryM` pure opaque) (fmap Free . sequenceNValue' id) -opaque :: Applicative f => NValue t f m +opaque :: Applicative f => NValue f m opaque = nvStr $ makeNixStringWithoutContext "" dethunk - :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + :: (MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m, MonadDataContext f m) => t - -> m (NValue t f m) + -> m (NValue f m) dethunk t = queryM t (pure opaque) removeEffects diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index 2b1c28499..7a61b383a 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -185,16 +186,16 @@ prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . foldFix exprFNixDoc prettyOriginExpr - :: forall t f m ann - . HasCitations1 m (NValue t f m) f - => NExprLocF (Maybe (NValue t f m)) + :: forall f m ann + . HasCitations1 m (NValue f m) f + => NExprLocF (Maybe (NValue f m)) -> Doc ann prettyOriginExpr = withoutParens . go where go = exprFNixDoc . annotated . getCompose . fmap render - render :: Maybe (NValue t f m) -> NixDoc ann - render Nothing = simpleExpr "_" + render :: Maybe (NValue f m) -> NixDoc ann + render Nothing = simpleExpr $ "_" render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p) render _ = simpleExpr "?" -- render (Just (NValue (citations -> ps))) = @@ -300,12 +301,12 @@ exprFNixDoc = \case NSynHole name -> simpleExpr $ pretty ("^" <> unpack name) where recPrefix = "rec" <> space -valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr +valueToExpr :: forall f m . MonadDataContext f m => NValue f m -> NExpr valueToExpr = iterNValue (\_ _ -> thk) phi where thk = Fix . NSym . pack $ "" - phi :: NValue' t f m NExpr -> NExpr + phi :: NValue' f m NExpr -> NExpr phi (NVConstant' a ) = Fix $ NConstant a phi (NVStr' ns) = mkStr ns phi (NVList' l ) = Fix $ NList l @@ -321,20 +322,20 @@ valueToExpr = iterNValue (\_ _ -> thk) phi mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)] prettyNValue - :: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann + :: forall f m ann . MonadDataContext f m => NValue f m -> Doc ann prettyNValue = prettyNix . valueToExpr prettyNValueProv :: forall t f m ann - . ( HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f - , MonadThunk t m (NValue t f m) + . ( HasCitations m (NValue f m) t + , HasCitations1 m (NValue f m) f + , MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m , MonadDataContext f m ) - => NValue t f m + => NValue f m -> Doc ann prettyNValueProv v = do - let ps = citations @m @(NValue t f m) v + let ps = citations @m @(NValue f m) v case ps of [] -> prettyNValue v ps -> @@ -350,15 +351,15 @@ prettyNValueProv v = do prettyNThunk :: forall t f m ann - . ( HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f - , MonadThunk t m (NValue t f m) + . ( HasCitations m (NValue f m) t + , HasCitations1 m (NValue f m) f + , MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m , MonadDataContext f m ) => t -> m (Doc ann) prettyNThunk t = do - let ps = citations @m @(NValue t f m) @t t + let ps = citations @m @(NValue f m) @t t v' <- prettyNValue <$> dethunk t pure $ fillSep @@ -371,12 +372,12 @@ prettyNThunk t = do ] -- | This function is used only by the testing code. -printNix :: forall t f m . MonadDataContext f m => NValue t f m -> String +printNix :: forall f m . MonadDataContext f m => NValue f m -> String printNix = iterNValue (\_ _ -> thk) phi where thk = "" - phi :: NValue' t f m String -> String + phi :: NValue' f m String -> String phi (NVConstant' a ) = unpack $ atomText a phi (NVStr' ns) = show $ stringIgnoreContext ns phi (NVList' l ) = "[ " <> unwords l <> " ]" diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index ed289aece..3f662773f 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -76,7 +76,7 @@ newtype Reducer m a = Reducer staticImport :: forall m . ( MonadIO m - , Scoped NExprLoc m + , Scoped m NExprLoc m , MonadFail m , MonadReader (Maybe FilePath, Scopes m NExprLoc) m , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m @@ -131,7 +131,7 @@ reduceExpr mpath expr = reduce :: forall m . ( MonadIO m - , Scoped NExprLoc m + , Scoped m NExprLoc m , MonadFail m , MonadReader (Maybe FilePath, Scopes m NExprLoc) m , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) m @@ -220,18 +220,18 @@ reduce e@(NSet_ ann NNonRecursive binds) = do Inherit{} -> True _ -> False if usesInherit - then clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds + then clearScopes $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds else Fix <$> sequence e -- Encountering a 'rec set' construction eliminates any hope of inlining -- definitions. reduce (NSet_ ann NRecursive binds) = - clearScopes @NExprLoc $ Fix . NSet_ ann NRecursive <$> traverse sequence binds + clearScopes $ Fix . NSet_ ann NRecursive <$> traverse sequence binds -- Encountering a 'with' construction eliminates any hope of inlining -- definitions. reduce (NWith_ ann scope body) = - clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body + clearScopes $ fmap Fix $ NWith_ ann <$> scope <*> body -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope. @@ -414,8 +414,8 @@ reducingEvalExpr eval mpath expr = do return (fromMaybe nNull expr'', eres) where addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x -instance Monad m => Scoped NExprLoc (Reducer m) where +instance Monad m => Scoped (Reducer m) NExprLoc (Reducer m) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(Reducer m) @NExprLoc pushScopes = pushScopesReader - lookupVar = lookupVarReader + askLookupVar = lookupVarReader diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs index e059a5e7f..d3550ec73 100644 --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} @@ -9,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Nix.Render where @@ -24,8 +26,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Void -import Nix.Utils.Fix1 ( Fix1T - , MonadFix1T ) +import Nix.Utils.Fix1 import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S @@ -73,8 +74,7 @@ instance MonadFile IO where doesDirectoryExist = S.doesDirectoryExist getSymbolicLinkStatus = S.getSymbolicLinkStatus - -instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) +deriving instance MonadFile (t (Fix1T t m) m) => MonadFile (Fix1T t m) posAndMsg :: SourcePos -> Doc a -> ParseError s Void posAndMsg (SourcePos _ lineNo _) msg = FancyError diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs index 69b49198f..b33fc258d 100644 --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -87,9 +87,9 @@ renderFrame renderFrame (NixFrame level f) | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e | Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e - | Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e - | Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e - | Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e + | Just (e :: ValueFrame f m) <- fromException f = renderValueFrame level e + | Just (e :: NormalLoop f m) <- fromException f = renderNormalLoop level e + | Just (e :: ExecFrame f m) <- fromException f = renderExecFrame level e | Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)] | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)] | otherwise = error $ "Unrecognized frame: " <> show f @@ -161,7 +161,7 @@ renderValueFrame :: forall e t f m ann . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel - -> ValueFrame t f m + -> ValueFrame f m -> m [Doc ann] renderValueFrame level = fmap (: []) . \case ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI @@ -191,7 +191,7 @@ renderValue => NixLevel -> String -> String - -> NValue t f m + -> NValue f m -> m (Doc ann) renderValue _level _longLabel _shortLabel v = do opts :: Options <- asks (view hasLens) @@ -202,7 +202,7 @@ renderValue _level _longLabel _shortLabel v = do renderExecFrame :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel - -> ExecFrame t f m + -> ExecFrame f m -> m [Doc ann] renderExecFrame level = \case Assertion ann v -> @@ -213,7 +213,7 @@ renderExecFrame level = \case ) renderThunkLoop - :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) + :: (MonadReader e m, Has e Options, MonadFile m, Show (Thunk m)) => NixLevel -> ThunkLoop -> m [Doc ann] @@ -223,7 +223,7 @@ renderThunkLoop _level = pure . (: []) . \case renderNormalLoop :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel - -> NormalLoop t f m + -> NormalLoop f m -> m [Doc ann] renderNormalLoop level = fmap (: []) . \case NormalLoop v -> do diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs index 8270372aa..41ad926b6 100644 --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} @@ -7,15 +8,29 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Nix.Scope where import Control.Applicative import Control.Monad.Reader +import Control.Monad.Trans.Writer import qualified Data.HashMap.Lazy as M import Data.Text ( Text ) import Lens.Family2 import Nix.Utils +import Nix.Utils.Fix1 + +class Scoped r binding m | m -> binding r where + currentScopes :: m (Scopes r binding) + clearScopes :: m x -> m x + pushScopes :: Scopes r binding -> m x -> m x + askLookupVar :: Text -> m (r (Maybe binding)) + +deriving instance Scoped r a (t (Fix1T t m) m) => Scoped r a (Fix1T t m) + +lookupVar :: (Monad m, Scoped m binding m) => Text -> m (Maybe binding) +lookupVar = join . askLookupVar newtype Scope a = Scope { getScope :: AttrSet a } deriving (Functor, Foldable, Traversable, Eq) @@ -46,15 +61,12 @@ instance Monoid (Scopes m a) where mempty = emptyScopes mappend = (<>) +instance Functor m => Functor (Scopes m) where + fmap f (Scopes l d) = Scopes (fmap (fmap f) l) (fmap (fmap (fmap f)) d) + emptyScopes :: forall m a . Scopes m a emptyScopes = Scopes [] [] -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 a e . (MonadReader e m, Has e (Scopes m a)) => m (Scopes m a) currentScopesReader = asks (view hasLens) @@ -63,24 +75,33 @@ clearScopesReader :: forall m a e r . (MonadReader e m, Has e (Scopes m a)) => m r -> m r clearScopesReader = local (set hasLens (emptyScopes @m @a)) -pushScope :: Scoped a m => AttrSet a -> m r -> m r +strongScope :: AttrSet a -> Scopes m a +strongScope a = Scopes [Scope a] [] + +pushScope :: Scoped r a m => AttrSet a -> m x -> m x pushScope s = pushScopes (Scopes [Scope s] []) -pushWeakScope :: (Functor m, Scoped a m) => m (AttrSet a) -> m r -> m r +pushWeakScope :: (Functor r, Scoped r a m) => r (AttrSet a) -> m x -> m x pushWeakScope s = pushScopes (Scopes [] [Scope <$> s]) pushScopesReader - :: (MonadReader e m, Has e (Scopes m a)) => Scopes m a -> m r -> m r + :: (MonadReader e m, Has e (Scopes r a)) => Scopes r a -> m x -> m x pushScopesReader s = local (over hasLens (s <>)) lookupVarReader - :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => Text -> m (Maybe a) + :: forall r m a e . (Monad r, MonadReader e m, Has e (Scopes r a)) => Text -> m (r (Maybe a)) lookupVarReader k = do - mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) + s <- asks $ view hasLens + pure $ lookupVarScopes k s + +lookupVarScopes + :: forall m a . Monad m => Text -> Scopes m a -> m (Maybe a) +lookupVarScopes k s = do + let mres = scopeLookup k $ lexicalScopes @m s case mres of Just sym -> pure $ Just sym Nothing -> do - ws <- asks (dynamicScopes . view hasLens) + let ws = dynamicScopes s foldr (\x rest -> do mres' <- M.lookup k . getScope <$> x @@ -91,5 +112,20 @@ lookupVarReader k = do (pure Nothing) ws -withScopes :: Scoped a m => Scopes m a -> m r -> m r +withScopes :: Scoped r a m => Scopes r a -> m x -> m x withScopes scope = clearScopes . pushScopes scope + +hoistDynamicScopes :: (m (Scope a) -> n (Scope a)) -> Scopes m a -> Scopes n a +hoistDynamicScopes f (Scopes s d) = Scopes s $ fmap f d + +instance (Scoped r a m, Monoid w, Monad m) => Scoped r a (WriterT w m) where + currentScopes = lift currentScopes + clearScopes m = do + (a, w) <- lift $ clearScopes $ runWriterT m + tell w + pure a + pushScopes s m = do + (a, w) <- lift $ pushScopes s $ runWriterT m + tell w + pure a + askLookupVar = lift . askLookupVar diff --git a/src/Nix/Scope/Basic.hs b/src/Nix/Scope/Basic.hs new file mode 100644 index 000000000..dd7f30431 --- /dev/null +++ b/src/Nix/Scope/Basic.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +module Nix.Scope.Basic where + +import Control.Applicative +import Control.Monad.Exception +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Catch +import Nix.Thunk +import Nix.Scope +#ifdef MIN_VERSION_haskeline +import System.Console.Haskeline.MonadException hiding(catch) +#endif + +-- `binding` is the information associated with a variable name in the scope +newtype ScopeT binding r m a = ScopeT { unScopeT :: ReaderT (Scopes r binding) m a } + deriving + ( Functor + , Applicative + , Monad + , Alternative + , MonadPlus + , MonadFail + , MonadFix + , MonadIO + , MonadCatch + , MonadThrow + , MonadException + , MonadMask + ) + +deriving instance MonadState s m => MonadState s (ScopeT binding r m) + +instance MonadReader a m => MonadReader a (ScopeT binding r m) where + ask = lift ask + local f = liftWrap $ local f + reader = lift . reader + +runScopeT :: ScopeT binding r m a -> Scopes r binding -> m a +runScopeT = runReaderT . unScopeT + +instance MonadTrans (ScopeT t r) where + lift = ScopeT . lift + +instance (Monad m, Monad r) => Scoped r t (ScopeT t r m) where + currentScopes = ScopeT ask + clearScopes = ScopeT . local (const mempty) . unScopeT + pushScopes added = + ScopeT . + local (\old -> added <> old) . + unScopeT + askLookupVar name = ScopeT $ do + scopes <- ask + pure $ lookupVarScopes name scopes + +instance MonadThunk m => MonadThunk (ScopeT binding r m) where + type Thunk (ScopeT binding r m) = Thunk m + type ThunkValue (ScopeT binding r m) = ThunkValue m + thunk a = ScopeT $ do + scopes <- ask + lift $ thunk $ runScopeT a scopes + queryM t n k = ScopeT $ do + scopes <- ask + lift $ queryM t (runScopeT n scopes) ((`runScopeT` scopes) . k) + force t k = ScopeT $ do + scopes <- ask + lift $ force t $ (`runScopeT` scopes) . k + forceEff t k = ScopeT $ do + scopes <- ask + lift $ forceEff t $ (`runScopeT` scopes) . k + further t k = ScopeT $ do + scopes <- ask + lift $ further t $ (`runScopeT` scopes) . k . lift + +instance MonadTransWrap (ScopeT binding r) where + liftWrap f a = ScopeT $ liftWrap f (unScopeT a) diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs index 18fc06cac..eaf7b1125 100644 --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -4,13 +4,16 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -18,8 +21,6 @@ module Nix.Standard where import Control.Applicative -import Control.Comonad ( Comonad ) -import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -28,71 +29,34 @@ import Control.Monad.Free import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State +import Data.Coerce +import Data.Functor.Identity import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Strict import Data.Text ( Text ) 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.Effects.Derivation import Nix.Expr.Types.Annotated -import Nix.Fresh -import Nix.Fresh.Basic +import Nix.Thunk.StableId +import Nix.Thunk.Basic import Nix.Options import Nix.Render import Nix.Scope +import Nix.Scope.Basic import Nix.Thunk -import Nix.Thunk.Basic import Nix.Utils.Fix1 import Nix.Value import Nix.Value.Monad -import Nix.Var - - -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 _ = "" - -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 MonadFile m => MonadFile (StandardTF r m) instance ( MonadFix m , MonadFile m , MonadCatch m , MonadEnv m - , MonadPaths m , MonadExec m , MonadHttp m , MonadInstantiate m @@ -102,14 +66,9 @@ instance ( MonadFix m , MonadStore m , MonadAtomicRef m , Typeable m - , Scoped (StdValue m) m - , MonadReader (Context m (StdValue m)) m - , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m - , MonadDataErrorContext (StdThunk m) (StdCited m) m - , MonadThunk (StdThunk m) m (StdValue m) - , MonadValue (StdValue m) m + , MonadPaths m ) - => MonadEffects (StdThunk m) (StdCited m) m where + => MonadEffects Identity (StandardT m) where makeAbsolutePath = defaultMakeAbsolutePath findEnvPath = defaultFindEnvPath findPath = defaultFindPath @@ -118,35 +77,6 @@ instance ( MonadFix m 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 @@ -155,12 +85,15 @@ instance ( MonadAtomicRef m -- whileForcingThunk frame = -- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame +type StandardTFInner r m = ScopeT (NValue Identity r) r + (ThunkT (NValue Identity r) --TODO: What should this `Identity` be? Probably (StdCited ...) + (ReaderT Context + (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m))) + newtype StandardTF r m a - = StandardTF (ReaderT (Context r (StdValue r)) - (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a) + = StandardTF { unStandardTF :: StandardTFInner r m a } deriving - ( Functor - , Applicative + ( Applicative , Alternative , Monad , MonadFail @@ -170,55 +103,93 @@ newtype StandardTF r m a , MonadCatch , MonadThrow , MonadMask - , MonadReader (Context r (StdValue r)) + , MonadReader Context , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) + , MonadStore ) +deriving instance (Monad m, Monad r, Thunk r ~ StdThunk r m) => Scoped r (Free (NValue' Identity r) (StdThunk r m)) (StandardTF r m) + +deriving instance Functor m => Functor (StandardTF r m) + instance MonadTrans (StandardTF r) where - lift = StandardTF . lift . lift + lift = StandardTF . lift . lift . lift . lift + +instance MonadTransWrap (StandardTF r) where + liftWrap f (StandardTF a) = StandardTF $ liftWrap (liftWrap (liftWrap (liftWrap f))) a + +instance (MonadPutStr m) => MonadPutStr (StandardTF r m) +instance (MonadHttp m) => MonadHttp (StandardTF r m) +instance (MonadEnv m) => MonadEnv (StandardTF r m) +instance (MonadInstantiate m) => MonadInstantiate (StandardTF r m) +instance (MonadExec m) => MonadExec (StandardTF r m) +instance (MonadIntrospect m) => MonadIntrospect (StandardTF r m) + +instance ( Monad m + , Typeable r + , Typeable (Thunk r) + , Typeable m + , MonadAtomicRef m + , MonadCatch m + ) => MonadThunk (StandardTF r m) where + type Thunk (StandardTF r m) = StdThunk r m + type ThunkValue (StandardTF r m) = StdValue r + thunk v = StandardTF $ StdThunk <$> thunk (unStandardTF v) + queryM = coerce $ queryM @(StandardTFInner r m) + force = coerce $ force @(StandardTFInner r m) + forceEff = coerce $ forceEff @(StandardTFInner r m) + further t f = fmap StdThunk $ StandardTF $ further (unStdThunk t) $ unStandardTF . f . StandardTF + +newtype StdThunk r m = StdThunk { unStdThunk :: Thunk (StandardTFInner r m) } + deriving (Eq, Ord, Show, Typeable) + +type StdValue r = NValue Identity r -instance (MonadPutStr r, MonadPutStr m) => MonadPutStr (StandardTF r m) -instance (MonadHttp r, MonadHttp m) => MonadHttp (StandardTF r m) -instance (MonadEnv r, MonadEnv m) => MonadEnv (StandardTF r m) -instance (MonadPaths r, MonadPaths m) => MonadPaths (StandardTF r m) -instance (MonadInstantiate r, MonadInstantiate m) => MonadInstantiate (StandardTF r m) -instance (MonadExec r, MonadExec m) => MonadExec (StandardTF r m) -instance (MonadIntrospect r, MonadIntrospect m) => MonadIntrospect (StandardTF r m) +instance MonadPaths m => MonadPaths (StandardTF r m) + +instance ( Monad m + , Typeable m + , MonadAtomicRef m + , MonadCatch m + ) => MonadValue (Free (NValue' Identity (StandardT m)) (StdThunk (StandardT m) m)) (StandardT m) where + defer = fmap pure . thunk + + demand (Pure v) f = force v (`demand` f) + demand (Free v) f = f (Free v) + + inform (Pure t) f = Pure <$> further t f + inform (Free v) f = Free <$> bindNValue' id (`inform` f) v + +--TODO +instance HasCitations m' v (StdThunk r m) where + citations _ = [] + addProvenance _ = id + +instance HasCitations1 m v Identity where + citations1 _ = [] + addProvenance1 _ = id --------------------------------------------------------------------------------- type StandardT m = Fix1T StandardTF m -instance MonadTrans (Fix1T StandardTF) where +instance (forall m. MonadTrans (t (Fix1T t m))) => MonadTrans (Fix1T t) 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, Data.HashMap.Strict.HashMap Text Text) m) - a + :: StandardTFInner (Fix1T StandardTF m) m a -> StandardT m a mkStandardT = Fix1T . StandardTF runStandardT :: StandardT m a - -> ReaderT - (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m) - a + -> StandardTFInner (Fix1T StandardTF m) m a runStandardT (Fix1T (StandardTF m)) = m runWithBasicEffects - :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a + :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT m a -> m a runWithBasicEffects opts = - go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT - where - go action = do - i <- newVar (1 :: Int) - runFreshIdT i action + (`evalStateT` mempty) . (`runReaderT` newContext opts) . (`runThunkT` nil) . (`runScopeT` mempty) . runStandardT -runWithBasicEffectsIO :: Options -> StandardT (StdIdT IO) a -> IO a +runWithBasicEffectsIO :: Options -> StandardT IO a -> IO a runWithBasicEffectsIO = runWithBasicEffects diff --git a/src/Nix/String/Coerce.hs b/src/Nix/String/Coerce.hs index 1c7312d54..6687eea71 100644 --- a/src/Nix/String/Coerce.hs +++ b/src/Nix/String/Coerce.hs @@ -42,13 +42,13 @@ coerceToString :: ( Framed e m , MonadStore m , MonadThrow m - , MonadDataErrorContext t f m - , MonadValue (NValue t f m) m + , MonadDataErrorContext f m + , MonadValue (NValue f m) m ) - => (NValue t f m -> NValue t f m -> m (NValue t f m)) + => (NValue f m -> NValue f m -> m (NValue f m)) -> CopyToStoreMode -> CoercionLevel - -> NValue t f m + -> NValue f m -> m NixString coerceToString call ctsm clevel = go where diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs index 9469bab3e..cecb12cd4 100644 --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -1,60 +1,75 @@ -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Nix.Thunk where import Control.Exception ( Exception ) -import Control.Monad.Trans.Class ( MonadTrans(..) ) -import Control.Monad.Trans.Except +import Control.Monad.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Data.Typeable ( Typeable ) +import Nix.Utils.Fix1 + +class MonadTransWrap t where + --TODO: Can we enforce that the resulting function is as linear as the provided one? + liftWrap :: Monad m => (forall x. m x -> m x) -> t m a -> t m a + +instance MonadTransWrap (ReaderT s) where + liftWrap f a = do + env <- ask + lift $ f $ runReaderT a env + +instance Monoid w => MonadTransWrap (WriterT w) where + liftWrap f a = do + (result, w) <- lift $ f $ runWriterT a + tell w + pure result + +instance MonadTransWrap (ExceptT e) where + liftWrap f a = do + lift (f $ runExceptT a) >>= \case + Left e -> throwError e + Right result -> pure result + +instance MonadTransWrap (StateT s) where + liftWrap f a = do + old <- get + (result, new) <- lift $ f $ runStateT a old + put new + pure result + +instance (forall m. MonadTransWrap (t (Fix1T t m))) => MonadTransWrap (Fix1T t) where + liftWrap f (Fix1T a) = Fix1T $ liftWrap f a + class ( Monad m - , Eq (ThunkId m) - , Ord (ThunkId m) - , Show (ThunkId m) - , Typeable (ThunkId m) - ) - => MonadThunkId m where - type ThunkId m :: * - freshId :: m (ThunkId m) - default freshId - :: ( MonadThunkId m' - , MonadTrans t - , m ~ t m' - , ThunkId m ~ ThunkId m' - ) - => m (ThunkId m) - freshId = lift freshId - -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 + , Eq (Thunk m) + , Ord (Thunk m) + , Show (Thunk m) + , Typeable (Thunk m) + ) => MonadThunk m where + type Thunk m :: * + type ThunkValue m :: * + thunk :: m (ThunkValue m) -> m (Thunk m) + + queryM :: Thunk m -> m r -> (ThunkValue m -> m r) -> m r + force :: Thunk m -> (ThunkValue m -> m r) -> m r + forceEff :: Thunk m -> (ThunkValue m -> 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 + further :: Thunk m -> (m (ThunkValue m) -> m (ThunkValue m)) -> m (Thunk m) + +deriving instance MonadThunk (t (Fix1T t m) m) => MonadThunk (Fix1T t m) newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId deriving Typeable diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs index 5e25b17b1..17aaefedb 100644 --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -1,52 +1,107 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} -module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where +module Nix.Thunk.Basic (ThunkT (..), runThunkT, NThunkF (..), Deferred (..)) where import Control.Exception hiding ( catch ) import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.State +import Nix.Effects import Nix.Thunk import Nix.Var +import Nix.Thunk.StableId +import Nix.Fresh.Stable +import Control.Applicative +import Control.Monad.Ref +import Data.Typeable +#ifdef MIN_VERSION_haskeline +import System.Console.Haskeline.MonadException hiding(catch) +#endif + +newtype ThunkT v m a = ThunkT { unThunkT :: FreshStableIdT m a } + deriving + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFail + , MonadFix + , MonadRef + , MonadAtomicRef + , MonadIO + , MonadCatch + , MonadThrow +#ifdef MIN_VERSION_haskeline + , MonadException +#endif + , MonadMask + , MonadStore + ) + +deriving instance MonadState s m => MonadState s (ThunkT v m) + +instance MonadReader r m => MonadReader r (ThunkT v m) where + ask = lift ask + local f = liftWrap $ local f + reader = lift . reader + +runThunkT :: Monad m => ThunkT v m a -> StableId -> m a +runThunkT (ThunkT a) root = runFreshStableIdT root a + +instance MonadTrans (ThunkT v) where + lift = ThunkT . lift + +instance MonadTransWrap (ThunkT v) where + liftWrap f (ThunkT a) = ThunkT $ liftWrap f a data Deferred m v = Deferred (m v) | Computed v deriving (Functor, Foldable, Traversable) -- | The type of very basic thunks data NThunkF m v - = Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v)) + = Thunk StableId (Var m Bool) (Var m (Deferred m v)) -instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where +instance Eq (NThunkF m v) where Thunk x _ _ == Thunk y _ _ = x == y -instance Show v => Show (NThunkF m v) where - show Thunk{} = "" +instance Ord (NThunkF m v) where + Thunk x _ _ `compare` Thunk y _ _ = x `compare` y -type MonadBasicThunk m = (MonadThunkId m, MonadVar m) +instance Show (NThunkF m v) where + show (Thunk tid _ _) = " show tid <> ">" -instance (MonadBasicThunk m, MonadCatch m) - => MonadThunk (NThunkF m v) m v where +instance (Typeable v, Typeable m, MonadAtomicRef m, MonadCatch m) + => MonadThunk (ThunkT v m) where + type Thunk (ThunkT v m) = NThunkF m v + type ThunkValue (ThunkT v m) = v thunk = buildThunk - thunkId (Thunk n _ _) = n - queryM = queryThunk - force = forceThunk + queryM = queryThunk + force = forceThunk forceEff = forceEffects - further = furtherThunk + further t f = thunk $ f $ force t pure -buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v) -buildThunk action = do +buildThunk :: MonadRef m => ThunkT v m v -> ThunkT v m (NThunkF m v) +buildThunk (ThunkT action) = ThunkT $ do freshThunkId <- freshId - Thunk freshThunkId <$> newVar False <*> newVar (Deferred action) + Thunk freshThunkId <$> newVar False <*> newVar (Deferred $ runFreshStableIdT freshThunkId action) -queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a +queryThunk :: MonadVar m => NThunkF m v -> ThunkT v m a -> (v -> ThunkT v m a) -> ThunkT v m a queryThunk (Thunk _ active ref) n k = do nowActive <- atomicModifyVar active (True, ) if nowActive @@ -61,10 +116,10 @@ queryThunk (Thunk _ active ref) n k = do forceThunk :: forall m v a - . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m)) + . (MonadVar m, MonadThrow m, MonadCatch m, Show StableId) => NThunkF m v - -> (v -> m a) - -> m a + -> (v -> ThunkT v m a) + -> ThunkT v m a forceThunk (Thunk n active ref) k = do eres <- readVar ref case eres of @@ -74,14 +129,14 @@ forceThunk (Thunk n active ref) k = do if nowActive then throwM $ ThunkLoop $ show n else do - v <- catch action $ \(e :: SomeException) -> do + v <- catch (ThunkT $ lift action) $ \(e :: SomeException) -> do _ <- atomicModifyVar active (False, ) throwM e _ <- atomicModifyVar active (False, ) writeVar ref (Computed v) k v -forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r +forceEffects :: MonadVar m => NThunkF m v -> (v -> ThunkT v m r) -> ThunkT v m r forceEffects (Thunk _ active ref) k = do nowActive <- atomicModifyVar active (True, ) if nowActive @@ -91,14 +146,17 @@ forceEffects (Thunk _ active ref) k = do case eres of Computed v -> k v Deferred action -> do - v <- action + v <- ThunkT $ lift action writeVar ref (Computed v) _ <- atomicModifyVar active (False, ) k v +{- +--[ryantrinkle] I'm worried about what impact this will have on the way withRootId works furtherThunk :: MonadVar m => NThunkF m v -> (m v -> m v) -> m (NThunkF m v) furtherThunk t@(Thunk _ _ ref) k = do _ <- atomicModifyVar ref $ \x -> case x of Computed _ -> (x, x) Deferred d -> (Deferred (k d), x) pure t +-} diff --git a/src/Nix/Thunk/Separate.hs b/src/Nix/Thunk/Separate.hs new file mode 100644 index 000000000..caa305c84 --- /dev/null +++ b/src/Nix/Thunk/Separate.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Thunk.Separate (NThunkF(..), MonadSeparateThunk, runSeparateThunkT, askThunkCache) where + +import Control.Exception hiding (catch) +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.Ref +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Nix.Thunk + +-- | The type of very basic thunks +data NThunkF m v + = Value v + | Thunk (ThunkId m) (SeparateThunkT v 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 _ _) = "" + +type MonadSeparateThunk m = (MonadThunkId m, MonadAtomicRef m, Ord (ThunkId m)) --TODO: ThunkId allocation also needs to be sufficiently deterministic + +type ThunkCache m v = Ref m (Map (ThunkId m) (Maybe v)) + +--TODO: HashMap? +newtype SeparateThunkT v m a = SeparateThunkT (ReaderT (ThunkCache m v) m a) + deriving + ( Functor + , Applicative + , Monad + , MonadRef + , MonadAtomicRef + , MonadCatch + , MonadThrow + ) + +askThunkCache :: Monad m => SeparateThunkT v m (ThunkCache m v) +askThunkCache = SeparateThunkT ask + +runSeparateThunkT :: ThunkCache m v -> SeparateThunkT v m a -> m a +runSeparateThunkT c (SeparateThunkT a) = runReaderT a c + +instance MonadTrans (SeparateThunkT v) where + lift = SeparateThunkT . lift + +instance MonadThunkId m => MonadThunkId (SeparateThunkT v m) where + type ThunkId (SeparateThunkT v m) = ThunkId m + +instance (MonadSeparateThunk m, MonadCatch m) + => MonadThunk (NThunkF m v) (SeparateThunkT 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 + +buildThunk :: MonadThunkId m => SeparateThunkT v m v -> SeparateThunkT v m (NThunkF m v) +buildThunk action = do + freshThunkId <- lift freshId + return $ Thunk freshThunkId action + +queryValue :: NThunkF m v -> a -> (v -> a) -> a +queryValue (Value v) _ k = k v +queryValue _ n _ = n + +queryThunk :: (MonadAtomicRef m, Ord (ThunkId m)) => NThunkF m v -> SeparateThunkT v m a -> (v -> SeparateThunkT v m a) -> SeparateThunkT v m a +queryThunk (Value v) _ k = k v +queryThunk (Thunk tid _) n k = do + c <- SeparateThunkT ask + mOldVal <- atomicModifyRef' c $ \old -> + -- Try to insert Nothing into the given key, but if something is already + -- there, just leave it + let (mOldVal, !new) = Map.insertLookupWithKey (\_ _ oldVal -> oldVal) tid Nothing old + in (new, mOldVal) + case mOldVal of + Nothing -> do + result <- n -- Not computed, inactive + -- This is the only case where we've actually changed c, so restore it + atomicModifyRef' c $ \old -> (Map.delete tid old, ()) + return result + Just Nothing -> n -- Active + Just (Just v) -> k v -- Computed, inactive + +forceThunk + :: forall m v a. + ( MonadAtomicRef m + , MonadThrow m + , MonadCatch m + , Show (ThunkId m) + , Ord (ThunkId m) + ) + => NThunkF m v -> (v -> SeparateThunkT v m a) -> SeparateThunkT v m a +forceThunk (Value v) k = k v +forceThunk (Thunk tid action) k = do + c <- SeparateThunkT ask + mOldVal <- atomicModifyRef' c $ \old -> + -- Try to insert Nothing into the given key, but if something is already + -- there, just leave it + let (mOldVal, !new) = Map.insertLookupWithKey (\_ _ oldVal -> oldVal) tid Nothing old + in (new, mOldVal) + case mOldVal of + Nothing -> do -- Not computed, inactive + v <- catch action $ \(e :: SomeException) -> do + -- This is the only case where we've actually changed c, so restore it + _ <- atomicModifyRef' c $ \old -> (Map.delete tid old, ()) + throwM e + atomicModifyRef' c $ \old -> (Map.insert tid (Just v) old, ()) + k v + Just Nothing -> throwM $ ThunkLoop $ show tid + Just (Just v) -> k v -- Computed, inactive + +forceEffects :: (MonadAtomicRef m, Ord (ThunkId m)) => NThunkF m v -> (v -> SeparateThunkT v m r) -> SeparateThunkT v m r +forceEffects (Value v) k = k v +forceEffects (Thunk tid action) k = do + c <- SeparateThunkT ask + mOldVal <- atomicModifyRef' c $ \old -> + -- Try to insert Nothing into the given key, but if something is already + -- there, just leave it + let (mOldVal, !new) = Map.insertLookupWithKey (\_ _ oldVal -> oldVal) tid Nothing old + in (new, mOldVal) + case mOldVal of + Nothing -> do -- Not computed, inactive + v <- action + atomicModifyRef' c $ \old -> (Map.insert tid (Just v) old, ()) + k v + Just Nothing -> return $ error "Loop detected" + Just (Just v) -> k v -- Computed, inactive diff --git a/src/Nix/Thunk/StableId.hs b/src/Nix/Thunk/StableId.hs new file mode 100644 index 000000000..df107924f --- /dev/null +++ b/src/Nix/Thunk/StableId.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MagicHash #-} + +-- Equivalent to [Int], but with near-O(1) amortized comparison +module Nix.Thunk.StableId (StableId, nil, cons, uncons) where + +import Data.IORef +import System.IO.Unsafe +import GHC.Prim +import Data.Hashable +import Data.List (unfoldr) +import Data.Ord + +--TODO: If we have a really long chain, we will keep leaking memory; what can we do about this? + +data StableId = StableId + { _stableId_value :: {-# UNPACK #-} !Int + , _stableId_hash :: {-# UNPACK #-} !Int + , _stableId_parent :: {-# UNPACK #-} !(IORef StableId) + } + +{-# NOINLINE nil #-} -- If nil is not a single value on the heap, infinite recursion can result +nil :: StableId +nil = StableId 0 0 $ unsafePerformIO $ newIORef $ error "nil" + +cons :: Int -> StableId -> StableId +cons v p@(StableId _ ph _) = StableId v (hash (v, ph)) $ unsafeDupablePerformIO $ newIORef p + +uncons :: StableId -> Maybe (Int, StableId) +uncons s = if _stableId_parent s == _stableId_parent nil + then Nothing + else Just + ( _stableId_value s + , unsafeDupablePerformIO $ readIORef $ _stableId_parent s + ) + +--TODO: Reimplement Eq in terms of Ord? +instance Eq StableId where + a == b = if + | _stableId_parent a == _stableId_parent b -- We're the exact same heap object + -> True + | _stableId_hash a /= _stableId_hash b || _stableId_value a /= _stableId_value b -- We're definitely different + -> False + | otherwise -- Different objects, but same value and hash. These are either the same value or a hash collision. + -> unsafeDupablePerformIO $ do + pa <- readIORef $ _stableId_parent a + pb <- readIORef $ _stableId_parent b + case reallyUnsafePtrEquality# pa pb of + -- Parents are different objects + 0# -> if pa == pb + then do writeIORef (_stableId_parent b) pa -- Parents are equivalent, so unify + return True + else return False -- Parents are not equivalent, so leave them alone + -- Parents are the same object already + _ -> return True + +instance Ord StableId where + a `compare` b = case comparing _stableId_hash a b <> comparing _stableId_value a b of + LT -> LT + GT -> GT + EQ -> case _stableId_parent a == _stableId_parent b of + True -> EQ + False -> unsafeDupablePerformIO $ do + pa <- readIORef $ _stableId_parent a + pb <- readIORef $ _stableId_parent b + case reallyUnsafePtrEquality# pa pb of + -- Parents are different objects + 0# -> case pa `compare` pb of + LT -> return LT + GT -> return GT + EQ -> do + writeIORef (_stableId_parent b) pa + return EQ + -- Parents are the same object already + _ -> return EQ + +toList :: StableId -> [Int] +toList = unfoldr uncons + +instance Show StableId where + showsPrec n = showsPrec n . toList diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index ac1f53576..8c04c9202 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -58,9 +58,11 @@ import Nix.Eval ( MonadEval(..) ) import qualified Nix.Eval as Eval import Nix.Expr.Types import Nix.Expr.Types.Annotated -import Nix.Fresh +import Nix.Fresh () import Nix.String import Nix.Scope +import Nix.Thunk.StableId +import Nix.Fresh.Stable import qualified Nix.Type.Assumption as As import Nix.Type.Env import qualified Nix.Type.Env as Env @@ -222,10 +224,9 @@ runInfer' = . (`runReaderT` (Set.empty, emptyScopes)) . getInfer -runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a +runInfer :: (forall s. InferT s (FreshStableIdT (ST s)) a) -> Either InferError a runInfer m = runST $ do - i <- newVar (1 :: Int) - runFreshIdT i (runInfer' m) + runFreshStableIdT nil (runInfer' m) inferType :: forall s m . MonadInfer m => Env -> NExpr -> InferT s m [(Subst, Type)] @@ -694,8 +695,8 @@ solve cs = solve' (nextSolvable cs) s' <- lift $ instantiate s solve (EqConst t s' : cs) -instance Monad m => Scoped (Judgment s) (InferT s m) where +instance Monad m => Scoped (InferT s m) (Judgment s) (InferT s m) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(InferT s m) @(Judgment s) pushScopes = pushScopesReader - lookupVar = lookupVarReader + askLookupVar = lookupVarReader diff --git a/src/Nix/Utils/Fix1.hs b/src/Nix/Utils/Fix1.hs index 2595fefb6..4f853e66b 100644 --- a/src/Nix/Utils/Fix1.hs +++ b/src/Nix/Utils/Fix1.hs @@ -29,6 +29,7 @@ import Control.Monad.Catch ( MonadCatch import Control.Monad.Reader ( MonadReader ) import Control.Monad.State ( MonadState ) + -- | The fixpoint combinator, courtesy of Gregory Malecha. -- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced newtype Fix1 (t :: (k -> *) -> k -> *) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a } @@ -64,7 +65,6 @@ deriving instance MonadMask (t (Fix1T t m) m) => MonadMask (Fix1T t m) deriving instance MonadReader e (t (Fix1T t m) m) => MonadReader e (Fix1T t m) deriving instance MonadState s (t (Fix1T t m) m) => MonadState s (Fix1T t m) - type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where @@ -73,10 +73,8 @@ instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where readRef = lift . readRef writeRef r = lift . writeRef r - instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where atomicModifyRef r = lift . atomicModifyRef r - {- newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a } diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index 591526431..ddb654028 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -5,12 +5,14 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} @@ -179,13 +181,13 @@ type MonadDataContext f (m :: * -> *) -- | At the time of constructor, the expected arguments to closures are values -- that may contain thunks. The type of such thunks are fixed at that time. -newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) } +newtype NValue' f m a = NValue { _nValue :: f (NValueF (NValue f m) m a) } deriving (Generic, Typeable, Functor, Foldable, Eq1) -instance (Comonad f, Show a) => Show (NValue' t f m a) where +instance (Comonad f, Show a) => Show (NValue' f m a) where show (NValue (extract -> v)) = show v -instance Comonad f => Show1 (NValue' t f m) where +instance Comonad f => Show1 (NValue' f m) where liftShowsPrec sp sl p = \case NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom NVStr' ns -> @@ -200,8 +202,8 @@ instance Comonad f => Show1 (NValue' t f m) where 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) + -> NValue' f m (n a) + -> n (NValue' f m a) sequenceNValue' transform (NValue v) = NValue <$> traverse (sequenceNValueF transform) v @@ -209,91 +211,91 @@ 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) + -> NValue' f m a + -> n (NValue' f m b) bindNValue' transform f (NValue v) = NValue <$> traverse (bindNValueF transform f) v hoistNValue' - :: (Functor m, Functor n, Functor f) + :: (Functor m, Functor n, Functor f, Thunk m ~ Thunk n) => (forall x . n x -> m x) -> (forall x . m x -> n x) - -> NValue' t f m a - -> NValue' t f n a + -> NValue' f m a + -> NValue' f n a hoistNValue' run lft (NValue v) = NValue $ lmapNValueF (hoistNValue lft run) . hoistNValueF lft <$> v liftNValue' - :: (MonadTrans u, Monad m, Functor (u m), Functor f) + :: (MonadTrans u, Monad m, Functor (u m), Functor f, Thunk m ~ Thunk (u m)) => (forall x . u m x -> m x) - -> NValue' t f m a - -> NValue' t f (u m) a + -> NValue' f m a + -> NValue' f (u m) a liftNValue' run = hoistNValue' run lift unliftNValue' - :: (MonadTrans u, Monad m, Functor (u m), Functor f) + :: (MonadTrans u, Monad m, Functor (u m), Functor f, Thunk m ~ Thunk (u m)) => (forall x . u m x -> m x) -- aka "run" - -> NValue' t f (u m) a - -> NValue' t f m a + -> NValue' f (u m) a + -> NValue' f m a unliftNValue' = hoistNValue' lift iterNValue' - :: forall t f m a r + :: forall 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 + => (a -> (NValue' f m a -> r) -> r) + -> (NValue' f m r -> r) + -> NValue' f m a -> r iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f)) --- | A 'NValue t f m' is +-- | A 'NValue f m' is -- a value in head normal form, where only the "top layer" has been --- evaluated. An action of type 'm (NValue t f m)' is a pending evaluation that --- has yet to be performed. An 't' is either a pending evaluation, or --- a value in head normal form. +-- evaluated. An action of type 'm (NValue f m)' is a pending evaluation that +-- has yet to be performed. -- -- The 'Free' structure is used here to represent the possibility that -- cycles may appear during normalization. -type NValue t f m = Free (NValue' t f m) t +--TODO: What does the `f` represent +type NValue f m = Free (NValue' f m) (Thunk m) hoistNValue - :: (Functor m, Functor n, Functor f) + :: (Functor m, Functor n, Functor f, Thunk m ~ Thunk n) => (forall x . n x -> m x) -> (forall x . m x -> n x) - -> NValue t f m - -> NValue t f n + -> NValue f m + -> NValue f n hoistNValue run lft = hoistFree (hoistNValue' run lft) liftNValue - :: (MonadTrans u, Monad m, Functor (u m), Functor f) + :: (MonadTrans u, Monad m, Functor (u m), Functor f, Thunk m ~ Thunk (u m)) => (forall x . u m x -> m x) - -> NValue t f m - -> NValue t f (u m) + -> NValue f m + -> NValue f (u m) liftNValue run = hoistNValue run lift unliftNValue - :: (MonadTrans u, Monad m, Functor (u m), Functor f) + :: (MonadTrans u, Monad m, Functor (u m), Functor f, Thunk m ~ Thunk (u m)) => (forall x . u m x -> m x) -- aka "run" - -> NValue t f (u m) - -> NValue t f m + -> NValue f (u m) + -> NValue f m unliftNValue = hoistNValue lift iterNValue - :: forall t f m r + :: forall f m r . MonadDataContext f m - => (t -> (NValue t f m -> r) -> r) - -> (NValue' t f m r -> r) - -> NValue t f m + => (Thunk m -> (NValue f m -> r) -> r) + -> (NValue' f m r -> r) + -> NValue f m -> r iterNValue k f = iter f . fmap (\t -> k t (iterNValue k f)) iterNValueM :: (MonadDataContext f m, Monad n) => (forall x . n x -> m x) - -> (t -> (NValue t f m -> n r) -> n r) - -> (NValue' t f m (n r) -> n r) - -> NValue t f m + -> (Thunk m -> (NValue f m -> n r) -> n r) + -> (NValue' f m (n r) -> n r) + -> NValue f m -> n r iterNValueM transform k f = iterM f <=< go . fmap (\t -> k t (iterNValueM transform k f)) @@ -303,95 +305,95 @@ iterNValueM transform k f = pattern NVThunk t <- Pure t -nvThunk :: Applicative f => t -> NValue t f m +nvThunk :: Applicative f => Thunk m -> NValue f m nvThunk = Pure pattern NVConstant' x <- NValue (extract -> NVConstantF x) pattern NVConstant x <- Free (NVConstant' x) -nvConstant' :: Applicative f => NAtom -> NValue' t f m r +nvConstant' :: Applicative f => NAtom -> NValue' f m r nvConstant' = NValue . pure . NVConstantF -nvConstant :: Applicative f => NAtom -> NValue t f m +nvConstant :: Applicative f => NAtom -> NValue f m nvConstant = Free . nvConstant' pattern NVStr' ns <- NValue (extract -> NVStrF ns) pattern NVStr ns <- Free (NVStr' ns) -nvStr' :: Applicative f => NixString -> NValue' t f m r +nvStr' :: Applicative f => NixString -> NValue' f m r nvStr' = NValue . pure . NVStrF -nvStr :: Applicative f => NixString -> NValue t f m +nvStr :: Applicative f => NixString -> NValue f m nvStr = Free . nvStr' pattern NVPath' x <- NValue (extract -> NVPathF x) pattern NVPath x <- Free (NVPath' x) -nvPath' :: Applicative f => FilePath -> NValue' t f m r +nvPath' :: Applicative f => FilePath -> NValue' f m r nvPath' = NValue . pure . NVPathF -nvPath :: Applicative f => FilePath -> NValue t f m +nvPath :: Applicative f => FilePath -> NValue f m nvPath = Free . nvPath' pattern NVList' l <- NValue (extract -> NVListF l) pattern NVList l <- Free (NVList' l) -nvList' :: Applicative f => [r] -> NValue' t f m r +nvList' :: Applicative f => [r] -> NValue' f m r nvList' = NValue . pure . NVListF -nvList :: Applicative f => [NValue t f m] -> NValue t f m +nvList :: Applicative f => [NValue f m] -> NValue f m nvList = Free . nvList' pattern NVSet' s x <- NValue (extract -> NVSetF s x) pattern NVSet s x <- Free (NVSet' s x) nvSet' :: Applicative f - => HashMap Text r -> HashMap Text SourcePos -> NValue' t f m r + => HashMap Text r -> HashMap Text SourcePos -> NValue' f m r nvSet' s x = NValue $ pure $ NVSetF s x nvSet :: Applicative f - => HashMap Text (NValue t f m) -> HashMap Text SourcePos -> NValue t f m + => HashMap Text (NValue f m) -> HashMap Text SourcePos -> NValue f m nvSet s x = Free $ nvSet' s x pattern NVClosure' x f <- NValue (extract -> NVClosureF x f) pattern NVClosure x f <- Free (NVClosure' x f) nvClosure' :: (Applicative f, Functor m) - => Params () -> (NValue t f m -> m r) -> NValue' t f m r + => Params () -> (NValue f m -> m r) -> NValue' f m r nvClosure' x f = NValue $ pure $ NVClosureF x f nvClosure :: (Applicative f, Functor m) - => Params () -> (NValue t f m -> m (NValue t f m)) -> NValue t f m + => Params () -> (NValue f m -> m (NValue f m)) -> NValue f m nvClosure x f = Free $ nvClosure' x f pattern NVBuiltin' name f <- NValue (extract -> NVBuiltinF name f) pattern NVBuiltin name f <- Free (NVBuiltin' name f) nvBuiltin' :: (Applicative f, Functor m) - => String -> (NValue t f m -> m r) -> NValue' t f m r + => String -> (NValue f m -> m r) -> NValue' 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 + => String -> (NValue f m -> m (NValue f m)) -> NValue f m nvBuiltin name f = Free $ nvBuiltin' name f builtin - :: forall m f t - . (MonadThunk t m (NValue t f m), MonadDataContext f m) + :: forall m f + . (MonadThunk m, ThunkValue m ~ NValue f m, MonadDataContext f m) => String - -> (NValue t f m -> m (NValue t f m)) - -> m (NValue t f m) + -> (NValue f m -> m (NValue f m)) + -> m (NValue f m) builtin name f = pure $ nvBuiltin name $ \a -> f a builtin2 - :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + :: (MonadThunk m, ThunkValue m ~ NValue f m, MonadDataContext f m) => String - -> (NValue t f m -> NValue t f m -> m (NValue t f m)) - -> m (NValue t f m) + -> (NValue f m -> NValue f m -> m (NValue f m)) + -> m (NValue 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) + :: (MonadThunk m, ThunkValue m ~ NValue f m, MonadDataContext f m) => String - -> ( NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) + -> ( NValue f m + -> NValue f m + -> NValue f m + -> m (NValue f m) ) - -> m (NValue t f m) + -> m (NValue f m) builtin3 name f = builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c @@ -445,31 +447,31 @@ describeValue = \case TPath -> "a path" TBuiltin -> "a builtin function" -showValueType :: (MonadThunk t m (NValue t f m), Comonad f) - => NValue t f m -> m String +showValueType :: (MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m, Comonad f) + => NValue 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 t - | ConcerningValue (NValue t f m) - | Comparison (NValue t f m) (NValue t f m) - | Addition (NValue t f m) (NValue t f m) - | Multiplication (NValue t f m) (NValue t f m) - | Division (NValue t f m) (NValue t f m) +data ValueFrame f m + = ForcingThunk (Thunk m) + | ConcerningValue (NValue f m) + | Comparison (NValue f m) (NValue f m) + | Addition (NValue f m) (NValue f m) + | Multiplication (NValue f m) (NValue f m) + | Division (NValue f m) (NValue f m) | Coercion ValueType ValueType - | CoercionToJson (NValue t f m) + | CoercionToJson (NValue f m) | CoercionFromJson A.Value - | Expectation ValueType (NValue t f m) + | Expectation ValueType (NValue f m) deriving Typeable -deriving instance (Comonad f, Show t) => Show (ValueFrame t f m) +deriving instance (Comonad f, Show (Thunk m)) => Show (ValueFrame f m) -type MonadDataErrorContext t f m - = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m) +type MonadDataErrorContext f m + = (Show (Thunk m), Typeable (Thunk m), Typeable m, Typeable f, MonadDataContext f m) -instance MonadDataErrorContext t f m => Exception (ValueFrame t f m) +instance MonadDataErrorContext f m => Exception (ValueFrame f m) $(makeTraversals ''NValueF) $(makeLenses ''NValue') @@ -477,5 +479,5 @@ $(makeLenses ''NValue') key :: (Traversable f, Applicative g) => VarName - -> LensLike' g (NValue' t f m a) (Maybe a) + -> LensLike' g (NValue' f m a) (Maybe a) key k = nValue . traverse . _NVSetF . _1 . hashAt k diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs index 6a54c1feb..9b14c5e97 100644 --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -41,9 +41,9 @@ import Nix.Utils import Nix.Value checkComparable - :: (Framed e m, MonadDataErrorContext t f m) - => NValue t f m - -> NValue t f m + :: (Framed e m, MonadDataErrorContext f m) + => NValue f m + -> NValue f m -> m () checkComparable x y = case (x, y) of (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () @@ -145,9 +145,9 @@ compareAttrSets f eq lm rm = runIdentity valueEqM :: forall t f m - . (MonadThunk t m (NValue t f m), Comonad f) - => NValue t f m - -> NValue t f m + . (MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m, Comonad f) + => NValue f m + -> NValue f m -> m Bool valueEqM ( Pure x) ( Pure y) = thunkEqM x y valueEqM ( Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y) @@ -162,10 +162,10 @@ valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) = NVStr' s -> pure $ Just s _ -> pure Nothing -thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool +thunkEqM :: (MonadThunk m, Thunk m ~ t, ThunkValue m ~ NValue f m, Comonad f) => t -> t -> m Bool thunkEqM lt rt = force lt $ \lv -> force rt $ \rv -> let unsafePtrEq = case (lt, rt) of - (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True + (lid, rid) | lid == rid -> pure True _ -> valueEqM lv rv in case (lv, rv) of (NVClosure _ _, NVClosure _ _) -> unsafePtrEq diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs index 7ab4ae660..f098ffb73 100644 --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -15,7 +15,7 @@ import Nix.String import Nix.Value import Text.XML.Light -toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString +toXML :: forall f m . MonadDataContext f m => NValue f m -> NixString toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi where cyc = pure $ mkElem "string" "value" "" @@ -27,7 +27,7 @@ toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi . ppElement . (\e -> Element (unqual "expr") [] [Elem e] Nothing) - phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element + phi :: NValue' f m (WithStringContext Element) -> WithStringContext Element phi = \case NVConstant' a -> case a of NURI t -> pure $ mkElem "string" "value" (Text.unpack t) diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs index c479eeb99..76a77218e 100644 --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -21,7 +21,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Time import GHC.Exts -import Nix.Lint +--import Nix.Lint import Nix.Options import Nix.Options.Parser import Nix.Parser @@ -115,7 +115,7 @@ assertParseFail opts file = do catch (case eres of Success expr -> do - _ <- pure $! runST $ void $ lint opts expr + -- _ <- pure $! runST $ void $ lint opts expr assertFailure $ "Unexpected success parsing `" ++ file diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs index f0042f18b..1d57444bd 100644 --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -7,14 +7,17 @@ module TestCommon where import Control.Monad.Catch import Control.Monad.IO.Class +import Data.Functor.Identity import Data.Text ( Text , unpack ) import Data.Time import Nix +import Nix.Cited +import Nix.Context import Nix.Exec ( ) import Nix.Standard -import Nix.Fresh.Basic +import Nix.Fresh.Stable import System.Environment import System.IO import System.Posix.Files @@ -22,7 +25,7 @@ import System.Posix.Temp import System.Process import Test.Tasty.HUnit -hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT (StdIdT IO))) +hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT IO)) hnixEvalFile opts file = do parseResult <- parseNixFileLoc file case parseResult of @@ -36,11 +39,11 @@ hnixEvalFile opts file = do NixException frames -> errorWithoutStackTrace . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) + =<< renderFrames @(StdValue (StandardT IO)) -- (StdValue (StandardT (FreshStableIdT IO))) + @(StdThunk (StandardT IO) IO) -- (StdThunk (StandardT (FreshStableIdT IO))) frames -hnixEvalText :: Options -> Text -> IO (StdValue (StandardT (StdIdT IO))) +hnixEvalText :: Options -> Text -> IO (NValue Identity (StandardT IO)) -- (StdValue (StandardT (FreshStableIdT IO))) hnixEvalText opts src = case parseNixText src of Failure err -> error @@ -49,7 +52,7 @@ hnixEvalText opts src = case parseNixText src of ++ "`.\n" ++ show err Success expr -> - runWithBasicEffects opts $ normalForm =<< nixEvalExpr Nothing expr + runWithBasicEffects opts $ normalForm =<< nixEvalExpr @Context @_ @(StandardT IO) Nothing expr nixEvalString :: String -> IO String nixEvalString expr = do