2018-04-16 08:01:22 +02:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2018-04-16 08:01:22 +02:00
|
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2018-04-08 00:34:54 +02:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
|
|
|
|
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
|
|
|
|
module Nix.Builtins (MonadBuiltins, baseEnv) where
|
|
|
|
|
|
|
|
import Control.Monad
|
2018-04-07 23:33:15 +02:00
|
|
|
import Control.Monad.Catch
|
2018-04-07 21:02:50 +02:00
|
|
|
import Control.Monad.Fix
|
|
|
|
import Control.Monad.ListM (sortByM)
|
|
|
|
import qualified Crypto.Hash.MD5 as MD5
|
|
|
|
import qualified Crypto.Hash.SHA1 as SHA1
|
|
|
|
import qualified Crypto.Hash.SHA256 as SHA256
|
|
|
|
import qualified Crypto.Hash.SHA512 as SHA512
|
|
|
|
import qualified Data.Aeson as A
|
|
|
|
import qualified Data.Aeson.Encoding as A
|
|
|
|
import Data.Align (alignWith)
|
|
|
|
import Data.Array
|
|
|
|
import Data.ByteString (ByteString)
|
2018-04-08 09:26:48 +02:00
|
|
|
import qualified Data.ByteString as B
|
2018-04-07 21:02:50 +02:00
|
|
|
import Data.ByteString.Base16 as Base16
|
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import Data.Char (isDigit)
|
|
|
|
import Data.Coerce
|
2018-04-17 06:39:41 +02:00
|
|
|
import Data.Foldable (foldrM)
|
|
|
|
import Data.HashMap.Lazy (HashMap)
|
2018-04-07 21:02:50 +02:00
|
|
|
import qualified Data.HashMap.Lazy as M
|
|
|
|
import Data.List
|
|
|
|
import Data.Maybe
|
|
|
|
import Data.Semigroup
|
|
|
|
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 Data.Traversable (mapM)
|
|
|
|
import qualified Data.Vector as V
|
2018-04-08 00:34:54 +02:00
|
|
|
import Language.Haskell.TH.Syntax (addDependentFile, runIO)
|
2018-04-07 21:02:50 +02:00
|
|
|
import Nix.Atoms
|
2018-04-15 07:58:50 +02:00
|
|
|
import Nix.Convert
|
2018-04-11 06:01:48 +02:00
|
|
|
import Nix.Effects
|
2018-04-07 21:02:50 +02:00
|
|
|
import Nix.Eval
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Exec
|
2018-04-07 21:02:50 +02:00
|
|
|
import Nix.Expr.Types
|
2018-04-17 06:39:41 +02:00
|
|
|
import Nix.Expr.Types.Annotated
|
2018-04-08 02:24:22 +02:00
|
|
|
import Nix.Normal
|
2018-04-08 00:34:54 +02:00
|
|
|
import Nix.Parser
|
2018-04-07 21:02:50 +02:00
|
|
|
import Nix.Scope
|
|
|
|
import Nix.Stack
|
|
|
|
import Nix.Thunk
|
|
|
|
import Nix.Utils
|
|
|
|
import Nix.Value
|
|
|
|
import Nix.XML
|
|
|
|
import System.FilePath
|
|
|
|
import System.Posix.Files
|
|
|
|
import Text.Regex.TDFA
|
|
|
|
|
|
|
|
type MonadBuiltins e m =
|
2018-04-11 20:53:30 +02:00
|
|
|
(Scoped e (NThunk m) m,
|
|
|
|
Framed e m, MonadVar m, MonadFile m, MonadCatch m,
|
|
|
|
MonadEffects m, MonadFix m)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
baseEnv :: (MonadBuiltins e m, Scoped e (NThunk m) m)
|
|
|
|
=> m (Scopes m (NThunk m))
|
2018-04-07 21:02:50 +02:00
|
|
|
baseEnv = do
|
|
|
|
ref <- thunk $ flip NVSet M.empty <$> builtins
|
2018-04-08 01:33:50 +02:00
|
|
|
lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins
|
2018-04-07 21:02:50 +02:00
|
|
|
pushScope (M.fromList lst) currentScopes
|
|
|
|
where
|
|
|
|
topLevelBuiltins = map mapping . filter isTopLevel <$> builtinsList
|
|
|
|
|
|
|
|
builtins :: MonadBuiltins e m => m (ValueSet m)
|
|
|
|
builtins = M.fromList . map mapping <$> builtinsList
|
|
|
|
|
|
|
|
data BuiltinType = Normal | TopLevel
|
|
|
|
data Builtin m = Builtin
|
|
|
|
{ kind :: BuiltinType
|
|
|
|
, mapping :: (Text, NThunk m)
|
|
|
|
}
|
|
|
|
|
|
|
|
isTopLevel :: Builtin m -> Bool
|
|
|
|
isTopLevel b = case kind b of Normal -> False; TopLevel -> True
|
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
valueThunk :: forall e m. MonadBuiltins e m => NValue m -> NThunk m
|
|
|
|
valueThunk = value @_ @_ @m
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
force' :: forall e m. MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
|
|
force' = force ?? pure
|
|
|
|
|
2018-04-07 21:02:50 +02:00
|
|
|
builtinsList :: forall e m. MonadBuiltins e m => m [ Builtin m ]
|
|
|
|
builtinsList = sequence [
|
2018-04-16 04:05:44 +02:00
|
|
|
do version <- toValue ("2.0" :: Text)
|
2018-04-16 01:21:47 +02:00
|
|
|
pure $ Builtin Normal ("nixVersion", version)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-13 10:20:24 +02:00
|
|
|
, add0 TopLevel "__nixPath" nixPath
|
2018-04-07 21:02:50 +02:00
|
|
|
, add TopLevel "toString" toString
|
|
|
|
, add TopLevel "import" import_
|
|
|
|
, add2 TopLevel "map" map_
|
2018-04-13 10:20:33 +02:00
|
|
|
, add TopLevel "baseNameOf" baseNameOf
|
2018-04-07 21:02:50 +02:00
|
|
|
, add TopLevel "dirOf" dirOf
|
|
|
|
, add2 TopLevel "removeAttrs" removeAttrs
|
|
|
|
, add TopLevel "isNull" isNull
|
|
|
|
, add TopLevel "abort" throw_ -- for now
|
|
|
|
, add TopLevel "throw" throw_
|
|
|
|
, add2 TopLevel "scopedImport" scopedImport
|
2018-04-08 00:34:54 +02:00
|
|
|
, add TopLevel "derivationStrict" derivationStrict_
|
2018-04-10 18:02:17 +02:00
|
|
|
, add0 TopLevel "derivation" $(do
|
|
|
|
let f = "data/nix/corepkgs/derivation.nix"
|
|
|
|
addDependentFile f
|
|
|
|
Success expr <- runIO $ parseNixFile f
|
|
|
|
[| evalExpr expr |]
|
|
|
|
)
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-07 21:02:50 +02:00
|
|
|
, add Normal "getEnv" getEnv_
|
|
|
|
, add2 Normal "hasAttr" hasAttr
|
|
|
|
, add2 Normal "getAttr" getAttr
|
|
|
|
, add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos
|
|
|
|
, add2 Normal "any" any_
|
|
|
|
, add2 Normal "all" all_
|
|
|
|
, add3 Normal "foldl'" foldl'_
|
|
|
|
, add Normal "head" head_
|
|
|
|
, add Normal "tail" tail_
|
|
|
|
, add Normal "splitVersion" splitVersion_
|
|
|
|
, add2 Normal "compareVersions" compareVersions_
|
|
|
|
, add2 Normal "match" match_
|
2018-04-10 06:35:46 +02:00
|
|
|
-- jww (2018-04-09): Support floats for `add` and `sub`
|
2018-04-08 09:26:48 +02:00
|
|
|
, add2 Normal "split" split_
|
2018-04-07 21:02:50 +02:00
|
|
|
, add' Normal "add" (arity2 ((+) @Integer))
|
|
|
|
, add' Normal "sub" (arity2 ((-) @Integer))
|
2018-04-15 10:43:01 +02:00
|
|
|
, add Normal "parseDrvName" parseDrvName
|
2018-04-07 21:02:50 +02:00
|
|
|
, add' Normal "substring" substring
|
|
|
|
, add' Normal "stringLength" (arity1 Text.length)
|
|
|
|
, add Normal "length" length_
|
2018-04-16 08:01:22 +02:00
|
|
|
, add' Normal "attrNames" (arity1 (attrNames @m))
|
|
|
|
, add' Normal "attrValues" (arity1 (attrValues @m))
|
2018-04-07 21:02:50 +02:00
|
|
|
, add2 Normal "catAttrs" catAttrs
|
2018-04-16 08:01:22 +02:00
|
|
|
, add' Normal "concatStringsSep" (arity2 Text.intercalate)
|
2018-04-07 21:02:50 +02:00
|
|
|
, add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext
|
|
|
|
, add2 Normal "seq" seq_
|
|
|
|
, add2 Normal "deepSeq" deepSeq
|
|
|
|
, add2 Normal "elem" elem_
|
|
|
|
, add2 Normal "elemAt" elemAt_
|
|
|
|
, add2 Normal "genList" genList
|
|
|
|
, add2 Normal "filter" filter_
|
2018-04-15 10:43:01 +02:00
|
|
|
, add3 Normal "replaceStrings" replaceStrings
|
2018-04-07 21:02:50 +02:00
|
|
|
, add Normal "pathExists" pathExists_
|
|
|
|
, add Normal "toPath" toPath
|
|
|
|
, add Normal "isAttrs" isAttrs
|
|
|
|
, add Normal "isList" isList
|
|
|
|
, add Normal "isFunction" isFunction
|
|
|
|
, add Normal "isString" isString
|
|
|
|
, add Normal "isInt" isInt
|
|
|
|
, add Normal "isFloat" isFloat
|
|
|
|
, add Normal "isBool" isBool
|
|
|
|
, add2 Normal "sort" sort_
|
|
|
|
, add2 Normal "lessThan" lessThan
|
|
|
|
, add Normal "concatLists" concatLists
|
|
|
|
, add Normal "listToAttrs" listToAttrs
|
|
|
|
, add2 Normal "intersectAttrs" intersectAttrs
|
|
|
|
, add Normal "functionArgs" functionArgs
|
|
|
|
, add' Normal "hashString" hashString
|
|
|
|
, add Normal "readFile" readFile_
|
|
|
|
, add Normal "readDir" readDir_
|
|
|
|
, add Normal "toXML" toXML_
|
|
|
|
, add Normal "typeOf" typeOf
|
|
|
|
, add2 Normal "partition" partition_
|
|
|
|
, add0 Normal "currentSystem" currentSystem
|
2018-04-07 23:33:15 +02:00
|
|
|
, add Normal "tryEval" tryEval
|
2018-04-11 22:56:18 +02:00
|
|
|
, add Normal "fetchTarball" fetchTarball
|
2018-04-09 09:52:10 +02:00
|
|
|
, add Normal "fromJSON" fromJSON
|
|
|
|
, add' Normal "toJSON"
|
|
|
|
(arity1 $ decodeUtf8 . LBS.toStrict . A.encodingToLazyByteString
|
|
|
|
. toEncodingSorted)
|
2018-04-07 21:02:50 +02:00
|
|
|
]
|
|
|
|
where
|
|
|
|
wrap t n f = Builtin t (n, f)
|
|
|
|
|
|
|
|
arity1 f = Prim . pure . f
|
|
|
|
arity2 f = ((Prim . pure) .) . f
|
|
|
|
|
|
|
|
add0 t n v = wrap t n <$> thunk v
|
|
|
|
add t n v = wrap t n <$> thunk (builtin (Text.unpack n) v)
|
|
|
|
add2 t n v = wrap t n <$> thunk (builtin2 (Text.unpack n) v)
|
|
|
|
add3 t n v = wrap t n <$> thunk (builtin3 (Text.unpack n) v)
|
|
|
|
|
|
|
|
add' :: ToBuiltin m a => BuiltinType -> Text -> a -> m (Builtin m)
|
|
|
|
add' t n v = wrap t n <$> thunk (toBuiltin (Text.unpack n) v)
|
|
|
|
|
|
|
|
-- Helpers
|
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
call1 :: MonadBuiltins e m
|
2018-04-17 06:39:41 +02:00
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
call1 f arg = f >>= callFunc ?? arg
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
call2 :: MonadBuiltins e m
|
2018-04-17 06:39:41 +02:00
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
call2 f arg1 arg2 = f >>= callFunc ?? arg1 >>= callFunc ?? arg2
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
-- Primops
|
|
|
|
|
2018-04-14 03:09:12 +02:00
|
|
|
foldNixPath :: forall e m r. MonadBuiltins e m
|
2018-04-14 01:37:11 +02:00
|
|
|
=> (FilePath -> Maybe String -> r -> m r) -> r -> m r
|
|
|
|
foldNixPath f z = do
|
|
|
|
mres <- lookupVar @_ @(NThunk m) "__includes"
|
|
|
|
dirs <- case mres of
|
|
|
|
Nothing -> return []
|
|
|
|
Just v -> force v $ \case
|
|
|
|
NVList xs -> forM xs $ flip force $ \case
|
|
|
|
NVStr s _ -> pure s
|
|
|
|
_ -> error "impossible"
|
|
|
|
_ -> error "impossible"
|
|
|
|
menv <- getEnvVar "NIX_PATH"
|
|
|
|
foldrM go z $ dirs ++ case menv of
|
|
|
|
Nothing -> []
|
|
|
|
Just str -> Text.splitOn ":" (Text.pack str)
|
|
|
|
where
|
|
|
|
go x rest = case Text.splitOn "=" x of
|
|
|
|
[p] -> f (Text.unpack p) Nothing rest
|
|
|
|
[n, p] -> f (Text.unpack p) (Just (Text.unpack n)) rest
|
|
|
|
_ -> throwError $ "Unexpected entry in NIX_PATH: " ++ show x
|
|
|
|
|
2018-04-13 10:20:24 +02:00
|
|
|
nixPath :: MonadBuiltins e m => m (NValue m)
|
2018-04-17 06:39:41 +02:00
|
|
|
nixPath = fmap NVList $ flip foldNixPath [] $ \p mn rest ->
|
|
|
|
pure $ valueThunk
|
|
|
|
(flip NVSet mempty $ M.fromList
|
|
|
|
[ ("path", valueThunk $ NVPath p)
|
|
|
|
, ("prefix", valueThunk $
|
|
|
|
NVStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
|
|
|
|
|
|
|
|
toString :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-07 21:02:50 +02:00
|
|
|
toString str = do
|
2018-04-17 06:39:41 +02:00
|
|
|
(s, d) <- str >>= normalForm >>= valueText False
|
2018-04-07 21:02:50 +02:00
|
|
|
return $ NVStr s d
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
hasAttr :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
hasAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
|
2018-04-07 21:02:50 +02:00
|
|
|
(NVStr key _, NVSet aset _) ->
|
|
|
|
return . NVConstant . NBool $ M.member key aset
|
|
|
|
(x, y) -> throwError $ "Invalid types for builtin.hasAttr: "
|
2018-04-11 06:11:46 +02:00
|
|
|
++ show (x, y)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
getAttr :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
getAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
|
2018-04-07 21:02:50 +02:00
|
|
|
(NVStr key _, NVSet aset _) -> case M.lookup key aset of
|
|
|
|
Nothing -> throwError $ "getAttr: field does not exist: "
|
|
|
|
++ Text.unpack key
|
|
|
|
Just action -> force action pure
|
|
|
|
(x, y) -> throwError $ "Invalid types for builtin.getAttr: "
|
2018-04-11 06:11:46 +02:00
|
|
|
++ show (x, y)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
unsafeGetAttrPos :: forall e m. MonadBuiltins e m
|
2018-04-17 06:39:41 +02:00
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
|
2018-04-07 21:02:50 +02:00
|
|
|
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
|
|
|
|
Nothing ->
|
|
|
|
throwError $ "unsafeGetAttrPos: field '" ++ Text.unpack key
|
|
|
|
++ "' does not exist in attr set: " ++ show apos
|
2018-04-16 04:05:44 +02:00
|
|
|
Just delta -> toValue delta
|
2018-04-07 21:02:50 +02:00
|
|
|
(x, y) -> throwError $ "Invalid types for builtin.unsafeGetAttrPos: "
|
2018-04-11 06:11:46 +02:00
|
|
|
++ show (x, y)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-16 06:03:43 +02:00
|
|
|
-- This function is a bit special in that it doesn't care about the contents
|
|
|
|
-- of the list.
|
2018-04-17 06:39:41 +02:00
|
|
|
length_ :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
length_ = toValue . (length :: [NThunk m] -> Int) <=< fromValue
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
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
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
any_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
any_ pred = fromValue >=>
|
|
|
|
toNix <=< anyM fromNix <=< mapM (call1 pred . force')
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
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
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
all_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
all_ pred = fromValue >=>
|
|
|
|
toNix <=< allM fromNix <=< mapM (call1 pred . force')
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
foldl'_ :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
foldl'_ f z = fromValue @[NThunk m] >=> foldl' go z
|
2018-04-07 21:02:50 +02:00
|
|
|
where
|
2018-04-17 06:39:41 +02:00
|
|
|
go :: m (NValue m) -> NThunk m -> m (NValue m)
|
|
|
|
go b a = force a $ \a' -> call2 f (pure a') b
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
head_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
head_ = fromValue >=> \case
|
2018-04-16 06:03:43 +02:00
|
|
|
[] -> throwError "builtins.head: empty list"
|
2018-04-17 06:39:41 +02:00
|
|
|
h:_ -> force' h
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
tail_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
tail_ = fromValue >=> \case
|
2018-04-16 06:03:43 +02:00
|
|
|
[] -> throwError "builtins.tail: empty list"
|
|
|
|
_:t -> return $ NVList t
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
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 (read $ 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
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
splitVersion_ :: MonadBuiltins 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
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
compareVersions :: Text -> Text -> Ordering
|
|
|
|
compareVersions s1 s2 =
|
|
|
|
mconcat $ alignWith f (splitVersion s1) (splitVersion s2)
|
|
|
|
where
|
|
|
|
z = VersionComponent_String ""
|
|
|
|
f = uncurry compare . fromThese z z
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
compareVersions_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
compareVersions_ t1 t2 =
|
|
|
|
fromNix t1 >>= \s1 ->
|
|
|
|
fromNix t2 >>= \s2 ->
|
2018-04-07 21:02:50 +02:00
|
|
|
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)
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
parseDrvName :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
parseDrvName = fromValue >=> \(s :: Text) -> do
|
2018-04-15 10:43:01 +02:00
|
|
|
let (name :: Text, version :: Text) = splitDrvName s
|
|
|
|
-- jww (2018-04-15): There should be an easier way to write this.
|
2018-04-16 04:05:44 +02:00
|
|
|
(toValue =<<) $ sequence $ M.fromList
|
|
|
|
[ ("name" :: Text, thunk (toValue name))
|
|
|
|
, ("version", thunk (toValue version)) ]
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
match_ :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
match_ pat str =
|
|
|
|
fromNix pat >>= \p ->
|
|
|
|
fromNix str >>= \s -> do
|
2018-04-07 21:02:50 +02:00
|
|
|
-- jww (2018-04-05): We should create a fundamental type for compiled
|
|
|
|
-- regular expressions if it turns out they get used often.
|
2018-04-17 06:39:41 +02:00
|
|
|
let re = makeRegex (encodeUtf8 p) :: Regex
|
|
|
|
case matchOnceText re (encodeUtf8 s) of
|
|
|
|
Just ("", sarr, "") -> do
|
|
|
|
let s = map fst (elems sarr)
|
|
|
|
NVList <$> traverse (toValue . decodeUtf8)
|
|
|
|
(if length s > 1 then tail s else s)
|
|
|
|
_ -> pure $ NVConstant NNull
|
|
|
|
|
|
|
|
split_ :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
split_ pat str =
|
|
|
|
fromNix pat >>= \p ->
|
|
|
|
fromNix str >>= \s -> do
|
|
|
|
let re = makeRegex (encodeUtf8 p) :: Regex
|
|
|
|
haystack = encodeUtf8 s
|
|
|
|
return $ NVList $
|
|
|
|
splitMatches 0 (map elems $ matchAllText re haystack) haystack
|
2018-04-08 09:26:48 +02:00
|
|
|
|
|
|
|
splitMatches
|
|
|
|
:: forall e m. MonadBuiltins e m
|
|
|
|
=> Int
|
|
|
|
-> [[(ByteString, (Int, Int))]]
|
|
|
|
-> ByteString
|
|
|
|
-> [NThunk m]
|
|
|
|
splitMatches _ [] haystack = [thunkStr haystack]
|
|
|
|
splitMatches _ ([]:_) _ = error "Error in splitMatches: this should never happen!"
|
|
|
|
splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
|
2018-04-11 08:06:47 +02:00
|
|
|
thunkStr before : caps : splitMatches (numDropped + relStart + len) mts (B.drop len rest)
|
2018-04-08 09:26:48 +02:00
|
|
|
where
|
2018-04-11 08:06:47 +02:00
|
|
|
relStart = max 0 start - numDropped
|
|
|
|
(before,rest) = B.splitAt relStart haystack
|
2018-04-08 09:26:48 +02:00
|
|
|
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)
|
|
|
|
|
2018-04-07 23:33:15 +02:00
|
|
|
substring :: MonadBuiltins e m => Int -> Int -> Text -> Prim m Text
|
|
|
|
substring start len str = Prim $
|
2018-04-07 21:02:50 +02:00
|
|
|
if start < 0 --NOTE: negative values of 'len' are OK
|
2018-04-07 23:33:15 +02:00
|
|
|
then throwError $ "builtins.substring: negative start position: " ++ show start
|
|
|
|
else pure $ Text.take len $ Text.drop start str
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-16 08:01:22 +02:00
|
|
|
attrNames :: ValueSet m -> [Text]
|
2018-04-16 06:03:43 +02:00
|
|
|
attrNames = sort . M.keys
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-16 08:01:22 +02:00
|
|
|
attrValues :: forall m. ValueSet m -> [NThunk m]
|
|
|
|
attrValues = fmap snd . sortOn (fst @Text @(NThunk m)) . M.toList
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
map_ :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
map_ f = toNix <=< traverse (thunk . call1 f . force')
|
|
|
|
<=< fromValue @[NThunk m]
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
filter_ :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
filter_ f = toNix <=< filterM (fromValue <=< call1 f . force')
|
|
|
|
<=< fromValue @[NThunk m]
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
catAttrs :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
catAttrs attrName xs =
|
|
|
|
fromNix @Text attrName >>= \n ->
|
|
|
|
fromValue @[NThunk m] xs >>= \l ->
|
|
|
|
fmap (NVList . catMaybes) $
|
|
|
|
forM l $ fmap (M.lookup n) . fromValue
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
baseNameOf :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
baseNameOf x = x >>= \case
|
2018-04-13 10:20:33 +02:00
|
|
|
--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
|
|
|
|
v -> throwError $ "dirOf: expected string or path, got " ++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
dirOf :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
dirOf x = x >>= \case
|
2018-04-07 21:02:50 +02:00
|
|
|
--TODO: Only allow strings that represent absolute paths
|
|
|
|
NVStr path ctx -> pure $ NVStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
|
2018-04-07 23:52:24 +02:00
|
|
|
NVPath path -> pure $ NVPath $ takeDirectory path
|
2018-04-09 09:52:10 +02:00
|
|
|
v -> throwError $ "dirOf: expected string or path, got " ++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
unsafeDiscardStringContext :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
unsafeDiscardStringContext = fromNix @Text >=> toNix
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
seq_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
seq_ a b = a >> b
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
deepSeq :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
2018-04-07 21:02:50 +02:00
|
|
|
deepSeq a b = do
|
|
|
|
-- We evaluate 'a' only for its effects, so data cycles are ignored.
|
2018-04-17 06:39:41 +02:00
|
|
|
_ <- normalFormBy (forceEffects . coerce) =<< a
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
-- 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).
|
2018-04-17 06:39:41 +02:00
|
|
|
b
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
elem_ :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
elem_ x xs = x >>= \x' ->
|
|
|
|
toValue <=< anyM (valueEq x' <=< force') <=< fromValue @[NThunk m] $ xs
|
2018-04-17 03:57:28 +02:00
|
|
|
|
|
|
|
elemAt :: [a] -> Int -> Maybe a
|
|
|
|
elemAt ls i = case drop i ls of
|
|
|
|
[] -> Nothing
|
|
|
|
a:_ -> Just a
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
elemAt_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
elemAt_ xs n = fromNix n >>= \n' -> fromValue xs >>= \xs' ->
|
2018-04-17 03:57:28 +02:00
|
|
|
case elemAt xs' n' of
|
2018-04-17 06:39:41 +02:00
|
|
|
Just a -> force' a
|
2018-04-17 03:57:28 +02:00
|
|
|
Nothing -> throwError $ "builtins.elem: Index " ++ show n'
|
|
|
|
++ " too large for list of length " ++ show (length xs')
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
genList :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
genList generator = fromNix @Integer >=> \n ->
|
|
|
|
if n >= 0
|
|
|
|
then generator >>= \f ->
|
|
|
|
toNix =<< forM [0 .. n - 1] (\i -> thunk $ f `callFunc` toNix i)
|
|
|
|
else throwError $ "builtins.genList: Expected a non-negative number, got "
|
|
|
|
++ show n
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
--TODO: Preserve string context
|
2018-04-17 06:39:41 +02:00
|
|
|
replaceStrings :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
|
2018-04-15 10:43:01 +02:00
|
|
|
replaceStrings tfrom tto ts =
|
2018-04-17 06:39:41 +02:00
|
|
|
fromNix tfrom >>= \(from :: [Text]) ->
|
|
|
|
fromNix tto >>= \(to :: [Text]) ->
|
|
|
|
fromNix ts >>= \(s :: Text) -> do
|
2018-04-15 10:43:01 +02:00
|
|
|
when (length from /= length to) $
|
|
|
|
throwError $ "'from' and 'to' arguments to 'replaceStrings'"
|
|
|
|
++ " have different lengths"
|
|
|
|
let lookupPrefix s = do
|
|
|
|
(prefix, replacement) <-
|
|
|
|
find ((`Text.isPrefixOf` s) . fst) $ zip from to
|
|
|
|
let rest = Text.drop (Text.length prefix) s
|
|
|
|
return (prefix, replacement, rest)
|
|
|
|
finish = LazyText.toStrict . Builder.toLazyText
|
|
|
|
go orig result = case lookupPrefix orig of
|
|
|
|
Nothing -> case Text.uncons orig of
|
|
|
|
Nothing -> finish result
|
|
|
|
Just (h, t) -> go t $ result <> Builder.singleton h
|
|
|
|
Just (prefix, replacement, rest) -> case prefix of
|
|
|
|
"" -> case Text.uncons rest of
|
|
|
|
Nothing -> finish $ result <> Builder.fromText replacement
|
|
|
|
Just (h, t) -> go t $ mconcat
|
|
|
|
[ result
|
|
|
|
, Builder.fromText replacement
|
|
|
|
, Builder.singleton h
|
|
|
|
]
|
|
|
|
_ -> go rest $ result <> Builder.fromText replacement
|
2018-04-16 07:01:01 +02:00
|
|
|
toNix $ go s mempty
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
removeAttrs :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
removeAttrs set = fromNix >=> \(toRemove :: [Text]) ->
|
|
|
|
fromValue @(HashMap Text (NThunk m),
|
|
|
|
HashMap Text SourcePos) set >>= \(m, p) ->
|
|
|
|
toNix (go m toRemove, go p toRemove)
|
2018-04-07 21:02:50 +02:00
|
|
|
where
|
|
|
|
go = foldl' (flip M.delete)
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
intersectAttrs :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
intersectAttrs set1 set2 =
|
|
|
|
fromValue @(HashMap Text (NThunk m),
|
|
|
|
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)
|
|
|
|
|
|
|
|
functionArgs :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
functionArgs fun = fun >>= \case
|
2018-04-08 07:46:05 +02:00
|
|
|
NVClosure p _ ->
|
2018-04-07 21:02:50 +02:00
|
|
|
-- jww (2018-04-05): Should we preserve the location where the
|
|
|
|
-- function arguments were declared for __unsafeGetAttrPos?
|
2018-04-17 06:39:41 +02:00
|
|
|
toValue @(HashMap Text (NThunk m)) $
|
|
|
|
valueThunk . NVConstant . NBool <$>
|
|
|
|
case p of
|
|
|
|
Param name -> M.singleton name False
|
|
|
|
ParamSet s _ _ -> isJust <$> M.fromList s
|
2018-04-07 21:02:50 +02:00
|
|
|
v -> throwError $ "builtins.functionArgs: expected function, got "
|
2018-04-09 09:52:10 +02:00
|
|
|
++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
toPath :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
toPath path = path >>= \case
|
2018-04-07 21:02:50 +02:00
|
|
|
NVStr p@(Text.uncons -> Just ('/', _)) _ ->
|
2018-04-07 23:52:24 +02:00
|
|
|
return $ NVPath (Text.unpack p)
|
|
|
|
v@(NVPath _) -> return v
|
2018-04-09 09:52:10 +02:00
|
|
|
v -> throwError $ "builtins.toPath: expected string, got " ++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
pathExists_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
pathExists_ path = path >>= \case
|
2018-04-16 06:03:43 +02:00
|
|
|
NVPath p -> toNix =<< pathExists p
|
2018-04-14 03:35:51 +02:00
|
|
|
-- jww (2018-04-13): Should this ever be a string?
|
2018-04-16 06:03:43 +02:00
|
|
|
NVStr s _ -> toNix =<< pathExists (Text.unpack s)
|
2018-04-09 09:52:10 +02:00
|
|
|
v -> throwError $ "builtins.pathExists: expected path, got " ++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-16 08:01:22 +02:00
|
|
|
hasKind :: forall a e m. (MonadBuiltins e m, FromNix a m (NValue m))
|
2018-04-17 06:39:41 +02:00
|
|
|
=> m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
hasKind = fromNixMay >=> toNix . \case Just (_ :: a) -> True; _ -> False
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isAttrs :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isAttrs = hasKind @(ValueSet m)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isList :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isList = hasKind @[NThunk m]
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isString :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isString = hasKind @Text
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isInt :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isInt = hasKind @Int
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isFloat :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isFloat = hasKind @Float
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isBool :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isBool = hasKind @Bool
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isNull :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
isNull = hasKind @()
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
isFunction :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
isFunction func = func >>= \case
|
2018-04-16 08:01:22 +02:00
|
|
|
NVClosure {} -> toValue True
|
2018-04-16 04:05:44 +02:00
|
|
|
_ -> toValue False
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
throw_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
throw_ = fromNix >=> throwError . Text.unpack
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
import_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
import_ = fromNix >=> importPath M.empty . getPath
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
scopedImport :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
scopedImport aset path =
|
|
|
|
fromValue aset >>= \s ->
|
|
|
|
fromNix path >>= \p -> importPath @m s (getPath p)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
getEnv_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-16 08:01:22 +02:00
|
|
|
getEnv_ = fromNix >=> \s -> do
|
|
|
|
mres <- getEnvVar (Text.unpack s)
|
|
|
|
toNix $ case mres of
|
|
|
|
Nothing -> ""
|
|
|
|
Just v -> Text.pack v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
sort_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
sort_ comparator = fromValue >=> sortByM cmp >=> toValue
|
|
|
|
where
|
|
|
|
cmp a b = do
|
|
|
|
isLessThan <- call2 comparator (force' a) (force' b)
|
|
|
|
fromValue isLessThan >>= \case
|
|
|
|
True -> pure LT
|
|
|
|
False -> do
|
|
|
|
isGreaterThan <- call2 comparator (force' b) (force' a)
|
|
|
|
fromValue isGreaterThan <&> \case
|
|
|
|
True -> GT
|
|
|
|
False -> EQ
|
|
|
|
|
|
|
|
lessThan :: MonadBuiltins e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
|
2018-04-07 21:02:50 +02:00
|
|
|
let badType = throwError $ "builtins.lessThan: expected two numbers or two strings, "
|
2018-04-09 09:52:10 +02:00
|
|
|
++ "got " ++ show va ++ " and " ++ show vb
|
2018-04-07 21:02:50 +02:00
|
|
|
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 $ a < b
|
|
|
|
_ -> badType
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
concatLists :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
concatLists = fromValue @[NThunk m]
|
|
|
|
>=> mapM (fromValue @[NThunk m] >=> pure)
|
|
|
|
>=> toValue . concat
|
|
|
|
|
|
|
|
listToAttrs :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
listToAttrs = fromValue @[NThunk m] >=> \l ->
|
|
|
|
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
|
2018-04-07 21:02:50 +02:00
|
|
|
(Just name, Just value) -> force name $ \case
|
|
|
|
NVStr n _ -> return (n, value)
|
|
|
|
v -> throwError $
|
|
|
|
"builtins.listToAttrs: expected name to be a string, got "
|
2018-04-09 09:52:10 +02:00
|
|
|
++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
_ -> throwError $
|
|
|
|
"builtins.listToAttrs: expected set with name and value, got"
|
|
|
|
++ show s
|
|
|
|
|
|
|
|
hashString :: MonadBuiltins e m => Text -> Text -> Prim m Text
|
|
|
|
hashString algo s = Prim $ do
|
|
|
|
hash <- case algo of
|
|
|
|
"md5" -> pure MD5.hash
|
|
|
|
"sha1" -> pure SHA1.hash
|
|
|
|
"sha256" -> pure SHA256.hash
|
|
|
|
"sha512" -> pure SHA512.hash
|
|
|
|
_ -> throwError $ "builtins.hashString: "
|
|
|
|
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
|
|
|
|
pure $ decodeUtf8 $ Base16.encode $ hash $ encodeUtf8 s
|
|
|
|
|
|
|
|
absolutePathFromValue :: MonadBuiltins e m => NValue m -> m FilePath
|
|
|
|
absolutePathFromValue = \case
|
|
|
|
NVStr pathText _ -> do
|
|
|
|
let path = Text.unpack pathText
|
|
|
|
unless (isAbsolute path) $
|
|
|
|
throwError $ "string " ++ show path ++ " doesn't represent an absolute path"
|
|
|
|
pure path
|
2018-04-07 23:52:24 +02:00
|
|
|
NVPath path -> pure path
|
2018-04-09 09:52:10 +02:00
|
|
|
v -> throwError $ "expected a path, got " ++ show v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
--TODO: Move all liftIO things into MonadNixEnv or similar
|
2018-04-17 06:39:41 +02:00
|
|
|
readFile_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
readFile_ path =
|
|
|
|
path >>= absolutePathFromValue >>= Nix.Stack.readFile >>= toNix
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
data FileType
|
|
|
|
= FileType_Regular
|
|
|
|
| FileType_Directory
|
|
|
|
| FileType_Symlink
|
|
|
|
| FileType_Unknown
|
|
|
|
deriving (Show, Read, Eq, Ord)
|
|
|
|
|
2018-04-16 07:01:01 +02:00
|
|
|
instance Applicative m => ToNix FileType m (NValue m) where
|
|
|
|
toNix = toNix . \case
|
2018-04-16 01:21:47 +02:00
|
|
|
FileType_Regular -> "regular" :: Text
|
2018-04-07 21:02:50 +02:00
|
|
|
FileType_Directory -> "directory"
|
2018-04-16 01:21:47 +02:00
|
|
|
FileType_Symlink -> "symlink"
|
|
|
|
FileType_Unknown -> "unknown"
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
readDir_ :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
2018-04-07 21:02:50 +02:00
|
|
|
readDir_ pathThunk = do
|
2018-04-17 06:39:41 +02:00
|
|
|
path <- absolutePathFromValue =<< pathThunk
|
2018-04-07 21:02:50 +02:00
|
|
|
items <- listDirectory path
|
|
|
|
itemsWithTypes <- forM items $ \item -> do
|
2018-04-11 06:01:48 +02:00
|
|
|
s <- Nix.Effects.getSymbolicLinkStatus $ path </> item
|
2018-04-07 21:02:50 +02:00
|
|
|
let t = if
|
|
|
|
| isRegularFile s -> FileType_Regular
|
|
|
|
| isDirectory s -> FileType_Directory
|
|
|
|
| isSymbolicLink s -> FileType_Symlink
|
|
|
|
| otherwise -> FileType_Unknown
|
|
|
|
pure (Text.pack item, t)
|
2018-04-16 07:01:01 +02:00
|
|
|
toNix (M.fromList itemsWithTypes)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
fromJSON :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
fromJSON = fromValue >=> \encoded ->
|
2018-04-07 21:02:50 +02:00
|
|
|
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
|
|
|
|
Left jsonError -> throwError $ "builtins.fromJSON: " ++ jsonError
|
2018-04-16 04:05:44 +02:00
|
|
|
Right v -> toValue v
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
toXML_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
toXML_ v = v >>= normalForm >>= \x ->
|
2018-04-07 21:02:50 +02:00
|
|
|
pure $ NVStr (Text.pack (toXML x)) mempty
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
typeOf :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
typeOf v = v >>= toNix @Text . \case
|
2018-04-07 21:02:50 +02:00
|
|
|
NVConstant a -> case a of
|
2018-04-16 07:01:01 +02:00
|
|
|
NInt _ -> "int"
|
2018-04-07 21:02:50 +02:00
|
|
|
NFloat _ -> "float"
|
2018-04-16 07:01:01 +02:00
|
|
|
NBool _ -> "bool"
|
|
|
|
NNull -> "null"
|
|
|
|
NUri _ -> "string" --TODO: Should we get rid of NUri?
|
|
|
|
NVStr _ _ -> "string"
|
|
|
|
NVList _ -> "list"
|
|
|
|
NVSet _ _ -> "set"
|
|
|
|
NVClosure {} -> "lambda"
|
|
|
|
NVPath _ -> "path"
|
2018-04-07 21:02:50 +02:00
|
|
|
NVBuiltin _ _ -> "lambda"
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
tryEval :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
tryEval e = catch (onSuccess <$> e) (pure . onError)
|
2018-04-07 23:33:15 +02:00
|
|
|
where
|
|
|
|
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)))
|
|
|
|
]
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
fetchTarball :: forall e m. MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
fetchTarball v = v >>= \case
|
2018-04-11 22:56:18 +02:00
|
|
|
NVSet s _ -> case M.lookup "url" s of
|
|
|
|
Nothing -> throwError "builtins.fetchTarball: Missing url attribute"
|
|
|
|
Just url -> force url (go (M.lookup "sha256" s))
|
|
|
|
v@NVStr {} -> go Nothing v
|
|
|
|
v@(NVConstant (NUri _)) -> go Nothing v
|
|
|
|
v -> throwError $ "builtins.fetchTarball: Expected URI or set, got "
|
|
|
|
++ show v
|
|
|
|
where
|
|
|
|
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
|
|
|
|
go msha = \case
|
|
|
|
NVStr uri _ -> fetch uri msha
|
|
|
|
NVConstant (NUri uri) -> fetch uri msha
|
|
|
|
v -> throwError $ "builtins.fetchTarball: Expected URI or string, got "
|
|
|
|
++ show v
|
|
|
|
|
|
|
|
{- jww (2018-04-11): This should be written using pipes in another module
|
|
|
|
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
|
|
|
fetch uri msha = case takeExtension (Text.unpack uri) of
|
|
|
|
".tgz" -> undefined
|
|
|
|
".gz" -> undefined
|
|
|
|
".bz2" -> undefined
|
|
|
|
".xz" -> undefined
|
|
|
|
".tar" -> undefined
|
|
|
|
ext -> throwError $ "builtins.fetchTarball: Unsupported extension '"
|
|
|
|
++ ext ++ "'"
|
|
|
|
-}
|
|
|
|
|
|
|
|
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
|
|
|
fetch uri Nothing =
|
|
|
|
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
|
|
|
|
Text.unpack uri ++ "\""
|
|
|
|
fetch url (Just m) = force m $ \case
|
|
|
|
NVStr sha _ ->
|
|
|
|
nixInstantiateExpr $ "builtins.fetchTarball { "
|
|
|
|
++ "url = \"" ++ Text.unpack url ++ "\"; "
|
|
|
|
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
|
|
|
|
v -> throwError $ "builtins.fetchTarball: sha256 must be a string, got "
|
|
|
|
++ show v
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
partition_ :: forall e m. MonadBuiltins e m
|
|
|
|
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
|
|
|
partition_ f = fromValue @[NThunk m] >=> \l -> do
|
|
|
|
let match t = call1 f (force' t) >>= \case
|
|
|
|
NVConstant (NBool b) -> return (b, t)
|
|
|
|
v -> throwError $ "partition: Expected boolean, got " ++ show v
|
|
|
|
selection <- traverse match l
|
|
|
|
let (right, wrong) = partition fst selection
|
|
|
|
let makeSide = valueThunk . NVList . map snd
|
|
|
|
toValue @(HashMap Text (NThunk m)) $
|
|
|
|
M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
currentSystem :: MonadBuiltins e m => m (NValue m)
|
2018-04-07 21:02:50 +02:00
|
|
|
currentSystem = do
|
|
|
|
os <- getCurrentSystemOS
|
|
|
|
arch <- getCurrentSystemArch
|
|
|
|
return $ NVStr (os <> "-" <> arch) mempty
|
|
|
|
|
2018-04-17 06:39:41 +02:00
|
|
|
derivationStrict_ :: MonadBuiltins e m => m (NValue m) -> m (NValue m)
|
|
|
|
derivationStrict_ = (>>= derivationStrict)
|
2018-04-08 00:34:54 +02:00
|
|
|
|
2018-04-07 21:02:50 +02:00
|
|
|
newtype Prim m a = Prim { runPrim :: m a }
|
|
|
|
|
|
|
|
-- | Types that support conversion to nix in a particular monad
|
|
|
|
class ToBuiltin m a | a -> m where
|
|
|
|
toBuiltin :: String -> a -> m (NValue m)
|
|
|
|
|
2018-04-16 05:43:04 +02:00
|
|
|
instance (MonadBuiltins e m, ToNix a m (NValue m)) => ToBuiltin m (Prim m a) where
|
|
|
|
toBuiltin _ p = toNix =<< runPrim p
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-16 05:43:04 +02:00
|
|
|
instance (MonadBuiltins e m, FromNix a m (NValue m), ToBuiltin m b)
|
2018-04-07 21:02:50 +02:00
|
|
|
=> ToBuiltin m (a -> b) where
|
2018-04-17 06:39:41 +02:00
|
|
|
toBuiltin name f = return $ NVBuiltin name (fromNix >=> toBuiltin name . f)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
toEncodingSorted :: A.Value -> A.Encoding
|
|
|
|
toEncodingSorted = \case
|
|
|
|
A.Object m -> A.pairs $ mconcat $ fmap (\(k, v) -> A.pair k $ toEncodingSorted v) $ sortOn fst $ M.toList m
|
|
|
|
A.Array l -> A.list toEncodingSorted $ V.toList l
|
|
|
|
v -> A.toEncoding v
|