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

Track value provenance during evaluation

This commit is contained in:
John Wiegley 2018-04-22 14:32:55 -07:00
parent a63d3ac30d
commit 3cf02e3902
9 changed files with 525 additions and 353 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Nix.hs
View File

@ -56,15 +56,15 @@ withNixContext :: forall e m r. MonadNix e m => Maybe FilePath -> m r -> m r
withNixContext mpath action = do
base <- builtins
opts :: Options <- asks (view hasLens)
let i = value @(NValue m) @(NThunk m) @m $ NVList $
let i = value @(NValue m) @(NThunk m) @m $ nvList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) (include opts)
. flip nvStr mempty . 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 = value @(NValue m) @(NThunk m) @m $ NVPath path
let ref = value @(NValue m) @(NThunk m) @m $ nvPath path
pushScope (M.singleton "__cur_file" ref) action
-- | This is the entry point for all evaluations, whatever the expression tree
@ -114,7 +114,7 @@ evaluateExpression mpath evaluator handler expr = do
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = embed $ Fix $ NVSet (M.fromList args) mempty
argmap args = embed $ Fix $ NVSetF (M.fromList args) mempty
compute ev x args p = do
f <- ev mpath x

102
src/Nix/Builtins.hs
View File

@ -74,7 +74,7 @@ import Text.Regex.TDFA
builtins :: (MonadNix e m, Scoped e (NThunk m) m)
=> m (Scopes m (NThunk m))
builtins = do
ref <- thunk $ flip NVSet M.empty <$> buildMap
ref <- thunk $ flip nvSet M.empty <$> buildMap
lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins
pushScope (M.fromList lst) currentScopes
where
@ -218,12 +218,12 @@ foldNixPath f z = do
_ -> throwError $ "Unexpected entry in NIX_PATH: " ++ show x
nixPath :: MonadNix e m => m (NValue m)
nixPath = fmap NVList $ flip foldNixPath [] $ \p mn rest ->
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest ->
pure $ valueThunk
(flip NVSet mempty $ M.fromList
[ ("path", valueThunk $ NVPath p)
(flip nvSet mempty $ M.fromList
[ ("path", valueThunk $ nvPath p)
, ("prefix", valueThunk $
NVStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
nvStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString str =
@ -232,7 +232,7 @@ toString str =
hasAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet aset _) ->
return . NVConstant . NBool $ M.member key aset
return . nvConstant . NBool $ M.member key aset
(x, y) -> throwError $ "Invalid types for builtin.hasAttr: "
++ show (x, y)
@ -301,7 +301,7 @@ head_ = fromValue >=> \case
tail_ :: MonadNix e m => m (NValue m) -> m (NValue m)
tail_ = fromValue >=> \case
[] -> throwError "builtins.tail: empty list"
_:t -> return $ NVList t
_:t -> return $ nvList t
data VersionComponent
= VersionComponent_Pre -- ^ The string "pre"
@ -337,8 +337,8 @@ splitVersion s = case Text.uncons s of
splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m)
splitVersion_ = fromNix >=> \s -> do
let vals = flip map (splitVersion s) $ \c ->
valueThunk $ NVStr (versionComponentToString c) mempty
return $ NVList vals
valueThunk $ nvStr (versionComponentToString c) mempty
return $ nvList vals
compareVersions :: Text -> Text -> Ordering
compareVersions s1 s2 =
@ -351,7 +351,7 @@ compareVersions_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
compareVersions_ t1 t2 =
fromNix t1 >>= \s1 ->
fromNix t2 >>= \s2 ->
return $ NVConstant $ NInt $ case compareVersions s1 s2 of
return $ nvConstant $ NInt $ case compareVersions s1 s2 of
LT -> -1
EQ -> 0
GT -> 1
@ -393,9 +393,9 @@ match_ pat str =
case matchOnceText re (encodeUtf8 s) of
Just ("", sarr, "") -> do
let s = map fst (elems sarr)
NVList <$> traverse (toValue . decodeUtf8)
nvList <$> traverse (toValue . decodeUtf8)
(if length s > 1 then tail s else s)
_ -> pure $ NVConstant NNull
_ -> pure $ nvConstant NNull
split_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
split_ pat str =
@ -403,7 +403,7 @@ split_ pat str =
fromNix str >>= \s -> do
let re = makeRegex (encodeUtf8 p) :: Regex
haystack = encodeUtf8 s
return $ NVList $
return $ nvList $
splitMatches 0 (map elems $ matchAllText re haystack) haystack
splitMatches
@ -419,10 +419,10 @@ splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
where
relStart = max 0 start - numDropped
(before,rest) = B.splitAt relStart haystack
caps = valueThunk $ NVList (map f captures)
f (a,(s,_)) = if s < 0 then valueThunk (NVConstant NNull) else thunkStr a
caps = valueThunk $ nvList (map f captures)
f (a,(s,_)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a
thunkStr s = valueThunk (NVStr (decodeUtf8 s) mempty)
thunkStr s = valueThunk (nvStr (decodeUtf8 s) mempty)
substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text
substring start len str = Prim $
@ -453,21 +453,21 @@ catAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValu
catAttrs attrName xs =
fromNix @Text attrName >>= \n ->
fromValue @[NThunk m] xs >>= \l ->
fmap (NVList . catMaybes) $
fmap (nvList . catMaybes) $
forM l $ fmap (M.lookup n) . fromValue
baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf x = x >>= \case
--TODO: Only allow strings that represent absolute paths
NVStr path ctx -> pure $ NVStr (Text.pack $ takeFileName $ Text.unpack path) ctx
NVPath path -> pure $ NVPath $ takeFileName path
NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError $ "dirOf: expected string or path, got " ++ show v
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case
--TODO: Only allow strings that represent absolute paths
NVStr path ctx -> pure $ NVStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
NVPath path -> pure $ NVPath $ takeDirectory path
NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError $ "dirOf: expected string or path, got " ++ show v
unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -557,7 +557,7 @@ intersectAttrs set1 set2 =
HashMap Text SourcePos) set1 >>= \(s1, p1) ->
fromValue @(HashMap Text (NThunk m),
HashMap Text SourcePos) set2 >>= \(s2, p2) ->
return $ NVSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
functionArgs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
functionArgs fun = fun >>= \case
@ -565,7 +565,7 @@ functionArgs fun = fun >>= \case
-- jww (2018-04-05): Should we preserve the location where the
-- function arguments were declared for __unsafeGetAttrPos?
toValue @(HashMap Text (NThunk m)) $
valueThunk . NVConstant . NBool <$>
valueThunk . nvConstant . NBool <$>
case p of
Param name -> M.singleton name False
ParamSet s _ _ -> isJust <$> M.fromList s
@ -582,7 +582,7 @@ pathExists_ path = path >>= \case
NVStr s _ -> toNix =<< pathExists (Text.unpack s)
v -> throwError $ "builtins.pathExists: expected path, got " ++ show v
hasKind :: forall a e m. (MonadNix e m, FromNix a m (NValue m))
hasKind :: forall a e m. (MonadNix e m, FromNix a m (NValueF m (NThunk m)))
=> m (NValue m) -> m (NValue m)
hasKind = fromNixMay >=> toNix . \case Just (_ :: a) -> True; _ -> False
@ -649,7 +649,7 @@ lessThan :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
let badType = throwError $ "builtins.lessThan: expected two numbers or two strings, "
++ "got " ++ show va ++ " and " ++ show vb
NVConstant . NBool <$> case (va, vb) of
nvConstant . NBool <$> case (va, vb) of
(NVConstant ca, NVConstant cb) -> case (ca, cb) of
(NInt a, NInt b) -> pure $ a < b
(NFloat a, NInt b) -> pure $ a < fromInteger b
@ -666,7 +666,7 @@ concatLists = fromValue @[NThunk m]
listToAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
listToAttrs = fromValue @[NThunk m] >=> \l ->
fmap (flip NVSet M.empty . M.fromList . reverse) $
fmap (flip nvSet M.empty . M.fromList . reverse) $
forM l $ fromValue @(HashMap Text (NThunk m)) >=> \s ->
case (M.lookup "name" s, M.lookup "value" s) of
(Just name, Just value) -> fromNix name <&> (, value)
@ -701,18 +701,18 @@ readFile_ path =
path >>= absolutePathFromValue >>= Nix.Stack.readFile >>= toNix
data FileType
= FileType_Regular
| FileType_Directory
| FileType_Symlink
| FileType_Unknown
= FileTypeRegular
| FileTypeDirectory
| FileTypeSymlink
| FileTypeUnknown
deriving (Show, Read, Eq, Ord)
instance Applicative m => ToNix FileType m (NValue m) where
instance Applicative m => ToNix FileType m (NValueF m r) where
toNix = toNix . \case
FileType_Regular -> "regular" :: Text
FileType_Directory -> "directory"
FileType_Symlink -> "symlink"
FileType_Unknown -> "unknown"
FileTypeRegular -> "regular" :: Text
FileTypeDirectory -> "directory"
FileTypeSymlink -> "symlink"
FileTypeUnknown -> "unknown"
readDir_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
readDir_ pathThunk = do
@ -721,10 +721,10 @@ readDir_ pathThunk = do
itemsWithTypes <- forM items $ \item -> do
s <- Nix.Effects.getSymbolicLinkStatus $ path </> item
let t = if
| isRegularFile s -> FileType_Regular
| isDirectory s -> FileType_Directory
| isSymbolicLink s -> FileType_Symlink
| otherwise -> FileType_Unknown
| isRegularFile s -> FileTypeRegular
| isDirectory s -> FileTypeDirectory
| isSymbolicLink s -> FileTypeSymlink
| otherwise -> FileTypeUnknown
pure (Text.pack item, t)
toNix (M.fromList itemsWithTypes)
@ -736,7 +736,7 @@ fromJSON = fromValue >=> \encoded ->
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
toXML_ v = v >>= normalForm >>= \x ->
pure $ NVStr (Text.pack (toXML x)) mempty
pure $ nvStr (Text.pack (toXML x)) mempty
typeOf :: MonadNix e m => m (NValue m) -> m (NValue m)
typeOf v = v >>= toNix @Text . \case
@ -752,19 +752,20 @@ typeOf v = v >>= toNix @Text . \case
NVClosure {} -> "lambda"
NVPath _ -> "path"
NVBuiltin _ _ -> "lambda"
_ -> error "Pattern synonyms obscure complete patterns"
tryEval :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
tryEval e = catch (onSuccess <$> e) (pure . onError)
where
onSuccess v = flip NVSet M.empty $ M.fromList
[ ("success", valueThunk (NVConstant (NBool True)))
onSuccess v = flip nvSet M.empty $ M.fromList
[ ("success", valueThunk (nvConstant (NBool True)))
, ("value", valueThunk v)
]
onError :: SomeException -> NValue m
onError _ = flip NVSet M.empty $ M.fromList
[ ("success", valueThunk (NVConstant (NBool False)))
, ("value", valueThunk (NVConstant (NBool False)))
onError _ = flip nvSet M.empty $ M.fromList
[ ("success", valueThunk (nvConstant (NBool False)))
, ("value", valueThunk (nvConstant (NBool False)))
]
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
@ -812,7 +813,7 @@ partition_ fun xs = fun >>= \f ->
let match t = f `callFunc` force' t >>= fmap (, t) . fromNix
selection <- traverse match l
let (right, wrong) = partition fst selection
let makeSide = valueThunk . NVList . map snd
let makeSide = valueThunk . nvList . map snd
toValue @(HashMap Text (NThunk m)) $
M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]
@ -820,7 +821,7 @@ currentSystem :: MonadNix e m => m (NValue m)
currentSystem = do
os <- getCurrentSystemOS
arch <- getCurrentSystemArch
return $ NVStr (arch <> "-" <> os) mempty
return $ nvStr (arch <> "-" <> os) mempty
derivationStrict_ :: MonadNix e m => m (NValue m) -> m (NValue m)
derivationStrict_ = (>>= derivationStrict)
@ -831,9 +832,10 @@ newtype Prim m a = Prim { runPrim :: m a }
class ToBuiltin m a | a -> m where
toBuiltin :: String -> a -> m (NValue m)
instance (MonadNix e m, ToNix a m (NValue m)) => ToBuiltin m (Prim m a) where
instance (MonadNix e m, ToNix a m (NValueF m (NThunk m)))
=> ToBuiltin m (Prim m a) where
toBuiltin _ p = toNix =<< runPrim p
instance (MonadNix e m, FromNix a m (NValue m), ToBuiltin m b)
instance (MonadNix e m, FromNix a m (NValueF m (NThunk m)), ToBuiltin m b)
=> ToBuiltin m (a -> b) where
toBuiltin name f = return $ NVBuiltin name (fromNix >=> toBuiltin name . f)
toBuiltin name f = return $ nvBuiltin name (fromNix >=> toBuiltin name . f)

311
src/Nix/Convert.hs
View File

@ -14,6 +14,13 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- | Although there are a lot of instances in this file, really it's just a
-- combinatorial explosion of the following combinations:
--
-- - Several Haskell types being converted to/from Nix wrappers
-- - Several types of Nix wrappers
-- - Whether to be shallow or deep while unwrapping
module Nix.Convert where
import Control.Monad
@ -46,7 +53,7 @@ type Convertible e m = (Framed e m, MonadVar m, MonadFile m)
instance Convertible e m => FromValue () m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant NNull) -> pure $ Just ()
Fix (NVConstantF NNull) -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -55,7 +62,7 @@ instance Convertible e m => FromValue () m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r))
=> FromValue () m (NValueF m r) where
fromValueMay = \case
NVConstant NNull -> pure $ Just ()
NVConstantF NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -64,7 +71,7 @@ instance (Convertible e m, Show (NValueF m r))
instance Convertible e m
=> FromValue Bool m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NBool b)) -> pure $ Just b
Fix (NVConstantF (NBool b)) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -73,7 +80,7 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue Bool m (NValueF m r) where
fromValueMay = \case
NVConstant (NBool b) -> pure $ Just b
NVConstantF (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -82,7 +89,7 @@ instance (Convertible e m, Show (NValueF m r))
instance Convertible e m
=> FromValue Int m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NInt b)) -> pure $ Just (fromInteger b)
Fix (NVConstantF (NInt b)) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -91,7 +98,7 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue Int m (NValueF m r) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
NVConstantF (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -100,7 +107,7 @@ instance (Convertible e m, Show (NValueF m r))
instance Convertible e m
=> FromValue Integer m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NInt b)) -> pure $ Just b
Fix (NVConstantF (NInt b)) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -109,7 +116,7 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue Integer m (NValueF m r) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just b
NVConstantF (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -118,8 +125,8 @@ instance (Convertible e m, Show (NValueF m r))
instance Convertible e m
=> FromValue Float m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NFloat b)) -> pure $ Just b
Fix (NVConstant (NInt i)) -> pure $ Just (fromInteger i)
Fix (NVConstantF (NFloat b)) -> pure $ Just b
Fix (NVConstantF (NInt i)) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -128,8 +135,8 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue Float m (NValueF m r) where
fromValueMay = \case
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
NVConstantF (NFloat b) -> pure $ Just b
NVConstantF (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -138,10 +145,10 @@ instance (Convertible e m, Show (NValueF m r))
instance (Convertible e m, MonadEffects m)
=> FromValue Text m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NUri u)) -> pure $ Just u
Fix (NVStr t _) -> pure $ Just t
Fix (NVPath p) -> Just . Text.pack . unStorePath <$> addPath p
Fix (NVSet s _) -> case M.lookup "outPath" s of
Fix (NVConstantF (NUri u)) -> pure $ Just u
Fix (NVStrF t _) -> pure $ Just t
Fix (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Text p
_ -> pure Nothing
@ -150,14 +157,13 @@ instance (Convertible e m, MonadEffects m)
_ -> throwError $ "Expected a string, but saw: " ++ show v
instance (Convertible e m, MonadEffects m,
MonadThunk (NValueF m r) r m,
FromValue Text m r, Show (NValueF m r))
=> FromValue Text m (NValueF m r) where
fromValueMay = \case
NVConstant (NUri u) -> pure $ Just u
NVStr t _ -> pure $ Just t
NVPath p -> Just . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
NVConstantF (NUri u) -> pure $ Just u
NVStrF t _ -> pure $ Just t
NVPathF p -> Just . Text.pack . unStorePath <$> addPath p
NVSetF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Text p
_ -> pure Nothing
@ -168,10 +174,10 @@ instance (Convertible e m, MonadEffects m,
instance (Convertible e m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NUri u)) -> pure $ Just (u, mempty)
Fix (NVStr t d) -> pure $ Just (t, d)
Fix (NVPath p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
Fix (NVSet s _) -> case M.lookup "outPath" s of
Fix (NVConstantF (NUri u)) -> pure $ Just (u, mempty)
Fix (NVStrF t d) -> pure $ Just (t, d)
Fix (NVPathF p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p
_ -> pure Nothing
@ -180,14 +186,13 @@ instance (Convertible e m, MonadEffects m)
_ -> throwError $ "Expected a string, but saw: " ++ show v
instance (Convertible e m, MonadEffects m,
MonadThunk (NValueF m r) r m,
FromValue Text m r, Show (NValueF m r))
=> FromValue (Text, DList Text) m (NValueF m r) where
fromValueMay = \case
NVConstant (NUri u) -> pure $ Just (u, mempty)
NVStr t d -> pure $ Just (t, d)
NVPath p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
NVConstantF (NUri u) -> pure $ Just (u, mempty)
NVStrF t d -> pure $ Just (t, d)
NVPathF p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
NVSetF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p
_ -> pure Nothing
@ -198,7 +203,7 @@ instance (Convertible e m, MonadEffects m,
instance Convertible e m
=> FromValue ByteString m (NValueNF m) where
fromValueMay = \case
Fix (NVStr t _) -> pure $ Just (encodeUtf8 t)
Fix (NVStrF t _) -> pure $ Just (encodeUtf8 t)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -207,7 +212,7 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue ByteString m (NValueF m r) where
fromValueMay = \case
NVStr t _ -> pure $ Just (encodeUtf8 t)
NVStrF t _ -> pure $ Just (encodeUtf8 t)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -219,10 +224,10 @@ newtype Path = Path { getPath :: FilePath }
instance Convertible e m
=> FromValue Path m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant (NUri u)) -> pure $ Just (Path (Text.unpack u))
Fix (NVPath p) -> pure $ Just (Path p)
Fix (NVStr s _) -> pure $ Just (Path (Text.unpack s))
Fix (NVSet s _) -> case M.lookup "outPath" s of
Fix (NVConstantF (NUri u)) -> pure $ Just (Path (Text.unpack u))
Fix (NVPathF p) -> pure $ Just (Path p)
Fix (NVStrF s _) -> pure $ Just (Path (Text.unpack s))
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
@ -230,14 +235,13 @@ instance Convertible e m
Just b -> pure b
_ -> throwError $ "Expected a path, but saw: " ++ show v
instance (Convertible e m, MonadThunk (NValueF m r) r m,
FromValue Path m r, Show (NValueF m r))
instance (Convertible e m, FromValue Path m r, Show (NValueF m r))
=> FromValue Path m (NValueF m r) where
fromValueMay = \case
NVConstant (NUri u) -> pure $ Just (Path (Text.unpack u))
NVPath p -> pure $ Just (Path p)
NVStr s _ -> pure $ Just (Path (Text.unpack s))
NVSet s _ -> case M.lookup "outPath" s of
NVConstantF (NUri u) -> pure $ Just (Path (Text.unpack u))
NVPathF p -> pure $ Just (Path p)
NVStrF s _ -> pure $ Just (Path (Text.unpack s))
NVSetF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
@ -249,7 +253,7 @@ instance (Convertible e m,
FromValue a m (NValueNF m), Show a)
=> FromValue [a] m (NValueNF m) where
fromValueMay = \case
Fix (NVList l) -> sequence <$> traverse fromValueMay l
Fix (NVListF l) -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -258,7 +262,7 @@ instance (Convertible e m,
instance (Convertible e m, Show (NValueF m r))
=> FromValue [r] m (NValueF m r) where
fromValueMay = \case
NVList l -> pure $ Just l
NVListF l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -267,7 +271,7 @@ instance (Convertible e m, Show (NValueF m r))
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m)) m (NValueNF m) where
fromValueMay = \case
Fix (NVSet s _) -> pure $ Just s
Fix (NVSetF s _) -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -276,7 +280,7 @@ instance Convertible e m
instance (Convertible e m, Show (NValueF m r))
=> FromValue (HashMap Text r) m (NValueF m r) where
fromValueMay = \case
NVSet s _ -> pure $ Just s
NVSetF s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -286,7 +290,7 @@ instance Convertible e m
=> FromValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
fromValueMay = \case
Fix (NVSet s p) -> pure $ Just (s, p)
Fix (NVSetF s p) -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -296,146 +300,144 @@ instance (Convertible e m, Show (NValueF m r))
=> FromValue (HashMap Text r,
HashMap Text SourcePos) m (NValueF m r) where
fromValueMay = \case
NVSet s p -> pure $ Just (s, p)
NVSetF s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
instance (MonadThunk (NValueF m r) r m, Convertible e m,
Show (NValueF m r))
=> FromValue r m (NValueF m r) where
fromValueMay = pure . Just . value @_ @_ @m
instance (MonadThunk (NValue m) (NThunk m) m, Convertible e m)
=> FromValue (NThunk m) m (NValueF m (NThunk m)) where
fromValueMay = pure . Just . value @_ @_ @m . NValue Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a thunk, but saw: " ++ show v
instance (Monad m, FromValue a m (NValueF m r))
=> FromValue a m (m (NValueF m r)) where
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
instance (MonadThunk (NValueF m r) (NThunk m) m, FromValue a m (NValueF m r))
instance (MonadThunk (NValue m) (NThunk m) m,
FromValue a m (NValueF m (NThunk m)))
=> FromValue a m (NThunk m) where
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
instance FromValue a m (NValueF m (NThunk m))
=> FromValue a m (NValue m) where
fromValueMay = fromValueMay . baseValue
fromValue = fromValue . baseValue
instance (Convertible e m, MonadEffects m)
=> FromValue A.Value m (NValueNF m) where
fromValueMay = \case
Fix (NVConstant a) -> pure $ Just $ case a of
Fix (NVConstantF a) -> pure $ Just $ case a of
NInt n -> toJSON n
NFloat n -> toJSON n
NBool b -> toJSON b
NNull -> A.Null
NUri u -> toJSON u
Fix (NVStr s _) -> pure $ Just $ toJSON s
Fix (NVList l) -> fmap (A.Array . V.fromList) . sequence
Fix (NVStrF s _) -> pure $ Just $ toJSON s
Fix (NVListF l) -> fmap (A.Array . V.fromList) . sequence
<$> traverse fromValueMay l
Fix (NVSet m _) -> fmap A.Object . sequence <$> traverse fromValueMay m
Fix NVClosure {} -> pure Nothing
Fix (NVPath p) -> Just . toJSON . unStorePath <$> addPath p
Fix (NVBuiltin _ _) -> pure Nothing
Fix (NVSetF m _) -> fmap A.Object . sequence <$> traverse fromValueMay m
Fix NVClosureF {} -> pure Nothing
Fix (NVPathF p) -> Just . toJSON . unStorePath <$> addPath p
Fix (NVBuiltinF _ _) -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Cannot convert value to JSON: " ++ show v
instance (Convertible e m,
MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue A.Value m (NValueF m (NThunk m)) where
fromValueMay = normalForm >=> fromValueMay
fromValue = normalForm >=> fromValue
class ToValue a m v where
toValue :: a -> m v
instance Applicative m => ToValue () m (NValueNF m) where
toValue _ = pure . Fix . NVConstant $ NNull
toValue _ = pure . Fix . NVConstantF $ NNull
instance Applicative m => ToValue () m (NValueF m r) where
toValue _ = pure . NVConstant $ NNull
toValue _ = pure . NVConstantF $ NNull
instance Applicative m => ToValue Bool m (NValueNF m) where
toValue = pure . Fix . NVConstant . NBool
toValue = pure . Fix . NVConstantF . NBool
instance Applicative m => ToValue Bool m (NValueF m r) where
toValue = pure . NVConstant . NBool
toValue = pure . NVConstantF . NBool
instance Applicative m => ToValue Int m (NValueNF m) where
toValue = pure . Fix . NVConstant . NInt . toInteger
toValue = pure . Fix . NVConstantF . NInt . toInteger
instance Applicative m => ToValue Int m (NValueF m r) where
toValue = pure . NVConstant . NInt . toInteger
toValue = pure . NVConstantF . NInt . toInteger
instance Applicative m => ToValue Integer m (NValueNF m) where
toValue = pure . Fix . NVConstant . NInt
toValue = pure . Fix . NVConstantF . NInt
instance Applicative m => ToValue Integer m (NValueF m r) where
toValue = pure . NVConstant . NInt
toValue = pure . NVConstantF . NInt
instance Applicative m => ToValue Float m (NValueNF m) where
toValue = pure . Fix . NVConstant . NFloat
toValue = pure . Fix . NVConstantF . NFloat
instance Applicative m => ToValue Float m (NValueF m r) where
toValue = pure . NVConstant . NFloat
toValue = pure . NVConstantF . NFloat
instance Applicative m => ToValue Text m (NValueNF m) where
toValue = pure . Fix . flip NVStr mempty
toValue = pure . Fix . flip NVStrF mempty
instance Applicative m => ToValue Text m (NValueF m r) where
toValue = pure . flip NVStr mempty
toValue = pure . flip NVStrF mempty
instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where
toValue = pure . Fix . uncurry NVStr
toValue = pure . Fix . uncurry NVStrF
instance Applicative m => ToValue (Text, DList Text) m (NValueF m r) where
toValue = pure . uncurry NVStr
toValue = pure . uncurry NVStrF
instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Fix . flip NVStr mempty . decodeUtf8
toValue = pure . Fix . flip NVStrF mempty . decodeUtf8
instance Applicative m => ToValue ByteString m (NValueF m r) where
toValue = pure . flip NVStr mempty . decodeUtf8
toValue = pure . flip NVStrF mempty . decodeUtf8
instance Applicative m => ToValue Path m (NValueNF m) where
toValue = pure . Fix . NVPath . getPath
toValue = pure . Fix . NVPathF . getPath
instance Applicative m => ToValue Path m (NValueF m r) where
toValue = pure . NVPath . getPath
toValue = pure . NVPathF . getPath
instance MonadThunk (NValueF m r) r m
=> ToValue SourcePos m (NValueF m r) where
instance MonadThunk (NValue m) (NThunk m) m
=> ToValue SourcePos m (NValueF m (NThunk m)) where
toValue (SourcePos f l c) = do
f' <- toValue @_ @_ @(NValueF m r) (Text.pack f)
l' <- toValue (unPos l)
c' <- toValue (unPos c)
f' <- NValue Nothing <$> toValue (Text.pack f)
l' <- NValue Nothing <$> toValue (unPos l)
c' <- NValue Nothing <$> toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, value @_ @_ @m f')
, ("line", value @_ @_ @m l')
, ("column", value @_ @_ @m c') ]
pure $ NVSet pos mempty
pure $ NVSetF pos mempty
instance (ToValue a m (NValueNF m), Applicative m)
=> ToValue [a] m (NValueNF m) where
toValue = fmap (Fix . NVList) . traverse toValue
toValue = fmap (Fix . NVListF) . traverse toValue
instance Applicative m => ToValue [r] m (NValueF m r) where
toValue = pure . NVList
toValue = pure . NVListF
instance Applicative m
=> ToValue (HashMap Text (NValueNF m)) m (NValueNF m) where
toValue = pure . Fix . flip NVSet M.empty
toValue = pure . Fix . flip NVSetF M.empty
instance Applicative m => ToValue (HashMap Text r) m (NValueF m r) where
toValue = pure . flip NVSet M.empty
toValue = pure . flip NVSetF M.empty
instance Applicative m => ToValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
toValue (s, p) = pure $ Fix $ NVSet s p
toValue (s, p) = pure $ Fix $ NVSetF s p
instance Applicative m => ToValue (HashMap Text r,
HashMap Text SourcePos) m (NValueF m r) where
toValue (s, p) = pure $ NVSet s p
toValue (s, p) = pure $ NVSetF s p
instance (MonadThunk (NValue m) (NThunk m) m, ToValue a m (NValue m))
=> ToValue a m (NThunk m) where
@ -447,20 +449,26 @@ instance Applicative m => ToValue Bool m (NExprF r) where
instance Applicative m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
instance (Framed e m, MonadThunk (NValueF m r) r m)
=> ToValue A.Value m (NValueF m r) where
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m)
=> ToValue A.Value m (NValueF m (NThunk m)) where
toValue = \case
A.Object m -> flip NVSet M.empty
<$> traverse (thunk . toValue @_ @_ @(NValueF m r)) m
A.Array l -> NVList <$>
A.Object m -> flip NVSetF M.empty
<$> traverse (thunk . fmap (NValue Nothing)
. toValue @_ @_ @(NValueF m (NThunk m))) m
A.Array l -> NVListF <$>
traverse (thunk . withStringContext "While coercing to a JSON value"
. toValue) (V.toList l)
A.String s -> pure $ NVStr s mempty
A.Number n -> pure $ NVConstant $ case floatingOrInteger n of
A.String s -> pure $ NVStrF s mempty
A.Number n -> pure $ NVConstantF $ case floatingOrInteger n of
Left r -> NFloat r
Right i -> NInt i
A.Bool b -> pure $ NVConstant $ NBool b
A.Null -> pure $ NVConstant NNull
A.Bool b -> pure $ NVConstantF $ NBool b
A.Null -> pure $ NVConstantF NNull
instance (MonadThunk (NValue m) (NThunk m) m,
ToValue a m (NValueF m (NThunk m)))
=> ToValue a m (NValue m) where
toValue = fmap (NValue Nothing) . toValue
class FromNix a m v where
fromNix :: v -> m a
@ -471,21 +479,21 @@ class FromNix a m v where
default fromNixMay :: FromValue a m v => v -> m (Maybe a)
fromNixMay = fromValueMay
instance (Convertible e m, MonadThunk (NValueF m r) r m,
FromNix a m (NValueF m r), Show (NValueF m r), Show a)
=> FromNix [a] m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValueF m (NThunk m)), Show a)
=> FromNix [a] m (NValueF m (NThunk m)) where
fromNixMay = \case
NVList l -> sequence <$> traverse (`force` fromNixMay) l
NVListF l -> sequence <$> traverse (`force` fromNixMay . baseValue) l
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
instance (Convertible e m, MonadThunk (NValueF m r) r m,
FromNix a m (NValueF m r), Show (NValueF m r), Show a)
=> FromNix (HashMap Text a) m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValueF m (NThunk m)), Show a)
=> FromNix (HashMap Text a) m (NValueF m (NThunk m)) where
fromNixMay = \case
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
NVSetF s _ -> sequence <$> traverse (`force` fromNixMay . baseValue) s
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
@ -502,44 +510,61 @@ instance (Convertible e m, Show (NValueF m r)) => FromNix Integer m (NValueF m r
instance Convertible e m => FromNix Float m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix Float m (NValueF m r) where
instance (Convertible e m, MonadEffects m) => FromNix Text m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValueF m r) r m, FromValue Text m r, Show (NValueF m r)) => FromNix Text m (NValueF m r) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m, FromValue Text m r, Show (NValueF m r)) => FromNix Text m (NValueF m r) where
instance (Convertible e m, MonadEffects m) => FromNix (Text, DList Text) m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValueF m r) r m, FromValue Text m r, Show (NValueF m r)) => FromNix (Text, DList Text) m (NValueF m r) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m, FromValue Text m r, Show (NValueF m r)) => FromNix (Text, DList Text) m (NValueF m r) where
instance Convertible e m => FromNix ByteString m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix ByteString m (NValueF m r) where
instance Convertible e m => FromNix Path m (NValueNF m) where
instance (Convertible e m, MonadThunk (NValueF m r) r m, FromValue Path m r, Show (NValueF m r)) => FromNix Path m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => FromNix Path m (NValueF m (NThunk 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, Show (NValueF m r)) => FromNix (HashMap Text r, HashMap Text SourcePos) m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValueF m r) r m, Show (NValueF m r)) => FromNix r m (NValueF m r) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValueF m r) r m) => FromNix A.Value m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValue m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueNF m) where
instance (Monad m, FromNix a m (NValueF m r)) => FromNix a m (m (NValueF m r)) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueF m (NThunk m)) where
fromNixMay = fromNixMay <=< normalForm . NValue Nothing
fromNix = fromNix <=< normalForm . NValue Nothing
instance FromNix a m (NValueF m (NThunk m)) => FromNix a m (NValue m) where
fromNixMay = fromNixMay . baseValue
fromNix = fromNix . baseValue
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
fromNix = (>>= fromNix)
instance (MonadThunk (NValueF m r) (NThunk m) m,
FromNix a m (NValueF m r)) => FromNix a m (NThunk m) where
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 (NValueF m (NThunk m)) where
fromNixMay = pure . Just . value . NValue Nothing
fromNix = pure . value . NValue Nothing
class ToNix a m v where
toNix :: a -> m v
default toNix :: ToValue a m v => a -> m v
toNix = toValue
instance (Framed e m, MonadThunk (NValueF m r) r m, ToNix a m (NValueF m r))
=> ToNix [a] m (NValueF m r) where
toNix = fmap NVList
. traverse (thunk . withStringContext "While coercing to a list" . toNix)
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValueF m (NThunk m)))
=> ToNix [a] m (NValueF m (NThunk m)) where
toNix = fmap NVListF
. traverse (thunk . withStringContext "While coercing to a list"
. fmap (NValue Nothing)
. toNix)
instance (Framed e m, MonadThunk (NValueF m r) r m, ToNix a m (NValueF m r))
=> ToNix (HashMap Text a) m (NValueF m r) where
toNix = fmap (flip NVSet M.empty)
. traverse (thunk . withStringContext "While coercing to a set" . toNix)
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValueF m (NThunk m)))
=> ToNix (HashMap Text a) m (NValueF m (NThunk m)) where
toNix = fmap (flip NVSetF M.empty)
. traverse (thunk . withStringContext "While coercing to a set"
. fmap (NValue Nothing)
. toNix)
instance Applicative m => ToNix () m (NValueNF m) where
instance Applicative m => ToNix () m (NValueF m r) where
@ -559,15 +584,27 @@ instance Applicative m => ToNix ByteString m (NValueNF m) where
instance Applicative m => ToNix ByteString m (NValueF m r) where
instance Applicative m => ToNix Path m (NValueNF m) where
instance Applicative m => ToNix Path m (NValueF m r) where
instance MonadThunk (NValueF m r) r m => ToNix SourcePos m (NValueF m r) where
instance (Applicative m, ToNix a m (NValueNF m), ToValue a m (NValueNF m)) => ToNix [a] m (NValueNF 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 r, HashMap Text SourcePos) m (NValueF m r) where
instance (MonadThunk (NValue m) (NThunk m) m, ToValue a m (NValue m)) => ToNix a m (NThunk m) where
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m) => ToNix A.Value m (NValueF m (NThunk m)) where
instance Applicative m => ToNix Bool m (NExprF r) where
instance Applicative m => ToNix () m (NExprF r) where
instance (Framed e m, MonadThunk (NValueF m r) r m) => ToNix A.Value m (NValueF m r) where
instance MonadThunk (NValueF m r) r m => ToNix r m (NValueF m r) where
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueF m (NThunk m)))
=> ToNix a m (NThunk m) where
toNix = thunk . fmap (NValue Nothing) . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueF m (NThunk m)))
=> ToNix a m (NValue m) where
toNix = fmap (NValue Nothing) . toNix
instance (Applicative m, ToNix a m (NValueNF m)) => ToNix [a] m (NValueNF m) where
toNix = fmap (Fix . NVListF) . traverse toNix
instance MonadThunk (NValue m) (NThunk m) m => ToNix (NThunk m) m (NValue m) where
toNix = force ?? pure
instance MonadThunk (NValue m) (NThunk m) m
=> ToNix (NThunk m) m (NValueF m (NThunk m)) where
toNix = force ?? (pure . baseValue)

256
src/Nix/Exec.hs
View File

@ -80,31 +80,79 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
force = forceThunk . coerce
value = coerce . valueRef
currentPos :: Framed e m => m SrcSpan
currentPos = do
frames <- asks (view @_ @Frames hasLens)
let Fix (Compose (Ann span _)) : _ =
mapMaybe (either (const Nothing) Just) frames
return span
instance MonadNix e m => MonadEval (NValue m) m where
freeVariable var =
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
evalCurPos = do
Fix (Compose (Ann (SrcSpan delta _) _)) : _ <-
asks (mapMaybe (either (const Nothing) Just)
. view @_ @Frames hasLens)
SrcSpan delta _ <- currentPos
toValue delta
evalConstant = pure . NVConstant
evalString = (pure .) . NVStr
evalLiteralPath = fmap NVPath . makeAbsolutePath
evalEnvPath = fmap NVPath . findEnvPath
evalUnary = execUnaryOp
evalBinary = execBinaryOp
evalWith = evalWithAttrSet
evalConstant c = do
scope <- currentScopes
span <- currentPos
pure $ nvConstantP (Provenance scope (NConstant_ span c)) c
evalIf c t f = fromValue c >>= \b -> if b then t else f
evalString s d = do
scope <- currentScopes
span <- currentPos
-- jww (2018-04-22): Determine full provenance for the string?
pure $ nvStrP (Provenance scope (NStr_ span (DoubleQuoted [Plain s]))) s d
evalAssert c body = fromValue c >>= \b ->
if b then body else nverr "assertion failed"
evalLiteralPath p = do
scope <- currentScopes
span <- currentPos
fmap (nvPathP (Provenance scope (NLiteralPath_ span p)))
(makeAbsolutePath p)
evalEnvPath p = do
scope <- currentScopes
span <- currentPos
fmap (nvPathP (Provenance scope (NEnvPath_ span p))) (findEnvPath p)
evalUnary op arg = do
scope <- currentScopes
span <- currentPos
execUnaryOp scope span op arg
evalBinary op larg rarg = do
scope <- currentScopes
span <- currentPos
execBinaryOp scope span op larg rarg
evalWith c b = do
_scope <- currentScopes @_ @(NThunk m)
_span <- currentPos
-- jww (2018-04-22): This one needs more work.
-- addProvenance scope (\b -> NWith_ span (Just c) (Just (pure b))) <$>
evalWithAttrSet c b
evalIf c t f = do
scope <- currentScopes
span <- currentPos
fromValue c >>= \b ->
if b
then addProvenance scope (\t -> NIf_ span (Just c) (Just t) Nothing) <$> t
else addProvenance scope (\f -> NIf_ span (Just c) Nothing (Just f)) <$> f
evalAssert c body = do
scope <- currentScopes
span <- currentPos
fromValue c >>= \b ->
if b
then addProvenance scope (\b -> NAssert_ span (Just c) (Just b)) <$> body
else nverr $ "assertion failed, value provenance: "
++ show (provenance c)
evalApp = callFunc
evalAbs = (pure .) . NVClosure
evalAbs = (pure .) . nvClosure -- jww (2018-04-22): NYI
evalError = throwError
@ -124,122 +172,144 @@ callFunc fun arg = case fun of
throwError $ "Attempt to call non-function '" ++ show x
++ "' with arg: " ++ show arg'
execUnaryOp
:: (Framed e m, MonadVar m, MonadFile m)
=> NUnaryOp -> NValue m -> m (NValue m)
execUnaryOp op arg = do
execUnaryOp :: (Framed e m, MonadVar m, MonadFile m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
-> m (NValue m)
execUnaryOp scope span op arg = do
traceM "NUnary"
case arg of
NVConstant c -> case (op, c) of
(NNeg, NInt i) -> return $ NVConstant $ NInt (-i)
(NNeg, NFloat f) -> return $ NVConstant $ NFloat (-f)
(NNot, NBool b) -> return $ NVConstant $ NBool (not b)
(NNeg, NInt i) -> unaryOp $ NInt (-i)
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
(NNot, NBool b) -> unaryOp $ NBool (not b)
_ -> throwError $ "unsupported argument type for unary operator "
++ show op
x -> throwError $ "argument to unary operator"
x ->
-- jww (2018-04-22): Improve error reporting so that instead of
-- using 'show' to paste the textual form of the value into a
-- string, we use smarter pattern with typed elements, allowing us
-- to render specially based on the output device and verbosity
-- selections.
throwError $ "argument to unary operator"
++ " must evaluate to an atomic type: " ++ show x
where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
execBinaryOp
:: forall e m. (MonadNix e m, MonadEval (NValue m) m)
=> NBinaryOp -> NValue m -> m (NValue m) -> m (NValue m)
=> Scopes m (NThunk m)
-> SrcSpan
-> NBinaryOp
-> NValue m
-> m (NValue m)
-> m (NValue m)
execBinaryOp NOr larg rarg = fromNix larg >>= \l ->
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
if l
then toNix True
else rarg >>= fromNix @Bool >>= toNix
then orOp Nothing True
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
where
orOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b)
execBinaryOp NAnd larg rarg = fromNix larg >>= \l ->
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
if l
then rarg >>= fromNix @Bool >>= toNix
else toNix False
then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)
else andOp Nothing False
where
andOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b)
-- jww (2018-04-08): Refactor so that eval (NBinary ..) *always* dispatches
-- based on operator first
execBinaryOp op lval rarg = do
execBinaryOp scope span op lval rarg = do
rval <- rarg
let bin :: (Provenance m -> a) -> a
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
toBool = pure . bin nvConstantP . NBool
case (lval, rval) of
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
(NEq, _, _) -> toValue =<< valueEq lval rval
(NNEq, _, _) -> toValue . not =<< valueEq lval rval
(NLt, l, r) -> toValue $ l < r
(NLte, l, r) -> toValue $ l <= r
(NGt, l, r) -> toValue $ l > r
(NGte, l, r) -> toValue $ l >= r
(NEq, _, _) -> toBool =<< valueEq lval rval
(NNEq, _, _) -> toBool . not =<< valueEq lval rval
(NLt, l, r) -> toBool $ l < r
(NLte, l, r) -> toBool $ l <= r
(NGt, l, r) -> toBool $ l > r
(NGte, l, r) -> toBool $ l >= r
(NAnd, _, _) -> nverr "should be impossible: && is handled above"
(NOr, _, _) -> nverr "should be impossible: || is handled above"
(NPlus, l, r) -> numBinOp (+) l r
(NMinus, l, r) -> numBinOp (-) l r
(NMult, l, r) -> numBinOp (*) l r
(NDiv, l, r) -> numBinOp' div (/) l r
(NPlus, l, r) -> numBinOp bin (+) l r
(NMinus, l, r) -> numBinOp bin (-) l r
(NMult, l, r) -> numBinOp bin (*) l r
(NDiv, l, r) -> numBinOp' bin div (/) l r
(NImpl,
NBool l, NBool r) -> toValue $ not l || r
NBool l, NBool r) -> toBool $ not l || r
_ -> nverr $ unsupportedTypes lval rval
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> pure $ NVStr (ls `mappend` rs) (lc `mappend` rc)
NEq -> toValue =<< valueEq lval rval
NNEq -> toValue . not =<< valueEq lval rval
NLt -> toValue $ ls < rs
NLte -> toValue $ ls <= rs
NGt -> toValue $ ls > rs
NGte -> toValue $ ls >= rs
NPlus -> pure $ bin nvStrP (ls `mappend` rs) (lc `mappend` rc)
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
NLt -> toBool $ ls < rs
NLte -> toBool $ ls <= rs
NGt -> toBool $ ls > rs
NGte -> toBool $ ls >= rs
_ -> nverr $ unsupportedTypes lval rval
(NVStr _ _, NVConstant NNull) -> case op of
NEq -> toValue =<< valueEq lval (NVStr "" mempty)
NNEq -> toValue . not =<< valueEq lval (NVStr "" mempty)
NEq -> toBool =<< valueEq lval (nvStr "" mempty)
NNEq -> toBool . not =<< valueEq lval (nvStr "" mempty)
_ -> nverr $ unsupportedTypes lval rval
(NVConstant NNull, NVStr _ _) -> case op of
NEq -> toValue =<< valueEq (NVStr "" mempty) rval
NNEq -> toValue . not =<< valueEq (NVStr "" mempty) rval
NEq -> toBool =<< valueEq (nvStr "" mempty) rval
NNEq -> toBool . not =<< valueEq (nvStr "" mempty) rval
_ -> nverr $ unsupportedTypes lval rval
(NVSet ls lp, NVSet rs rp) -> case op of
NUpdate -> pure $ NVSet (rs `M.union` ls) (rp `M.union` lp)
NEq -> toValue =<< valueEq lval rval
NNEq -> toValue . not =<< valueEq lval rval
NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp)
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
(NVSet ls lp, NVConstant NNull) -> case op of
NUpdate -> pure $ NVSet ls lp
NEq -> toValue =<< valueEq lval (NVSet M.empty M.empty)
NNEq -> toValue . not =<< valueEq lval (NVSet M.empty M.empty)
NUpdate -> pure $ bin nvSetP ls lp
NEq -> toBool =<< valueEq lval (nvSet M.empty M.empty)
NNEq -> toBool . not =<< valueEq lval (nvSet M.empty M.empty)
_ -> nverr $ unsupportedTypes lval rval
(NVConstant NNull, NVSet rs rp) -> case op of
NUpdate -> pure $ NVSet rs rp
NEq -> toValue =<< valueEq (NVSet M.empty M.empty) rval
NNEq -> toValue . not =<< valueEq (NVSet M.empty M.empty) rval
NUpdate -> pure $ bin nvSetP rs rp
NEq -> toBool =<< valueEq (nvSet M.empty M.empty) rval
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
_ -> nverr $ unsupportedTypes lval rval
(NVList ls, NVList rs) -> case op of
NConcat -> pure $ NVList $ ls ++ rs
NEq -> toValue =<< valueEq lval rval
NNEq -> toValue . not =<< valueEq lval rval
NConcat -> pure $ bin nvListP $ ls ++ rs
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
(NVList ls, NVConstant NNull) -> case op of
NConcat -> pure $ NVList ls
NEq -> toValue =<< valueEq lval (NVList [])
NNEq -> toValue . not =<< valueEq lval (NVList [])
NConcat -> pure $ bin nvListP ls
NEq -> toBool =<< valueEq lval (nvList [])
NNEq -> toBool . not =<< valueEq lval (nvList [])
_ -> nverr $ unsupportedTypes lval rval
(NVConstant NNull, NVList rs) -> case op of
NConcat -> pure $ NVList rs
NEq -> toValue =<< valueEq (NVList []) rval
NNEq -> toValue . not =<< valueEq (NVList []) rval
NConcat -> pure $ bin nvListP rs
NEq -> toBool =<< valueEq (nvList []) rval
NNEq -> toBool . not =<< valueEq (nvList []) rval
_ -> nverr $ unsupportedTypes lval rval
(NVPath p, NVStr s _) -> case op of
-- jww (2018-04-13): Do we need to make the path absolute here?
NEq -> toValue $ p == Text.unpack s
NNEq -> toValue $ p /= Text.unpack s
NPlus -> NVPath <$> makeAbsolutePath (p `mappend` Text.unpack s)
NEq -> toBool $ p == Text.unpack s
NNEq -> toBool $ p /= Text.unpack s
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack s)
_ -> nverr $ unsupportedTypes lval rval
(NVPath ls, NVPath rs) -> case op of
NPlus -> NVPath <$> makeAbsolutePath (ls ++ rs)
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ unsupportedTypes lval rval
@ -249,22 +319,23 @@ execBinaryOp op lval rarg = do
"Unsupported argument types for binary operator "
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
numBinOp :: (forall a. Num a => a -> a -> a) -> NAtom -> NAtom
-> m (NValue m)
numBinOp f = numBinOp' f f
numBinOp :: (forall r. (Provenance m -> r) -> r)
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue m)
numBinOp bin f = numBinOp' bin f f
numBinOp'
:: (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom -> NAtom -> m (NValue m)
numBinOp' intF floatF l r = case (l, r) of
(NInt li, NInt ri) -> toValue $ li `intF` ri
(NInt li, NFloat rf) -> toValue $ fromInteger li `floatF` rf
(NFloat lf, NInt ri) -> toValue $ lf `floatF` fromInteger ri
(NFloat lf, NFloat rf) -> toValue $ lf `floatF` rf
numBinOp' :: (forall r. (Provenance m -> r) -> r)
-> (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom -> NAtom -> m (NValue 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
(NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri
(NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf
_ -> nverr $ unsupportedTypes l r
nverr = evalError @(NValue m)
where
toInt = pure . bin nvConstantP . NInt
toFloat = pure . bin nvConstantP . NFloat
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m))) m a }
@ -341,7 +412,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m, Alternative m)
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success expr -> do
let ref = value @_ @_ @(Lazy m) (NVPath path')
let ref = value @_ @_ @(Lazy m) (nvPath path')
-- Use this cookie so that when we evaluate the next
-- import, we'll remember which directory its containing
-- file was in.
@ -365,10 +436,11 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m, Alternative m)
Nothing -> pure False
Just v -> fromNix v
v' <- normalForm
=<< toNix @(ValueSet (Lazy m)) . M.fromList
=<< toValue @(ValueSet (Lazy m)) . M.fromList
=<< mapMaybeM
(\(k, v) -> fmap (k,) <$> case k of
"args" -> fmap Just $ thunk $ toNix =<< fromNix @[Text] v
"args" -> fmap Just . thunk . fmap (NValue Nothing) $
toNix =<< fromNix @[Text] v
"__ignoreNulls" -> pure Nothing
_ -> force v $ \case
NVConstant NNull | ignoreNulls -> pure Nothing
@ -524,5 +596,5 @@ evalExprLoc expr = do
adi (addTracing phi) (raise addStackFrames) expr
else adi phi addStackFrames expr
where
phi = Eval.eval . annotated . getCompose
phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x

43
src/Nix/Normal.hs
View File

@ -29,19 +29,20 @@ normalFormBy k n v = do
traceM $ replicate n ' ' ++ "normalFormBy: " ++ show v
when (n > 2000) $ throwError "<<loop during normalization>>"
case v of
NVConstant a -> return $ Fix $ NVConstant a
NVStr t s -> return $ Fix $ NVStr t s
NVConstant a -> return $ Fix $ NVConstantF a
NVStr t s -> return $ Fix $ NVStrF t s
NVList l ->
fmap (Fix . NVList) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
fmap (Fix . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ replicate n ' ' ++ "normalFormBy: List[" ++ show i ++ "]"
t `k` normalFormBy k (succ n)
NVSet s p ->
fmap (Fix . flip NVSet p) $ sequence $ flip M.mapWithKey s $ \key t -> do
fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \key t -> do
traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show key ++ "}"
t `k` normalFormBy k (succ n)
NVClosure p f -> return $ Fix $ NVClosure p f
NVPath fp -> return $ Fix $ NVPath fp
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
NVClosure p f -> return $ Fix $ NVClosureF p f
NVPath fp -> return $ Fix $ NVPathF fp
NVBuiltin name f -> return $ Fix $ NVBuiltinF name f
_ -> error "Pattern synonyms mask complete matches"
normalForm :: (Framed e m, MonadVar m, MonadFile m,
MonadThunk (NValue m) (NThunk m) m)
@ -51,38 +52,38 @@ normalForm = normalFormBy force 0
embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
=> NValueNF m -> m (NValue m)
embed (Fix x) = case x of
NVConstant a -> return $ NVConstant a
NVStr t s -> return $ NVStr t s
NVList l -> NVList . fmap (value @_ @_ @m)
NVConstantF a -> return $ nvConstant a
NVStrF t s -> return $ nvStr t s
NVListF l -> nvList . fmap (value @_ @_ @m)
<$> traverse embed l
NVSet s p -> flip NVSet p . fmap (value @_ @_ @m)
NVSetF s p -> flip nvSet p . fmap (value @_ @_ @m)
<$> traverse embed s
NVClosure p f -> return $ NVClosure p f
NVPath fp -> return $ NVPath fp
NVBuiltin name f -> return $ NVBuiltin name f
NVClosureF p f -> return $ nvClosure p f
NVPathF fp -> return $ nvPath fp
NVBuiltinF name f -> return $ nvBuiltin name f
valueText :: forall e m. (Framed e m, MonadFile m, MonadEffects m)
=> Bool -> NValueNF m -> m (Text, DList Text)
valueText addPathsToStore = cata phi
where
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
phi (NVConstant a) = pure (atomText a, mempty)
phi (NVStr t c) = pure (t, c)
phi (NVList _) = throwError "Cannot coerce a list to a string"
phi (NVSet s _)
phi (NVConstantF a) = pure (atomText a, mempty)
phi (NVStrF t c) = pure (t, c)
phi (NVListF _) = throwError "Cannot coerce a list to a string"
phi (NVSetF s _)
| Just asString <-
-- TODO: Should this be run through valueText recursively?
M.lookup "__asString" s = asString
| otherwise = throwError "Cannot coerce a set to a string"
phi NVClosure {} = throwError "Cannot coerce a function to a string"
phi (NVPath originalPath)
phi NVClosureF {} = throwError "Cannot coerce a function to a string"
phi (NVPathF originalPath)
| addPathsToStore = do
-- TODO: Capture and use the path of the file being processed as the
-- base path
storePath <- addPath originalPath
pure (Text.pack $ unStorePath storePath, mempty)
| otherwise = pure (Text.pack originalPath, mempty)
phi (NVBuiltin _ _) = throwError "Cannot coerce a function to a string"
phi (NVBuiltinF _ _) = throwError "Cannot coerce a function to a string"
valueTextNoContext :: (Framed e m, MonadFile m, MonadEffects m)
=> Bool -> NValueNF m -> m Text

42
src/Nix/Pretty.hs
View File

@ -11,6 +11,7 @@ module Nix.Pretty where
import Control.Monad
import Data.Fix
import Data.Functor.Compose
import Data.HashMap.Lazy (toList)
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as HashSet
@ -207,41 +208,44 @@ prettyNixValue = prettyNix . valueToExpr
where valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go
go (NVConstant a) = NConstant a
go (NVStr t _) = NStr (DoubleQuoted [Plain t])
go (NVList l) = NList l
go (NVSet s p) = NSet
go (NVConstantF a) = NConstant a
go (NVStrF t _) = NStr (DoubleQuoted [Plain t])
go (NVListF l) = NList l
go (NVSetF s p) = NSet
[ NamedVar (StaticKey k (M.lookup k p) :| []) v
| (k, v) <- toList s ]
go (NVClosure _ _) = NSym . pack $ "<closure>"
go (NVPath p) = NLiteralPath p
go (NVBuiltin name _) = NSym $ Text.pack $ "builtins." ++ name
go (NVClosureF _ _) = NSym . pack $ "<closure>"
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
printNix :: Functor m => NValueNF m -> String
printNix = cata phi
where phi :: NValueF m String -> String
phi (NVConstant a) = unpack $ atomText a
phi (NVStr t _) = show t
phi (NVList l) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
phi (NVConstantF a) = unpack $ atomText a
phi (NVStrF t _) = show t
phi (NVListF l) = "[ " ++ unwords l ++ " ]"
phi (NVSetF s _) =
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
phi NVClosure {} = "<<lambda>>"
phi (NVPath fp) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
phi NVClosureF {} = "<<lambda>>"
phi (NVPathF fp) = fp
phi (NVBuiltinF name _) = "<<builtin " ++ name ++ ">>"
removeEffects :: Functor m => NValue m -> NValueNF m
removeEffects = Fix . fmap dethunk
removeEffects = Fix . fmap dethunk . baseValue
where
dethunk (NThunk (Value v)) = removeEffects v
dethunk (NThunk _) = Fix $ NVStr "<thunk>" mempty
dethunk (NThunk _) = Fix $ NVStrF "<thunk>" mempty
showValue :: Functor m => NValue m -> String
showValue = show . prettyNixValue . removeEffects
instance Functor m => Show (NValueF m (NThunk m)) where
show = show . prettyNixValue . removeEffects . NValue Nothing
instance Functor m => Show (NValue m) where
show = showValue
show (NValue p v) = "(" ++ show v ++ " from " ++ show p ++ ")"
instance Functor m => Show (NThunk m) where
show (NThunk (Value v)) = show v
show (NThunk _) = "<thunk>"
instance Functor m => Show (Provenance m) where
show (Provenance _ (Compose (Ann _ expr))) = show expr

94
src/Nix/Value.hs
View File

@ -10,10 +10,14 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}
module Nix.Value where
import Control.Monad
@ -30,21 +34,22 @@ import Data.Void
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated (SourcePos(..))
import Nix.Expr.Types.Annotated
import Nix.Scope
import Nix.Thunk
import Nix.Utils
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
-- is completed.
data NValueF m r
= NVConstant NAtom
= NVConstantF NAtom
-- | A string has a value and a context, which can be used to record what a
-- string has been build from
| NVStr Text (DList Text)
| NVPath FilePath
| NVList [r]
| NVSet (AttrSet r) (AttrSet SourcePos)
| NVClosure (Params Void) (m (NValue m) -> m (NValue m))
| NVStrF Text (DList Text)
| NVPathF FilePath
| NVListF [r]
| NVSetF (AttrSet r) (AttrSet SourcePos)
| NVClosureF (Params Void) (m (NValue m) -> m (NValue m))
-- ^ 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
@ -56,7 +61,7 @@ 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.
| NVBuiltin String (m (NValue m) -> m (NValue m))
| NVBuiltinF String (m (NValue m) -> m (NValue m))
-- ^ 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.
@ -71,18 +76,69 @@ data NValueF m r
type NValueNF m = Fix (NValueF m) -- normal form
newtype NThunk m = NThunk (Thunk m (NValue m))
type NValue m = NValueF m (NThunk m) -- head normal form
type ValueSet m = AttrSet (NThunk m)
data Provenance m = Provenance
{ lexicalScope :: Scopes m (NThunk m)
, originExpr :: NExprLocF (Maybe (NValue m))
}
-- jww (2018-04-22): Tracking value provenance may need to be a compile-time
-- option.
data NValue m = NValue
{ provenance :: Maybe (Provenance m)
, baseValue :: NValueF m (NThunk m)
}
addProvenance :: Scopes m (NThunk m)
-> (NValue m -> NExprLocF (Maybe (NValue m)))
-> NValue m -> NValue m
addProvenance s f l@(NValue _ v) = NValue (Just (Provenance s (f l))) v
pattern NVConstant x <- NValue _ (NVConstantF x)
nvConstant x = NValue Nothing (NVConstantF x)
nvConstantP p x = NValue (Just p) (NVConstantF x)
pattern NVStr s d <- NValue _ (NVStrF s d)
nvStr s d = NValue Nothing (NVStrF s d)
nvStrP p s d = NValue (Just p) (NVStrF s d)
pattern NVPath x <- NValue _ (NVPathF x)
nvPath x = NValue Nothing (NVPathF x)
nvPathP p x = NValue (Just p) (NVPathF x)
pattern NVList l <- NValue _ (NVListF l)
nvList l = NValue Nothing (NVListF l)
nvListP p l = NValue (Just p) (NVListF l)
pattern NVSet s x <- NValue _ (NVSetF s x)
nvSet s x = NValue Nothing (NVSetF s x)
nvSetP p s x = NValue (Just p) (NVSetF s x)
pattern NVClosure x f <- NValue _ (NVClosureF x f)
nvClosure x f = NValue Nothing (NVClosureF x f)
nvClosureP p x f = NValue (Just p) (NVClosureF x f)
pattern NVBuiltin name f <- NValue _ (NVBuiltinF name f)
nvBuiltin name f = NValue Nothing (NVBuiltinF name f)
nvBuiltinP p name f = NValue (Just p) (NVBuiltinF name f)
instance Show (NValueF m (Fix (NValueF m))) where
showsPrec = flip go where
go (NVConstant atom) = showsCon1 "NVConstant" atom
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
go (NVList list) = showsCon1 "NVList" list
go (NVSet attrs _) = showsCon1 "NVSet" attrs
go (NVClosure p _) = showsCon1 "NVClosure" p
go (NVPath p) = showsCon1 "NVPath" p
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name
go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF text context) = showsCon2 "NVStr" text (appEndo context [])
go (NVListF list) = showsCon1 "NVList" list
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p) = showsCon1 "NVPath" p
go (NVBuiltinF name _) = showsCon1 "NVBuiltin" name
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
@ -98,7 +154,7 @@ instance Show (NValueF m (Fix (NValueF m))) where
. showsPrec 11 b
builtin :: Monad m => String -> (m (NValue m) -> m (NValue m)) -> m (NValue m)
builtin name f = return $ NVBuiltin name f
builtin name f = return $ nvBuiltin name f
builtin2 :: Monad m
=> String -> (m (NValue m) -> m (NValue m) -> m (NValue m)) -> m (NValue m)
@ -111,7 +167,7 @@ builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
isClosureNF :: Monad m => NValueNF m -> Bool
isClosureNF (Fix NVClosure {}) = True
isClosureNF (Fix NVClosureF {}) = True
isClosureNF _ = False
thunkEq :: MonadThunk (NValue m) (NThunk m) m
@ -137,7 +193,7 @@ isDerivation :: MonadThunk (NValue m) (NThunk m) m
=> AttrSet (NThunk m) -> m Bool
isDerivation m = case M.lookup "type" m of
Nothing -> pure False
Just t -> force t $ valueEq (NVStr "derivation" mempty)
Just t -> force t $ valueEq (nvStr "derivation" mempty)
valueEq :: MonadThunk (NValue m) (NThunk m) m
=> NValue m -> NValue m -> m Bool

14
src/Nix/XML.hs
View File

@ -19,25 +19,25 @@ toXML = (.) ((++ "\n") .
(\e -> Element (unqual "expr") [] [Elem e] Nothing))
$ cata
$ \case
NVConstant a -> case a of
NVConstantF a -> case a of
NInt n -> mkElem "int" "value" (show n)
NFloat f -> mkElem "float" "value" (show f)
NBool b -> mkElem "bool" "value" (if b then "true" else "false")
NNull -> Element (unqual "null") [] [] Nothing
NUri u -> mkElem "uri" "value" (Text.unpack u)
NVStr t _ -> mkElem "string" "value" (Text.unpack t)
NVList l -> Element (unqual "list") [] (Elem <$> l) Nothing
NVStrF t _ -> mkElem "string" "value" (Text.unpack t)
NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing
NVSet s _ -> Element (unqual "attrs") []
NVSetF s _ -> Element (unqual "attrs") []
(map (\(k, v) -> Elem (Element (unqual "attr")
[Attr (unqual "name") (Text.unpack k)]
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList s)) Nothing
NVClosure p _ -> Element (unqual "function") [] (paramsXML p) Nothing
NVPath fp -> mkElem "path" "value" fp
NVBuiltin name _ -> mkElem "function" "name" name
NVClosureF p _ -> Element (unqual "function") [] (paramsXML p) Nothing
NVPathF fp -> mkElem "path" "value" fp
NVBuiltinF name _ -> mkElem "function" "name" name
mkElem :: String -> String -> String -> Element
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing

8
tests/EvalTests.hs
View File

@ -151,10 +151,10 @@ genEvalCompareTests = do
mkTestCase f = testCase f $ assertEvalFileMatchesNix (testDir </> f)
instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
NVConstant x == NVConstant y = x == y
NVStr x _ == NVStr y _ = x == y
NVList x == NVList y = and (zipWith (==) x y)
NVSet x _ == NVSet y _ =
NVConstantF x == NVConstantF y = x == y
NVStrF x _ == NVStrF y _ = x == y
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))
x == y = error $ "Need to add comparison for values: "