picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Merge pull request #478 from haskell-nix/johnw/data-abstract

Browse source 
Abstract the core value representation further
This commit is contained in:
John Wiegley 2019-03-16 21:44:53 -07:00 committed by GitHub
parent 107f29d3fd 954e201408
commit 767ebe4ea1
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
32 changed files with 1910 additions and 1228 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
README-design.md Normal file
View file

@ -0,0 +1,37 @@
# Design of the hnix code base
Welcome to the hnix code! You may notice some strange things as you venture
into this realm, so this document is meant to prepare you, dear reader, for
the secrets of the labyrinth as we've designed them.
The first thing to note is that hnix was primarily designed so that Haskell
authors could use it to craft custom tooling around the Nix ecosystem. Thus,
it was never fully intended for just the end user. As a result, we use a great
deal of abstraction so that these enterprising Haskell authors may inject
their own behavior at various points within the type hierarchy, the value
representation, and the behavior of the evaluator.
To this end, you'll see a lot of type variables floating around, almost
everywhere. These provide many of the "injection points" mentioned above.
There is a strict convention followed for the naming of these variables, the
lexicon for which is stated here.
`t` is the type of thunks. It turns out that hnix dosen't actually need to
know how thunks are represented, at all. It only needs to know that the
interface can be honored: pending action that yield values may be turned into
thunks, and thunks can later be forced into values.
`f` is the type of a comonadic and applicative functor that gets injected at
every level of a value's recursive structure. In the standard evaluation
scheme, this is used to provide "provenance" information to track which
expression context a value originated from (e.g., this 10 came from that
expression "5 + 5" over in this file, here).
`m` is the "monad of evaluation", which must support at least the features
required by the evaluator. The fact that the user can evaluate in his own base
monad makes it possible to create custom builtins that make use of arbitrary
effects.
`v` is the type of values, which is almost always going to be `NValue t f m`,
though it could be `NValueNF t f m`, the type of normal form values. Very few
points in the code are generic over both.

7
hnix.cabal
View file

@ -439,6 +439,7 @@ library
Nix.Atoms
Nix.Builtins
Nix.Cache
Nix.Cited
Nix.Context
Nix.Convert
Nix.Effects
@ -465,6 +466,7 @@ library
Nix.TH
Nix.Thunk
Nix.Thunk.Basic
Nix.Thunk.Standard
Nix.Type.Assumption
Nix.Type.Env
Nix.Type.Infer
@ -484,6 +486,7 @@ library
, base >=4.9 && <5
, binary
, bytestring
, comonad
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
@ -502,6 +505,7 @@ library
, lens-family-th
, logict
, megaparsec >=7.0 && <7.1
, monad-control
, monadlist
, mtl
, optparse-applicative
@ -520,6 +524,7 @@ library
, these
, time
, transformers
, transformers-base
, unix
, unordered-containers >=0.2.9 && <0.3
, vector
@ -572,6 +577,7 @@ executable hnix
aeson
, base >=4.9 && <5
, bytestring
, comonad
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
@ -584,6 +590,7 @@ executable hnix
, optparse-applicative
, pretty-show
, prettyprinter
, ref-tf
, repline
, template-haskell
, text

29
main/Main.hs
View file

@ -26,12 +26,14 @@ import qualified Data.Text.Lazy.IO as TL
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text
import Nix
import Nix.Cited
import Nix.Convert
import qualified Nix.Eval as Eval
import Nix.Json
-- import Nix.Lint
import Nix.Options.Parser
import Nix.Thunk.Basic
import Nix.Thunk.Standard
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import Nix.Utils
@ -46,7 +48,7 @@ main :: IO ()
main = do
time <- liftIO getCurrentTime
opts <- execParser (nixOptionsInfo time)
runLazyM opts $ case readFrom opts of
runStdLazyM opts $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
@ -93,7 +95,7 @@ main = do
catch (process opts mpath expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames @(NThunk (Lazy IO)) frames
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
when (repl opts) $
withNixContext Nothing $ Repl.main
@ -135,13 +137,15 @@ main = do
. prettyNix
. stripAnnotation $ expr
where
printer :: forall e m. (MonadNix e m, MonadIO m, Typeable m)
=> NValue m -> m ()
printer
| finder opts =
fromValue @(AttrSet (NThunk m)) >=> findAttrs
fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
| xml opts =
liftIO . putStrLn . Text.unpack . principledStringIgnoreContext . toXML <=< normalForm
liftIO . putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts =
liftIO . Text.putStrLn
. principledStringIgnoreContext
@ -157,12 +161,12 @@ main = do
where
go prefix s = do
xs <- forM (sortOn fst (M.toList s))
$ \(k, nv@(NThunk (NCited _ t))) -> case t of
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar ref
val <- readVar @(StdLazy IO) ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k,) <$> forceEntry path nv
@ -176,7 +180,8 @@ main = do
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ -> go (path ++ ".") s'
NVSet s' _ ->
go (path ++ ".") s'
_ -> return ()
where
filterEntry path k = case (path, k) of
@ -202,7 +207,7 @@ main = do
. ("Exception forcing " ++)
. (k ++)
. (": " ++) . show
=<< renderFrames @(NThunk (Lazy IO)) frames
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
return Nothing
reduction path mp x = do
@ -212,8 +217,8 @@ main = do
handleReduced :: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue m))
-> m (NValue m)
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path

49
main/Repl.hs
View file

@ -23,6 +23,8 @@
module Repl where
import Nix hiding (exec, try)
import Nix.Builtins (MonadBuiltins)
import Nix.Cited
import Nix.Convert
import Nix.Eval
import Nix.Scope
@ -30,6 +32,7 @@ import qualified Nix.Type.Env as Env
import Nix.Type.Infer
import Nix.Utils
import Control.Comonad
import qualified Data.HashMap.Lazy as M
import Data.List (isPrefixOf, foldl')
import qualified Data.Map as Map
@ -51,7 +54,7 @@ import System.Environment
import System.Exit
main :: (MonadNix e m, MonadIO m, MonadException m) => m ()
main :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => m ()
main = flip evalStateT initState $
#if MIN_VERSION_repline(0, 2, 0)
evalRepl (return prefix) cmd options (Just ':') completer welcomeText
@ -66,15 +69,15 @@ main = flip evalStateT initState $
-- Types
-------------------------------------------------------------------------------
newtype IState m = IState
{ tmctx :: AttrSet (NValue m) -- Value environment
newtype IState t f m = IState
{ tmctx :: AttrSet (NValue t f m) -- Value environment
}
initState :: MonadIO m => IState m
initState :: MonadIO m => IState t f m
initState = IState M.empty
type Repl e m = HaskelineT (StateT (IState m) m)
hoistErr :: MonadIO m => Result a -> Repl e m a
type Repl e t f m = HaskelineT (StateT (IState t f m) m)
hoistErr :: MonadIO m => Result a -> Repl e t f m a
hoistErr (Success val) = return val
hoistErr (Failure err) = do
liftIO $ print err
@ -84,8 +87,8 @@ hoistErr (Failure err) = do
-- Execution
-------------------------------------------------------------------------------
exec :: forall e m. (MonadNix e m, MonadIO m, MonadException m)
=> Bool -> Text.Text -> Repl e m (NValue m)
exec :: forall e t f m. (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> Bool -> Text.Text -> Repl e t f m (NValue t f m)
exec update source = do
-- Get the current interpreter state
st <- get
@ -98,11 +101,12 @@ exec update source = do
-- tyctx' <- hoistErr $ inferTop (tyctx st) expr
-- TODO: track scope with (tmctx st)
mVal <- lift $ lift $ try $ pushScope @(NThunk m) M.empty (evalExprLoc expr)
mVal <- lift $ lift $ try $ pushScope @t M.empty (evalExprLoc expr)
case mVal of
Left (NixException frames) -> do
lift $ lift $ liftIO . print =<< renderFrames @(NThunk m) frames
lift $ lift $ liftIO . print
=<< renderFrames @(NValue t f m) @t frames
abort
Right val -> do
-- Update the interpreter state
@ -113,7 +117,7 @@ exec update source = do
return val
cmd :: (MonadNix e m, MonadIO m, MonadException m) => String -> Repl e m ()
cmd :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => String -> Repl e t f m ()
cmd source = do
val <- exec True (Text.pack source)
lift $ lift $ do
@ -129,31 +133,31 @@ cmd source = do
-------------------------------------------------------------------------------
-- :browse command
browse :: MonadNix e m => [String] -> Repl e m ()
browse :: MonadBuiltins e t f m => [String] -> Repl e t f m ()
browse _ = do
st <- get
undefined
-- liftIO $ mapM_ putStrLn $ ppenv (tyctx st)
-- :load command
load :: (MonadNix e m, MonadIO m, MonadException m) => [String] -> Repl e m ()
load :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => [String] -> Repl e t f m ()
load args = do
contents <- liftIO $ Text.readFile (unwords args)
void $ exec True contents
-- :type command
typeof :: (MonadNix e m, MonadException m, MonadIO m) => [String] -> Repl e m ()
typeof :: (MonadBuiltins e t f m, MonadException m, MonadIO m) => [String] -> Repl e t f m ()
typeof args = do
st <- get
val <- case M.lookup line (tmctx st) of
Just val -> return val
Nothing -> exec False line
liftIO $ putStrLn $ describeValue . valueType . _cited . _nValue $ val
liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val
where
line = Text.pack (unwords args)
-- :quit command
quit :: (MonadNix e m, MonadIO m) => a -> Repl e m ()
quit :: (MonadBuiltins e t f m, MonadIO m) => a -> Repl e t f m ()
quit _ = liftIO exitSuccess
-------------------------------------------------------------------------------
@ -175,8 +179,8 @@ comp n = do
-- let defs = map unpack $ Map.keys ctx
return $ filter (isPrefixOf n) (cmds {-++ defs-})
options :: (MonadNix e m, MonadIO m, MonadException m)
=> [(String, [String] -> Repl e m ())]
options :: (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [(String, [String] -> Repl e t f m ())]
options = [
("load" , load)
--, ("browse" , browse)
@ -185,11 +189,12 @@ options = [
, ("help" , help)
]
help :: forall e m . (MonadNix e m, MonadIO m, MonadException m)
=> [String] -> Repl e m ()
help :: forall e t f m . (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [String] -> Repl e t f m ()
help _ = liftIO $ do
putStrLn "Available commands:\n"
mapM_ putStrLn $ map (\o -> ":" ++ (fst o)) (options @e @m)
mapM_ putStrLn $ map (\o -> ":" ++ (fst o)) (options @e @t @f @m)
completer :: (MonadNix e m, MonadIO m) => CompleterStyle (StateT (IState m) m)
completer :: (MonadBuiltins e t f m, MonadIO m)
=> CompleterStyle (StateT (IState t f m) m)
completer = Prefix (wordCompleter comp) defaultMatcher

41
src/Nix.hs
View file

@ -24,7 +24,6 @@ module Nix (module Nix.Cache,
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Free
import Control.Monad.Reader
import Data.Fix
import qualified Data.HashMap.Lazy as M
@ -51,20 +50,20 @@ import Nix.XML
-- | This is the entry point for all evaluations, whatever the expression tree
-- type. It sets up the common Nix environment and applies the
-- transformations, allowing them to be easily composed.
nixEval :: (MonadNix e m, Has e Options, Functor f)
=> Maybe FilePath -> Transform f (m a) -> Alg f (m a) -> Fix f -> m a
nixEval :: (MonadBuiltins e t f m, Has e Options, Functor g)
=> Maybe FilePath -> Transform g (m a) -> Alg g (m a) -> Fix g -> m a
nixEval mpath xform alg = withNixContext mpath . adi alg xform
-- | Evaluate a nix expression in the default context
nixEvalExpr :: forall e m. (MonadNix e m, Has e Options)
=> Maybe FilePath -> NExpr -> m (NValue m)
nixEvalExpr :: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath -> NExpr -> m (NValue t f m)
nixEvalExpr mpath = nixEval mpath id Eval.eval
-- | Evaluate a nix expression in the default context
nixEvalExprLoc :: forall e m. (MonadNix e m, Has e Options)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixEvalExprLoc :: forall e t f m. (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
nixEvalExprLoc mpath =
nixEval mpath (Eval.addStackFrames @(NThunk m) . Eval.addSourcePositions)
nixEval mpath (Eval.addStackFrames @t . Eval.addSourcePositions)
(Eval.eval . annotated . getCompose)
-- | Evaluate a nix expression with tracing in the default context. Note that
@ -73,15 +72,15 @@ nixEvalExprLoc mpath =
-- 'MonadNix'). All this function does is provide the right type class
-- context.
nixTracingEvalExprLoc
:: forall e m. (MonadNix e m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
evaluateExpression
:: (MonadNix e m, Has e Options)
:: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue m))
-> (NValue m -> m a)
-> (Maybe FilePath -> NExprLoc -> m (NValue t f m))
-> (NValue t f m -> m a)
-> NExprLoc
-> m a
evaluateExpression mpath evaluator handler expr = do
@ -97,27 +96,29 @@ evaluateExpression mpath evaluator handler expr = do
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = embed $ Free $ NVSetF (M.fromList args) mempty
argmap args = pure $ nvSet (M.fromList args') mempty
where
args' = map (fmap (wrapValue . nValueFromNF)) args
compute ev x args p = do
f <- ev mpath x
f :: NValue t f m <- ev mpath x
processResult p =<< case f of
NVClosure _ g -> g args
NVClosure _ g -> force ?? pure =<< g args
_ -> pure f
processResult :: forall e m a. (MonadNix e m, Has e Options)
=> (NValue m -> m a) -> NValue m -> m a
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 -> m a
processResult h val = do
opts :: Options <- asks (view hasLens)
case attr opts of
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue m -> m a
go :: [Text.Text] -> NValue t f m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")):ks) v = case v of
NVList xs -> case ks of
[] -> force @(NValue m) @(NThunk m) (xs !! n) h
[] -> force @t @m @(NValue t f m) (xs !! n) h
_ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $
"Expected a list for selector '" ++ show n

388
src/Nix/Builtins.hs
View file

@ -21,7 +21,7 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Builtins (withNixContext, builtins) where
module Nix.Builtins (MonadBuiltins, withNixContext, builtins) where
import Control.Monad
import Control.Monad.Catch
@ -32,7 +32,7 @@ import Control.Monad.Reader (asks)
-- us to put the hashing package in the unconditional dependency list.
-- See https://github.com/NixOS/cabal2nix/issues/348 for more info
#if MIN_VERSION_hashing(0, 1, 0)
import Crypto.Hash
import "hashing" Crypto.Hash
import qualified "hashing" Crypto.Hash.MD5 as MD5
import qualified "hashing" Crypto.Hash.SHA1 as SHA1
import qualified "hashing" Crypto.Hash.SHA256 as SHA256
@ -95,25 +95,41 @@ import System.Posix.Files (isRegularFile, isDirectory, isSymbolicLink)
import Text.Read
import Text.Regex.TDFA
-- | This constraint synonym establishes all the ways in which we must be able
-- to relate different Haskell values to the thunk representation that will
-- be chosen by the caller.
type MonadBuiltins e t f m =
( MonadNix e t f m
, FromValue NixString m t
, FromValue Path m t
, FromValue [t] m t
, FromValue (M.HashMap Text t) m t
, ToValue NixString m t
, ToValue Int m t
, ToValue () m t
, FromNix [NixString] m t
, ToNix t m (NValue t f m)
)
-- | Evaluate a nix expression in the default context
withNixContext :: forall e m r. (MonadNix e m, Has e Options)
withNixContext :: forall e t f m r. (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath -> m r -> m r
withNixContext mpath action = do
base <- builtins
opts :: Options <- asks (view hasLens)
let i = wrapValue @(NValue m) @(NThunk m) @m $ nvList $
map (wrapValue @(NValue m) @(NThunk m) @m
let i = wrapValue @t @m @(NValue t f m) $ nvList $
map (wrapValue @t @m @(NValue t f m)
. nvStr . hackyMakeNixStringWithoutContext . Text.pack) (include opts)
pushScope (M.singleton "__includes" i) $
pushScopes base $ case mpath of
Nothing -> action
Just path -> do
traceM $ "Setting __cur_file = " ++ show path
let ref = wrapValue @(NValue m) @(NThunk m) @m $ nvPath path
let ref = wrapValue @t @m @(NValue t f m) $ nvPath path
pushScope (M.singleton "__cur_file" ref) action
builtins :: (MonadNix e m, Scoped (NThunk m) m)
=> m (Scopes m (NThunk m))
builtins :: (MonadBuiltins e t f m, Scoped t m)
=> m (Scopes m t)
builtins = do
ref <- thunk $ flip nvSet M.empty <$> buildMap
lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins
@ -129,18 +145,18 @@ builtins = do
Builtin TopLevel ("__" <> name, builtin)
data BuiltinType = Normal | TopLevel
data Builtin m = Builtin
data Builtin t = Builtin
{ _kind :: BuiltinType
, mapping :: (Text, NThunk m)
, mapping :: (Text, t)
}
valueThunk :: forall e m. MonadNix e m => NValue m -> NThunk m
valueThunk = wrapValue @_ @_ @m
valueThunk :: forall e t f m. MonadBuiltins e t f m => NValue t f m -> t
valueThunk = wrapValue @_ @m
force' :: forall e m. MonadNix e m => NThunk m -> m (NValue m)
force' :: forall e t f m. MonadBuiltins e t f m => t -> m (NValue t f m)
force' = force ?? pure
builtinsList :: forall e m. MonadNix e m => m [ Builtin m ]
builtinsList :: forall e t f m. MonadBuiltins e t f m => m [Builtin t]
builtinsList = sequence [
do version <- toValue (principledMakeNixStringWithoutContext "2.0")
pure $ Builtin Normal ("nixVersion", version)
@ -288,12 +304,12 @@ 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' :: ToBuiltin m a => BuiltinType -> Text -> a -> m (Builtin m)
add' :: ToBuiltin t f m a => BuiltinType -> Text -> a -> m (Builtin t)
add' t n v = wrap t n <$> mkThunk n (toBuiltin (Text.unpack n) v)
-- Primops
foldNixPath :: forall e m r. MonadNix e m
foldNixPath :: forall e t f m r. MonadBuiltins e t f m
=> (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) -> r -> m r
foldNixPath f z = do
mres <- lookupVar "__includes"
@ -313,7 +329,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 m => m (NValue m)
nixPath :: MonadBuiltins e t f m => m (NValue t f m)
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest ->
pure $ valueThunk
(flip nvSet mempty $ M.fromList
@ -323,33 +339,33 @@ nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest ->
, ("prefix", valueThunk $
nvStr (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn))) ]) : rest
toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
toString str = str >>= coerceToString DontCopyToStore CoerceAny >>= toNix
hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
hasAttr x y =
fromValue x >>= fromStringNoContext >>= \key ->
fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) ->
fromValue @(AttrSet t, AttrSet SourcePos) y >>= \(aset, _) ->
toNix $ M.member key aset
attrsetGet :: MonadNix e m => Text -> AttrSet t -> m t
attrsetGet :: MonadBuiltins e t f m => Text -> AttrSet t -> m t
attrsetGet k s = case M.lookup k s of
Just v -> pure v
Nothing ->
throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required"
hasContext :: MonadNix e m => m (NValue m) -> m (NValue m)
hasContext :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
hasContext =
toNix . stringHasContext <=< fromValue
getAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
getAttr :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
getAttr x y =
fromValue x >>= fromStringNoContext >>= \key ->
fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) ->
fromValue @(AttrSet t, AttrSet SourcePos) y >>= \(aset, _) ->
attrsetGet key aset >>= force'
unsafeGetAttrPos :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
unsafeGetAttrPos :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr ns, NVSet _ apos) -> case M.lookup (hackyStringIgnoreContext ns) apos of
Nothing -> pure $ nvConstant NNull
@ -359,10 +375,10 @@ unsafeGetAttrPos x y = x >>= \x' -> 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 m. MonadNix e m => m (NValue m) -> m (NValue m)
length_ = toValue . (length :: [NThunk m] -> Int) <=< fromValue
length_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
length_ = toValue . (length :: [t] -> Int) <=< fromValue
add_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
add_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
add_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVConstant (NInt x), NVConstant (NInt y)) ->
toNix ( x + y :: Integer)
@ -372,7 +388,7 @@ add_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(_, _) ->
throwError $ Addition x' y'
mul_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
mul_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
mul_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVConstant (NInt x), NVConstant (NInt y)) ->
toNix ( x * y :: Integer)
@ -382,7 +398,7 @@ mul_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(_, _) ->
throwError $ Multiplication x' y'
div_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
div_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 ->
toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer)
@ -402,7 +418,7 @@ anyM p (x:xs) = do
if q then return True
else anyM p xs
any_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
any_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
any_ fun xs = fun >>= \f ->
toNix <=< anyM fromValue <=< mapM ((f `callFunc`) . force')
<=< fromValue $ xs
@ -414,24 +430,24 @@ allM p (x:xs) = do
if q then allM p xs
else return False
all_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
all_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
all_ fun xs = fun >>= \f ->
toNix <=< allM fromValue <=< mapM ((f `callFunc`) . force')
<=< fromValue $ xs
foldl'_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
foldl'_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
foldl'_ fun z xs =
fun >>= \f -> fromValue @[NThunk m] xs >>= foldl' (go f) z
fun >>= \f -> fromValue @[t] xs >>= foldl' (go f) z
where
go f b a = f `callFunc` b >>= (`callFunc` force' a)
head_ :: MonadNix e m => m (NValue m) -> m (NValue m)
head_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
head_ = fromValue >=> \case
[] -> throwError $ ErrorCall "builtins.head: empty list"
h:_ -> force' h
tail_ :: MonadNix e m => m (NValue m) -> m (NValue m)
tail_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
tail_ = fromValue >=> \case
[] -> throwError $ ErrorCall "builtins.tail: empty list"
_:t -> return $ nvList t
@ -459,7 +475,11 @@ splitVersion s = case Text.uncons s of
| h `elem` versionComponentSeparators -> splitVersion t
| isDigit h ->
let (digits, rest) = Text.span isDigit s
in VersionComponent_Number (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) $ readMaybe $ Text.unpack digits) : splitVersion rest
in VersionComponent_Number
(fromMaybe (error $ "splitVersion: couldn't parse " <> show digits)
$ readMaybe
$ Text.unpack digits)
: splitVersion rest
| otherwise ->
let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s
thisComponent = case chars of
@ -467,10 +487,12 @@ splitVersion s = case Text.uncons s of
x -> VersionComponent_String x
in thisComponent : splitVersion rest
splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m)
splitVersion_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
splitVersion_ = fromValue >=> fromStringNoContext >=> \s ->
return $ nvList $ flip map (splitVersion s) $ \c ->
valueThunk $ nvStr $ principledMakeNixStringWithoutContext $ versionComponentToString c
return $ nvList $ flip map (splitVersion s) $
valueThunk . nvStr
. principledMakeNixStringWithoutContext
. versionComponentToString
compareVersions :: Text -> Text -> Ordering
compareVersions s1 s2 =
@ -479,7 +501,7 @@ compareVersions s1 s2 =
z = VersionComponent_String ""
f = uncurry compare . fromThese z z
compareVersions_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
compareVersions_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
compareVersions_ t1 t2 =
fromValue t1 >>= fromStringNoContext >>= \s1 ->
fromValue t2 >>= fromStringNoContext >>= \s2 ->
@ -507,19 +529,19 @@ splitDrvName s =
breakAfterFirstItem isFirstVersionPiece pieces
in (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)
parseDrvName :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
parseDrvName :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do
let (name :: Text, version :: Text) = splitDrvName s
-- jww (2018-04-15): There should be an easier way to write this.
(toValue =<<) $ sequence $ M.fromList
[ ("name" :: Text,
thunk @_ @(NThunk m)
thunk @t
(toValue $ principledMakeNixStringWithoutContext name))
, ("version",
thunk @_ @(NThunk m)
thunk @t
(toValue $ principledMakeNixStringWithoutContext version)) ]
match_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
match_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
match_ pat str =
fromValue pat >>= fromStringNoContext >>= \p ->
fromValue str >>= \ns -> do
@ -540,7 +562,7 @@ match_ pat str =
(if length s > 1 then tail s else s)
_ -> pure $ nvConstant NNull
split_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
split_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
split_ pat str =
fromValue pat >>= fromStringNoContext >>= \p ->
fromValue str >>= \ns -> do
@ -555,11 +577,11 @@ split_ pat str =
splitMatches 0 (map elems $ matchAllText re haystack) haystack
splitMatches
:: forall e m. MonadNix e m
:: forall e t f m. MonadBuiltins e t f m
=> Int
-> [[(ByteString, (Int, Int))]]
-> ByteString
-> [NThunk m]
-> [t]
splitMatches _ [] haystack = [thunkStr haystack]
splitMatches _ ([]:_) _ = error "Error in splitMatches: this should never happen!"
splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
@ -572,86 +594,88 @@ splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
thunkStr s = valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)))
substring :: MonadNix e m => Int -> Int -> NixString -> Prim m NixString
substring :: MonadBuiltins e t f m => Int -> Int -> NixString -> Prim m NixString
substring start len str = Prim $
if start < 0 --NOTE: negative values of 'len' are OK
then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start
else pure $ principledModifyNixContents (Text.take len . Text.drop start) str
attrNames :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
attrNames = fromValue @(ValueSet m) >=> toNix . map principledMakeNixStringWithoutContext . sort . M.keys
attrNames :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
attrNames = fromValue @(AttrSet t)
>=> toNix . map principledMakeNixStringWithoutContext . sort . M.keys
attrValues :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
attrValues = fromValue @(ValueSet m) >=>
toValue . fmap snd . sortOn (fst @Text @(NThunk m)) . M.toList
attrValues :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
attrValues = fromValue @(AttrSet t) >=>
toValue . fmap snd . sortOn (fst @Text @t) . M.toList
map_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
map_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
map_ fun xs = fun >>= \f ->
toNix <=< traverse (thunk @_ @(NThunk m) . withFrame Debug
(ErrorCall "While applying f in map:\n")
. (f `callFunc`) . force')
<=< fromValue @[NThunk m] $ xs
toNix <=< traverse (thunk @t . withFrame Debug
(ErrorCall "While applying f in map:\n")
. (f `callFunc`) . force')
<=< fromValue @[t] $ xs
mapAttrs_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
mapAttrs_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
mapAttrs_ fun xs = fun >>= \f ->
fromValue @(AttrSet (NThunk m)) xs >>= \aset -> do
fromValue @(AttrSet t) xs >>= \aset -> do
let pairs = M.toList aset
values <- for pairs $ \(key, value) ->
thunk @_ @(NThunk m) $
thunk @t $
withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $
callFunc ?? force' value =<< callFunc f (pure (nvStr (principledMakeNixStringWithoutContext key)))
callFunc ?? force' value
=<< callFunc f (pure (nvStr (principledMakeNixStringWithoutContext key)))
toNix . M.fromList . zip (map fst pairs) $ values
filter_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
filter_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
filter_ fun xs = fun >>= \f ->
toNix <=< filterM (fromValue <=< callFunc f . force')
<=< fromValue @[NThunk m] $ xs
<=< fromValue @[t] $ xs
catAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
catAttrs :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
catAttrs attrName xs =
fromValue attrName >>= fromStringNoContext >>= \n ->
fromValue @[NThunk m] xs >>= \l ->
fromValue @[t] xs >>= \l ->
fmap (nvList . catMaybes) $
forM l $ fmap (M.lookup n) . fromValue
baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
baseNameOf x = do
ns <- coerceToString DontCopyToStore CoerceStringy =<< x
pure $ nvStr (principledModifyNixContents (Text.pack . takeFileName . Text.unpack) ns)
bitAnd :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
bitAnd :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
bitAnd x y =
fromValue @Integer x >>= \a ->
fromValue @Integer y >>= \b -> toNix (a .&. b)
bitOr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
bitOr :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
bitOr x y =
fromValue @Integer x >>= \a ->
fromValue @Integer y >>= \b -> toNix (a .|. b)
bitXor :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
bitXor :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
bitXor x y =
fromValue @Integer x >>= \a ->
fromValue @Integer y >>= \b -> toNix (a `xor` b)
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
dirOf x = x >>= \case
NVStr ns -> pure $ nvStr (principledModifyNixContents (Text.pack . takeDirectory . Text.unpack) ns)
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
-- jww (2018-04-28): This should only be a string argument, and not coerced?
unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m)
unsafeDiscardStringContext :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
unsafeDiscardStringContext mnv = do
ns <- fromValue mnv
toNix $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext ns
seq_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
seq_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
seq_ a b = a >> b
deepSeq :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
deepSeq :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
deepSeq a b = do
-- We evaluate 'a' only for its effects, so data cycles are ignored.
normalForm_ =<< a
@ -661,34 +685,34 @@ deepSeq a b = do
-- recursive data structures in Haskell).
b
elem_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
elem_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
elem_ x xs = x >>= \x' ->
toValue <=< anyM (valueEq x' <=< force') <=< fromValue @[NThunk m] $ xs
toValue <=< anyM (valueEq x' <=< force') <=< fromValue @[t] $ xs
elemAt :: [a] -> Int -> Maybe a
elemAt ls i = case drop i ls of
[] -> Nothing
a:_ -> Just a
elemAt_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
elemAt_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' ->
case elemAt xs' n' of
Just a -> force' a
Nothing -> throwError $ ErrorCall $ "builtins.elem: Index " ++ show n'
++ " too large for list of length " ++ show (length xs')
genList :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
genList :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
genList generator = fromValue @Integer >=> \n ->
if n >= 0
then generator >>= \f ->
toNix =<< forM [0 .. n - 1]
(\i -> thunk @_ @(NThunk m) $ f `callFunc` toNix i)
(\i -> thunk @t $ f `callFunc` toNix i)
else throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got "
++ show n
genericClosure :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
genericClosure :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
genericClosure = fromValue @(AttrSet t) >=> \s ->
case (M.lookup "startSet" s, M.lookup "operator" s) of
(Nothing, Nothing) ->
throwError $ ErrorCall $
@ -701,15 +725,15 @@ genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'operator' required"
(Just startSet, Just operator) ->
fromValue @[NThunk m] startSet >>= \ss ->
fromValue @[t] startSet >>= \ss ->
force operator $ \op ->
toValue @[NThunk m] =<< snd <$> go op ss S.empty
toValue @[t] =<< snd <$> go op ss S.empty
where
go :: NValue m -> [NThunk m] -> Set (NValue m)
-> m (Set (NValue m), [NThunk m])
go :: NValue t f m -> [t] -> Set (NValue t f m)
-> m (Set (NValue t f m), [t])
go _ [] ks = pure (ks, [])
go op (t:ts) ks =
force t $ \v -> fromValue @(AttrSet (NThunk m)) t >>= \s ->
force t $ \v -> fromValue @(AttrSet t) t >>= \s ->
case M.lookup "key" s of
Nothing ->
throwError $ ErrorCall $
@ -718,13 +742,13 @@ genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
if S.member k' ks
then go op ts ks
else do
ys <- fromValue @[NThunk m] =<< (op `callFunc` pure v)
ys <- fromValue @[t] =<< (op `callFunc` pure v)
case S.toList ks of
[] -> checkComparable k' k'
j:_ -> checkComparable k' j
fmap (t:) <$> go op (ts ++ ys) (S.insert k' ks)
replaceStrings :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
replaceStrings :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
replaceStrings tfrom tto ts =
fromNix tfrom >>= \(nsFrom :: [NixString]) ->
fromNix tto >>= \(nsTo :: [NixString]) ->
@ -758,28 +782,28 @@ replaceStrings tfrom tto ts =
_ -> go rest (result <> Builder.fromText replacement) (ctx <> newCtx)
toNix $ go (principledStringIgnoreContext ns) mempty $ principledGetContext ns
removeAttrs :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
removeAttrs :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
removeAttrs set = fromNix >=> \(nsToRemove :: [NixString]) ->
fromValue @(AttrSet (NThunk m),
fromValue @(AttrSet t,
AttrSet SourcePos) set >>= \(m, p) -> do
toRemove <- mapM fromStringNoContext nsToRemove
toNix (go m toRemove, go p toRemove)
where
go = foldl' (flip M.delete)
intersectAttrs :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
intersectAttrs :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
intersectAttrs set1 set2 =
fromValue @(AttrSet (NThunk m),
fromValue @(AttrSet t,
AttrSet SourcePos) set1 >>= \(s1, p1) ->
fromValue @(AttrSet (NThunk m),
fromValue @(AttrSet t,
AttrSet SourcePos) set2 >>= \(s2, p2) ->
return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
functionArgs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
functionArgs :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
functionArgs fun = fun >>= \case
NVClosure p _ -> toValue @(AttrSet (NThunk m)) $
NVClosure p _ -> toValue @(AttrSet t) $
valueThunk . nvConstant . NBool <$>
case p of
Param name -> M.singleton name False
@ -787,7 +811,7 @@ functionArgs fun = fun >>= \case
v -> throwError $ ErrorCall $
"builtins.functionArgs: expected function, got " ++ show v
toFile :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
toFile :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
toFile name s = do
name' <- fromStringNoContext =<< fromValue name
s' <- fromValue s
@ -799,74 +823,74 @@ toFile name s = do
sc = StringContext t DirectPath
toNix $ principledMakeNixStringWithSingletonContext t sc
toPath :: MonadNix e m => m (NValue m) -> m (NValue m)
toPath :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
toPath = fromValue @Path >=> toNix @Path
pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m)
pathExists_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
pathExists_ path = path >>= \case
NVPath p -> toNix =<< pathExists p
NVStr ns -> toNix =<< pathExists (Text.unpack (hackyStringIgnoreContext ns))
v -> throwError $ ErrorCall $
"builtins.pathExists: expected path, got " ++ show v
hasKind :: forall a e m. (MonadNix e m, FromValue a m (NValue m))
=> m (NValue m) -> m (NValue m)
hasKind :: forall a e t f m. (MonadBuiltins e t f m, FromValue a m (NValue t f m))
=> m (NValue t f m) -> m (NValue t f m)
hasKind = fromValueMay >=> toNix . \case Just (_ :: a) -> True; _ -> False
isAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isAttrs = hasKind @(ValueSet m)
isAttrs :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isAttrs = hasKind @(AttrSet t)
isList :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isList = hasKind @[NThunk m]
isList :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isList = hasKind @[t]
isString :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isString :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isString = hasKind @NixString
isInt :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isInt :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isInt = hasKind @Int
isFloat :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isFloat :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isFloat = hasKind @Float
isBool :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isBool :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isBool = hasKind @Bool
isNull :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
isNull :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isNull = hasKind @()
isFunction :: MonadNix e m => m (NValue m) -> m (NValue m)
isFunction :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isFunction func = func >>= \case
NVClosure {} -> toValue True
_ -> toValue False
throw_ :: MonadNix e m => m (NValue m) -> m (NValue m)
throw_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
throw_ mnv = do
ns <- coerceToString CopyToStore CoerceStringy =<< mnv
throwError . ErrorCall . Text.unpack $ principledStringIgnoreContext ns
import_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
import_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
import_ = scopedImport (pure (nvSet M.empty M.empty))
scopedImport :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
scopedImport :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
scopedImport asetArg pathArg =
fromValue @(AttrSet (NThunk m)) asetArg >>= \s ->
fromValue @(AttrSet t) asetArg >>= \s ->
fromValue pathArg >>= \(Path p) -> do
path <- pathToDefaultNix p
path <- pathToDefaultNix @t @f @m p
mres <- lookupVar "__cur_file"
path' <- case mres of
Nothing -> do
traceM "No known current directory"
return path
Just p -> fromValue @_ @_ @(NThunk m) p >>= \(Path p') -> do
Just p -> fromValue @_ @_ @t p >>= \(Path p') -> do
traceM $ "Current file being evaluated is: " ++ show p'
return $ takeDirectory p' </> path
clearScopes @(NThunk m) $
clearScopes @t $
withNixContext (Just path') $
pushScope s $
importPath @m path'
importPath @t @f @m path'
getEnv_ :: MonadNix e m => m (NValue m) -> m (NValue m)
getEnv_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
getEnv_ = fromValue >=> fromStringNoContext >=> \s -> do
mres <- getEnvVar (Text.unpack s)
toNix $ principledMakeNixStringWithoutContext $
@ -874,7 +898,7 @@ getEnv_ = fromValue >=> fromStringNoContext >=> \s -> do
Nothing -> ""
Just v -> Text.pack v
sort_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
sort_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
sort_ comparator xs = comparator >>= \comp ->
fromValue xs >>= sortByM (cmp comp) >>= toValue
where
@ -888,7 +912,7 @@ sort_ comparator xs = comparator >>= \comp ->
True -> GT
False -> EQ
lessThan :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
lessThan :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
let badType = throwError $ ErrorCall $
"builtins.lessThan: expected two numbers or two strings, "
@ -903,15 +927,15 @@ lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
(NVStr a, NVStr b) -> pure $ principledStringIgnoreContext a < principledStringIgnoreContext b
_ -> badType
concatLists :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
concatLists = fromValue @[NThunk m]
>=> mapM (fromValue @[NThunk m] >=> pure)
concatLists :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
concatLists = fromValue @[t]
>=> mapM (fromValue @[t] >=> pure)
>=> toValue . concat
listToAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
listToAttrs = fromValue @[NThunk m] >=> \l ->
listToAttrs :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
listToAttrs = fromValue @[t] >=> \l ->
fmap (flip nvSet M.empty . M.fromList . reverse) $
forM l $ fromValue @(AttrSet (NThunk m)) >=> \s -> do
forM l $ fromValue @(AttrSet t) >=> \s -> do
name <- fromStringNoContext =<< fromValue =<< attrsetGet "name" s
val <- attrsetGet "value" s
pure (name, val)
@ -919,7 +943,7 @@ listToAttrs = fromValue @[NThunk m] >=> \l ->
-- prim_hashString from nix/src/libexpr/primops.cc
-- fail if context in the algo arg
-- propagate context from the s arg
hashString :: MonadNix e m => NixString -> NixString -> Prim m NixString
hashString :: MonadBuiltins e t f m => NixString -> NixString -> Prim m NixString
hashString nsAlgo ns = Prim $ do
algo <- fromStringNoContext nsAlgo
let f g = pure $ principledModifyNixContents g ns
@ -951,7 +975,7 @@ hashString nsAlgo ns = Prim $ do
_ -> throwError $ ErrorCall $ "builtins.hashString: "
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
placeHolder :: MonadNix e m => m (NValue m) -> m (NValue m)
placeHolder :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
placeHolder = fromValue >=> fromStringNoContext >=> \t -> do
h <- runPrim (hashString (principledMakeNixStringWithoutContext "sha256")
(principledMakeNixStringWithoutContext ("nix-output:" <> t)))
@ -959,7 +983,7 @@ placeHolder = fromValue >=> fromStringNoContext >=> \t -> do
-- The result coming out of hashString is base16 encoded
fst $ Base16.decode $ encodeUtf8 $ principledStringIgnoreContext h
absolutePathFromValue :: MonadNix e m => NValue m -> m FilePath
absolutePathFromValue :: MonadBuiltins e t f m => NValue t f m -> m FilePath
absolutePathFromValue = \case
NVStr ns -> do
let path = Text.unpack $ hackyStringIgnoreContext ns
@ -969,18 +993,18 @@ absolutePathFromValue = \case
NVPath path -> pure path
v -> throwError $ ErrorCall $ "expected a path, got " ++ show v
readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m)
readFile_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
readFile_ path =
path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix
findFile_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
findFile_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
findFile_ aset filePath =
aset >>= \aset' ->
filePath >>= \filePath' ->
case (aset', filePath') of
(NVList x, NVStr ns) -> do
mres <- findPath x (Text.unpack (hackyStringIgnoreContext ns))
mres <- findPath @t @f @m x (Text.unpack (hackyStringIgnoreContext ns))
pure $ nvPath mres
(NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " ++ show y
(x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x
@ -993,14 +1017,14 @@ data FileType
| FileTypeUnknown
deriving (Show, Read, Eq, Ord)
instance Applicative m => ToNix FileType m (NValue m) where
instance Convertible e t f m => ToNix FileType m (NValue t f m) where
toNix = toNix . principledMakeNixStringWithoutContext . \case
FileTypeRegular -> "regular" :: Text
FileTypeDirectory -> "directory"
FileTypeSymlink -> "symlink"
FileTypeUnknown -> "unknown"
readDir_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
readDir_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
readDir_ pathThunk = do
path <- absolutePathFromValue =<< pathThunk
items <- listDirectory path
@ -1014,7 +1038,8 @@ readDir_ pathThunk = do
pure (Text.pack item, t)
toNix (M.fromList itemsWithTypes)
fromJSON :: forall e m. (MonadNix e m, Typeable m) => m (NValue m) -> m (NValue m)
fromJSON :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m)
fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
Left jsonError ->
@ -1025,8 +1050,10 @@ fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
A.Object m -> flip nvSet M.empty
<$> traverse (thunk . jsonToNValue) m
A.Array l -> nvList <$>
traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x)
. jsonToNValue $ x) (V.toList l)
traverse (\x -> thunk @t @m @(NValue t f m)
. whileForcingThunk @t @f (CoercionFromJson @t @f @m x)
. jsonToNValue $ x)
(V.toList l)
A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s
A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
Left r -> NFloat r
@ -1035,15 +1062,15 @@ fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
A.Null -> pure $ nvConstant NNull
prim_toJSON
:: MonadNix e m
=> m (NValue m)
-> m (NValue m)
:: MonadBuiltins e t f m
=> m (NValue t f m)
-> m (NValue t f m)
prim_toJSON x = x >>= nvalueToJSONNixString >>= pure . nvStr
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
toXML_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
toXML_ v = v >>= normalForm >>= pure . nvStr . toXML
typeOf :: MonadNix e m => m (NValue m) -> m (NValue m)
typeOf :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case
NVConstant a -> case a of
NInt _ -> "int"
@ -1058,7 +1085,7 @@ typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case
NVBuiltin _ _ -> "lambda"
_ -> error "Pattern synonyms obscure complete patterns"
tryEval :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
tryEval :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
tryEval e = catch (onSuccess <$> e) (pure . onError)
where
onSuccess v = flip nvSet M.empty $ M.fromList
@ -1066,38 +1093,43 @@ tryEval e = catch (onSuccess <$> e) (pure . onError)
, ("value", valueThunk v)
]
onError :: SomeException -> NValue m
onError :: SomeException -> NValue t f m
onError _ = flip nvSet M.empty $ M.fromList
[ ("success", valueThunk (nvConstant (NBool False)))
, ("value", valueThunk (nvConstant (NBool False)))
]
trace_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
trace_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
trace_ msg action = do
traceEffect . Text.unpack . principledStringIgnoreContext =<< fromValue msg
traceEffect @t @f @m
. Text.unpack
. principledStringIgnoreContext
=<< fromValue msg
action
-- TODO: remember error context
addErrorContext :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
addErrorContext :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
addErrorContext _ action = action
exec_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
exec_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
exec_ xs = do
ls <- fromValue @[NThunk m] xs
ls <- fromValue @[t] xs
xs <- traverse (coerceToString DontCopyToStore CoerceStringy <=< force') ls
-- TODO Still need to do something with the context here
-- See prim_exec in nix/src/libexpr/primops.cc
-- Requires the implementation of EvalState::realiseContext
exec (map (Text.unpack . hackyStringIgnoreContext) xs)
fetchurl :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
fetchurl :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
fetchurl v = v >>= \case
NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s))
v@NVStr {} -> go Nothing v
v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got "
++ show v
where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go :: Maybe t -> NValue t f m -> m (NValue t f m)
go _msha = \case
NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha
Left e -> throwError e
@ -1110,41 +1142,45 @@ fetchurl v = v >>= \case
"builtins.fetchurl: unsupported arguments to url"
Just t -> pure t
partition_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
partition_ :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)
partition_ fun xs = fun >>= \f ->
fromValue @[NThunk m] xs >>= \l -> do
fromValue @[t] xs >>= \l -> do
let match t = f `callFunc` force' t >>= fmap (, t) . fromValue
selection <- traverse match l
let (right, wrong) = partition fst selection
let makeSide = valueThunk . nvList . map snd
toValue @(AttrSet (NThunk m)) $
toValue @(AttrSet t) $
M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]
currentSystem :: MonadNix e m => m (NValue m)
currentSystem :: MonadBuiltins e t f m => m (NValue t f m)
currentSystem = do
os <- getCurrentSystemOS
arch <- getCurrentSystemArch
return $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os)
currentTime_ :: MonadNix e m => m (NValue m)
currentTime_ :: MonadBuiltins e t f m => m (NValue t f m)
currentTime_ = do
opts :: Options <- asks (view hasLens)
toNix @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts)
derivationStrict_ :: MonadNix e m => m (NValue m) -> m (NValue m)
derivationStrict_ :: MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m)
derivationStrict_ = (>>= derivationStrict)
newtype Prim m a = Prim { runPrim :: m a }
-- | Types that support conversion to nix in a particular monad
class ToBuiltin m a | a -> m where
toBuiltin :: String -> a -> m (NValue m)
class ToBuiltin t f m a | a -> m where
toBuiltin :: String -> a -> m (NValue t f m)
instance (MonadNix e m, ToNix a m (NValue m))
=> ToBuiltin m (Prim m a) where
instance (MonadBuiltins e t f m, ToNix a m (NValue t f m))
=> ToBuiltin t f m (Prim m a) where
toBuiltin _ p = toNix =<< runPrim p
instance (MonadNix e m, FromNix a m (NValue m), ToBuiltin m b)
=> ToBuiltin m (a -> b) where
toBuiltin name f = return $ nvBuiltin name (fromNix >=> toBuiltin name . f)
instance ( MonadBuiltins e t f m
, FromNix a m (NValue t f m)
, ToBuiltin t f m b)
=> ToBuiltin t f m (a -> b) where
toBuiltin name f = return $ nvBuiltin name
(fromNix >=> fmap wrapValue . toBuiltin name . f)

66
src/Nix/Cited.hs Normal file
View file

@ -0,0 +1,66 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Nix.Cited where
import Control.Comonad
import Control.Comonad.Env
import Data.Typeable (Typeable)
import GHC.Generics
import Lens.Family2.TH
import Nix.Expr.Types.Annotated
import Nix.Scope
import Nix.Value
data Provenance t f m = Provenance
{ _lexicalScope :: Scopes m t
, _originExpr :: NExprLocF (Maybe (NValue t f m))
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
-- result of the call, but what was called and with what arguments.
}
deriving (Generic, Typeable, Show)
data NCited t f m a = NCited
{ _provenance :: [Provenance t f m]
, _cited :: a
}
deriving (Generic, Typeable, Functor, Foldable, Traversable, Show)
instance Applicative (NCited t f m) where
pure = NCited []
-- jww (2019-03-11): ??
NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)
instance Comonad (NCited t f m) where
duplicate p = NCited (_provenance p) p
extract = _cited
instance ComonadEnv [Provenance t f m] (NCited t f m) where
ask = _provenance
$(makeLenses ''Provenance)
$(makeLenses ''NCited)
class HasCitations t f m a where
citations :: a -> [Provenance t f m]
addProvenance :: Provenance t f m -> a -> a
instance HasCitations t f m (NCited t f m a) where
citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v)
class HasCitations1 t f m where
citations1 :: f a -> [Provenance t f m]
addProvenance1 :: Provenance t f m -> f a -> f a

14
src/Nix/Context.hs
View file

@ -10,24 +10,24 @@ import Nix.Frames
import Nix.Utils
import Nix.Expr.Types.Annotated (SrcSpan, nullSpan)
data Context m v = Context
{ scopes :: Scopes m v
data Context m t = Context
{ scopes :: Scopes m t
, source :: SrcSpan
, frames :: Frames
, options :: Options
}
instance Has (Context m v) (Scopes m v) where
instance Has (Context m t) (Scopes m t) where
hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x
instance Has (Context m v) SrcSpan where
instance Has (Context m t) SrcSpan where
hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y
instance Has (Context m v) Frames where
instance Has (Context m t) Frames where
hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z
instance Has (Context m v) Options where
instance Has (Context m t) Options where
hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w
newContext :: Options -> Context m v
newContext :: Options -> Context m t
newContext = Context emptyScopes nullSpan []

384
src/Nix/Convert.hs
View file

@ -11,6 +11,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
@ -26,7 +28,6 @@
module Nix.Convert where
import Control.Monad
import Control.Monad.Free
import Data.ByteString
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
@ -40,9 +41,7 @@ import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Nix.Var
{-
@ -61,18 +60,18 @@ class FromValue a m v where
fromValue :: v -> m a
fromValueMay :: v -> m (Maybe a)
type Convertible e m = (Framed e m, MonadVar m, Typeable m)
type Convertible e t f m =
(Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
instance Convertible e m => FromValue () m (NValueNF m) where
instance Convertible e t f m => FromValue () m (NValueNF t f m) where
fromValueMay = \case
Free (NVConstantF NNull) -> pure $ Just ()
NVConstantNF NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TNull v
instance Convertible e m
=> FromValue () m (NValue m) where
instance Convertible e t f m => FromValue () m (NValue t f m) where
fromValueMay = \case
NVConstant NNull -> pure $ Just ()
_ -> pure Nothing
@ -80,17 +79,15 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TNull v
instance Convertible e m
=> FromValue Bool m (NValueNF m) where
instance Convertible e t f m => FromValue Bool m (NValueNF t f m) where
fromValueMay = \case
Free (NVConstantF (NBool b)) -> pure $ Just b
NVConstantNF (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TBool v
instance Convertible e m
=> FromValue Bool m (NValue m) where
instance Convertible e t f m => FromValue Bool m (NValue t f m) where
fromValueMay = \case
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
@ -98,17 +95,15 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TBool v
instance Convertible e m
=> FromValue Int m (NValueNF m) where
instance Convertible e t f m => FromValue Int m (NValueNF t f m) where
fromValueMay = \case
Free (NVConstantF (NInt b)) -> pure $ Just (fromInteger b)
NVConstantNF (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e m
=> FromValue Int m (NValue m) where
instance Convertible e t f m => FromValue Int m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
@ -116,17 +111,15 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e m
=> FromValue Integer m (NValueNF m) where
instance Convertible e t f m => FromValue Integer m (NValueNF t f m) where
fromValueMay = \case
Free (NVConstantF (NInt b)) -> pure $ Just b
NVConstantNF (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e m
=> FromValue Integer m (NValue m) where
instance Convertible e t f m => FromValue Integer m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
@ -134,18 +127,16 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e m
=> FromValue Float m (NValueNF m) where
instance Convertible e t f m => FromValue Float m (NValueNF t f m) where
fromValueMay = \case
Free (NVConstantF (NFloat b)) -> pure $ Just b
Free (NVConstantF (NInt i)) -> pure $ Just (fromInteger i)
NVConstantNF (NFloat b) -> pure $ Just b
NVConstantNF (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TFloat v
instance Convertible e m
=> FromValue Float m (NValue m) where
instance Convertible e t f m => FromValue Float m (NValue t f m) where
fromValueMay = \case
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
@ -154,12 +145,14 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TFloat v
instance (Convertible e m, MonadEffects m)
=> FromValue NixString m (NValueNF m) where
instance (Convertible e t f m, MonadEffects t f m)
=> FromValue NixString m (NValueNF t f m) where
fromValueMay = \case
Free (NVStrF ns) -> pure $ Just ns
Free (NVPathF p) -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of
NVStrNF ns -> pure $ Just ns
NVPathNF p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
@ -167,11 +160,13 @@ instance (Convertible e m, MonadEffects m)
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue NixString m (NValue m) where
instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
=> FromValue NixString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ Just ns
NVPath p -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
NVPath p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
@ -180,17 +175,17 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
instance Convertible e m
=> FromValue ByteString m (NValueNF m) where
instance Convertible e t f m
=> FromValue ByteString m (NValueNF t f m) where
fromValueMay = \case
Free (NVStrF ns) -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance Convertible e m
=> FromValue ByteString m (NValue m) where
instance Convertible e t f m
=> FromValue ByteString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
@ -201,11 +196,11 @@ instance Convertible e m
newtype Path = Path { getPath :: FilePath }
deriving Show
instance Convertible e m => FromValue Path m (NValueNF m) where
instance Convertible e t f m => FromValue Path m (NValueNF t f m) where
fromValueMay = \case
Free (NVPathF p) -> pure $ Just (Path p)
Free (NVStrF ns) -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
Free (NVSetF s _) -> case M.lookup "outPath" s of
NVPathNF p -> pure $ Just (Path p)
NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
@ -213,8 +208,8 @@ instance Convertible e m => FromValue Path m (NValueNF m) where
Just b -> pure b
_ -> throwError $ ExpectationNF TPath v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue Path m (NValue m) where
instance (Convertible e t f m, FromValue Path m t)
=> FromValue Path m (NValue t f m) where
fromValueMay = \case
NVPath p -> pure $ Just (Path p)
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
@ -226,16 +221,16 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
Just b -> pure b
_ -> throwError $ Expectation TPath v
instance (Convertible e m, FromValue a m (NValueNF m), Show a)
=> FromValue [a] m (NValueNF m) where
instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)
=> FromValue [a] m (NValueNF t f m) where
fromValueMay = \case
Free (NVListF l) -> sequence <$> traverse fromValueMay l
NVListNF l -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TList v
instance Convertible e m => FromValue [NThunk m] m (NValue m) where
instance Convertible e t f m => FromValue [t] m (NValue t f m) where
fromValueMay = \case
NVList l -> pure $ Just l
_ -> pure Nothing
@ -243,17 +238,17 @@ instance Convertible e m => FromValue [NThunk m] m (NValue m) where
Just b -> pure b
_ -> throwError $ Expectation TList v
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
fromValueMay = \case
Free (NVSetF s _) -> pure $ Just s
NVSetNF s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e m
=> FromValue (HashMap Text (NThunk m)) m (NValue m) where
instance Convertible e t f m
=> FromValue (HashMap Text t) m (NValue t f m) where
fromValueMay = \case
NVSet s _ -> pure $ Just s
_ -> pure Nothing
@ -261,19 +256,19 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
fromValueMay = \case
Free (NVSetF s p) -> pure $ Just (s, p)
NVSetNF s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e m
=> FromValue (HashMap Text (NThunk m),
HashMap Text SourcePos) m (NValue m) where
instance Convertible e t f m
=> FromValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
fromValueMay = \case
NVSet s p -> pure $ Just (s, p)
_ -> pure Nothing
@ -281,127 +276,110 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue (NThunk m) m (NValue m) where
fromValueMay = pure . Just . wrapValue @_ @_ @m
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> error "Impossible, see fromValueMay"
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
instance (MonadThunk (NValue m) (NThunk m) m, FromValue a m (NValue m))
=> FromValue a m (NThunk m) where
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
class ToValue a m v where
toValue :: a -> m v
instance Applicative m => ToValue () m (NValueNF m) where
toValue _ = pure . Free . NVConstantF $ NNull
instance Convertible e t f m => ToValue () m (NValueNF t f m) where
toValue _ = pure . nvConstantNF $ NNull
instance Applicative m => ToValue () m (NValue m) where
instance Convertible e t f m => ToValue () m (NValue t f m) where
toValue _ = pure . nvConstant $ NNull
instance Applicative m => ToValue Bool m (NValueNF m) where
toValue = pure . Free . NVConstantF . NBool
instance Convertible e t f m => ToValue Bool m (NValueNF t f m) where
toValue = pure . nvConstantNF . NBool
instance Applicative m => ToValue Bool m (NValue m) where
instance Convertible e t f m => ToValue Bool m (NValue t f m) where
toValue = pure . nvConstant . NBool
instance Applicative m => ToValue Int m (NValueNF m) where
toValue = pure . Free . NVConstantF . NInt . toInteger
instance Convertible e t f m => ToValue Int m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt . toInteger
instance Applicative m => ToValue Int m (NValue m) where
instance Convertible e t f m => ToValue Int m (NValue t f m) where
toValue = pure . nvConstant . NInt . toInteger
instance Applicative m => ToValue Integer m (NValueNF m) where
toValue = pure . Free . NVConstantF . NInt
instance Convertible e t f m => ToValue Integer m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt
instance Applicative m => ToValue Integer m (NValue m) where
instance Convertible e t f m => ToValue Integer m (NValue t f m) where
toValue = pure . nvConstant . NInt
instance Applicative m => ToValue Float m (NValueNF m) where
toValue = pure . Free . NVConstantF . NFloat
instance Convertible e t f m => ToValue Float m (NValueNF t f m) where
toValue = pure . nvConstantNF . NFloat
instance Applicative m => ToValue Float m (NValue m) where
instance Convertible e t f m => ToValue Float m (NValue t f m) where
toValue = pure . nvConstant . NFloat
instance Applicative m => ToValue NixString m (NValueNF m) where
toValue = pure . Free . NVStrF
instance Convertible e t f m => ToValue NixString m (NValueNF t f m) where
toValue = pure . nvStrNF
instance Applicative m => ToValue NixString m (NValue m) where
instance Convertible e t f m => ToValue NixString m (NValue t f m) where
toValue = pure . nvStr
instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Free . NVStrF . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue ByteString m (NValueNF t f m) where
toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8
instance Applicative m => ToValue ByteString m (NValue m) where
instance Convertible e t f m => ToValue ByteString m (NValue t f m) where
toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8
instance Applicative m => ToValue Path m (NValueNF m) where
toValue = pure . Free . NVPathF . getPath
instance Convertible e t f m => ToValue Path m (NValueNF t f m) where
toValue = pure . nvPathNF . getPath
instance Applicative m => ToValue Path m (NValue m) where
instance Convertible e t f m => ToValue Path m (NValue t f m) where
toValue = pure . nvPath . getPath
instance Applicative m => ToValue StorePath m (NValueNF m) where
instance Convertible e t f m => ToValue StorePath m (NValueNF t f m) where
toValue = toValue . Path . unStorePath
instance Applicative m => ToValue StorePath m (NValue m) where
instance Convertible e t f m => ToValue StorePath m (NValue t f m) where
toValue = toValue . Path . unStorePath
instance MonadThunk (NValue m) (NThunk m) m
=> ToValue SourcePos m (NValue m) where
instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
toValue (SourcePos f l c) = do
f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f)
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, wrapValue @_ @_ @m f')
, ("line", wrapValue @_ @_ @m l')
, ("column", wrapValue @_ @_ @m c') ]
[ ("file" :: Text, wrapValue f')
, ("line", wrapValue l')
, ("column", wrapValue c') ]
pure $ nvSet pos mempty
instance (ToValue a m (NValueNF m), Applicative m)
=> ToValue [a] m (NValueNF m) where
toValue = fmap (Free . NVListF) . traverse toValue
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
=> ToValue [a] m (NValueNF t f m) where
toValue = fmap nvListNF . traverse toValue
instance Applicative m => ToValue [NThunk m] m (NValue m) where
instance Convertible e t f m => ToValue [t] m (NValue t f m) where
toValue = pure . nvList
instance Applicative m
=> ToValue (HashMap Text (NValueNF m)) m (NValueNF m) where
toValue = pure . Free . flip NVSetF M.empty
instance Convertible e t f m
=> ToValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
toValue = pure . flip nvSetNF M.empty
instance Applicative m => ToValue (HashMap Text (NThunk m)) m (NValue m) where
instance Convertible e t f m => ToValue (HashMap Text t) m (NValue t f m) where
toValue = pure . flip nvSet M.empty
instance Applicative m => ToValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
toValue (s, p) = pure $ Free $ NVSetF s p
instance Convertible e t f m => ToValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
toValue (s, p) = pure $ nvSetNF s p
instance Applicative m => ToValue (HashMap Text (NThunk m),
HashMap Text SourcePos) m (NValue m) where
instance Convertible e t f m => ToValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
toValue (s, p) = pure $ nvSet s p
instance (MonadThunk (NValue m) (NThunk m) m, ToValue a m (NValue m))
=> ToValue a m (NThunk m) where
toValue = fmap (wrapValue @(NValue m) @_ @m) . toValue
instance Applicative m => ToValue Bool m (NExprF r) where
instance Convertible e t f m => ToValue Bool m (NExprF r) where
toValue = pure . NConstant . NBool
instance Applicative m => ToValue () m (NExprF r) where
instance Convertible e t f m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
whileForcingThunk :: forall s e m r. (Framed e m, Exception s, Typeable m)
whileForcingThunk :: forall t f m s e r. (Exception s, Convertible e t f m)
=> s -> m r -> m r
whileForcingThunk frame =
withFrame Debug (ForcingThunk @m) . withFrame Debug frame
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
class FromNix a m v where
fromNix :: v -> m a
@ -412,9 +390,8 @@ class FromNix a m v where
default fromNixMay :: FromValue a m v => v -> m (Maybe a)
fromNixMay = fromValueMay
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m))
=> FromNix [a] m (NValue m) where
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix [a] m (NValue t f m) where
fromNixMay = \case
NVList l -> sequence <$> traverse (`force` fromNixMay) l
_ -> pure Nothing
@ -422,9 +399,8 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
Just b -> pure b
_ -> throwError $ Expectation TList v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m))
=> FromNix (HashMap Text a) m (NValue m) where
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix (HashMap Text a) m (NValue t f m) where
fromNixMay = \case
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
_ -> pure Nothing
@ -432,91 +408,91 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e m => FromNix () m (NValueNF m) where
instance Convertible e m => FromNix () m (NValue m) where
instance Convertible e m => FromNix Bool m (NValueNF m) where
instance Convertible e m => FromNix Bool m (NValue m) where
instance Convertible e m => FromNix Int m (NValueNF m) where
instance Convertible e m => FromNix Int m (NValue m) where
instance Convertible e m => FromNix Integer m (NValueNF m) where
instance Convertible e m => FromNix Integer m (NValue m) where
instance Convertible e m => FromNix Float m (NValueNF m) where
instance Convertible e m => FromNix Float m (NValue m) where
instance (Convertible e m, MonadEffects m) => FromNix NixString m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix NixString m (NValue m) where
instance Convertible e m => FromNix ByteString m (NValueNF m) where
instance Convertible e m => FromNix ByteString m (NValue m) where
instance Convertible e m => FromNix Path m (NValueNF m) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => FromNix Path m (NValue m) where
instance (Convertible e m, FromValue a m (NValueNF m), Show a) => FromNix [a] m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance Convertible e t f m => FromNix () m (NValueNF t f m) where
instance Convertible e t f m => FromNix () m (NValue t f m) where
instance Convertible e t f m => FromNix Bool m (NValueNF t f m) where
instance Convertible e t f m => FromNix Bool m (NValue t f m) where
instance Convertible e t f m => FromNix Int m (NValueNF t f m) where
instance Convertible e t f m => FromNix Int m (NValue t f m) where
instance Convertible e t f m => FromNix Integer m (NValueNF t f m) where
instance Convertible e t f m => FromNix Integer m (NValue t f m) where
instance Convertible e t f m => FromNix Float m (NValueNF t f m) where
instance Convertible e t f m => FromNix Float m (NValue t f m) where
instance (Convertible e t f m, MonadEffects t f m)
=> FromNix NixString m (NValueNF t f m) where
instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
=> FromNix NixString m (NValue t f m) where
instance Convertible e t f m => FromNix ByteString m (NValueNF t f m) where
instance Convertible e t f m => FromNix ByteString m (NValue t f m) where
instance Convertible e t f m => FromNix Path m (NValueNF t f m) where
instance (Convertible e t f m, FromValue Path m t)
=> FromNix Path m (NValue t f m) where
instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)
=> FromNix [a] m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
fromNix = (>>= fromNix)
instance (MonadThunk (NValue m) (NThunk m) m, FromNix a m (NValue m))
=> FromNix a m (NThunk m) where
fromNixMay = force ?? fromNixMay
fromNix = force ?? fromNix
instance MonadThunk (NValue m) (NThunk m) m
=> FromNix (NThunk m) m (NValue m) where
fromNixMay = pure . Just . wrapValue
fromNix = pure . wrapValue
class ToNix a m v where
toNix :: a -> m v
default toNix :: ToValue a m v => a -> m v
toNix = toValue
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m))
=> ToNix [a] m (NValue m) where
toNix = fmap nvList
. traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
<=< toNix))
instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix [a] m (NValue t f m) where
toNix = fmap nvList . traverse (thunk . go)
where
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
<=< toNix
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m))
=> ToNix (HashMap Text a) m (NValue m) where
toNix = fmap (flip nvSet M.empty)
. traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
<=< toNix))
instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix (HashMap Text a) m (NValue t f m) where
toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)
where
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
<=< toNix
instance Applicative m => ToNix () m (NValueNF m) where
instance Applicative m => ToNix () m (NValue m) where
instance Applicative m => ToNix Bool m (NValueNF m) where
instance Applicative m => ToNix Bool m (NValue m) where
instance Applicative m => ToNix Int m (NValueNF m) where
instance Applicative m => ToNix Int m (NValue m) where
instance Applicative m => ToNix Integer m (NValueNF m) where
instance Applicative m => ToNix Integer m (NValue m) where
instance Applicative m => ToNix Float m (NValueNF m) where
instance Applicative m => ToNix Float m (NValue m) where
instance Applicative m => ToNix NixString m (NValueNF m) where
instance Applicative m => ToNix NixString m (NValue m) where
instance Applicative m => ToNix ByteString m (NValueNF m) where
instance Applicative m => ToNix ByteString m (NValue m) where
instance Applicative m => ToNix Path m (NValueNF m) where
instance Applicative m => ToNix Path m (NValue m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance Applicative m => ToNix Bool m (NExprF r) where
instance Applicative m => ToNix () m (NExprF r) where
instance Convertible e t f m => ToNix () m (NValueNF t f m) where
instance Convertible e t f m => ToNix () m (NValue t f m) where
instance Convertible e t f m => ToNix Bool m (NValueNF t f m) where
instance Convertible e t f m => ToNix Bool m (NValue t f m) where
instance Convertible e t f m => ToNix Int m (NValueNF t f m) where
instance Convertible e t f m => ToNix Int m (NValue t f m) where
instance Convertible e t f m => ToNix Integer m (NValueNF t f m) where
instance Convertible e t f m => ToNix Integer m (NValue t f m) where
instance Convertible e t f m => ToNix Float m (NValueNF t f m) where
instance Convertible e t f m => ToNix Float m (NValue t f m) where
instance Convertible e t f m => ToNix NixString m (NValueNF t f m) where
instance Convertible e t f m => ToNix NixString m (NValue t f m) where
instance Convertible e t f m => ToNix ByteString m (NValueNF t f m) where
instance Convertible e t f m => ToNix ByteString m (NValue t f m) where
instance Convertible e t f m => ToNix Path m (NValueNF t f m) where
instance Convertible e t f m => ToNix Path m (NValue t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (NThunk m) where
toNix = thunk . toNix
instance Convertible e t f m => ToNix Bool m (NExprF r) where
toNix = pure . NConstant . NBool
instance (Applicative m, ToNix a m (NValueNF m)) => ToNix [a] m (NValueNF m) where
toNix = fmap (Free . NVListF) . traverse toNix
instance Convertible e t f m => ToNix () m (NExprF r) where
toNix _ = pure $ NConstant NNull
instance MonadThunk (NValue m) (NThunk m) m => ToNix (NThunk m) m (NValue m) where
toNix = force ?? pure
instance (Convertible e t f m, ToNix a m (NValueNF t f m))
=> ToNix [a] m (NValueNF t f m) where
toNix = fmap nvListNF . traverse toNix
convertNix :: forall a t m v. (FromNix a m t, ToNix a m v, Monad m) => t -> m v
convertNix = fromNix @a >=> toNix

18
src/Nix/Effects.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Nix.Effects where
import Prelude hiding (putStr, putStrLn, print)
@ -31,19 +34,26 @@ import System.Process
-- | A path into the nix store
newtype StorePath = StorePath { unStorePath :: FilePath }
class (MonadFile m, MonadStore m, MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m, MonadIntrospect m) => MonadEffects m where
class (MonadFile m,
MonadStore m,
MonadPutStr m,
MonadHttp m,
MonadEnv m,
MonadInstantiate m,
MonadExec m,
MonadIntrospect m) => MonadEffects t f m where
-- | Determine the absolute path of relative path in the current context
makeAbsolutePath :: FilePath -> m FilePath
findEnvPath :: String -> m FilePath
-- | Having an explicit list of sets corresponding to the NIX_PATH
-- and a file path try to find an existing path
findPath :: [NThunk m] -> FilePath -> m FilePath
findPath :: [t] -> FilePath -> m FilePath
importPath :: FilePath -> m (NValue m)
importPath :: FilePath -> m (NValue t f m)
pathToDefaultNix :: FilePath -> m FilePath
derivationStrict :: NValue m -> m (NValue m)
derivationStrict :: NValue t f m -> m (NValue t f m)
traceEffect :: String -> m ()

18
src/Nix/Eval.hs
View file

@ -80,7 +80,7 @@ class (Show v, Monad m) => MonadEval v m where
type MonadNixEval v t m =
(MonadEval v m,
Scoped t m,
MonadThunk v t m,
MonadThunk t m v,
MonadFix m,
ToValue Bool m v,
ToValue [t] m v,
@ -88,14 +88,14 @@ type MonadNixEval v t m =
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
data EvalFrame m v
= EvaluatingExpr (Scopes m v) NExprLoc
| ForcingExpr (Scopes m v) NExprLoc
data EvalFrame m t
= EvaluatingExpr (Scopes m t) NExprLoc
| ForcingExpr (Scopes m t) NExprLoc
| Calling String SrcSpan
| SynHole (SynHoleInfo m v)
| SynHole (SynHoleInfo m t)
deriving (Show, Typeable)
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
instance (Typeable m, Typeable t) => Exception (EvalFrame m t)
data SynHoleInfo m t = SynHoleInfo
{ _synHoleInfo_expr :: NExprLoc
@ -131,7 +131,7 @@ eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l) = do
scope <- currentScopes
for l (thunk @v @t . withScopes @t scope) >>= toValue
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
@ -168,7 +168,7 @@ evalWithAttrSet aset body = do
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
scope <- currentScopes :: m (Scopes m t)
s <- thunk @v @t $ withScopes scope aset
s <- thunk @t @m @v $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
@ -241,7 +241,7 @@ evalBinds recursive binds = do
finalValue >>= fromValue >>= \(o', p') ->
-- jww (2018-05-09): What to do with the key position here?
return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'),
force @v @t v pure))
force @t @m @v v pure))
(M.toList o')
go _ (NamedVar pathExpr finalValue pos) = do

424
src/Nix/Exec.hs
View file

@ -37,9 +37,7 @@ import Control.Monad.Ref
import Control.Monad.State.Strict
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State.Strict (StateT(..))
import Data.Coerce
import Data.Fix
import Data.GADT.Compare
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List
@ -51,25 +49,23 @@ import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Data.Typeable
import Nix.Atoms
import Nix.Cited
import Nix.Context
import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.String
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Pretty
import Nix.Render
import Nix.Scope
import Nix.String
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
#endif
@ -84,18 +80,75 @@ import GHC.DataSize
#endif
#endif
type MonadNix e m =
(Scoped (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
Alternative m, MonadFreshId Int m)
type Cited t f m =
( HasCitations1 t f m
, MonadDataContext f m
)
data ExecFrame m = Assertion SrcSpan (NValue m)
nvConstantP :: Cited t f m
=> Provenance t f m -> NAtom -> NValue t f m
nvConstantP p x = addProvenance p (nvConstant x)
nvStrP :: Cited t f m
=> Provenance t f m -> NixString -> NValue t f m
nvStrP p ns = addProvenance p (nvStr ns)
nvPathP :: Cited t f m
=> Provenance t f m -> FilePath -> NValue t f m
nvPathP p x = addProvenance p (nvPath x)
nvListP :: Cited t f m
=> Provenance t f m -> [t] -> NValue t f m
nvListP p l = addProvenance p (nvList l)
nvSetP :: Cited t f m
=> Provenance t f m -> AttrSet t -> AttrSet SourcePos
-> NValue t f m
nvSetP p s x = addProvenance p (nvSet s x)
nvClosureP :: Cited t f m
=> Provenance t f m
-> Params ()
-> (m (NValue t f m) -> m t)
-> NValue t f m
nvClosureP p x f = addProvenance p (nvClosure x f)
nvBuiltinP :: Cited t f m
=> Provenance t f m
-> String
-> (m (NValue t f m) -> m t)
-> NValue t f m
nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
type MonadCitedThunks t f m =
( MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations1 t f m
)
type MonadNix e t f m =
( Has e SrcSpan
, Has e Options
, Scoped t m
, Framed e m
, MonadFix m
, MonadCatch m
, MonadThrow m
, Alternative m
, MonadEffects t f m
, MonadCitedThunks t f m
)
data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
deriving (Show, Typeable)
instance Typeable m => Exception (ExecFrame m)
instance MonadDataErrorContext t f m => Exception (ExecFrame t f m)
nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
nverr = evalError @(NValue m)
nverr
:: forall e t f s m a.
(MonadNix e t f m, FromValue NixString m t, Exception s)
=> s -> m a
nverr = evalError @(NValue t f m)
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
currentPos = asks (view hasLens)
@ -103,94 +156,41 @@ currentPos = asks (view hasLens)
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (NThunk . NCited ps . coerce) . buildThunk $ mv
else
fmap (NThunk . NCited [] . coerce) . buildThunk $ mv
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
forceEff (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceEffects t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceEffects t f)
wrapValue = NThunk . NCited [] . coerce . valueRef
getValue (NThunk (NCited _ v)) = thunkValue (coerce v)
{-
prov :: MonadNix e m
=> (NValue m -> Provenance m) -> NValue m -> m (NValue m)
prov p v = do
opts :: Options <- asks (view hasLens)
pure $ if values opts
then addProvenance p v
else v
-}
instance MonadNix e m => MonadEval (NValue m) m where
freeVariable var =
nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
instance ( MonadNix e t f m
, FromValue NixString m t
) => MonadEval (NValue t f m) m where
freeVariable var = nverr @e @t @f $
ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
synHole name = do
span <- currentPos
scope <- currentScopes
evalError @(NValue m) $ SynHole $ SynHoleInfo
evalError @(NValue t f m) $ SynHole $ SynHoleInfo
{ _synHoleInfo_expr = Fix $ NSynHole_ span name
, _synHoleInfo_scope = scope
}
attrMissing ks Nothing =
evalError @(NValue m) $ ErrorCall $
evalError @(NValue t f m) $ ErrorCall $
"Inheriting unknown attribute: "
++ intercalate "." (map Text.unpack (NE.toList ks))
attrMissing ks (Just s) = do
s' <- prettyNValue s
evalError @(NValue m) $ ErrorCall $ "Could not look up attribute "
evalError @(NValue t f m) $ ErrorCall $ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show s'
evalCurPos = do
scope <- currentScopes
span@(SrcSpan delta _) <- currentPos
addProvenance (\_ -> Provenance scope (NSym_ span "__curPos"))
addProvenance @_ @f (Provenance scope (NSym_ span "__curPos"))
<$> toValue delta
evaledSym name val = do
scope <- currentScopes
span <- currentPos
pure $ addProvenance (const $ Provenance scope (NSym_ span name)) val
pure $ addProvenance @_ @f (Provenance scope (NSym_ span name)) val
evalConstant c = do
scope <- currentScopes
@ -208,12 +208,12 @@ instance MonadNix e m => MonadEval (NValue m) m where
evalLiteralPath p = do
scope <- currentScopes
span <- currentPos
nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath p
nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath @t @f @m p
evalEnvPath p = do
scope <- currentScopes
span <- currentPos
nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath p
nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath @t @f @m p
evalUnary op arg = do
scope <- currentScopes
@ -228,7 +228,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
evalWith c b = do
scope <- currentScopes
span <- currentPos
addProvenance (\b -> Provenance scope (NWith_ span Nothing (Just b)))
(\b -> addProvenance (Provenance scope (NWith_ span Nothing (Just b))) b)
<$> evalWithAttrSet c b
evalIf c t f = do
@ -236,34 +236,34 @@ instance MonadNix e m => MonadEval (NValue m) m where
span <- currentPos
fromValue c >>= \b ->
if b
then addProvenance (\t -> Provenance scope (NIf_ span (Just c) (Just t) Nothing)) <$> t
else addProvenance (\f -> Provenance scope (NIf_ span (Just c) Nothing (Just f))) <$> f
then (\t -> addProvenance (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) t) <$> t
else (\f -> addProvenance (Provenance scope (NIf_ span (Just c) Nothing (Just f))) f) <$> f
evalAssert c body = fromValue c >>= \b -> do
span <- currentPos
if b
then do
scope <- currentScopes
addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body
(\b -> addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b) <$> body
else nverr $ Assertion span c
evalApp f x = do
scope <- currentScopes
span <- currentPos
addProvenance (const $ Provenance scope (NBinary_ span NApp (Just f) Nothing))
addProvenance (Provenance scope (NBinary_ span NApp (Just f) Nothing))
<$> callFunc f x
evalAbs p k = do
scope <- currentScopes
span <- currentPos
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
(void p) (\arg -> snd <$> k arg (\_ b -> ((),) <$> b))
(void p) (\arg -> wrapValue . snd <$> k arg (\_ b -> ((),) <$> b))
evalError = throwError
infixl 1 `callFunc`
callFunc :: forall e m. (MonadNix e m, Typeable m)
=> NValue m -> m (NValue m) -> m (NValue m)
callFunc :: forall e t f m. MonadNix e t f m
=> NValue t f m -> m (NValue t f m) -> m (NValue t f m)
callFunc fun arg = do
frames :: Frames <- asks (view hasLens)
when (length frames > 2000) $
@ -271,18 +271,18 @@ callFunc fun arg = do
case fun of
NVClosure params f -> do
traceM $ "callFunc:NVFunction taking " ++ show params
f arg
force ?? pure =<< f arg
NVBuiltin name f -> do
span <- currentPos
withFrame Info (Calling @m @(NThunk m) name span) $ f arg
force ?? pure =<< withFrame Info (Calling @m @t name span) (f arg)
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp :: (Framed e m, MonadVar m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
-> m (NValue m)
execUnaryOp :: (Framed e m, Cited t f m, Show t)
=> Scopes m t -> SrcSpan -> NUnaryOp -> NValue t f m
-> m (NValue t f m)
execUnaryOp scope span op arg = do
traceM "NUnary"
case arg of
@ -298,13 +298,16 @@ execUnaryOp scope span op arg = do
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
execBinaryOp
:: forall e m. (MonadNix e m, MonadEval (NValue m) m)
=> Scopes m (NThunk m)
:: forall e t f m.
(MonadNix e t f m,
FromValue NixString m t,
MonadEval (NValue t f m) m)
=> Scopes m t
-> SrcSpan
-> NBinaryOp
-> NValue m
-> m (NValue m)
-> m (NValue m)
-> NValue t f m
-> m (NValue t f m)
-> m (NValue t f m)
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
if l
@ -324,7 +327,7 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
execBinaryOp scope span op lval rarg = do
rval <- rarg
let bin :: (Provenance m -> a) -> a
let bin :: (Provenance t f m -> a) -> a
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
toBool = pure . bin nvConstantP . NBool
case (lval, rval) of
@ -420,11 +423,12 @@ execBinaryOp scope span op lval rarg = do
(NVPath p, NVStr ns) -> case op of
NEq -> toBool False -- From eqValues in nix/src/libexpr/eval.cc
NNEq -> toBool True
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack (hackyStringIgnoreContext ns))
NPlus -> bin nvPathP <$> makeAbsolutePath @t @f
(p `mappend` Text.unpack (hackyStringIgnoreContext ns))
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath ls, NVPath rs) -> case op of
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
NPlus -> bin nvPathP <$> makeAbsolutePath @t @f (ls ++ rs)
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
_ -> case op of
@ -437,14 +441,14 @@ execBinaryOp scope span op lval rarg = do
"Unsupported argument types for binary operator "
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
numBinOp :: (forall r. (Provenance m -> r) -> r)
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue m)
numBinOp :: (forall r. (Provenance t f m -> r) -> r)
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue t f m)
numBinOp bin f = numBinOp' bin f f
numBinOp' :: (forall r. (Provenance m -> r) -> r)
numBinOp' :: (forall r. (Provenance t f m -> r) -> r)
-> (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom -> NAtom -> m (NValue m)
-> NAtom -> NAtom -> m (NValue t f m)
numBinOp' bin intF floatF l r = case (l, r) of
(NInt li, NInt ri) -> toInt $ li `intF` ri
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
@ -471,7 +475,7 @@ data CopyToStoreMode
-- ^ Add paths to the store as they are encountered
deriving (Eq,Ord,Enum,Bounded)
coerceToString :: MonadNix e m => CopyToStoreMode -> CoercionLevel -> NValue m -> m NixString
coerceToString :: MonadNix e t f m => CopyToStoreMode -> CoercionLevel -> NValue t f m -> m NixString
coerceToString ctsm clevel = go
where
go = \case
@ -502,71 +506,94 @@ coerceToString ctsm clevel = go
where
t = Text.pack $ unStorePath sp
fromStringNoContext :: MonadNix e m => NixString -> m Text
fromStringNoContext :: MonadNix e t f m => NixString -> m Text
fromStringNoContext ns =
case principledGetStringNoContext ns of
Just str -> return str
Nothing -> throwError $ ErrorCall
"expected string with no context"
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
(StateT (HashMap FilePath NExprLoc) (FreshIdT Int m)) a }
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
MonadFix, MonadIO,
MonadReader (Context (Lazy m) (NThunk (Lazy m))))
newtype Lazy t (f :: * -> *) m a = Lazy
{ runLazy :: ReaderT (Context (Lazy t f m) t)
(StateT (HashMap FilePath NExprLoc) m) a }
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadFix
, MonadIO
, MonadReader (Context (Lazy t f m) t)
)
instance MonadTrans Lazy where
lift = Lazy . lift . lift . lift
instance MonadTrans (Lazy t f) where
lift = Lazy . lift . lift
instance MonadRef m => MonadRef (Lazy m) where
type Ref (Lazy m) = Ref m
instance MonadRef m => MonadRef (Lazy t f m) where
type Ref (Lazy t f m) = Ref m
newRef = lift . newRef
readRef = lift . readRef
writeRef r = lift . writeRef r
instance MonadAtomicRef m => MonadAtomicRef (Lazy m) where
instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where
atomicModifyRef r = lift . atomicModifyRef r
instance (MonadFile m, Monad m) => MonadFile (Lazy m)
instance (MonadFile m, Monad m) => MonadFile (Lazy t f m)
instance MonadCatch m => MonadCatch (Lazy m) where
instance MonadCatch m => MonadCatch (Lazy t f m) where
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
catch (m e) ((`runReaderT` e) . runLazy . f)
instance MonadThrow m => MonadThrow (Lazy m) where
instance MonadThrow m => MonadThrow (Lazy t f m) where
throwM = Lazy . throwM
#ifdef MIN_VERSION_haskeline
instance MonadException m => MonadException (Lazy m) where
instance MonadException m => MonadException (Lazy t f m) where
controlIO f = Lazy $ controlIO $ \(RunIO run) ->
let run' = RunIO (fmap Lazy . run . runLazy)
in runLazy <$> f run'
#endif
instance Monad m => MonadFreshId Int (Lazy m) where
freshId = Lazy $ lift $ lift freshId
instance MonadStore m => MonadStore (Lazy m) where
instance MonadStore m => MonadStore (Lazy t f m) where
addPath' = lift . addPath'
toFile_' n = lift . toFile_' n
instance MonadPutStr m => MonadPutStr (Lazy m)
instance MonadPutStr m => MonadPutStr (Lazy t f m)
instance MonadHttp m => MonadHttp (Lazy m)
instance MonadHttp m => MonadHttp (Lazy t f m)
instance MonadEnv m => MonadEnv (Lazy m)
instance MonadEnv m => MonadEnv (Lazy t f m)
instance MonadInstantiate m => MonadInstantiate (Lazy m)
instance MonadInstantiate m => MonadInstantiate (Lazy t f m)
instance MonadExec m => MonadExec (Lazy m)
instance MonadExec m => MonadExec (Lazy t f m)
instance MonadIntrospect m => MonadIntrospect (Lazy m)
instance MonadIntrospect m => MonadIntrospect (Lazy t f m)
instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m,
MonadIntrospect m, Alternative m, MonadPlus m, Typeable m)
=> MonadEffects (Lazy m) where
instance MonadThunkId m => MonadThunkId (Lazy t f m) where
type ThunkId (Lazy t f m) = ThunkId m
instance ( MonadFix m
, MonadCatch m
, MonadFile m
, MonadStore m
, MonadPutStr m
, MonadHttp m
, MonadEnv m
, MonadInstantiate m
, MonadExec m
, MonadIntrospect m
, Alternative m
, MonadPlus m
, MonadCitedThunks t f (Lazy t f m)
, FromNix Bool (Lazy t f m) t
, FromValue NixString (Lazy t f m) t
, FromValue Path (Lazy t f m) t
, ToNix NixString (Lazy t f m) t
, ToNix [t] (Lazy t f m) t
)
=> MonadEffects t f (Lazy t f m) where
makeAbsolutePath origPath = do
origPathExpanded <- expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
@ -608,17 +635,18 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
modify (M.insert path expr)
pure expr
derivationStrict = fromValue @(ValueSet (Lazy m)) >=> \s -> do
derivationStrict = fromValue @(AttrSet t) >=> \s -> do
nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s)
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
v' <- normalForm =<< toValue @(ValueSet (Lazy m)) s'
v' <- normalForm
=<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
where
mapMaybeM :: (a -> Lazy m (Maybe b)) -> [a] -> Lazy m [b]
mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b]
mapMaybeM op = foldr f (return [])
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
handleEntry :: Bool -> (Text, NThunk (Lazy m)) -> Lazy m (Maybe (Text, NThunk (Lazy m)))
handleEntry :: Bool -> (Text, t) -> Lazy t f m (Maybe (Text, t))
handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of
-- The `args' attribute is special: it supplies the command-line
-- arguments to the builder.
@ -631,16 +659,17 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
v' -> Just <$> coerceNix v'
where
coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
coerceNixList = toNix <=< traverse (\x -> force x coerceNix) <=< fromValue @[NThunk (Lazy m)]
coerceNixList =
toNix <=< traverse (\x -> force x coerceNix)
<=< fromValue @[t]
traceEffect = putStrLn
getRecursiveSize :: MonadIntrospect m => a -> m (NValue m)
getRecursiveSize = toNix @Integer . fromIntegral <=< recursiveSize
getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m)
getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize
runLazyM :: Options -> MonadIO m => Lazy m a -> m a
runLazyM opts = runFreshIdT 0
. (`evalStateT` M.empty)
runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a
runLazyM opts = (`evalStateT` M.empty)
. (`runReaderT` newContext opts)
. runLazy
@ -673,9 +702,11 @@ x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
joinPath $ head [ xs ++ drop (length tx) ys
| tx <- tails xs, tx `elem` inits ys ]
findPathBy :: forall e m. MonadNix e m =>
(FilePath -> m (Maybe FilePath)) ->
[NThunk m] -> FilePath -> m FilePath
findPathBy
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> (FilePath -> m (Maybe FilePath))
-> [t] -> FilePath -> m FilePath
findPathBy finder l name = do
mpath <- foldM go Nothing l
case mpath of
@ -685,10 +716,10 @@ findPathBy finder l name = do
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
where
go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
go :: Maybe FilePath -> t -> m (Maybe FilePath)
go p@(Just _) _ = pure p
go Nothing l = force l $ fromValue >=>
\(s :: HashMap Text (NThunk m)) -> do
\(s :: HashMap Text t) -> do
p <- resolvePath s
force p $ fromValue >=> \(Path path) ->
case M.lookup "prefix" s of
@ -713,36 +744,40 @@ findPathBy finder l name = do
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: " ++ show s
findPathM :: forall e m. MonadNix e m =>
[NThunk m] -> FilePath -> m FilePath
findPathM
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> [t] -> FilePath -> m FilePath
findPathM l name = findPathBy path l name
where
path :: MonadEffects m => FilePath -> m (Maybe FilePath)
path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
path path = do
path <- makeAbsolutePath path
path <- makeAbsolutePath @t @f path
exists <- doesPathExist path
return $ if exists then Just path else Nothing
findEnvPathM :: forall e m. MonadNix e m
=> FilePath -> m FilePath
findEnvPathM
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> FilePath -> m FilePath
findEnvPathM name = do
mres <- lookupVar "__nixPath"
case mres of
Nothing -> error "impossible"
Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
Just x -> force x $ fromValue >=> \(l :: [t]) ->
findPathBy nixFilePath l name
where
nixFilePath :: MonadEffects m => FilePath -> m (Maybe FilePath)
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
nixFilePath path = do
path <- makeAbsolutePath path
path <- makeAbsolutePath @t @f path
exists <- doesDirectoryExist path
path' <- if exists
then makeAbsolutePath $ path </> "default.nix"
then makeAbsolutePath @t @f $ path </> "default.nix"
else return path
exists <- doesFileExist path'
return $ if exists then Just path' else Nothing
addTracing :: (MonadNix e m, Has e Options,
addTracing :: (MonadNix e t f m, Has e Options,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
addTracing k v = do
@ -767,21 +802,26 @@ addTracing k v = do
print $ msg rendered <> " ...done"
return res
evalExprLoc :: forall e m. (MonadNix e m, Has e Options)
=> NExprLoc -> m (NValue m)
evalExprLoc
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, Has e Options)
=> NExprLoc -> m (NValue t f m)
evalExprLoc expr = do
opts :: Options <- asks (view hasLens)
if tracing opts
then join . (`runReaderT` (0 :: Int)) $
adi (addTracing phi)
(raise (addStackFrames @(NThunk m) . addSourcePositions))
(raise (addStackFrames @t . addSourcePositions))
expr
else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr
else adi phi (addStackFrames @t . addSourcePositions) expr
where
phi = Eval.eval . annotated . getCompose
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
fetchTarball
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t)
=> m (NValue t f m) -> m (NValue t f m)
fetchTarball v = v >>= \case
NVSet s _ -> case M.lookup "url" s of
Nothing -> throwError $ ErrorCall
@ -791,14 +831,14 @@ fetchTarball v = v >>= \case
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or set, got " ++ show v
where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go :: Maybe t -> NValue t f m -> m (NValue t f m)
go msha = \case
NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or string, got " ++ show v
{- jww (2018-04-11): This should be written using pipes in another module
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m)
fetch uri msha = case takeExtension (Text.unpack uri) of
".tgz" -> undefined
".gz" -> undefined
@ -809,7 +849,7 @@ fetchTarball v = v >>= \case
++ ext ++ "'"
-}
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
fetch :: Text -> Maybe t -> m (NValue t f m)
fetch uri Nothing =
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
Text.unpack uri ++ "\""
@ -820,47 +860,25 @@ fetchTarball v = v >>= \case
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
exec
:: ( MonadExec m
, Framed e m
, MonadThrow m
, Alternative m
, MonadCatch m
, MonadFix m
, MonadEffects m
, MonadFreshId Int m
, GEq (Ref m)
, MonadAtomicRef m
, Typeable m
, Has e Options
, Has e SrcSpan
, Scoped (NThunk m) m
)
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
)
=> [String]
-> m (NValue m)
-> m (NValue t f m)
exec args = either throwError evalExprLoc =<< exec' args
nixInstantiateExpr
:: ( MonadInstantiate m
, Framed e m
, MonadThrow m
, Alternative m
, MonadCatch m
, MonadFix m
, MonadEffects m
, MonadFreshId Int m
, GEq (Ref m)
, MonadAtomicRef m
, Typeable m
, Has e Options
, Has e SrcSpan
, Scoped (NThunk m) m
)
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
)
=> String
-> m (NValue m)
-> m (NValue t f m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
instance Monad m => Scoped (NThunk (Lazy m)) (Lazy m) where
instance Monad m => Scoped t (Lazy t f m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lazy m) @(NThunk (Lazy m))
clearScopes = clearScopesReader @(Lazy t f m) @t
pushScopes = pushScopesReader
lookupVar = lookupVarReader

3
src/Nix/Expr/Types.hs
View file

@ -70,6 +70,9 @@ import qualified Type.Reflection as Reflection
type VarName = Text
hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
hashAt = flip alterF
-- unfortunate orphans
#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NonEmpty

59
src/Nix/Fresh.hs
View file

@ -6,6 +6,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
@ -14,6 +15,7 @@
module Nix.Fresh where
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
@ -21,24 +23,21 @@ import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Writer
import Data.Typeable
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
#endif
-- TODO better fresh name supply
class Monad m => MonadFreshId i m | m -> i where
freshId :: m i
default freshId :: (MonadFreshId i m', MonadTrans t, m ~ (t m')) => m i
freshId = lift freshId
import Nix.Var
import Nix.Thunk
newtype FreshIdT i m a = FreshIdT { unFreshIdT :: StateT i m a }
newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a }
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadTrans
, MonadFix
, MonadRef
, MonadAtomicRef
@ -50,16 +49,46 @@ newtype FreshIdT i m a = FreshIdT { unFreshIdT :: StateT i m a }
#endif
)
instance (Monad m, Num i) => MonadFreshId i (FreshIdT i m) where
freshId = FreshIdT $ get <* modify (+ 1)
instance MonadTrans (FreshIdT i) where
lift = FreshIdT . lift
runFreshIdT :: Functor m => i -> FreshIdT i m a -> m a
runFreshIdT i m = fst <$> runStateT (unFreshIdT m) i
instance MonadBase b m => MonadBase b (FreshIdT i m) where
liftBase = FreshIdT . liftBase
instance MonadFreshId i m => MonadFreshId i (ReaderT r m)
instance (Monoid w, MonadFreshId i m) => MonadFreshId i (WriterT w m)
instance MonadFreshId i m => MonadFreshId i (ExceptT e m)
instance MonadFreshId i m => MonadFreshId i (StateT s m)
-- instance MonadTransControl (FreshIdT i) where
-- type StT (FreshIdT i) a = StT (ReaderT (Var m i)) a
-- liftWith = defaultLiftWith FreshIdT unFreshIdT
-- restoreT = defaultRestoreT FreshIdT
-- instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where
-- type StM (FreshIdT i m) a = ComposeSt (FreshIdT i) m a
-- liftBaseWith = defaultLiftBaseWith
-- restoreM = defaultRestoreM
instance ( MonadVar m
, Eq i
, Ord i
, 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))
runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a
runFreshIdT i m = runReaderT (unFreshIdT m) i
instance MonadThunkId m => MonadThunkId (ReaderT r m) where
type ThunkId (ReaderT r m) = ThunkId m
instance (Monoid w, MonadThunkId m) => MonadThunkId (WriterT w m) where
type ThunkId (WriterT w m) = ThunkId m
instance MonadThunkId m => MonadThunkId (ExceptT e m) where
type ThunkId (ExceptT e m) = ThunkId m
instance MonadThunkId m => MonadThunkId (StateT s m) where
type ThunkId (StateT s m) = ThunkId m
-- Orphan instance needed by Infer.hs and Lint.hs

14
src/Nix/Json.hs
View file

@ -22,12 +22,14 @@ import Nix.Thunk
import Nix.Utils
import Nix.Value
nvalueToJSONNixString :: MonadNix e m => NValue m -> m NixString
nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString
nvalueToJSONNixString = runWithStringContextT
. fmap (TL.toStrict . TL.decodeUtf8 . A.encodingToLazyByteString . toEncodingSorted)
. fmap (TL.toStrict . TL.decodeUtf8
. A.encodingToLazyByteString
. toEncodingSorted)
. nvalueToJSON
nvalueToJSON :: MonadNix e m => NValue m -> WithStringContextT m A.Value
nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
nvalueToJSON = \case
NVConstant (NInt n) -> pure $ A.toJSON n
NVConstant (NFloat n) -> pure $ A.toJSON n
@ -35,9 +37,11 @@ nvalueToJSON = \case
NVConstant NNull -> pure $ A.Null
NVStr ns -> A.toJSON <$> extractNixString ns
NVList l ->
A.Array . V.fromList <$> traverse (join . lift . flip force (return . nvalueToJSON)) l
A.Array . V.fromList
<$> traverse (join . lift . flip force (return . nvalueToJSON)) l
NVSet m _ -> case HM.lookup "outPath" m of
Nothing -> A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
Nothing -> A.Object
<$> traverse (join . lift . flip force (return . nvalueToJSON)) m
Just outPath -> join $ lift $ force outPath (return . nvalueToJSON)
NVPath p -> do
fp <- lift $ unStorePath <$> addPath p

25
src/Nix/Lint.hs
View file

@ -120,7 +120,7 @@ unpackSymbolic :: MonadVar m
unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
MonadCatch m, MonadFreshId Int m)
MonadCatch m, MonadThunkId m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m) . ErrorCall
@ -248,12 +248,15 @@ instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
instance ToValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
instance MonadLint e m => MonadThunk (Symbolic m) (SThunk m) m where
thunk = fmap coerce . buildThunk
force = forceThunk . coerce
forceEff = forceEffects . coerce
wrapValue = coerce . valueRef
getValue = thunkValue . coerce
instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where
thunk = fmap SThunk . thunk
thunkId = thunkId . getSThunk
query x b f = query (getSThunk x) b f
queryM x b f = queryM (getSThunk x) b f
force = force . getSThunk
forceEff = forceEff . getSThunk
wrapValue = SThunk . wrapValue
getValue = getValue . getSThunk
instance MonadLint e m => MonadEval (Symbolic m) m where
freeVariable var = symerr $
@ -303,7 +306,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
s <- thunk @(Symbolic m) @(SThunk m) scope
s <- thunk @(SThunk m) @m @(Symbolic m) scope
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
NMany [TSet (Just s')] -> return s'
NMany [TSet Nothing] -> error "NYI: with unknown"
@ -400,7 +403,7 @@ newtype Lint s a = Lint
, Monad
, MonadFix
, MonadReader (Context (Lint s) (SThunk (Lint s)))
, MonadFreshId Int
, MonadThunkId
, MonadRef
, MonadAtomicRef
)
@ -412,7 +415,9 @@ instance MonadCatch (Lint s) where
catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'"
runLintM :: Options -> Lint s a -> ST s a
runLintM opts = runFreshIdT 0 . flip runReaderT (newContext opts) . runLint
runLintM opts action = do
i <- newVar (1 :: Int)
runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action
symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
symbolicBaseEnv = return emptyScopes

158
src/Nix/Normal.hs
View file

@ -12,98 +12,94 @@
module Nix.Normal where
import Control.Monad
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import qualified Data.HashMap.Lazy as M
import Data.List (find)
import Data.Maybe (isJust)
import Nix.Frames
-- import Nix.Pretty
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Set
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
newtype NormalLoop m = NormalLoop (NValue m)
newtype NormalLoop t f m = NormalLoop (NValue t f m)
deriving Show
instance Typeable m => Exception (NormalLoop m)
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalFormBy
:: forall e m. (Framed e m, MonadVar m, Typeable m)
=> (forall r. NThunk m -> (NValue m -> StateT [Var m Bool] m r)
-> StateT [Var m Bool] m r)
-> Int
-> NValue m
-> StateT [Var m Bool] m (NValueNF m)
normalFormBy k n v = case v of
NVConstant a -> return $ Free $ NVConstantF a
NVStr ns -> return $ Free $ NVStrF ns
NVList l ->
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
k t (next t)
NVSet s p ->
fmap (Free . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
traceM $ show n ++ ": normalFormBy: Set{" ++ show ky ++ "}"
k t (next t)
NVClosure p f -> return $ Free $ NVClosureF p f
NVPath fp -> return $ Free $ NVPathF fp
NVBuiltin name f -> return $ Free $ NVBuiltinF name f
_ -> error "Pattern synonyms mask complete matches"
normalForm'
:: forall e t m f.
( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> (forall r. t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValueNF t f m)
normalForm' f = run . nValueToNFM run go
where
next t val = do
b <- seen t
if b
then return $ Pure val
else normalFormBy k (succ n) val
start = 0 :: Int
table = mempty
seen (NThunk (NCited _ (Thunk _ b _))) = do
res <- gets (isJust . find (eqVar @m b))
unless res $
modify (b:)
return res
seen _ = pure False
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
normalForm' :: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
-> NValue m -> m (NValueNF m)
normalForm' f = flip evalStateT mempty . normalFormBy go 0
where
go :: NThunk m
-> (NValue m -> StateT [Var m Bool] m r)
-> StateT [Var m Bool] m r
go :: t
-> (NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
go t k = do
s <- get
(res, s') <- lift $ f t $ \v -> runStateT (k v) s
put s'
i <- ask
when (i > 2000) $
error "Exceeded maximum normalization depth of 2000 levels"
s <- lift get
(res, s') <- lift $ lift $ f t $ \v ->
(`runStateT` s) . (`runReaderT` i) $ local succ $ do
b <- seen t
if b
then return $ pure (error "Loop detected" <$ v)
else k v
lift $ put s'
return res
normalForm :: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> NValue m -> m (NValueNF m)
seen t = case thunkId t of
Just tid -> lift $ do
res <- gets (member tid)
unless res $ modify (insert tid)
return res
Nothing ->
return False
normalForm
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m (NValueNF t f m)
normalForm = normalForm' force
normalForm_
:: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> NValue m -> m ()
normalForm_ = void . normalForm' (forceEffects . _cited . _nThunk)
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m ()
normalForm_ = void <$> normalForm' forceEff
embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
=> NValueNF m -> m (NValue m)
embed (Pure v) = return v
embed (Free x) = case x of
NVConstantF a -> return $ nvConstant a
NVStrF ns -> return $ nvStr ns
NVListF l ->
nvList . fmap (wrapValue @_ @_ @m) <$> traverse embed l
NVSetF s p ->
flip nvSet p . fmap (wrapValue @_ @_ @m) <$> traverse embed s
NVClosureF p f -> return $ nvClosure p f
NVPathF fp -> return $ nvPath fp
NVBuiltinF n f -> return $ nvBuiltin n f
removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> NValueNF t f m
removeEffects = nValueToNF (flip query opaque)
removeEffectsM :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> m (NValueNF t f m)
removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
opaque :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m
opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"
dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t -> m (NValueNF t f m)
dethunk t = queryM t (pure opaque) removeEffectsM

176
src/Nix/Pretty.hs
View file

@ -2,9 +2,12 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
@ -14,8 +17,7 @@
module Nix.Pretty where
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Free
import Control.Comonad
import Data.Fix
import Data.HashMap.Lazy (toList)
import qualified Data.HashMap.Lazy as M
@ -28,19 +30,19 @@ import Data.Text (pack, unpack, replace, strip)
import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Nix.Atoms
import Nix.Cited
import Nix.Expr
import Nix.Normal
import Nix.Parser
import Nix.String
import Nix.Strings
import Nix.Thunk
import Nix.Thunk.Basic
#if ENABLE_TRACING
import Nix.Utils
#else
import Nix.Utils hiding ((<$>))
#endif
import Nix.Value
import Nix.Var
import Prelude hiding ((<$>))
import Text.Read (readMaybe)
@ -170,14 +172,22 @@ prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom
prettyNix :: NExpr -> Doc ann
prettyNix = withoutParens . cata exprFNixDoc
prettyOriginExpr :: NExprLocF (Maybe (NValue m)) -> Doc ann
instance HasCitations1 t f m
=> HasCitations t f m (NValue' t f m a) where
citations (NValue f) = citations1 f
addProvenance x (NValue f) = NValue (addProvenance1 x f)
prettyOriginExpr :: forall t f m ann. HasCitations1 t f m
=> NExprLocF (Maybe (NValue t 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 (Just (NValue (NCited (reverse -> p:_) _))) = go (_originExpr p)
render (Just (NValue (NCited _ _))) = simpleExpr "?"
render (Just (reverse . citations @t @f @m -> p:_)) = go (_originExpr p)
render _ = simpleExpr "?"
-- render (Just (NValue (citations -> ps))) =
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
-- . go . originExpr)
-- mempty (reverse ps)
@ -264,42 +274,36 @@ exprFNixDoc = \case
where
recPrefix = "rec" <> space
fixate :: Functor f => (a -> f (Fix f)) -> Free f a -> Fix f
fixate g = Fix . go
valueToExpr :: forall t f m. MonadDataContext f m => NValueNF t f m -> NExpr
valueToExpr = iterNValueNF
(const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))
phi
where
go (Pure a) = g a
go (Free f) = fmap (Fix . go) f
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
where
check :: NValueNF m -> Fix (NValueF m)
check = fixate $ const $ NVStrF $ principledMakeNixStringWithoutContext "<CYCLE>"
go (NVConstantF a) = NConstant a
go (NVStrF ns) = NStr (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])
go (NVListF l) = NList l
go (NVSetF s p) = NSet
phi :: NValue' t f m NExpr -> NExpr
phi (NVConstant a) = Fix $ NConstant a
phi (NVStr ns) = mkStr ns
phi (NVList l) = Fix $ NList l
phi (NVSet s p) = Fix $ NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s ]
go (NVClosureF _ _) = NSym . pack $ "<closure>"
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
phi (NVClosure _ _) = Fix . NSym . pack $ "<closure>"
phi (NVPath p) = Fix $ NLiteralPath p
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
phi _ = error "Pattern synonyms foil completeness check"
prettyNValueNF :: Functor m => NValueNF m -> Doc ann
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann
prettyNValueNF = prettyNix . valueToExpr
printNix :: Functor m => NValueNF m -> String
printNix = iter phi . check
printNix :: forall t f m. MonadDataContext f m => NValueNF t f m -> String
printNix = iterNValueNF (const "<CYCLE>") phi
where
check :: NValueNF m -> Free (NValueF m) String
check = fmap (const "<CYCLE>")
phi :: NValueF m String -> String
phi (NVConstantF a) = unpack $ atomText a
phi (NVStrF ns) = show $ hackyStringIgnoreContext ns
phi (NVListF l) = "[ " ++ unwords l ++ " ]"
phi (NVSetF s _) =
phi :: NValue' t f m String -> String
phi (NVConstant a) = unpack $ atomText a
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
phi (NVList l) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
"{ " ++ concat [ check (unpack k) ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
where
@ -309,60 +313,50 @@ printNix = iter phi . check
<|> (fmap (surround . show) (readMaybe v :: Maybe Float)))
where
surround s = "\"" ++ s ++ "\""
phi NVClosureF {} = "<<lambda>>"
phi (NVPathF fp) = fp
phi (NVBuiltinF name _) = "<<builtin " ++ name ++ ">>"
phi NVClosure {} = "<<lambda>>"
phi (NVPath fp) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
phi _ = error "Pattern synonyms foil completeness check"
removeEffects :: MonadThunk (NThunk m) (NValue m) m
=> NValueF m (NThunk m) -> NValueNF m
removeEffects = Free . fmap dethunk
where
dethunk (NThunk (NCited _ (Value (NValue v)))) = removeEffects (_cited v)
dethunk (NThunk (NCited _ _)) =
Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
prettyNValue
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> m (Doc ann)
prettyNValue = fmap prettyNValueNF . removeEffectsM
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
removeEffectsM = fmap Free . traverse dethunk
prettyNValueProv
:: forall t f m ann.
( HasCitations1 t f m
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> NValue t f m -> m (Doc ann)
prettyNValueProv v@(NValue nv) = do
let ps = citations1 @t @f @m nv
case ps of
[] -> prettyNValue v
ps -> do
v' <- prettyNValue v
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
$ "from: "
: map (prettyOriginExpr . _originExpr) ps
]
prettyNValueF :: MonadVar m => NValueF m (NThunk m) -> m (Doc ann)
prettyNValueF = fmap prettyNValueNF . removeEffectsM
prettyNValue :: MonadVar m => NValue m -> m (Doc ann)
prettyNValue (NValue (NCited _ v)) = prettyNValueF v
prettyNValueProv :: MonadVar m => NValue m -> m (Doc ann)
prettyNValueProv = \case
NValue (NCited [] v) -> prettyNValueF v
NValue (NCited ps v) -> do
v' <- prettyNValueF v
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
$ "from: "
: map (prettyOriginExpr . _originExpr) ps
]
prettyNThunk :: MonadVar m => NThunk m -> m (Doc ann)
prettyNThunk = \case
t@(NThunk (NCited ps _)) -> do
v' <- fmap prettyNValueNF (dethunk t)
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
$ "thunk from: "
: map (prettyOriginExpr . _originExpr) ps
]
dethunk :: MonadVar m => NThunk m -> m (NValueNF m)
dethunk = \case
NThunk (NCited _ (Value (NValue v))) -> removeEffectsM (_cited v)
NThunk (NCited _ (Thunk _ active ref)) -> do
nowActive <- atomicModifyVar active (True,)
if nowActive
then pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
else do
eres <- readVar ref
res <- case eres of
Computed (NValue v) -> removeEffectsM (_cited v)
_ -> pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
_ <- atomicModifyVar active (False,)
return res
prettyNThunk
:: forall t f m ann.
( HasCitations t f m t
, HasCitations1 t f m
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> t -> m (Doc ann)
prettyNThunk t = do
let ps = citations @t @f @m @t t
v' <- prettyNValueNF <$> dethunk t
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
$ "thunk from: "
: map (prettyOriginExpr . _originExpr) ps
]

94
src/Nix/Render/Frame.hs
View file

@ -28,28 +28,31 @@ import Nix.Render
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Nix.Var
import Text.Megaparsec.Pos
#ifdef MIN_VERSION_pretty_show
import qualified Text.Show.Pretty as PS
#endif
renderFrames
:: forall v e m ann
. ( MonadReader e m, Has e Options
, MonadVar m, MonadFile m, Typeable m, Typeable v)
:: forall v t f e m ann
. ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
, Typeable v
)
=> Frames -> m (Doc ann)
renderFrames [] = pure mempty
renderFrames (x:xs) = do
opts :: Options <- asks (view hasLens)
frames <-
if | verbose opts <= ErrorsOnly ->
renderFrame @v x
renderFrame @v @t @f x
| verbose opts <= Informational -> do
f <- renderFrame @v x
f <- renderFrame @v @t @f x
pure $ concatMap go (reverse xs) ++ f
| otherwise ->
concat <$> mapM (renderFrame @v) (reverse (x:xs))
concat <$> mapM (renderFrame @v @t @f) (reverse (x:xs))
pure $ case frames of
[] -> mempty
_ -> vsep frames
@ -62,8 +65,8 @@ renderFrames (x:xs) = do
<> colon]
Nothing -> []
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
-> Maybe SourcePos
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v)
=> NixFrame -> Maybe SourcePos
framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
@ -71,18 +74,23 @@ framePos (NixFrame _ f)
_ -> Nothing
| otherwise = Nothing
renderFrame :: forall v e m ann.
(MonadReader e m, Has e Options, MonadVar m,
MonadFile m, Typeable m, Typeable v)
=> NixFrame -> m [Doc ann]
renderFrame
:: forall v t f e m ann.
( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
, Typeable v
)
=> NixFrame -> m [Doc ann]
renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame 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)]
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
| Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show f
wrapExpr :: NExprF r -> NExpr
@ -142,9 +150,13 @@ renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
]
else pretty shortLabel <> fillSep [": ", rendered]
renderValueFrame :: (MonadReader e m, Has e Options,
MonadFile m, MonadVar m)
=> NixLevel -> ValueFrame m -> m [Doc ann]
renderValueFrame
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> ValueFrame t f m -> m [Doc ann]
renderValueFrame level = fmap (:[]) . \case
ForcingThunk -> pure "ForcingThunk"
ConcerningValue _v -> pure "ConcerningValue"
@ -173,31 +185,45 @@ renderValueFrame level = fmap (:[]) . \case
pure $ "Saw " <> v'
<> " but expected " <> pretty (describeValue t)
renderValue :: (MonadReader e m, Has e Options, MonadFile m, MonadVar m)
=> NixLevel -> String -> String -> NValue m -> m (Doc ann)
renderValue
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue _level _longLabel _shortLabel v = do
opts :: Options <- asks (view hasLens)
if values opts
then prettyNValueProv v
else prettyNValue v
renderExecFrame :: (MonadReader e m, Has e Options, MonadVar m, MonadFile m)
=> NixLevel -> ExecFrame m -> m [Doc ann]
renderExecFrame
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> ExecFrame t f m -> m [Doc ann]
renderExecFrame level = \case
Assertion ann v ->
fmap (:[]) $ renderLocation ann
=<< ((\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v)
renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop _level = pure . (:[]) . \case
ThunkLoop Nothing -> "Infinite recursion"
ThunkLoop (Just n) ->
pretty $ "Infinite recursion in thunk #" ++ show n
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n
renderNormalLoop :: (MonadReader e m, Has e Options, MonadFile m, MonadVar m)
=> NixLevel -> NormalLoop m -> m [Doc ann]
renderNormalLoop
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> NormalLoop t f m -> m [Doc ann]
renderNormalLoop level = fmap (:[]) . \case
NormalLoop v -> do
v' <- renderValue level "" "" v

28
src/Nix/Scope.hs
View file

@ -20,38 +20,38 @@ import Data.Text (Text)
import Lens.Family2
import Nix.Utils
newtype Scope a = Scope { getScope :: AttrSet a }
deriving (Functor, Foldable, Traversable)
newtype Scope t = Scope { getScope :: AttrSet t }
deriving (Functor, Foldable, Traversable, Eq)
instance Show (Scope a) where
instance Show (Scope t) where
show (Scope m) = show (M.keys m)
newScope :: AttrSet a -> Scope a
newScope :: AttrSet t -> Scope t
newScope = Scope
scopeLookup :: Text -> [Scope v] -> Maybe v
scopeLookup :: Text -> [Scope t] -> Maybe t
scopeLookup key = foldr go Nothing
where
go (Scope m) rest = M.lookup key m <|> rest
data Scopes m v = Scopes
{ lexicalScopes :: [Scope v]
, dynamicScopes :: [m (Scope v)]
data Scopes m t = Scopes
{ lexicalScopes :: [Scope t]
, dynamicScopes :: [m (Scope t)]
}
instance Show (Scopes m v) where
show (Scopes m v) =
instance Show (Scopes m t) where
show (Scopes m t) =
"Scopes: " ++ show m ++ ", and "
++ show (length v) ++ " with-scopes"
++ show (length t) ++ " with-scopes"
instance Semigroup (Scopes m v) where
instance Semigroup (Scopes m t) where
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
instance Monoid (Scopes m v) where
instance Monoid (Scopes m t) where
mempty = emptyScopes
mappend = (<>)
emptyScopes :: forall m v. Scopes m v
emptyScopes :: forall m t. Scopes m t
emptyScopes = Scopes [] []
class Scoped t m | m -> t where

2
src/Nix/String.hs
View file

@ -23,7 +23,7 @@ module Nix.String (
, principledStringMempty
, principledStringMConcat
, WithStringContext
, WithStringContextT
, WithStringContextT(..)
, extractNixString
, addStringContext
, addSingletonStringContext

40
src/Nix/Thunk.hs
View file

@ -1,21 +1,51 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Nix.Thunk where
import Control.Exception hiding (catch)
import Data.Typeable
import Control.Exception (Exception)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Typeable (Typeable)
class Monad m => MonadThunk v t m | t -> m, t -> v where
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
class MonadThunkId m => MonadThunk t m v | t -> m, t -> v where
thunk :: m v -> m t
-- | Return an identifier for the thunk unless it is a pure value (i.e.,
-- strictly an encapsulation of some 'v' without any additional
-- structure). For pure values represented as thunks, returns Nothing.
thunkId :: t -> Maybe (ThunkId m)
query :: t -> r -> (v -> r) -> r
queryM :: t -> m r -> (v -> m r) -> m r
force :: t -> (v -> m r) -> m r
forceEff :: t -> (v -> m r) -> m r
wrapValue :: v -> t
getValue :: t -> Maybe v
newtype ThunkLoop = ThunkLoop (Maybe Int)
deriving (Show, Typeable)
newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
deriving Typeable
instance Show ThunkLoop where
show (ThunkLoop i) = "ThunkLoop " ++ i
instance Exception ThunkLoop

74
src/Nix/Thunk/Basic.hs
View file

@ -4,21 +4,20 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Thunk.Basic where
module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Control.Monad.Ref
import Data.GADT.Compare
import Nix.Fresh
import Nix.Thunk
import Nix.Utils
import Nix.Var
@ -29,22 +28,31 @@ data Deferred m v = Deferred (m v) | Computed v
-- | The type of very basic thunks
data NThunkF m v
= Value v
| Thunk Int (Var m Bool) (Var m (Deferred m v))
| Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))
instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where
Value x == Value y = x == y
Thunk x _ _ == Thunk y _ _ = x == y
_ == _ = False -- jww (2019-03-16): not accurate...
instance Show v => Show (NThunkF m v) where
show (Value v) = show v
show (Thunk _ _ _) = "<thunk>"
type MonadBasicThunk m
= (MonadAtomicRef m, GEq (Ref m), MonadFreshId Int m, MonadCatch m)
type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
instance (MonadAtomicRef m, GEq (Ref m), MonadFreshId Int m, MonadCatch m)
=> MonadThunk v (NThunkF m v) m where
thunk = buildThunk
force = forceThunk
forceEff = forceEffects
instance (MonadBasicThunk m, MonadCatch m)
=> MonadThunk (NThunkF m v) m v where
thunk = buildThunk
thunkId = \case
Value _ -> Nothing
Thunk n _ _ -> Just n
query = queryValue
queryM = queryThunk
force = forceThunk
forceEff = forceEffects
wrapValue = valueRef
getValue = thunkValue
getValue = thunkValue
valueRef :: v -> NThunkF m v
valueRef = Value
@ -53,14 +61,38 @@ thunkValue :: NThunkF m v -> Maybe v
thunkValue (Value v) = Just v
thunkValue _ = Nothing
buildThunk :: (MonadVar m, MonadFreshId Int m) => m v -> m (NThunkF m v)
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk action =do
freshThunkId <- freshId
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
forceThunk :: (MonadVar m, MonadThrow m, MonadCatch m)
=> NThunkF m v -> (v -> m a) -> m a
forceThunk (Value ref) k = k ref
queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a
queryValue (Value v) _ k = k v
queryValue _ n _ = n
queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk (Value v) _ k = k v
queryThunk (Thunk _ active ref) n k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then n
else do
eres <- readVar ref
res <- case eres of
Computed v -> k v
_ -> n
_ <- atomicModifyVar active (False,)
return res
forceThunk
:: forall m v a.
( MonadVar m
, MonadThrow m
, MonadCatch m
, Show (ThunkId m)
)
=> NThunkF m v -> (v -> m a) -> m a
forceThunk (Value v) k = k v
forceThunk (Thunk n active ref) k = do
eres <- readVar ref
case eres of
@ -69,7 +101,7 @@ forceThunk (Thunk n active ref) k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then
throwM $ ThunkLoop (Just n)
throwM $ ThunkLoop $ show n
else do
traceM $ "Forcing " ++ show n
v <- catch action $ \(e :: SomeException) -> do
@ -79,12 +111,12 @@ forceThunk (Thunk n active ref) k = do
writeVar ref (Computed v)
k v
forceEffects :: MonadVar m => NThunkF m v -> (v -> m a) -> m a
forceEffects (Value ref) k = k ref
forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
forceEffects (Value v) k = k v
forceEffects (Thunk _ active ref) k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then return $ error "forceEffects: a value was expected"
then return $ error "Loop detected"
else do
eres <- readVar ref
case eres of

216
src/Nix/Thunk/Standard.hs Normal file
View file

@ -0,0 +1,216 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Thunk.Standard where
import Control.Comonad (Comonad)
import Control.Comonad.Env (ComonadEnv)
import Control.Monad.Catch hiding (catchJust)
import Control.Monad.Reader
import Data.Fix
import GHC.Generics
import Nix.Cited
import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.Options
import Nix.Render
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var (MonadVar, newVar)
newtype StdCited m a = StdCited
{ _stdCited :: NCited (StdThunk m) (StdCited m) (StdLazy m) a }
deriving
( Generic
, Typeable
, Functor
, Applicative
, Foldable
, Traversable
, Comonad
, ComonadEnv [Provenance (StdThunk m) (StdCited m) (StdLazy m)]
)
newtype StdThunk m = StdThunk
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy m)
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) (StdLazy m)
type StdIdT m = FreshIdT Int m
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT m)
type MonadStdThunk m =
( MonadVar m
, MonadCatch m
, MonadThrow m
, Typeable m
)
instance MonadStdThunk m
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
else
fmap (StdThunk . StdCited . NCited []) . thunk $ mv
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
query (StdThunk (StdCited (NCited _ t))) = query t
queryM (StdThunk (StdCited (NCited _ t))) = queryM t
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann s _)):_ ->
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (force t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(force t f)
forceEff (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann s _)):_ -> do
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (forceEff t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(forceEff t f)
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
instance ( MonadStdThunk m
, ToValue a (StdLazy m) (StdValue m)
)
=> ToValue a (StdLazy m) (StdThunk m) where
toValue = fmap wrapValue . toValue
instance MonadStdThunk m
=> ToValue (StdThunk m) (StdLazy m) (StdValue m) where
toValue = force ?? pure
instance ( MonadStdThunk m
, FromValue a (StdLazy m) (StdValue m)
)
=> FromValue a (StdLazy m) (StdThunk m) where
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
instance MonadStdThunk m
=> FromValue (StdThunk m) (StdLazy m) (StdValue m) where
fromValueMay = pure . Just . wrapValue
fromValue = pure . wrapValue
instance ( MonadStdThunk m
, ToNix a (StdLazy m) (StdValue m)
)
=> ToNix a (StdLazy m) (StdThunk m) where
toNix = fmap wrapValue . toNix
instance MonadStdThunk m
=> ToNix (StdThunk m) (StdLazy m) (StdValue m) where
toNix = force ?? pure
instance ( MonadStdThunk m
, FromNix a (StdLazy m) (StdValue m)
)
=> FromNix a (StdLazy m) (StdThunk m) where
fromNixMay = force ?? fromNixMay
fromNix = force ?? fromNix
instance MonadStdThunk m
=> FromNix (StdThunk m) (StdLazy m) (StdValue m) where
fromNixMay = pure . Just . wrapValue
fromNix = pure . wrapValue
instance Show (StdThunk m) where
show _ = "<thunk>" -- jww (2019-03-15): NYI
instance MonadFile m => MonadFile (StdIdT m)
instance MonadIntrospect m => MonadIntrospect (StdIdT m)
instance MonadStore m => MonadStore (StdIdT m) where
addPath' = lift . addPath'
toFile_' = (lift .) . toFile_'
instance MonadPutStr m => MonadPutStr (StdIdT m)
instance MonadHttp m => MonadHttp (StdIdT m)
instance MonadEnv m => MonadEnv (StdIdT m)
instance MonadInstantiate m => MonadInstantiate (StdIdT m)
instance MonadExec m => MonadExec (StdIdT m)
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 = (lift .) . findPath @t @f @m
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
instance HasCitations1 (StdThunk m) (StdCited m) (StdLazy m) where
citations1 (StdCited c) = citations c
addProvenance1 x (StdCited c) = StdCited (addProvenance x c)
runStdLazyM :: (MonadVar m, MonadIO m) => Options -> StdLazy m a -> m a
runStdLazyM opts action = do
i <- newVar (1 :: Int)
runFreshIdT i $ runLazyM opts action

115
src/Nix/Type/Infer.hs
View file

@ -1,3 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -40,7 +42,6 @@ import Data.List (delete, find, nub, intersect, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.STRef
import qualified Data.Set as Set
import Data.Text (Text)
import Nix.Atoms
@ -59,6 +60,7 @@ import Nix.Type.Env
import qualified Nix.Type.Env as Env
import Nix.Type.Type
import Nix.Utils
import Nix.Var
-------------------------------------------------------------------------------
-- Classes
@ -70,10 +72,24 @@ newtype InferT s m a = InferT
ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
(StateT InferState (ExceptT InferError m)) a
}
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)), MonadFail,
MonadState InferState, MonadError InferError,
MonadFreshId i)
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadFix
, MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
, MonadFail
, MonadState InferState
, MonadError InferError
)
instance MonadTrans (InferT s) where
lift = InferT . lift . lift . lift
instance MonadThunkId m => MonadThunkId (InferT s m) where
type ThunkId (InferT s m) = ThunkId m
-- | Inference state
newtype InferState = InferState { count :: Int }
@ -189,26 +205,19 @@ instance Monoid InferError where
-------------------------------------------------------------------------------
-- | Run the inference monad
runInfer' ::
( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => InferT s m a -> m (Either InferError a)
runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a)
runInfer' = runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
. getInfer
runInfer :: (forall s. InferT s (FreshIdT Int (ST s)) a) -> Either InferError a
runInfer m = runST (runFreshIdT 0 (runInfer' m))
runInfer m = runST $ do
i <- newVar (1 :: Int)
runFreshIdT i (runInfer' m)
inferType ::
( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => Env -> NExpr -> InferT s m [(Subst, Type)]
inferType :: forall s m. MonadInfer m
=> Env -> NExpr -> InferT s m [(Subst, Type)]
inferType env ex = do
Judgment as cs t <- infer ex
let unbounds = Set.fromList (As.keys as) `Set.difference`
@ -325,13 +334,13 @@ binops u1 = \case
liftInfer :: Monad m => m a -> InferT s m a
liftInfer = InferT . lift . lift . lift
instance (MonadRef m, Ref m ~ STRef s) => MonadRef (InferT s m) where
instance MonadRef m => MonadRef (InferT s m) where
type Ref (InferT s m) = Ref m
newRef x = liftInfer $ newRef x
readRef x = liftInfer $ readRef x
writeRef x y = liftInfer $ writeRef x y
instance (MonadAtomicRef m, Ref m ~ STRef s) => MonadAtomicRef (InferT s m) where
instance MonadAtomicRef m => MonadAtomicRef (InferT s m) where
atomicModifyRef x f = liftInfer $ do
res <- snd . f <$> readRef x
_ <- modifyRef x (fst . f)
@ -349,27 +358,31 @@ instance Monad m => MonadCatch (InferT s m) where
(fromException (toException e))
err -> error $ "Unexpected error: " ++ show err
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
) => MonadThunk (Judgment s) (JThunkT s m) (InferT s m) where
thunk = fmap JThunk . buildThunk
type MonadInfer m
= ( MonadThunkId m
, MonadVar m
, MonadFix m
)
force (JThunk t) f = catch (forceThunk t f) $ \(_ :: ThunkLoop) ->
instance MonadInfer m
=> MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
thunk = fmap JThunk . thunk
thunkId (JThunk x) = thunkId x
query (JThunk x) b f = query x b f
queryM (JThunk x) b f = queryM x b f
force (JThunk t) f = catch (force t f) $ \(_ :: ThunkLoop) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
forceEff (JThunk t) f = catch (forceEffects t f) $ \(_ :: ThunkLoop) ->
forceEff (JThunk t) f = catch (forceEff t f) $ \(_ :: ThunkLoop) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
wrapValue = JThunk . valueRef
getValue (JThunk x) = thunkValue x
wrapValue = JThunk . wrapValue
getValue (JThunk x) = getValue x
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => MonadEval (Judgment s) (InferT s m) where
instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
freeVariable var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
@ -486,11 +499,9 @@ instance Monad m => FromValue NixString (InferT s m) (Judgment s) where
fromValueMay _ = return Nothing
fromValue _ = error "Unused"
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => FromValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
instance MonadInfer m
=> FromValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
fromValueMay (Judgment _ _ (TSet _ xs)) = do
let sing _ = Judgment As.empty []
pure $ Just (M.mapWithKey (\k v -> wrapValue (sing k v)) xs, M.empty)
@ -499,11 +510,9 @@ instance ( MonadFreshId Int m
Just v -> pure v
Nothing -> pure (M.empty, M.empty)
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
instance MonadInfer m
=> ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
toValue (xs, _) = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@ -511,11 +520,7 @@ instance ( MonadFreshId Int m
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
toValue xs = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@ -523,18 +528,10 @@ instance ( MonadFreshId Int m
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue Bool (InferT s m) (Judgment s) where
instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where
toValue _ = pure $ Judgment As.empty [] typeBool
infer :: ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => NExpr -> InferT s m (Judgment s)
infer :: MonadInfer m => NExpr -> InferT s m (Judgment s)
infer = cata Eval.eval
inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env

22
src/Nix/Utils.hs
View file

@ -5,16 +5,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Nix.Utils (module Nix.Utils, module X) where
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Free
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix
import Data.Functor.Compose
import Data.Hashable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (sortOn)
@ -24,6 +30,7 @@ import qualified Data.Text as Text
import qualified Data.Vector as V
import Lens.Family2 as X
import Lens.Family2.Stock (_1, _2)
import Lens.Family2.TH
#if ENABLE_TRACING
import Debug.Trace as X
@ -35,6 +42,9 @@ traceM :: Monad m => String -> m ()
traceM = const (return ())
#endif
$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix)
$(makeLensesBy (\n -> Just ("_" ++ n)) ''Compose)
type DList a = Endo [a]
type AttrSet = HashMap Text
@ -75,6 +85,12 @@ cataPM f x = f x <=< traverse (cataPM f) . unFix $ x
transport :: Functor g => (forall x. f x -> g x) -> Fix f -> Fix g
transport f (Fix x) = Fix $ fmap (transport f) (f x)
fixate :: Functor f => Free f (f (Fix f)) -> Fix f
fixate = Fix . go
where
go (Pure a) = a
go (Free f) = fmap (Fix . go) f
-- | adi is Abstracting Definitional Interpreters:
--
-- https://arxiv.org/abs/1707.04755
@ -124,3 +140,9 @@ uriAwareSplit = go where
let ((suffix, _):path) = go (Text.drop 3 e2)
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
alterF :: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
alterF f k m = f (M.lookup k m) <&> \case
Nothing -> M.delete k m
Just v -> M.insert k v m

543
src/Nix/Value.hs
View file

@ -9,6 +9,7 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -18,6 +19,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
@ -28,20 +30,22 @@
module Nix.Value where
import Control.Comonad
import Control.Exception
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import Data.Align
import Data.Fix
import Data.Eq.Deriving
import Data.Functor.Classes
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Hashable
import Data.Text (Text)
import Data.These
import Data.Typeable (Typeable)
import Data.Void
import GHC.Generics
import Lens.Family2
import Lens.Family2.Stock
@ -50,30 +54,14 @@ import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.Scope
import Nix.String
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
data Provenance m = Provenance
{ _lexicalScope :: Scopes m (NThunk m)
, _originExpr :: NExprLocF (Maybe (NValue m))
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
-- result of the call, but what was called and with what arguments.
}
data NCited f m a = NCited
{ _provenance :: [Provenance m]
, _cited :: f m a
}
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is
-- completed. 's' is related to the type of errors that might occur during
-- construction or use of a value.
data NValueF m r
data NValueF p m r
= NVConstantF NAtom
-- | A string has a value and a context, which can be used to record what a
-- string has been build from
@ -81,7 +69,7 @@ data NValueF m r
| NVPathF FilePath
| NVListF [r]
| NVSetF (AttrSet r) (AttrSet SourcePos)
| NVClosureF (Params ()) (m (NValue m) -> m (NValue m))
| NVClosureF (Params ()) (m p -> m r)
-- ^ A function is a closed set of parameters representing the "call
-- signature", used at application time to check the type of arguments
-- passed to the function. Since it supports default values which may
@ -93,87 +81,81 @@ data NValueF m r
-- Note that 'm r' is being used here because effectively a function
-- and its set of default arguments is "never fully evaluated". This
-- enforces in the type that it must be re-evaluated for each call.
| NVBuiltinF String (m (NValue m) -> m (NValue m))
| NVBuiltinF String (m p -> m r)
-- ^ A builtin function is itself already in normal form. Also, it may
-- or may not choose to evaluate its argument in the production of a
-- result.
deriving (Generic, Typeable, Functor, Foldable, Traversable)
deriving (Generic, Typeable, Functor)
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is
-- a value in head normal form, where only the "top layer" has been
-- evaluated. An action of type 'm (NValue m)' is a pending evualation that
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys
-- to thunks.
--
-- The 'Free' structure is used here to represent the possibility that
-- cycles may appear during normalization.
-- | This 'Foldable' instance only folds what the value actually is known to
-- contain at time of fold.
instance Foldable (NValueF p m) where
foldMap f = \case
NVConstantF _ -> mempty
NVStrF _ -> mempty
NVPathF _ -> mempty
NVListF l -> foldMap f l
NVSetF s _ -> foldMap f s
NVClosureF _ _ -> mempty
NVBuiltinF _ _ -> mempty
type NValueNF m = Free (NValueF m) (NValue m)
type ValueSet m = AttrSet (NThunk m)
bindNValueF :: (Monad m, Monad n)
=> (forall x. n x -> m x) -> (a -> n b) -> NValueF p m a
-> n (NValueF p m b)
bindNValueF transform f = \case
NVConstantF a -> pure $ NVConstantF a
NVStrF s -> pure $ NVStrF s
NVPathF p -> pure $ NVPathF p
NVListF l -> NVListF <$> traverse f l
NVSetF s p -> NVSetF <$> traverse f s <*> pure p
NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g)
-- These mutually recursive types interleave thunk representations with value
-- representations, each provided by functors 't' and 'v'.
newtype NThunkR t v = NThunk { _nThunk :: t (NValueR t v) }
newtype NValueR t v = NValue { _nValue :: v (NThunkR t v) }
lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
lmapNValueF f = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p (g . fmap f)
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
-- jww (2019-03-11): The code below should be generic in 'f', rather than
-- specialized to 'NCited'.
type NThunk m = NThunkR (NCited NThunkF m) (NCited NValueF m)
type NValue m = NValueR (NCited NThunkF m) (NCited NValueF m)
liftNValueF :: (MonadTrans u, Monad m)
=> (forall x. u m x -> m x)
-> NValueF p m a
-> NValueF p (u m) a
liftNValueF run = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p $ lift . g . run
NVBuiltinF s g -> NVBuiltinF s $ lift . g . run
thunkEq :: (MonadThunk (NValue m) (NThunk m) m, MonadBasicThunk m)
=> NThunk m -> NThunk m -> m Bool
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
let unsafePtrEq = case (lt, rt) of
(NThunk (NCited _ (Thunk lid _ _)),
NThunk (NCited _ (Thunk rid _ _))) | lid == rid -> return True
_ -> valueEq lv rv
in case (lv, rv) of
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
(NVList _, NVList _) -> unsafePtrEq
(NVSet _ _, NVSet _ _) -> unsafePtrEq
_ -> valueEq lv rv
unliftNValueF :: (MonadTrans u, Monad m)
=> (forall x. u m x -> m x)
-> NValueF p (u m) a
-> NValueF p m a
unliftNValueF run = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p $ run . g . lift
NVBuiltinF s g -> NVBuiltinF s $ run . g . lift
addProvenance :: (NValue m -> Provenance m) -> NValue m -> NValue m
addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
type MonadDataContext f (m :: * -> *) =
(Comonad f, Applicative f, Traversable f, Monad m)
pattern NVConstant x <- NValue (NCited _ (NVConstantF x))
-- | At the time of constructor, the expected arguments to closures are values
-- that may contain thunks. The type of such thunks are fixed at that time.
newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
deriving (Generic, Typeable, Functor, Foldable)
nvConstant x = NValue (NCited [] (NVConstantF x))
nvConstantP p x = NValue (NCited [p] (NVConstantF x))
pattern NVStr ns <- NValue (NCited _ (NVStrF ns))
nvStr ns = NValue (NCited [] (NVStrF ns))
nvStrP p ns = NValue (NCited [p] (NVStrF ns))
pattern NVPath x <- NValue (NCited _ (NVPathF x))
nvPath x = NValue (NCited [] (NVPathF x))
nvPathP p x = NValue (NCited [p] (NVPathF x))
pattern NVList l <- NValue (NCited _ (NVListF l))
nvList l = NValue (NCited [] (NVListF l))
nvListP p l = NValue (NCited [p] (NVListF l))
pattern NVSet s x <- NValue (NCited _ (NVSetF s x))
nvSet s x = NValue (NCited [] (NVSetF s x))
nvSetP p s x = NValue (NCited [p] (NVSetF s x))
pattern NVClosure x f <- NValue (NCited _ (NVClosureF x f))
nvClosure x f = NValue (NCited [] (NVClosureF x f))
nvClosureP p x f = NValue (NCited [p] (NVClosureF x f))
pattern NVBuiltin name f <- NValue (NCited _ (NVBuiltinF name f))
nvBuiltin name f = NValue (NCited [] (NVBuiltinF name f))
nvBuiltinP p name f = NValue (NCited [p] (NVBuiltinF name f))
instance Show (NValueF m (Fix (NValueF m))) where
instance Show r => Show (NValueF p m r) where
showsPrec = flip go where
go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF ns) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
@ -186,17 +168,165 @@ instance Show (NValueF m (Fix (NValueF m))) where
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
{-
showsCon2 :: (Show a, Show b)
=> String -> a -> b -> Int -> String -> String
showsCon2 con a b d =
showParen (d > 10)
$ showString (con ++ " ")
. showsPrec 11 a
. showString " "
. showsPrec 11 b
-}
instance Eq (NValue m) where
instance (Comonad f, Show a) => Show (NValue' t f m a) where
show (NValue (extract -> v)) = show v
type NValue t f m = NValue' t f m t
bindNValue :: (Traversable f, Monad m, Monad n)
=> (forall x. n x -> m x) -> (a -> n b) -> NValue' t f m a
-> n (NValue' t f m b)
bindNValue transform f (NValue v) =
NValue <$> traverse (bindNValueF transform f) v
liftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x. u m x -> m x)
-> NValue' t f m a
-> NValue' t f (u m) a
liftNValue run (NValue v) =
NValue (fmap (lmapNValueF (unliftNValue run) . liftNValueF run) v)
unliftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x. u m x -> m x)
-> NValue' t f (u m) a
-> NValue' t f m a
unliftNValue run (NValue v) =
NValue (fmap (lmapNValueF (liftNValue run) . unliftNValueF run) v)
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is
-- a value in head normal form, where only the "top layer" has been
-- evaluated. An action of type 'm (NValue f t m)' is a pending evualation that
-- has yet to be performed. An 't' is either a pending evaluation, or
-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys
-- to thunks.
--
-- The 'Free' structure is used here to represent the possibility that
-- cycles may appear during normalization.
type NValueNF t f m = Free (NValue' t f m) (NValue' t f m Void)
iterNValue
:: forall t f m a r. MonadDataContext f m
=> (a -> (NValue' t f m a -> r) -> r)
-> (NValue' t f m r -> r)
-> NValue' t f m a -> r
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
iterNValueM
:: (MonadDataContext f m, Monad n)
=> (forall x. n x -> m x)
-> (a -> (NValue' t f m a -> n r) -> n r)
-> (NValue' t f m r -> n r)
-> NValue' t f m a -> n r
iterNValueM transform k f =
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
iterNValueNF
:: MonadDataContext f m
=> (NValue' t f m Void -> r)
-> (NValue' t f m r -> r)
-> NValueNF t f m -> r
iterNValueNF k f = iter f . fmap k
sequenceNValueNF :: (Functor n, Traversable f, Monad m, Monad n)
=> (forall x. n x -> m x) -> Free (NValue' t f m) (n a)
-> n (Free (NValue' t f m) a)
sequenceNValueNF transform = go
where
go (Pure a) = Pure <$> a
go (Free fa) = Free <$> bindNValue transform go fa
iterNValueNFM
:: forall f m n t r. (MonadDataContext f m, Monad n)
=> (forall x. n x -> m x)
-> (NValue' t f m Void -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValueNF t f m -> n r
iterNValueNFM transform k f v =
iterM f =<< sequenceNValueNF transform (fmap k v)
nValueFromNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m -> NValue t f m
nValueFromNF = iterNValueNF (fmap absurd) (fmap wrapValue)
nValueToNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
-> NValue t f m
-> NValueNF t f m
nValueToNF k = iterNValue k Free
nValueToNFM
:: (MonadDataContext f m, Monad n)
=> (forall x. n x -> m x)
-> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
-> NValue t f m
-> n (NValueNF t f m)
nValueToNFM transform k = iterNValueM transform k $ pure . Free
pattern NVConstant x <- NValue (extract -> NVConstantF x)
pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))
nvConstant :: Applicative f => NAtom -> NValue t f m
nvConstant x = NValue (pure (NVConstantF x))
nvConstantNF :: Applicative f => NAtom -> NValueNF t f m
nvConstantNF x = Free (NValue (pure (NVConstantF x)))
pattern NVStr ns <- NValue (extract -> NVStrF ns)
pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))
nvStr :: Applicative f => NixString -> NValue t f m
nvStr ns = NValue (pure (NVStrF ns))
nvStrNF :: Applicative f => NixString -> NValueNF t f m
nvStrNF ns = Free (NValue (pure (NVStrF ns)))
pattern NVPath x <- NValue (extract -> NVPathF x)
pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))
nvPath :: Applicative f => FilePath -> NValue t f m
nvPath x = NValue (pure (NVPathF x))
nvPathNF :: Applicative f => FilePath -> NValueNF t f m
nvPathNF x = Free (NValue (pure (NVPathF x)))
pattern NVList l <- NValue (extract -> NVListF l)
pattern NVListNF l <- Free (NValue (extract -> NVListF l))
nvList :: Applicative f => [t] -> NValue t f m
nvList l = NValue (pure (NVListF l))
nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m
nvListNF l = Free (NValue (pure (NVListF l)))
pattern NVSet s x <- NValue (extract -> NVSetF s x)
pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))
nvSet :: Applicative f
=> HashMap Text t -> HashMap Text SourcePos -> NValue t f m
nvSet s x = NValue (pure (NVSetF s x))
nvSetNF :: Applicative f
=> HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m
nvSetNF s x = Free (NValue (pure (NVSetF s x)))
pattern NVClosure x f <- NValue (extract -> NVClosureF x f)
pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))
nvClosure :: Applicative f
=> Params () -> (m (NValue t f m) -> m t) -> NValue t f m
nvClosure x f = NValue (pure (NVClosureF x f))
nvClosureNF :: Applicative f
=> Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvClosureNF x f = Free (NValue (pure (NVClosureF x f)))
pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)
pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))
nvBuiltin :: Applicative f
=> String -> (m (NValue t f m) -> m t) -> NValue t f m
nvBuiltin name f = NValue (pure (NVBuiltinF name f))
nvBuiltinNF :: Applicative f
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
instance Comonad f => Eq (NValue' t f m a) where
NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
NVConstant (NInt x) == NVConstant (NInt y) = x == y
@ -205,7 +335,7 @@ instance Eq (NValue m) where
NVPath x == NVPath y = x == y
_ == _ = False
instance Ord (NValue m) where
instance Comonad f => Ord (NValue' t f m a) where
NVConstant (NFloat x) <= NVConstant (NInt y) = x <= fromInteger y
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
@ -214,7 +344,8 @@ instance Ord (NValue m) where
NVPath x <= NVPath y = x <= y
_ <= _ = False
checkComparable :: (Framed e m, Typeable m) => NValue m -> NValue m -> m ()
checkComparable :: (Framed e m, MonadDataErrorContext t f m)
=> NValue t f m -> NValue t f m -> m ()
checkComparable x y = case (x, y) of
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
@ -224,24 +355,37 @@ checkComparable x y = case (x, y) of
(NVPath _, NVPath _) -> pure ()
_ -> throwError $ Comparison x y
builtin :: Monad m
=> String -> (m (NValue m) -> m (NValue m)) -> m (NValue m)
builtin name f = return $ nvBuiltin name f
thunkEq :: (MonadThunk t m (NValue t f m), Comonad f)
=> t -> t -> m Bool
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
let unsafePtrEq = case (lt, rt) of
(thunkId -> lid, thunkId -> rid)
| lid == rid -> return True
_ -> valueEq lv rv
in case (lv, rv) of
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
(NVList _, NVList _) -> unsafePtrEq
(NVSet _ _, NVSet _ _) -> unsafePtrEq
_ -> valueEq lv rv
builtin2 :: Monad m
=> String -> (m (NValue m) -> m (NValue m) -> m (NValue m))
-> m (NValue m)
builtin :: forall m f t. (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String -> (m (NValue t f m) -> m (NValue t f m)) -> m (NValue t f m)
builtin name f = return $ nvBuiltin name $ thunk . f
builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
-> m (NValue t f m)
builtin2 name f = builtin name (builtin name . f)
builtin3 :: Monad m
builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m))
-> m (NValue m)
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
-> m (NValue t f m)
builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
isClosureNF :: Monad m => NValueNF m -> Bool
isClosureNF (Free NVClosureF {}) = True
isClosureNF :: Comonad f => NValueNF t f m -> Bool
isClosureNF NVClosureNF {} = True
isClosureNF _ = False
-- | Checks whether two containers are equal, using the given item equality
@ -259,36 +403,73 @@ alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
_ -> throwE ()
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
isDerivation :: (MonadThunk (NValue m) (NThunk m) m, MonadBasicThunk m)
=> AttrSet (NThunk m) -> m Bool
isDerivation m = case M.lookup "type" m of
isDerivation :: Monad m
=> (t -> m (Maybe NixString)) -> AttrSet t
-> m Bool
isDerivation f m = case M.lookup "type" m of
Nothing -> pure False
Just t -> force t $ \case
-- We should probably really make sure the context is empty here but the
-- C++ implementation ignores it.
NVStr s -> pure $ principledStringIgnoreContext s == "derivation"
_ -> pure False
Just t -> do
mres <- f t
case mres of
-- We should probably really make sure the context is empty here
-- but the C++ implementation ignores it.
Just s -> pure $ principledStringIgnoreContext s == "derivation"
Nothing -> pure False
valueEq :: (MonadThunk (NValue m) (NThunk m) m, MonadBasicThunk m)
=> NValue m -> NValue m -> m Bool
valueEq = curry $ \case
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
(NVStr ls, NVStr rs) ->
valueFEq :: Monad m
=> (AttrSet a -> AttrSet a -> m Bool)
-> (a -> a -> m Bool)
-> NValueF p m a
-> NValueF p m a
-> m Bool
valueFEq attrsEq eq = curry $ \case
(NVConstantF lc, NVConstantF rc) -> pure $ lc == rc
(NVStrF ls, NVStrF rs) ->
pure $ principledStringIgnoreContext ls
== principledStringIgnoreContext rs
(NVList ls, NVList rs) -> alignEqM thunkEq ls rs
(NVSet lm _, NVSet rm _) -> do
let compareAttrs = alignEqM thunkEq lm rm
isDerivation lm >>= \case
True -> isDerivation rm >>= \case
True | Just lp <- M.lookup "outPath" lm
, Just rp <- M.lookup "outPath" rm
-> thunkEq lp rp
_ -> compareAttrs
_ -> compareAttrs
(NVPath lp, NVPath rp) -> pure $ lp == rp
(NVListF ls, NVListF rs) -> alignEqM eq ls rs
(NVSetF lm _, NVSetF rm _) -> attrsEq lm rm
(NVPathF lp, NVPathF rp) -> pure $ lp == rp
_ -> pure False
compareAttrSets :: Monad m
=> (t -> m (Maybe NixString))
-> (t -> t -> m Bool)
-> AttrSet t
-> AttrSet t
-> m Bool
compareAttrSets f eq lm rm = do
isDerivation f lm >>= \case
True -> isDerivation f rm >>= \case
True | Just lp <- M.lookup "outPath" lm
, Just rp <- M.lookup "outPath" rm
-> eq lp rp
_ -> compareAttrs
_ -> compareAttrs
where
compareAttrs = alignEqM eq lm rm
valueEq :: (MonadThunk t m (NValue t f m), Comonad f)
=> NValue t f m -> NValue t f m -> m Bool
valueEq (NValue (extract -> x)) (NValue (extract -> y)) =
valueFEq (compareAttrSets f thunkEq) thunkEq x y
where
f t = force t $ \case
NVStr s -> pure $ Just s
_ -> pure Nothing
valueNFEq :: (Comonad f, Monad m)
=> NValueNF t f m -> NValueNF t f m -> m Bool
valueNFEq (Pure _) (Pure _) = pure False
valueNFEq (Pure _) (Free _) = pure False
valueNFEq (Free _) (Pure _) = pure False
valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
where
f (Pure (NVStr s)) = pure $ Just s
f (Free (NVStr s)) = pure $ Just s
f _ = pure Nothing
data TStringContext = NoContext | HasContext
deriving Show
@ -305,7 +486,7 @@ data ValueType
| TBuiltin
deriving Show
valueType :: NValueF m r -> ValueType
valueType :: NValueF a m r -> ValueType
valueType = \case
NVConstantF a -> case a of
NInt _ -> TInt
@ -334,64 +515,50 @@ describeValue = \case
TPath -> "a path"
TBuiltin -> "a builtin function"
instance Show (NValueF m (NThunk m)) where
show = show . describeValue . valueType
instance Show (NValue m) where
show (NValue (NCited _ v)) = show v
instance MonadThunk (NValue m) (NThunk m) m => Show (NThunk m) where
show (NThunk (NCited _ (thunkValue -> Just v))) = show v
show (NThunk (NCited _ _)) = "<thunk>"
instance Eq1 (NValueF m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x) (NVStrF y) = x == y
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y
liftEq _ (NVPathF x) (NVPathF y) = x == y
instance Eq1 (NValueF p m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x) (NVStrF y) = x == y
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y
liftEq _ (NVPathF x) (NVPathF y) = x == y
liftEq _ _ _ = False
instance Show1 (NValueF m) where
instance Comonad f => Show1 (NValue' t f m) where
liftShowsPrec sp sl p = \case
NVConstantF atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStrF ns -> showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
NVListF lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSetF attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVClosureF c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVPathF path -> showsUnaryWith showsPrec "NVPathF" p path
NVBuiltinF name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStr ns -> showsUnaryWith showsPrec "NVStrF" p
(hackyStringIgnoreContext ns)
NVList lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSet attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVPath path -> showsUnaryWith showsPrec "NVPathF" p path
NVClosure c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
_ -> error "Pattern synonyms mask coverage"
data ValueFrame m
data ValueFrame t f m
= ForcingThunk
| ConcerningValue (NValue m)
| Comparison (NValue m) (NValue m)
| Addition (NValue m) (NValue m)
| Multiplication (NValue m) (NValue m)
| Division (NValue m) (NValue m)
| 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)
| Coercion ValueType ValueType
| CoercionToJson (NValue m)
| CoercionToJson (NValue t f m)
| CoercionFromJson A.Value
| ExpectationNF ValueType (NValueNF m)
| Expectation ValueType (NValue m)
| ExpectationNF ValueType (NValueNF t f m)
| Expectation ValueType (NValue t f m)
deriving (Show, Typeable)
instance Typeable m => Exception (ValueFrame m)
type MonadDataErrorContext t f m =
(Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)
$(makeTraversals ''NValueF)
$(makeLenses ''Provenance)
$(makeLenses ''NCited)
$(makeLenses ''NThunkR)
$(makeLenses ''NValueR)
$(makeLenses ''NValue')
alterF :: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
alterF f k m = f (M.lookup k m) <&> \case
Nothing -> M.delete k m
Just v -> M.insert k v m
key :: (Traversable f, Applicative g)
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
key k = nValue.traverse._NVSetF._1.hashAt k
hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
hashAt = flip alterF
key :: Applicative f => VarName -> LensLike' f (NValue m) (Maybe (NThunk m))
key k = nValue.cited._NVSetF._1.hashAt k
$(deriveEq1 ''NValue')

6
src/Nix/Var.hs
View file

@ -20,11 +20,7 @@ import Unsafe.Coerce
type Var m = Ref m
--TODO: Eliminate the old MonadVar shims
type MonadVar m =
( MonadAtomicRef m
, GEq (Ref m)
)
type MonadVar m = MonadAtomicRef m
eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
eqVar a b = isJust $ geq a b

27
src/Nix/XML.hs
View file

@ -5,7 +5,6 @@
module Nix.XML (toXML) where
import Control.Monad.Free
import qualified Data.HashMap.Lazy as M
import Data.List
import Data.Ord
@ -16,8 +15,10 @@ import Nix.String
import Nix.Value
import Text.XML.Light
toXML :: Functor m => NValueNF m -> NixString
toXML = runWithStringContext . fmap pp . iterM phi . check
toXML :: forall t f m. MonadDataContext f m => NValueNF t f m -> NixString
toXML = runWithStringContext
. fmap pp
. iterNValueNF (const (pure (mkElem "cycle" "value" ""))) phi
where
pp = ("<?xml version='1.0' encoding='utf-8'?>\n" <>)
. (<> "\n")
@ -25,22 +26,19 @@ toXML = runWithStringContext . fmap pp . iterM phi . check
. ppElement
. (\e -> Element (unqual "expr") [] [Elem e] Nothing)
check :: NValueNF f -> Free (NValueF f) Element
check = fmap $ const $ mkElem "cycle" "value" ""
phi :: NValueF f (WithStringContext Element) -> WithStringContext Element
phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
phi = \case
NVConstantF a -> case a of
NVConstant a -> case a of
NInt n -> return $ mkElem "int" "value" (show n)
NFloat f -> return $ mkElem "float" "value" (show f)
NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false")
NNull -> return $ Element (unqual "null") [] [] Nothing
NVStrF str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
NVListF l -> sequence l >>= \els ->
NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
NVList l -> sequence l >>= \els ->
return $ Element (unqual "list") [] (Elem <$> els) Nothing
NVSetF s _ -> sequence s >>= \kvs ->
NVSet s _ -> sequence s >>= \kvs ->
return $ Element (unqual "attrs") []
(map (\(k, v) ->
Elem (Element (unqual "attr")
@ -48,9 +46,10 @@ toXML = runWithStringContext . fmap pp . iterM phi . check
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList kvs)) Nothing
NVClosureF p _ -> return $ Element (unqual "function") [] (paramsXML p) Nothing
NVPathF fp -> return $ mkElem "path" "value" fp
NVBuiltinF name _ -> return $ mkElem "function" "name" name
NVClosure p _ -> return $ Element (unqual "function") [] (paramsXML p) Nothing
NVPath fp -> return $ mkElem "path" "value" fp
NVBuiltin name _ -> return $ mkElem "function" "name" name
_ -> error "Pattern synonyms mask coverage"
mkElem :: String -> String -> String -> Element
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing

44
tests/EvalTests.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
@ -9,18 +10,19 @@
module EvalTests (tests, genEvalCompareTests) where
import Control.Applicative ((<|>))
import Control.Monad.Catch
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.HashMap.Lazy as M
-- import qualified Data.HashMap.Lazy as M
import Data.List ((\\))
import Data.Maybe (isJust)
import Data.String.Interpolate.IsString
import qualified Data.Set as S
import Data.String.Interpolate.IsString
import Data.Text (Text)
import Data.Time
import Nix
import Nix.TH
import Nix.Thunk.Standard
import qualified System.Directory as D
import System.Environment
import System.FilePath
@ -417,26 +419,27 @@ genEvalCompareTests = do
mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> f)
instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
NVConstantF x == NVConstantF y = x == y
NVStrF ls == NVStrF rs = hackyStringIgnoreContext ls == hackyStringIgnoreContext rs
NVListF x == NVListF y = and (zipWith (==) x y)
NVSetF x _ == NVSetF y _ =
M.keys x == M.keys y &&
and (zipWith (==) (M.elems x) (M.elems y))
NVPathF x == NVPathF y = x == y
x == y = error $ "Need to add comparison for values: "
++ show x ++ " == " ++ show y
-- instance (Show r, Show (NValueF p m r), Eq r) => Eq (NValueF p m r) where
-- NVConstantF x == NVConstantF y = x == y
-- NVStrF ls == NVStrF rs = hackyStringIgnoreContext ls == hackyStringIgnoreContext rs
-- NVListF x == NVListF y = and (zipWith (==) x y)
-- NVSetF x _ == NVSetF y _ =
-- M.keys x == M.keys y &&
-- and (zipWith (==) (M.elems x) (M.elems y))
-- NVPathF x == NVPathF y = x == y
-- x == y = error $ "Need to add comparison for values: "
-- ++ show x ++ " == " ++ show y
constantEqual :: NExprLoc -> NExprLoc -> Assertion
constantEqual a b = do
time <- liftIO getCurrentTime
let opts = defaultOptions time
-- putStrLn =<< lint (stripAnnotation a)
a' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a
-- putStrLn =<< lint (stripAnnotation b)
b' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing b
assertEqual "" a' b'
res <- runStdLazyM opts $ do
a' <- normalForm =<< nixEvalExprLoc Nothing a
b' <- normalForm =<< nixEvalExprLoc Nothing b
valueNFEq a' b'
assertBool "" res
constantEqualText' :: Text -> Text -> Assertion
constantEqualText' a b = do
@ -456,14 +459,13 @@ assertNixEvalThrows a = do
let Success a' = parseNixTextLoc a
time <- liftIO getCurrentTime
let opts = defaultOptions time
errored <- catch ((runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a') >> pure False) handler
errored <- catch
(False <$ runStdLazyM opts (normalForm =<< nixEvalExprLoc Nothing a'))
(\(_ :: NixException) -> pure True)
if errored then
pure ()
else
assertFailure "Did not catch nix exception"
where
handler :: NixException -> IO Bool
handler _ = pure True
freeVarsEqual :: Text -> [VarName] -> Assertion
freeVarsEqual a xs = do

4
tests/Main.hs
View file

@ -18,12 +18,12 @@ import Data.Text (unpack)
import Data.Time
import qualified EvalTests
import qualified Nix
import Nix.Exec
import Nix.Expr.Types
import Nix.String
import Nix.Options
import Nix.Parser
import Nix.Value
import Nix.Thunk.Standard
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
@ -58,7 +58,7 @@ ensureNixpkgsCanParse =
}|]) $ \expr -> do
NVStr ns <- do
time <- liftIO getCurrentTime
runLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
runStdLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
let dir = hackyStringIgnoreContext ns
exists <- fileExist (unpack dir)
unless exists $

13
tests/TestCommon.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module TestCommon where
@ -8,6 +9,7 @@ import Control.Monad.IO.Class
import Data.Text (Text, unpack)
import Data.Time
import Nix
import Nix.Thunk.Standard
import System.Environment
import System.IO
import System.Posix.Files
@ -15,7 +17,7 @@ import System.Posix.Temp
import System.Process
import Test.Tasty.HUnit
hnixEvalFile :: Options -> FilePath -> IO (NValueNF (Lazy IO))
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF IO)
hnixEvalFile opts file = do
parseResult <- parseNixFileLoc file
case parseResult of
@ -23,20 +25,21 @@ hnixEvalFile opts file = do
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
Success expr -> do
setEnv "TEST_VAR" "foo"
runLazyM opts $
runStdLazyM opts $
catch (evaluateExpression (Just file) nixEvalExprLoc
normalForm expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames @(NThunk (Lazy IO)) frames
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
hnixEvalText :: Options -> Text -> IO (NValueNF (Lazy IO))
hnixEvalText :: Options -> Text -> IO (StdValueNF IO)
hnixEvalText opts src = case parseNixText src of
Failure err ->
error $ "Parsing failed for expressien `"
++ unpack src ++ "`.\n" ++ show err
Success expr ->
runLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
-- runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
nixEvalString :: String -> IO String
nixEvalString expr = do