hnix/src/Nix/Builtins.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Nix.Builtins (MonadBuiltins, withNixContext, builtins) where

import           Control.Monad
import           Control.Monad.Catch
import           Control.Monad.ListM (sortByM)
import           Control.Monad.Reader (asks)

-- Using package imports here because there is a bug in cabal2nix that forces
-- 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           "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
import qualified "hashing" Crypto.Hash.SHA512 as SHA512
#else
import qualified "cryptohash-md5" Crypto.Hash.MD5 as MD5
import qualified "cryptohash-sha1" Crypto.Hash.SHA1 as SHA1
import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256
import qualified "cryptohash-sha512" Crypto.Hash.SHA512 as SHA512
#endif

import qualified Data.Aeson as A
import           Data.Align (alignWith)
import           Data.Array
import           Data.Bits
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.ByteString.Base16 as Base16
import           Data.Char (isDigit)
import           Data.Fix
import           Data.Foldable (foldrM)
import qualified Data.HashMap.Lazy as M
import           Data.List
import           Data.Maybe
import           Data.Scientific
import           Data.String.Interpolate.IsString
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Text.Encoding
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Builder as Builder
import           Data.These (fromThese)
import qualified Data.Time.Clock.POSIX as Time
import           Data.Traversable (for, mapM)
import qualified Data.Vector as V
import           Nix.Atoms
import           Nix.Convert
import           Nix.Effects
import qualified Nix.Eval as Eval
import           Nix.Exec
import           Nix.Expr.Types
import           Nix.Expr.Types.Annotated
import           Nix.Frames
import           Nix.Json
import           Nix.Normal
import           Nix.Options
import           Nix.Parser hiding (nixPath)
import           Nix.Render
import           Nix.Scope
import           Nix.String
import           Nix.Thunk
import           Nix.Utils
import           Nix.Value
import           Nix.XML
import           System.Nix.Internal.Hash (printHashBytes32)
import           System.FilePath
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 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 @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 @t @m @(NValue t f m) $ nvPath path
                pushScope (M.singleton "__cur_file" ref) action

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
    pushScope (M.fromList lst) currentScopes
  where
    buildMap = M.fromList . map mapping <$> builtinsList
    topLevelBuiltins = map mapping <$> fullBuiltinsList

    fullBuiltinsList = map go <$> builtinsList
      where
        go b@(Builtin TopLevel _) = b
        go (Builtin Normal (name, builtin)) =
            Builtin TopLevel ("__" <> name, builtin)

data BuiltinType = Normal | TopLevel
data Builtin t = Builtin
    { _kind   :: BuiltinType
    , mapping :: (Text, t)
    }

valueThunk :: forall e t f m. MonadBuiltins e t f m => NValue t f m -> t
valueThunk = wrapValue @_ @m

force' :: forall e t f m. MonadBuiltins e t f m => t -> m (NValue t f m)
force' = force ?? pure

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)

    , do version <- toValue (5 :: Int)
         pure $ Builtin Normal ("langVersion", version)

    , add0 Normal   "nixPath"                    nixPath
    , add  TopLevel "abort"                      throw_ -- for now
    , add2 Normal   "add"                        add_
    , add2 Normal   "addErrorContext"            addErrorContext
    , add2 Normal   "all"                        all_
    , add2 Normal   "any"                        any_
    , add  Normal   "attrNames"                  attrNames
    , add  Normal   "attrValues"                 attrValues
    , add  TopLevel "baseNameOf"                 baseNameOf
    , add2 Normal   "bitAnd"                     bitAnd
    , add2 Normal   "bitOr"                      bitOr
    , add2 Normal   "bitXor"                     bitXor
    , add2 Normal   "catAttrs"                   catAttrs
    , add2 Normal   "compareVersions"            compareVersions_
    , add  Normal   "concatLists"                concatLists
    , add' Normal   "concatStringsSep"           (arity2 principledIntercalateNixString)
    , add0 Normal   "currentSystem"              currentSystem
    , add0 Normal   "currentTime"                currentTime_
    , add2 Normal   "deepSeq"                    deepSeq

    , add0 TopLevel "derivation" $(do
          -- This is compiled in so that we only parse and evaluate it once,
          -- at compile-time.
          let Success expr = parseNixText [i|
    /* This is the implementation of the ‘derivation’ builtin function.
       It's actually a wrapper around the ‘derivationStrict’ primop. */

    drvAttrs @ { outputs ? [ "out" ], ... }:

    let

      strict = derivationStrict drvAttrs;

      commonAttrs = drvAttrs // (builtins.listToAttrs outputsList) //
        { all = map (x: x.value) outputsList;
          inherit drvAttrs;
        };

      outputToAttrListElement = outputName:
        { name = outputName;
          value = commonAttrs // {
            outPath = builtins.getAttr outputName strict;
            drvPath = strict.drvPath;
            type = "derivation";
            inherit outputName;
          };
        };

      outputsList = map outputToAttrListElement outputs;

    in (builtins.head outputsList).value|]
          [| cata Eval.eval expr |]
      )

    , add  TopLevel "derivationStrict"           derivationStrict_
    , add  TopLevel "dirOf"                      dirOf
    , add2 Normal   "div"                        div_
    , add2 Normal   "elem"                       elem_
    , add2 Normal   "elemAt"                     elemAt_
    , add  Normal   "exec"                       exec_
    , add0 Normal   "false"                      (return $ nvConstant $ NBool False)
    , add  Normal   "fetchTarball"               fetchTarball
    , add  Normal   "fetchurl"                   fetchurl
    , add2 Normal   "filter"                     filter_
    , add3 Normal   "foldl'"                     foldl'_
    , add  Normal   "fromJSON"                   fromJSON
    , add  Normal   "functionArgs"               functionArgs
    , add2 Normal   "genList"                    genList
    , add  Normal   "genericClosure"             genericClosure
    , add2 Normal   "getAttr"                    getAttr
    , add  Normal   "getEnv"                     getEnv_
    , add2 Normal   "hasAttr"                    hasAttr
    , add  Normal   "hasContext"                 hasContext
    , add' Normal   "hashString"                 hashString
    , add  Normal   "head"                       head_
    , add  TopLevel "import"                     import_
    , add2 Normal   "intersectAttrs"             intersectAttrs
    , add  Normal   "isAttrs"                    isAttrs
    , add  Normal   "isBool"                     isBool
    , add  Normal   "isFloat"                    isFloat
    , add  Normal   "isFunction"                 isFunction
    , add  Normal   "isInt"                      isInt
    , add  Normal   "isList"                     isList
    , add  TopLevel "isNull"                     isNull
    , add  Normal   "isString"                   isString
    , add  Normal   "length"                     length_
    , add2 Normal   "lessThan"                   lessThan
    , add  Normal   "listToAttrs"                listToAttrs
    , add2 TopLevel "map"                        map_
    , add2 TopLevel "mapAttrs"                   mapAttrs_
    , add2 Normal   "match"                      match_
    , add2 Normal   "mul"                        mul_
    , add0 Normal   "null"                       (return $ nvConstant NNull)
    , add  Normal   "parseDrvName"               parseDrvName
    , add2 Normal   "partition"                  partition_
    , add  Normal   "pathExists"                 pathExists_
    , add  TopLevel "placeholder"                placeHolder
    , add  Normal   "readDir"                    readDir_
    , add  Normal   "readFile"                   readFile_
    , add2 Normal   "findFile"                   findFile_
    , add2 TopLevel "removeAttrs"                removeAttrs
    , add3 Normal   "replaceStrings"             replaceStrings
    , add2 TopLevel "scopedImport"               scopedImport
    , add2 Normal   "seq"                        seq_
    , add2 Normal   "sort"                       sort_
    , add2 Normal   "split"                      split_
    , add  Normal   "splitVersion"               splitVersion_
    , add0 Normal   "storeDir"                   (return $ nvStr $ principledMakeNixStringWithoutContext "/nix/store")
    , add' Normal   "stringLength"               (arity1 $ Text.length . principledStringIgnoreContext)
    , add' Normal   "sub"                        (arity2 ((-) @Integer))
    , add' Normal   "substring"                  substring
    , add  Normal   "tail"                       tail_
    , add0 Normal   "true"                       (return $ nvConstant $ NBool True)
    , add  TopLevel "throw"                      throw_
    , add  Normal   "toJSON"                     prim_toJSON
    , add2 Normal   "toFile"                     toFile
    , add  Normal   "toPath"                     toPath
    , add  TopLevel "toString"                   toString
    , add  Normal   "toXML"                      toXML_
    , add2 TopLevel "trace"                      trace_
    , add  Normal   "tryEval"                    tryEval
    , add  Normal   "typeOf"                     typeOf
    , add  Normal   "unsafeDiscardStringContext" unsafeDiscardStringContext
    , add2 Normal   "unsafeGetAttrPos"           unsafeGetAttrPos
    , add  Normal   "valueSize"                  getRecursiveSize
  ]
  where
    wrap t n f = Builtin t (n, f)

    arity1 f = Prim . pure . f
    arity2 f = ((Prim . pure) .) . f

    mkThunk n = thunk . withFrame Info
        (ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n")

    add0 t n v = wrap t n <$> mkThunk n v
    add  t n v = wrap t n <$> mkThunk n (builtin  (Text.unpack n) v)
    add2 t n v = wrap t n <$> mkThunk n (builtin2 (Text.unpack n) v)
    add3 t n v = wrap t n <$> mkThunk n (builtin3 (Text.unpack n) v)

    add' :: 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 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"
    dirs <- case mres of
        Nothing -> return []
        Just v  -> fromNix v
    menv <- getEnvVar "NIX_PATH"
    foldrM go z $ map (fromInclude . principledStringIgnoreContext) dirs ++ case menv of
        Nothing -> []
        Just str -> uriAwareSplit (Text.pack str)
  where
    fromInclude x
        | "://" `Text.isInfixOf` x = (x, PathEntryURI)
        | otherwise = (x, PathEntryPath)
    go (x, ty) rest = case Text.splitOn "=" x of
        [p]    -> f (Text.unpack p) Nothing ty rest
        [n, p] -> f (Text.unpack p) (Just (Text.unpack n)) ty rest
        _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x

nixPath :: 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
            [ case ty of
                PathEntryPath -> ("path", valueThunk $ nvPath p)
                PathEntryURI ->  ("uri",  valueThunk $ nvStr (hackyMakeNixStringWithoutContext (Text.pack p)))
            , ("prefix", valueThunk $
                   nvStr (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn))) ]) : rest

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 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 t, AttrSet SourcePos) y >>= \(aset, _) ->
        toNix $ M.member key aset

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 :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
hasContext =
    toNix . stringHasContext <=< fromValue

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 t, AttrSet SourcePos) y >>= \(aset, _) ->
        attrsetGet key aset >>= force'

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
        Just delta -> toValue delta
    (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: "
                 ++ show (x, y)

-- This function is a bit special in that it doesn't care about the contents
-- of the list.
length_ :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
length_ = toValue . (length :: [t] -> Int) <=< fromValue

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)
    (NVConstant (NFloat x), NVConstant (NInt y))   -> toNix (x + fromInteger y)
    (NVConstant (NInt x),   NVConstant (NFloat y)) -> toNix (fromInteger x + y)
    (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x + y)
    (_, _) ->
        throwError $ Addition x' y'

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)
    (NVConstant (NFloat x), NVConstant (NInt y))   -> toNix (x * fromInteger y)
    (NVConstant (NInt x),   NVConstant (NFloat y)) -> toNix (fromInteger x * y)
    (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x * y)
    (_, _) ->
        throwError $ Multiplication x' y'

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)
    (NVConstant (NFloat x), NVConstant (NInt y))   | y /= 0 ->
        toNix (x / fromInteger y)
    (NVConstant (NInt x),   NVConstant (NFloat y)) | y /= 0 ->
        toNix (fromInteger x / y)
    (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 ->
        toNix (x / y)
    (_, _) ->
        throwError $ Division x' y'

anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ []       = return False
anyM p (x:xs)   = do
        q <- p x
        if q then return True
             else anyM p xs

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

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ []       = return True
allM p (x:xs)   = do
        q <- p x
        if q then allM p xs
             else return False

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 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 @[t] xs >>= foldl' (go f) z
  where
    go f b a = f `callFunc` b >>= (`callFunc` force' a)

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_ :: 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

data VersionComponent
   = VersionComponent_Pre -- ^ The string "pre"
   | VersionComponent_String Text -- ^ A string other than "pre"
   | VersionComponent_Number Integer -- ^ A number
   deriving (Show, Read, Eq, Ord)

versionComponentToString :: VersionComponent -> Text
versionComponentToString = \case
  VersionComponent_Pre -> "pre"
  VersionComponent_String s -> s
  VersionComponent_Number n -> Text.pack $ show n

-- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44
versionComponentSeparators :: String
versionComponentSeparators = ".-"

splitVersion :: Text -> [VersionComponent]
splitVersion s = case Text.uncons s of
    Nothing -> []
    Just (h, t)
      | h `elem` versionComponentSeparators -> splitVersion t
      | isDigit h ->
          let (digits, rest) = Text.span isDigit s
          in VersionComponent_Number
              (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits)
                   $ readMaybe
                   $ Text.unpack digits)
              : splitVersion rest
      | otherwise ->
          let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s
              thisComponent = case chars of
                  "pre" -> VersionComponent_Pre
                  x -> VersionComponent_String x
          in thisComponent : splitVersion rest

splitVersion_ :: 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) $
    valueThunk . nvStr
               . principledMakeNixStringWithoutContext
               . versionComponentToString

compareVersions :: Text -> Text -> Ordering
compareVersions s1 s2 =
    mconcat $ alignWith f (splitVersion s1) (splitVersion s2)
  where
    z = VersionComponent_String ""
    f = uncurry compare . fromThese z z

compareVersions_ :: 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 ->
      return $ nvConstant $ NInt $ case compareVersions s1 s2 of
        LT -> -1
        EQ -> 0
        GT -> 1

splitDrvName :: Text -> (Text, Text)
splitDrvName s =
    let sep = "-"
        pieces = Text.splitOn sep s
        isFirstVersionPiece p = case Text.uncons p of
            Just (h, _) | isDigit h -> True
            _ -> False
        -- Like 'break', but always puts the first item into the first result
        -- list
        breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a])
        breakAfterFirstItem f = \case
            h : t ->
                let (a, b) = break f t
                in (h : a, b)
            [] -> ([], [])
        (namePieces, versionPieces) =
          breakAfterFirstItem isFirstVersionPiece pieces
    in (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)

parseDrvName :: forall e t f m. 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 @t
             (toValue $ principledMakeNixStringWithoutContext name))
        , ("version",
           thunk @t
             (toValue $ principledMakeNixStringWithoutContext version)) ]

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
        -- NOTE: Currently prim_match in nix/src/libexpr/primops.cc ignores the
        -- context of its second argument. This is probably a bug but we're
        -- going to preserve the behavior here until it is fixed upstream.
        -- Relevant issue: https://github.com/NixOS/nix/issues/2547
        let s = principledStringIgnoreContext ns

        let re = makeRegex (encodeUtf8 p) :: Regex
        let mkMatch t = if Text.null t
                          then toValue () -- Shorthand for Null
                          else toValue $ principledMakeNixStringWithoutContext t
        case matchOnceText re (encodeUtf8 s) of
            Just ("", sarr, "") -> do
                let s = map fst (elems sarr)
                nvList <$> traverse (mkMatch . decodeUtf8)
                    (if length s > 1 then tail s else s)
            _ -> pure $ nvConstant NNull

split_ :: forall e t f m. 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
        -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the
        -- context of its second argument. This is probably a bug but we're
        -- going to preserve the behavior here until it is fixed upstream.
        -- Relevant issue: https://github.com/NixOS/nix/issues/2547
        let s = principledStringIgnoreContext ns
        let re = makeRegex (encodeUtf8 p) :: Regex
            haystack = encodeUtf8 s
        return $ nvList $
            splitMatches 0 (map elems $ matchAllText re haystack) haystack

splitMatches
  :: forall e t f m. MonadBuiltins e t f m
  => Int
  -> [[(ByteString, (Int, Int))]]
  -> ByteString
  -> [t]
splitMatches _ [] haystack = [thunkStr haystack]
splitMatches _ ([]:_) _ = error "Error in splitMatches: this should never happen!"
splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
    thunkStr before : caps : splitMatches (numDropped + relStart + len) mts (B.drop len rest)
  where
    relStart = max 0 start - numDropped
    (before,rest) = B.splitAt relStart haystack
    caps = valueThunk $ nvList (map f captures)
    f (a,(s,_)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a

thunkStr s = valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)))

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 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 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 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 @t . withFrame Debug
                           (ErrorCall "While applying f in map:\n")
                           . (f `callFunc`) . force')
          <=< fromValue @[t] $ xs

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 t) xs >>= \aset -> do
        let pairs = M.toList aset
        values <- for pairs $ \(key, value) ->
            thunk @t $
            withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $
            callFunc ?? force' value
                =<< callFunc f (pure (nvStr (principledMakeNixStringWithoutContext key)))
        toNix . M.fromList . zip (map fst pairs) $ values

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 @[t] $ xs

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 @[t] xs >>= \l ->
        fmap (nvList . catMaybes) $
            forM l $ fmap (M.lookup n) . fromValue

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 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 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 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 :: 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 :: 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_ :: 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 :: 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

    -- Then we evaluate the other argument to deepseq, thus this function
    -- should always produce a result (unlike applying 'deepseq' on infinitely
    -- recursive data structures in Haskell).
    b

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 (valueEqM x' <=< force') <=< fromValue @[t] $ xs

elemAt :: [a] -> Int -> Maybe a
elemAt ls i = case drop i ls of
   [] -> Nothing
   a:_ -> Just a

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 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 @t $ f `callFunc` toNix i)
    else throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got "
             ++ show n

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 $
              "builtins.genericClosure: "
                  ++ "Attributes 'startSet' and 'operator' required"
      (Nothing, Just _) ->
          throwError $ ErrorCall $
              "builtins.genericClosure: Attribute 'startSet' required"
      (Just _, Nothing) ->
          throwError $ ErrorCall $
              "builtins.genericClosure: Attribute 'operator' required"
      (Just startSet, Just operator) ->
          fromValue @[t] startSet >>= \ss ->
          force operator $ \op ->
              toValue @[t] =<< snd <$> go op ss []
  where
    go :: NValue t f m -> [t] -> [NValue t f m] -> m ([NValue t f m], [t])
    go _ [] ks = pure (ks, [])
    go op (t:ts) ks =
        force t $ \v -> fromValue @(AttrSet t) t >>= \s ->
            case M.lookup "key" s of
                Nothing ->
                    throwError $ ErrorCall $
                        "builtins.genericClosure: Attribute 'key' required"
                Just k -> force k $ \k' -> do
                    ys <- fromValue @[t] =<< (op `callFunc` pure v)
                    case ks of
                        []  -> checkComparable k' k'
                        j:_ -> checkComparable k' j
                    fmap (t:) <$> go op (ts ++ ys) (k':ks)

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]) ->
    fromValue ts  >>= \(ns    :: NixString) -> do
        let from = map principledStringIgnoreContext nsFrom
        when (length nsFrom /= length nsTo) $
            throwError $ ErrorCall $
                "'from' and 'to' arguments to 'replaceStrings'"
                    ++ " have different lengths"
        let lookupPrefix s = do
                (prefix, replacement) <-
                    find ((`Text.isPrefixOf` s) . fst) $ zip from nsTo
                let rest = Text.drop (Text.length prefix) s
                return (prefix, replacement, rest)
            finish b = principledMakeNixString (LazyText.toStrict $ Builder.toLazyText b)
            go orig result ctx = case lookupPrefix orig of
                Nothing -> case Text.uncons orig of
                    Nothing -> finish result ctx
                    Just (h, t) -> go t (result <> Builder.singleton h) ctx
                Just (prefix, replacementNS, rest) ->
                  let replacement = principledStringIgnoreContext replacementNS
                      newCtx = principledGetContext replacementNS
                  in case prefix of
                       "" -> case Text.uncons rest of
                           Nothing -> finish (result <> Builder.fromText replacement) (ctx <> newCtx)
                           Just (h, t) -> go t (mconcat
                               [ result
                               , Builder.fromText replacement
                               , Builder.singleton h
                               ]) (ctx <> newCtx)
                       _ -> go rest (result <> Builder.fromText replacement) (ctx <> newCtx)
        toNix $ go (principledStringIgnoreContext ns) mempty $ principledGetContext ns

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 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 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 t,
                AttrSet SourcePos) set1 >>= \(s1, p1) ->
    fromValue @(AttrSet t,
                AttrSet SourcePos) set2 >>= \(s2, p2) ->
        return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)

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 t) $
        valueThunk . nvConstant . NBool <$>
            case p of
                Param name -> M.singleton name False
                ParamSet s _ _ -> isJust <$> M.fromList s
    v -> throwError $ ErrorCall $
            "builtins.functionArgs: expected function, got " ++ show v

toFile :: 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
    -- TODO Using hacky here because we still need to turn the context into
    -- runtime references of the resulting file.
    -- See prim_toFile in nix/src/libexpr/primops.cc
    mres <- toFile_ (Text.unpack name') (Text.unpack $ hackyStringIgnoreContext s')
    let t = Text.pack $ unStorePath mres
        sc = StringContext t DirectPath
    toNix $ principledMakeNixStringWithSingletonContext t sc

toPath :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
toPath = fromValue @Path >=> toNix @Path

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 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 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 t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isList = hasKind @[t]

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 t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isInt = hasKind @Int

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 t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isBool = hasKind @Bool

isNull :: forall e t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
isNull = hasKind @()

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_ :: 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 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 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 t) asetArg >>= \s ->
    fromValue pathArg >>= \(Path p) -> do
        path  <- pathToDefaultNix @t @f @m p
        mres  <- lookupVar "__cur_file"
        path' <- case mres of
            Nothing  -> do
                traceM "No known current directory"
                return path
            Just p -> fromValue @_ @_ @t p >>= \(Path p') -> do
                traceM $ "Current file being evaluated is: " ++ show p'
                return $ takeDirectory p' </> path
        clearScopes @t $
            withNixContext (Just path') $
                pushScope s $
                    importPath @t @f @m path'

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 $
      case mres of
        Nothing -> ""
        Just v  -> Text.pack v

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
    cmp f a b = do
        isLessThan <- f `callFunc` force' a >>= (`callFunc` force' b)
        fromValue isLessThan >>= \case
            True -> pure LT
            False -> do
                isGreaterThan <- f `callFunc` force' b >>= (`callFunc` force' a)
                fromValue isGreaterThan <&> \case
                    True  -> GT
                    False -> EQ

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, "
                ++ "got " ++ show va ++ " and " ++ show vb
    nvConstant . NBool <$> case (va, vb) of
        (NVConstant ca, NVConstant cb) -> case (ca, cb) of
            (NInt   a, NInt   b) -> pure $ a < b
            (NFloat a, NInt   b) -> pure $ a < fromInteger b
            (NInt   a, NFloat b) -> pure $ fromInteger a < b
            (NFloat a, NFloat b) -> pure $ a < b
            _ -> badType
        (NVStr a, NVStr b) -> pure $ principledStringIgnoreContext a < principledStringIgnoreContext b
        _ -> badType

concatLists :: forall e t f m. 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 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 t) >=> \s -> do
            name <- fromStringNoContext =<< fromValue =<< attrsetGet "name" s
            val  <- attrsetGet "value" s
            pure (name, val)

-- prim_hashString from nix/src/libexpr/primops.cc
-- fail if context in the algo arg
-- propagate context from the s arg
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
    case algo of
        "md5"    -> f $ \s ->
#if MIN_VERSION_hashing(0, 1, 0)
          Text.pack $ show (hash (encodeUtf8 s) :: MD5.MD5)
#else
          decodeUtf8 $ Base16.encode $ MD5.hash $ encodeUtf8 s
#endif
        "sha1"   -> f $ \s ->
#if MIN_VERSION_hashing(0, 1, 0)
          Text.pack $ show (hash (encodeUtf8 s) :: SHA1.SHA1)
#else
          decodeUtf8 $ Base16.encode $ SHA1.hash $ encodeUtf8 s
#endif
        "sha256" -> f $ \s ->
#if MIN_VERSION_hashing(0, 1, 0)
          Text.pack $ show (hash (encodeUtf8 s) :: SHA256.SHA256)
#else
          decodeUtf8 $ Base16.encode $ SHA256.hash $ encodeUtf8 s
#endif
        "sha512" -> f $ \s ->
#if MIN_VERSION_hashing(0, 1, 0)
          Text.pack $ show (hash (encodeUtf8 s) :: SHA512.SHA512)
#else
          decodeUtf8 $ Base16.encode $ SHA512.hash $ encodeUtf8 s
#endif
        _ -> throwError $ ErrorCall $ "builtins.hashString: "
            ++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo

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)))
    toNix $ principledMakeNixStringWithoutContext $ Text.cons '/' $ printHashBytes32 $
      -- The result coming out of hashString is base16 encoded
      fst $ Base16.decode $ encodeUtf8 $ principledStringIgnoreContext h

absolutePathFromValue :: MonadBuiltins e t f m => NValue t f m -> m FilePath
absolutePathFromValue = \case
    NVStr ns -> do
        let path = Text.unpack $ hackyStringIgnoreContext ns
        unless (isAbsolute path) $
            throwError $ ErrorCall $ "string " ++ show path ++ " doesn't represent an absolute path"
        pure path
    NVPath path -> pure path
    v -> throwError $ ErrorCall $ "expected a path, got " ++ show v

readFile_ :: 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 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 @t @f @m x (Text.unpack (hackyStringIgnoreContext ns))
          pure $ nvPath mres
      (NVList _, y)  -> throwError $ ErrorCall $ "expected a string, got " ++ show y
      (x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x
      (x, y)         -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show (x, y)

data FileType
   = FileTypeRegular
   | FileTypeDirectory
   | FileTypeSymlink
   | FileTypeUnknown
   deriving (Show, Read, Eq, Ord)

instance Convertible e t f m => ToNix FileType m (NValue t f m) where
    toNix = toNix . principledMakeNixStringWithoutContext . \case
        FileTypeRegular   -> "regular" :: Text
        FileTypeDirectory -> "directory"
        FileTypeSymlink   -> "symlink"
        FileTypeUnknown   -> "unknown"

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
    itemsWithTypes <- forM items $ \item -> do
        s <- getSymbolicLinkStatus $ path </> item
        let t = if
                | isRegularFile s  -> FileTypeRegular
                | isDirectory s    -> FileTypeDirectory
                | isSymbolicLink s -> FileTypeSymlink
                | otherwise        -> FileTypeUnknown
        pure (Text.pack item, t)
    toNix (M.fromList itemsWithTypes)

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 ->
            throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError
        Right v -> jsonToNValue v
  where
    jsonToNValue = \case
        A.Object m -> flip nvSet M.empty
            <$> traverse (thunk . jsonToNValue) m
        A.Array l -> nvList <$>
            traverse (\x -> thunk @t @m @(NValue t f m)
                         . whileForcingThunk @t @f (CoercionFromJson @t @f @m x)
                         . jsonToNValue $ x)
                     (V.toList l)
        A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s
        A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
            Left r -> NFloat r
            Right i -> NInt i
        A.Bool b -> pure $ nvConstant $ NBool b
        A.Null -> pure $ nvConstant NNull

prim_toJSON
  :: MonadBuiltins e t f m
  => m (NValue t f m)
  -> m (NValue t f m)
prim_toJSON x = x >>= nvalueToJSONNixString >>= pure . nvStr

toXML_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
toXML_ v = v >>= normalForm >>= pure . nvStr . toXML

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"
        NFloat _ -> "float"
        NBool _  -> "bool"
        NNull    -> "null"
    NVStr _     -> "string"
    NVList _      -> "list"
    NVSet _ _     -> "set"
    NVClosure {}  -> "lambda"
    NVPath _      -> "path"
    NVBuiltin _ _ -> "lambda"
    _ -> error "Pattern synonyms obscure complete patterns"

tryEval :: forall e t f m. 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
        [ ("success", valueThunk (nvConstant (NBool True)))
        , ("value", valueThunk v)
        ]

    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 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 @t @f @m
      . Text.unpack
      . principledStringIgnoreContext
      =<< fromValue msg
  action

-- TODO: remember error context
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 t f m. MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
exec_ xs = do
  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 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 t -> NValue t f m -> m (NValue t f m)
    go _msha = \case
        NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha
            Left e -> throwError e
            Right p -> toValue p
        v -> throwError $ ErrorCall $
          "builtins.fetchurl: Expected URI or string, got " ++ show v
  
    noContextAttrs ns = case principledGetStringNoContext ns of
      Nothing -> throwError $ ErrorCall $
        "builtins.fetchurl: unsupported arguments to url"
      Just t -> pure t

partition_ :: forall e t f m. 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 @[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 t) $
            M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]

currentSystem :: MonadBuiltins e t f m => m (NValue t f m)
currentSystem = do
  os <- getCurrentSystemOS
  arch <- getCurrentSystemArch
  return $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os)

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_ :: 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 t f m a | a -> m where
    toBuiltin :: String -> a -> m (NValue t f m)

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 ( 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)