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

Get rid of ConvertValue in favor of Nix.Context

Browse source 
There remains some simplification work to be done, still, as there is much
duplication in Builtins.hs as things stand now. At least for now only one type
class-based, automatic conversion mechanism exists.
This commit is contained in:
John Wiegley 2018-04-15 01:43:01 -07:00
parent a6b004d04b
commit 5ce5ac8791
6 changed files with 239 additions and 348 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

148
src/Nix/Builtins.hs
View file

@ -98,8 +98,7 @@ valueThunk = value @_ @_ @m
builtinsList :: forall e m. MonadBuiltins e m => m [ Builtin m ]
builtinsList = sequence [
do version <- toNix ("2.0" :: Text)
pure $ Builtin Normal ("nixVersion", valueThunk version)
pure $ Builtin Normal ("nixVersion", toNix ("2.0" :: Text))
, add0 TopLevel "__nixPath" nixPath
, add TopLevel "toString" toString
@ -136,14 +135,14 @@ builtinsList = sequence [
, add2 Normal "split" split_
, add' Normal "add" (arity2 ((+) @Integer))
, add' Normal "sub" (arity2 ((-) @Integer))
, add' Normal "parseDrvName" parseDrvName
, add Normal "parseDrvName" parseDrvName
, add' Normal "substring" substring
, add' Normal "stringLength" (arity1 Text.length)
, add Normal "length" length_
, add Normal "attrNames" attrNames
, add Normal "attrValues" attrValues
, add2 Normal "catAttrs" catAttrs
, add' Normal "concatStringsSep" (arity2 Text.intercalate)
, add2 Normal "concatStringsSep" concatStringsSep
, add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext
, add2 Normal "seq" seq_
, add2 Normal "deepSeq" deepSeq
@ -151,7 +150,7 @@ builtinsList = sequence [
, add2 Normal "elemAt" elemAt_
, add2 Normal "genList" genList
, add2 Normal "filter" filter_
, add' Normal "replaceStrings" replaceStrings
, add3 Normal "replaceStrings" replaceStrings
, add Normal "pathExists" pathExists_
, add Normal "toPath" toPath
, add Normal "isAttrs" isAttrs
@ -278,7 +277,7 @@ unsafeGetAttrPos x y = force x $ \x' -> force y $ \y' -> case (x', y') of
Nothing ->
throwError $ "unsafeGetAttrPos: field '" ++ Text.unpack key
++ "' does not exist in attr set: " ++ show apos
Just delta -> toNix delta
Just delta -> pure $ toNix delta
(x, y) -> throwError $ "Invalid types for builtin.unsafeGetAttrPos: "
++ show (x, y)
@ -413,9 +412,13 @@ splitDrvName s =
breakAfterFirstItem isFirstVersionPiece pieces
in (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)
parseDrvName :: Applicative m => Text -> Prim m (AttrSet Text)
parseDrvName s = Prim $ pure $ M.fromList [("name", name), ("version", version)]
where (name, version) = splitDrvName s
parseDrvName :: forall e m. MonadBuiltins e m => NThunk m -> m (NValue m)
parseDrvName = flip force $ fromNix >=> \(s :: Text) -> do
let (name :: Text, version :: Text) = splitDrvName s
-- jww (2018-04-15): There should be an easier way to write this.
pure $ toNix $ M.fromList
[ ("name" :: Text, value @_ @_ @m (toNix name))
, ("version", value @_ @_ @m (toNix version)) ]
match_ :: forall e m. MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
match_ pat str = force pat $ \pat' -> force str $ \str' ->
@ -425,9 +428,9 @@ match_ pat str = force pat $ \pat' -> force str $ \str' ->
(NVStr p _, NVStr s _) -> do
let re = makeRegex (encodeUtf8 p) :: Regex
case matchOnceText re (encodeUtf8 s) of
Just ("", sarr, "") -> do
Just ("", sarr, "") ->
let s = map fst (elems sarr)
NVList <$> traverse (toNix . decodeUtf8)
in pure $ NVList $ fmap (toNix . decodeUtf8)
(if length s > 1 then tail s else s)
_ -> pure $ NVConstant NNull
(p, s) ->
@ -469,9 +472,9 @@ substring start len str = Prim $
then throwError $ "builtins.substring: negative start position: " ++ show start
else pure $ Text.take len $ Text.drop start str
attrNames :: MonadBuiltins e m => NThunk m -> m (NValue m)
attrNames :: forall e m. MonadBuiltins e m => NThunk m -> m (NValue m)
attrNames = flip force $ \case
NVSet m _ -> toNix $ sort $ M.keys m
NVSet m _ -> pure $ toNix $ fmap (value @_ @_ @m . toNix) $ sort $ M.keys m
v -> throwError $ "builtins.attrNames: Expected attribute set, got "
++ show v
@ -503,6 +506,11 @@ catAttrs attrName lt = force lt $ \case
v -> throwError $ "builtins.catAttrs: Expected a list, got "
++ show v
concatStringsSep :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
concatStringsSep s1 s2 = force s1 $ fromNix >=> \(s1' :: Text) ->
force s2 $ fromNix >=> traverse (`force` fromNix) >=> \(s2' :: [Text]) ->
pure $ toNix $ Text.intercalate s1' s2'
baseNameOf :: MonadBuiltins e m => NThunk m -> m (NValue m)
baseNameOf = flip force $ \case
--TODO: Only allow strings that represent absolute paths
@ -539,7 +547,7 @@ deepSeq a b = do
elem_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
elem_ x xs = force xs $ \case
NVList l -> toNix =<< anyM (thunkEq x) l
NVList l -> toNix <$> anyM (thunkEq x) l
v -> throwError $ "builtins.elem: Expected a list, got " ++ show v
elemAt_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
@ -553,42 +561,46 @@ elemAt_ xs n = force n $ extractInt >=> \n' -> force xs $ \case
genList :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
genList generator length = force length $ \case
NVConstant (NInt n) | n >= 0 -> fmap NVList $ forM [0 .. n - 1] $ \i ->
thunk $ force generator (`callFunc` toNix i)
thunk $ force generator (`callFunc` pure (toNix i))
v -> throwError $ "builtins.genList: Expected a non-negative number, got "
++ show v
--TODO: Preserve string context
replaceStrings :: MonadBuiltins e m => [Text] -> [Text] -> Text -> Prim m Text
replaceStrings from to s = Prim $ do
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
return $ go s mempty
replaceStrings :: MonadBuiltins e m => NThunk m -> NThunk m -> NThunk m -> m (NValue m)
replaceStrings tfrom tto ts =
force tfrom $ fromNix >=> traverse (`force` fromNix) >=> \(from :: [Text]) ->
force tto $ fromNix >=> traverse (`force` fromNix) >=> \(to :: [Text]) ->
force ts $ fromNix >=> \(s :: Text) -> do
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
return $ toNix $ go s mempty
removeAttrs :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
removeAttrs set list = force list $ fromNix >=> \(toRemove :: [Text]) ->
force set $ \case
NVSet m p -> return $ NVSet (go m toRemove) (go p toRemove)
v -> throwError $ "removeAttrs: expected set, got " ++ show v
removeAttrs set list = force list $
fromNix >=> traverse (`force` fromNix) >=> \(toRemove :: [Text]) ->
force set $ \case
NVSet m p -> return $ NVSet (go m toRemove) (go p toRemove)
v -> throwError $ "removeAttrs: expected set, got " ++ show v
where
go = foldl' (flip M.delete)
@ -629,43 +641,43 @@ pathExists_ = flip force $ \case
isAttrs :: MonadBuiltins e m => NThunk m -> m (NValue m)
isAttrs = flip force $ \case
NVSet _ _ -> toNix True
_ -> toNix False
NVSet _ _ -> pure $ toNix True
_ -> pure $ toNix False
isList :: MonadBuiltins e m => NThunk m -> m (NValue m)
isList = flip force $ \case
NVList _ -> toNix True
_ -> toNix False
NVList _ -> pure $ toNix True
_ -> pure $ toNix False
isFunction :: MonadBuiltins e m => NThunk m -> m (NValue m)
isFunction = flip force $ \case
NVClosure {} -> toNix True
_ -> toNix False
NVClosure {} -> pure $ toNix True
_ -> pure $ toNix False
isString :: MonadBuiltins e m => NThunk m -> m (NValue m)
isString = flip force $ \case
NVStr _ _ -> toNix True
_ -> toNix False
NVStr _ _ -> pure $ toNix True
_ -> pure $ toNix False
isInt :: MonadBuiltins e m => NThunk m -> m (NValue m)
isInt = flip force $ \case
NVConstant (NInt _) -> toNix True
_ -> toNix False
NVConstant (NInt _) -> pure $ toNix True
_ -> pure $ toNix False
isFloat :: MonadBuiltins e m => NThunk m -> m (NValue m)
isFloat = flip force $ \case
NVConstant (NFloat _) -> toNix True
_ -> toNix False
NVConstant (NFloat _) -> pure $ toNix True
_ -> pure $ toNix False
isBool :: MonadBuiltins e m => NThunk m -> m (NValue m)
isBool = flip force $ \case
NVConstant (NBool _) -> toNix True
_ -> toNix False
NVConstant (NBool _) -> pure $ toNix True
_ -> pure $ toNix False
isNull :: MonadBuiltins e m => NThunk m -> m (NValue m)
isNull = flip force $ \case
NVConstant NNull -> toNix True
_ -> toNix False
NVConstant NNull -> pure $ toNix True
_ -> pure $ toNix False
throw_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
throw_ = flip force $ \case
@ -771,7 +783,7 @@ absolutePathFromValue = \case
readFile_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
readFile_ pathThunk = do
path <- force pathThunk absolutePathFromValue
toNix =<< Nix.Stack.readFile path
toNix <$> Nix.Stack.readFile path
data FileType
= FileType_Regular
@ -780,14 +792,14 @@ data FileType
| FileType_Unknown
deriving (Show, Read, Eq, Ord)
instance ToNix FileType m (NValue m) where
instance ToNix FileType (NValue m) where
toNix = toNix . \case
FileType_Regular -> "regular" :: Text
FileType_Directory -> "directory"
FileType_Symlink -> "symlink"
FileType_Unknown -> "unknown"
readDir_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
readDir_ :: forall e m. MonadBuiltins e m => NThunk m -> m (NValue m)
readDir_ pathThunk = do
path <- force pathThunk absolutePathFromValue
items <- listDirectory path
@ -799,20 +811,20 @@ readDir_ pathThunk = do
| isSymbolicLink s -> FileType_Symlink
| otherwise -> FileType_Unknown
pure (Text.pack item, t)
toNix $ M.fromList itemsWithTypes
pure $ toNix $ fmap (value @_ @_ @m . toNix) $ M.fromList itemsWithTypes
fromJSON :: MonadBuiltins e m => NThunk m -> m (NValue m)
fromJSON t = force t $ fromNix >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
Left jsonError -> throwError $ "builtins.fromJSON: " ++ jsonError
Right v -> toNix v
Right v -> pure $ toNix v
toXML_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
toXML_ = flip force $ normalForm >=> \x ->
pure $ NVStr (Text.pack (toXML x)) mempty
typeOf :: MonadBuiltins e m => NThunk m -> m (NValue m)
typeOf t = force t $ \v -> toNix @Text $ case v of
typeOf t = force t $ \v -> pure $ toNix @Text $ case v of
NVConstant a -> case a of
NInt _ -> "int"
NFloat _ -> "float"
@ -909,8 +921,8 @@ newtype Prim m a = Prim { runPrim :: m a }
class ToBuiltin m a | a -> m where
toBuiltin :: String -> a -> m (NValue m)
instance (MonadBuiltins e m, ToNix a m (NValue m)) => ToBuiltin m (Prim m a) where
toBuiltin _ p = toNix =<< runPrim p
instance (MonadBuiltins e m, ToNix a (NValue m)) => ToBuiltin m (Prim m a) where
toBuiltin _ p = toNix <$> runPrim p
instance (MonadBuiltins e m, FromNix a m (NValue m), ToBuiltin m b)
=> ToBuiltin m (a -> b) where

219
src/Nix/Convert.hs
View file

@ -15,14 +15,10 @@
module Nix.Convert where
import Control.Monad
-- import Control.Monad.Catch
-- import Control.Monad.Fix
-- import Control.Monad.IO.Class
import Data.Aeson (toJSON)
import qualified Data.Aeson as A
import Data.ByteString
import Data.Fix
import Data.Functor.Compose
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Scientific
@ -35,13 +31,9 @@ import Nix.Effects
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Normal
-- import Nix.Scope
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Text.Megaparsec.Pos
-- import {-# SOURCE #-} Nix.Entry
class FromNix a m v where
fromNix :: (Framed e m, MonadVar m, MonadFile m) => v -> m a
@ -165,17 +157,24 @@ instance FromNix Path m (NValue m) where
instance (FromNix a m (NValueNF m), Show a)
=> FromNix [a] m (NValueNF m) where
fromNixMay = \case
Fix (NVList l) -> fmap sequence $ traverse fromNixMay l
Fix (NVList l) -> sequence <$> traverse fromNixMay l
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an attrset, but saw: " ++ show v
instance (MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m), Show a)
=> FromNix [a] m (NValue m) where
-- instance (MonadThunk (NValue m) (NThunk m) m,
-- FromNix a m (NValue m), Show a) => FromNix [a] m (NValue m) where
-- fromNixMay = \case
-- NVList l -> sequence <$> traverse (`force` fromNixMay) l
-- _ -> pure Nothing
-- fromNix = fromNixMay >=> \case
-- Just b -> pure b
-- v -> throwError $ "Expected an attrset, but saw: " ++ show v
instance FromNix [NThunk m] m (NValue m) where
fromNixMay = \case
NVList l -> fmap sequence $ traverse fromNixMay l
NVList l -> pure $ Just l
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
@ -189,6 +188,16 @@ instance FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where
Just b -> pure b
v -> throwError $ "Expected an attrset, but saw: " ++ show v
-- instance (MonadThunk (NValue m) (NThunk m) m,
-- FromNix a m (NValue m), Show a)
-- => FromNix (HashMap Text a) m (NValue m) where
-- fromNixMay = \case
-- NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
-- _ -> pure Nothing
-- fromNix = fromNixMay >=> \case
-- Just b -> pure b
-- v -> throwError $ "Expected an attrset, but saw: " ++ show v
instance FromNix (HashMap Text (NThunk m)) m (NValue m) where
fromNixMay = \case
NVSet s _ -> pure $ Just s
@ -222,32 +231,6 @@ instance (MonadThunk (NValue m) (NThunk m) m)
Just b -> pure b
v -> throwError $ "Expected a thunk, but saw: " ++ show v
instance FromNix a m (NValue m) => FromNix a m (m (NValue m)) where
fromNix v = v >>= fromNix
fromNixMay v = v >>= fromNixMay
instance (MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m)) => FromNix a m (NThunk m) where
fromNix = force ?? fromNix
fromNixMay = force ?? fromNixMay
instance (MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m)) => FromNix a m (m (NThunk m)) where
fromNix v = v >>= fromNix
fromNixMay v = v >>= fromNixMay
{-
instance (MonadNix e m, FromNix a m (NValue m))
=> FromNix a m NExprLoc where
fromNix = evalLoc Nothing [] >=> fromNix
fromNixMay = evalLoc Nothing [] >=> fromNixMay
instance (MonadCatch m, MonadFix m, MonadIO m, MonadEffects m,
FromNix a m (NValue m)) => FromNix a m NExpr where
fromNix = eval Nothing [] >=> fromNix
fromNixMay = eval Nothing [] >=> fromNixMay
-}
instance MonadEffects m => FromNix A.Value m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant a) -> pure $ Just $ case a of
@ -272,119 +255,107 @@ instance (MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
fromNixMay = normalForm >=> fromNixMay
fromNix = normalForm >=> fromNix
class ToNix a m v where
toNix :: Monad m => a -> m v
class ToNix a v where
toNix :: a -> v
instance ToNix Bool m (NValueNF m) where
toNix = pure . Fix . NVConstant . NBool
instance ToNix Bool (NValueNF m) where
toNix = Fix . NVConstant . NBool
instance ToNix Bool m (NValue m) where
toNix = pure . NVConstant . NBool
instance ToNix Bool (NValue m) where
toNix = NVConstant . NBool
instance ToNix Int m (NValueNF m) where
toNix = pure . Fix . NVConstant . NInt . toInteger
instance ToNix Int (NValueNF m) where
toNix = Fix . NVConstant . NInt . toInteger
instance ToNix Int m (NValue m) where
toNix = pure . NVConstant . NInt . toInteger
instance ToNix Int (NValue m) where
toNix = NVConstant . NInt . toInteger
instance ToNix Integer m (NValueNF m) where
toNix = pure . Fix . NVConstant . NInt
instance ToNix Integer (NValueNF m) where
toNix = Fix . NVConstant . NInt
instance ToNix Integer m (NValue m) where
toNix = pure . NVConstant . NInt
instance ToNix Integer (NValue m) where
toNix = NVConstant . NInt
instance ToNix Float m (NValueNF m) where
toNix = pure . Fix . NVConstant . NFloat
instance ToNix Float (NValueNF m) where
toNix = Fix . NVConstant . NFloat
instance ToNix Float m (NValue m) where
toNix = pure . NVConstant . NFloat
instance ToNix Float (NValue m) where
toNix = NVConstant . NFloat
instance ToNix Text m (NValueNF m) where
toNix = pure . Fix . flip NVStr mempty
instance ToNix Text (NValueNF m) where
toNix = Fix . flip NVStr mempty
instance ToNix Text m (NValue m) where
toNix = pure . flip NVStr mempty
instance ToNix Text (NValue m) where
toNix = flip NVStr mempty
instance ToNix ByteString m (NValueNF m) where
toNix = pure . Fix . flip NVStr mempty . decodeUtf8
instance ToNix ByteString (NValueNF m) where
toNix = Fix . flip NVStr mempty . decodeUtf8
instance ToNix ByteString m (NValue m) where
toNix = pure . flip NVStr mempty . decodeUtf8
instance ToNix ByteString (NValue m) where
toNix = flip NVStr mempty . decodeUtf8
instance ToNix Path m (NValueNF m) where
toNix = pure . Fix . NVPath . getPath
instance ToNix Path (NValueNF m) where
toNix = Fix . NVPath . getPath
instance ToNix Path m (NValue m) where
toNix = pure . NVPath . getPath
instance ToNix Path (NValue m) where
toNix = NVPath . getPath
instance MonadThunk (NValue m) (NThunk m) m
=> ToNix SourcePos m (NValue m) where
toNix (SourcePos f l c) = do
f' <- toNix @_ @_ @(NValue m) (Text.pack f)
l' <- toNix (unPos l)
c' <- toNix (unPos c)
toNix $ M.fromList [ ("file" :: Text, value @_ @_ @m f')
, ("line", value @_ @_ @m l')
, ("column", value @_ @_ @m c') ]
=> ToNix SourcePos (NValue m) where
toNix (SourcePos f l c) =
let f' = toNix @_ @(NValue m) (Text.pack f)
l' = toNix (unPos l)
c' = toNix (unPos c)
pos = M.fromList
[ ("file" :: Text, value @_ @_ @m f')
, ("line", value @_ @_ @m l')
, ("column", value @_ @_ @m c') ]
in NVSet pos mempty
instance ToNix a m (NValueNF m) => ToNix [a] m (NValueNF m) where
toNix = fmap (Fix . NVList) . traverse toNix
instance ToNix a (NValueNF m) => ToNix [a] (NValueNF m) where
toNix = Fix . NVList . fmap toNix
instance (MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m)) => ToNix [a] m (NValue m) where
toNix = fmap NVList . traverse toNix
-- instance (MonadThunk (NValue m) (NThunk m) m,
-- ToNix a (NValue m)) => ToNix [a] (NValue m) where
-- toNix = NVList . fmap toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueNF m))
=> ToNix (HashMap Text a) m (NValueNF m) where
toNix = fmap (Fix . flip NVSet M.empty) . traverse toNix
instance ToNix [NThunk m] (NValue m) where
toNix = NVList
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix (HashMap Text a) m (NValue m) where
toNix = fmap (flip NVSet M.empty) . traverse toNix
instance ToNix (HashMap Text (NValueNF m)) (NValueNF m) where
toNix = Fix . flip NVSet M.empty
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueNF m))
=> ToNix (HashMap Text a, HashMap Text SourcePos) m (NValueNF m) where
toNix (s, p) = Fix . flip NVSet p <$> traverse toNix s
-- instance (MonadThunk (NValue m) (NThunk m) m,
-- ToNix a (NValue m))
-- => ToNix (HashMap Text a) (NValue m) where
-- toNix = flip NVSet M.empty . fmap toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix (HashMap Text a, HashMap Text SourcePos) m (NValue m) where
toNix (s, p) = flip NVSet p <$> traverse toNix s
instance ToNix (HashMap Text (NThunk m)) (NValue m) where
toNix = flip NVSet M.empty
instance (MonadThunk (NValue m) (NThunk m) m)
=> ToNix (NThunk m) m (NValue m) where
toNix = force ?? pure
instance ToNix (HashMap Text (NValueNF m),
HashMap Text SourcePos) (NValueNF m) where
toNix (s, p) = Fix $ NVSet s p
instance ToNix a m (NValue m) => ToNix a m (m (NValue m)) where
toNix = pure . toNix
instance ToNix (HashMap Text (NThunk m),
HashMap Text SourcePos) (NValue m) where
toNix (s, p) = NVSet s p
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (NThunk m) where
toNix = fmap (value @(NValue m) @_ @m) . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a (NValue m))
=> ToNix a (NThunk m) where
toNix = value @(NValue m) @_ @m . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (m (NThunk m)) where
toNix = pure . fmap (value @(NValue m) @_ @m) . toNix
instance ToNix Bool m (NExprF r) where
toNix = pure . NConstant . NBool
instance ToNix a m (NExprF (Fix NExprF)) => ToNix a m NExpr where
toNix = fmap Fix . toNix
instance ToNix a m (NExprF (Fix (Compose (Ann SrcSpan) NExprF)))
=> ToNix a m NExprLoc where
toNix = fmap (Fix . Compose . Ann (SrcSpan blankSpan blankSpan)) . toNix
where
blankSpan = SourcePos "<unknown>" (mkPos 1) (mkPos 1)
instance ToNix Bool (NExprF r) where
toNix = NConstant . NBool
instance MonadThunk (NValue m) (NThunk m) m
=> ToNix A.Value m (NValue m) where
=> ToNix A.Value (NValue m) where
toNix = \case
A.Object m -> flip NVSet M.empty <$> traverse (thunk . toNix @_ @_ @(NValue m)) m
A.Array l -> NVList <$> traverse (thunk . toNix) (V.toList l)
A.String s -> pure $ NVStr s mempty
A.Number n -> pure $ NVConstant $ case floatingOrInteger n of
A.Object m -> flip NVSet M.empty $ fmap (value @_ @_ @m . toNix @_ @(NValue m)) m
A.Array l -> NVList $ fmap (value @_ @_ @m . toNix) (V.toList l)
A.String s -> NVStr s mempty
A.Number n -> 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
A.Bool b -> NVConstant $ NBool b
A.Null -> NVConstant NNull

44
src/Nix/Eval.hs
View file

@ -34,6 +34,7 @@ import qualified Data.Text as Text
import Data.These
import Data.Traversable (for)
import Nix.Atoms
import Nix.Convert
import Nix.Expr
import Nix.Scope
import Nix.Stack
@ -71,10 +72,11 @@ class (Show v, Monoid (MText v), Monad m) => MonadEval v m | v -> m where
type MonadNixEval e v t m =
(MonadEval v m, Scoped e t m, MonadThunk v t m, MonadFix m,
ConvertValue v Bool,
ConvertValue v [t],
ConvertValue v (AttrSet t),
ConvertValue v (AttrSet t, AttrSet SourcePos))
Framed e m, MonadFile m, MonadVar m,
ToNix Bool v, ToNix [t] v,
ToNix (AttrSet t) v, FromNix (AttrSet t) m v,
ToNix (AttrSet t, AttrSet SourcePos) v,
FromNix (AttrSet t, AttrSet SourcePos) m v)
-- | Evaluate an nix expression, with a given NThunkSet as environment
evalExpr :: MonadNixEval e v t m => NExpr -> m v
@ -114,27 +116,27 @@ eval (NSelect aset attr alt) = do
eval (NHasAttr aset attr) = do
traceM "NHasAttr"
ofVal . either (const False) (const True)
toNix . either (const False) (const True)
<$> evalSelect aset attr
eval (NList l) = do
traceM "NList"
scope <- currentScopes
ofVal <$> for l (thunk . withScopes @t scope)
toNix <$> for l (thunk . withScopes @t scope)
eval (NSet binds) = do
traceM "NSet..1"
(s, p) <- evalBinds True False binds
traceM $ "NSet..2: s = " ++ show (void s)
traceM $ "NSet..2: p = " ++ show (void p)
return $ ofVal (s, p)
return $ toNix (s, p)
eval (NRecSet binds) = do
traceM "NRecSet..1"
(s, p) <- evalBinds True True binds
traceM $ "NRecSet..2: s = " ++ show (void s)
traceM $ "NRecSet..2: p = " ++ show (void p)
return $ ofVal (s, p)
return $ toNix (s, p)
eval (NLet binds e) = do
traceM "Let..1"
@ -173,9 +175,8 @@ attrSetAlter (p:ps) m val = case M.lookup p m of
| otherwise -> recurse M.empty
Just x
| null ps -> go
| otherwise -> x >>= \v -> case wantVal v of
Just (s :: AttrSet t) ->
recurse (force ?? pure <$> s)
| otherwise -> x >>= \v -> fromNixMay v >>= \case
Just (s :: AttrSet t) -> recurse (force ?? pure <$> s)
_ -> evalError @v $ "attribute " ++ show p
++ " is not a set, but a " ++ show v
where
@ -183,7 +184,7 @@ attrSetAlter (p:ps) m val = case M.lookup p m of
-- jww (2018-04-13): Need to record positions for attr paths as well
recurse s = attrSetAlter ps s val <&> \m' ->
M.insert p (ofVal . fmap (value @_ @_ @m) <$> sequence m') m
M.insert p (toNix . fmap (value @_ @_ @m) <$> sequence m') m
evalBinds :: forall e v t m. MonadNixEval e v t m
=> Bool
@ -200,7 +201,7 @@ evalBinds allowDynamic recursive binds = do
go :: Scopes m t -> Binding (m v) -> m [([Text], Maybe SourcePos, m v)]
go _ (NamedVar [StaticKey "__overrides" _] finalValue) =
finalValue >>= \v -> case wantVal v of
finalValue >>= \v -> fromNixMay v >>= \case
Just (o', p') ->
return $ map (\(k, v) -> ([k], M.lookup k p', force v pure))
(M.toList o')
@ -214,7 +215,7 @@ evalBinds allowDynamic recursive binds = do
h : t -> evalSetterKeyName allowDynamic h >>= \case
(Nothing, _) ->
pure ([], Nothing,
pure (ofVal (mempty :: AttrSet t)))
pure (toNix (mempty :: AttrSet t)))
(Just k, pos) -> do
(restOfPath, _, v) <- go t
pure (k : restOfPath, pos, v)
@ -230,7 +231,7 @@ evalBinds allowDynamic recursive binds = do
(Just key, pos) -> return $ Just ([key], pos, do
mv <- case ms of
Nothing -> withScopes outsideScope $ lookupVar key
Just s -> s >>= \v -> case wantVal v of
Just s -> s >>= \v -> fromNixMay v >>= \case
Just (s :: AttrSet t) ->
clearScopes @t $ pushScope s $ lookupVar key
_ -> evalError @v $ "Wanted a set, but saw: " ++ show v
@ -267,12 +268,11 @@ evalSelect aset attr =
join $ extract <$> aset <*> evalSelector True attr
where
extract v [] = return $ Right v
extract x (k:ks) =
case wantVal @_ @(AttrSet t, AttrSet SourcePos) x of
Just (s, p) -> case M.lookup k s of
Just v -> force v $ extract ?? ks
Nothing -> return $ Left (ofVal (s, p), k:ks)
Nothing -> return $ Left (x, k:ks)
extract x (k:ks) = fromNixMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos) -> case M.lookup k s of
Just v -> force v $ extract ?? ks
Nothing -> return $ Left (toNix (s, p), k:ks)
Nothing -> return $ Left (x, k:ks)
evalSelector :: MonadEval v m
=> Bool -> NAttrPath (m v) -> m [Text]
@ -339,7 +339,7 @@ buildArgument :: forall e v t m. MonadNixEval e v t m
buildArgument params arg = case params of
Param name -> M.singleton name <$> thunk arg
ParamSet s isVariadic m ->
arg >>= \v -> case wantVal v of
arg >>= \v -> fromNixMay v >>= \case
Just args -> do
let inject = case m of
Nothing -> id

126
src/Nix/Exec.hs
View file

@ -71,62 +71,6 @@ import {-# SOURCE #-} Nix.Entry as Entry
nverr :: forall e m a. MonadNix e m => String -> m a
nverr = evalError @(NValue m)
instance MonadNix e m => ConvertValue (NValue m) Bool where
ofVal = NVConstant . NBool
wantVal = \case NVConstant (NBool b) -> Just b; _ -> Nothing
instance ConvertValue (NValue m) Int where
ofVal = NVConstant . NInt . fromIntegral
wantVal = \case NVConstant (NInt i) -> Just (fromIntegral i); _ -> Nothing
instance ConvertValue (NValue m) Integer where
ofVal = NVConstant . NInt
wantVal = \case NVConstant (NInt i) -> Just i; _ -> Nothing
instance ConvertValue (NValue m) Float where
ofVal = NVConstant . NFloat
wantVal = \case NVConstant (NFloat f) -> Just f; _ -> Nothing
instance ConvertValue (NValue m) Text where
ofVal = flip NVStr mempty
wantVal = \case
NVStr t _ -> Just t
NVPath p -> Just (Text.pack p)
_ -> Nothing
instance ConvertValue (NValue m) (Maybe Text) where
ofVal (Just s) = NVStr s mempty
ofVal Nothing = NVConstant NNull
wantVal (NVStr s _) = Just (Just s)
wantVal (NVPath s) = Just (Just (Text.pack s))
wantVal (NVConstant NNull) = Just Nothing
wantVal _ = Nothing
instance ConvertValue (NValue m) (Text, DList Text) where
ofVal = uncurry NVStr
wantVal = \case NVStr s p -> Just (s, p); _ -> Nothing
instance ConvertValue (NValue m) (Maybe (Text, DList Text)) where
ofVal Nothing = NVConstant NNull
ofVal (Just (s, p)) = NVStr s p
wantVal = \case
NVStr s p -> Just (Just (s, p))
NVConstant NNull -> Just Nothing
_ -> Nothing
instance ConvertValue (NValue m) [NThunk m] where
ofVal = NVList
wantVal = \case NVList l -> Just l; _ -> Nothing
instance ConvertValue (NValue m)
(AttrSet (NThunk m), AttrSet SourcePos) where
ofVal (s, p) = NVSet s p
wantVal = \case NVSet s p -> Just (s, p); _ -> Nothing
instance ConvertValue (NValue m) (AttrSet (NThunk m)) where
ofVal = flip NVSet M.empty
wantVal = \case NVSet s _ -> Just s; _ -> Nothing
instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
thunk = fmap coerce . buildThunk
force = forceThunk . coerce
@ -140,7 +84,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
Compose (Ann (SrcSpan delta _) _):_ <-
asks (mapMaybe (either (const Nothing) Just)
. view @_ @Frames hasLens)
toNix delta
return $ toNix delta
evalConstant = pure . NVConstant
evalString = pure . uncurry NVStr
@ -156,18 +100,18 @@ instance MonadNix e m => MonadEval (NValue m) m where
-- its value is only computed once.
traceM "Evaluating with scope"
s <- thunk scope
pushWeakScope ?? body $ force s $ \v -> case wantVal v of
pushWeakScope ?? body $ force s $ \v -> fromNixMay v >>= \case
Just (s :: AttrSet (NThunk m)) -> do
traceM $ "Scope is: " ++ show (void s)
pure s
_ -> nverr $ "scope must be a set in with statement, but saw: "
++ show v
evalIf c t f = case wantVal c of
evalIf c t f = fromNixMay c >>= \case
Just b -> if b then t else f
_ -> nverr $ "condition must be a boolean: "++ show c
evalAssert c body = case wantVal c of
evalAssert c body = fromNixMay c >>= \case
Just b -> if b then body else nverr "assertion failed"
_ -> nverr $ "assertion condition must be boolean, but saw: "
++ show c
@ -254,82 +198,82 @@ execBinaryOp op larg rarg = do
-> NAtom -> NAtom -> m (NValue m)
numBinOp' intF floatF l r = case (l, r) of
(NInt li, NInt ri) ->
pure . ofVal $ li `intF` ri
pure . toNix $ li `intF` ri
(NInt li, NFloat rf) ->
pure . ofVal $ fromInteger li `floatF` rf
pure . toNix $ fromInteger li `floatF` rf
(NFloat lf, NInt ri) ->
pure . ofVal $ lf `floatF` fromInteger ri
pure . toNix $ lf `floatF` fromInteger ri
(NFloat lf, NFloat rf) ->
pure . ofVal $ lf `floatF` rf
pure . toNix $ lf `floatF` rf
_ -> nverr unsupportedTypes
nverr = evalError @(NValue m)
case (lval, rval) of
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
(NEq, _, _) -> ofVal <$> valueEq lval rval
(NNEq, _, _) -> ofVal . not <$> valueEq lval rval
(NLt, l, r) -> pure . ofVal $ l < r
(NLte, l, r) -> pure . ofVal $ l <= r
(NGt, l, r) -> pure . ofVal $ l > r
(NGte, l, r) -> pure . ofVal $ l >= r
(NEq, _, _) -> toNix <$> valueEq lval rval
(NNEq, _, _) -> toNix . not <$> valueEq lval rval
(NLt, l, r) -> pure . toNix $ l < r
(NLte, l, r) -> pure . toNix $ l <= r
(NGt, l, r) -> pure . toNix $ l > r
(NGte, l, r) -> pure . toNix $ l >= r
(NAnd, _, _) -> nverr "should be impossible: && is handled above"
(NOr, _, _) -> nverr "should be impossible: || is handled above"
(NPlus, l, r) -> numBinOp (+) l r
(NMinus, l, r) -> numBinOp (-) l r
(NMult, l, r) -> numBinOp (*) l r
(NDiv, l, r) -> numBinOp' div (/) l r
(NImpl, NBool l, NBool r) -> pure . ofVal $ not l || r
(NImpl, NBool l, NBool r) -> pure . toNix $ not l || r
_ -> nverr unsupportedTypes
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> pure $ NVStr (ls `mappend` rs) (lc `mappend` rc)
NEq -> ofVal <$> valueEq lval rval
NNEq -> ofVal . not <$> valueEq lval rval
NLt -> pure . ofVal $ ls < rs
NLte -> pure . ofVal $ ls <= rs
NGt -> pure . ofVal $ ls > rs
NGte -> pure . ofVal $ ls >= rs
NEq -> toNix <$> valueEq lval rval
NNEq -> toNix . not <$> valueEq lval rval
NLt -> pure . toNix $ ls < rs
NLte -> pure . toNix $ ls <= rs
NGt -> pure . toNix $ ls > rs
NGte -> pure . toNix $ ls >= rs
_ -> nverr unsupportedTypes
(NVStr _ _, NVConstant NNull) -> case op of
NEq -> ofVal <$> valueEq lval (NVStr "" mempty)
NNEq -> ofVal . not <$> valueEq lval (NVStr "" mempty)
NEq -> toNix <$> valueEq lval (NVStr "" mempty)
NNEq -> toNix . not <$> valueEq lval (NVStr "" mempty)
_ -> nverr unsupportedTypes
(NVConstant NNull, NVStr _ _) -> case op of
NEq -> ofVal <$> valueEq (NVStr "" mempty) rval
NNEq -> ofVal . not <$> valueEq (NVStr "" mempty) rval
NEq -> toNix <$> valueEq (NVStr "" mempty) rval
NNEq -> toNix . not <$> valueEq (NVStr "" mempty) rval
_ -> nverr unsupportedTypes
(NVSet ls lp, NVSet rs rp) -> case op of
NUpdate -> pure $ NVSet (rs `M.union` ls) (rp `M.union` lp)
NEq -> ofVal <$> valueEq lval rval
NNEq -> ofVal . not <$> valueEq lval rval
NEq -> toNix <$> valueEq lval rval
NNEq -> toNix . not <$> valueEq lval rval
_ -> nverr unsupportedTypes
(NVList ls, NVList rs) -> case op of
NConcat -> pure $ NVList $ ls ++ rs
NEq -> ofVal <$> valueEq lval rval
NNEq -> ofVal . not <$> valueEq lval rval
NEq -> toNix <$> valueEq lval rval
NNEq -> toNix . not <$> valueEq lval rval
_ -> nverr unsupportedTypes
(NVList ls, NVConstant NNull) -> case op of
NConcat -> pure $ NVList ls
NEq -> ofVal <$> valueEq lval (NVList [])
NNEq -> ofVal . not <$> valueEq lval (NVList [])
NEq -> toNix <$> valueEq lval (NVList [])
NNEq -> toNix . not <$> valueEq lval (NVList [])
_ -> nverr unsupportedTypes
(NVConstant NNull, NVList rs) -> case op of
NConcat -> pure $ NVList rs
NEq -> ofVal <$> valueEq (NVList []) rval
NNEq -> ofVal . not <$> valueEq (NVList []) rval
NEq -> toNix <$> valueEq (NVList []) rval
NNEq -> toNix . not <$> valueEq (NVList []) rval
_ -> nverr unsupportedTypes
(NVPath p, NVStr s _) -> case op of
-- jww (2018-04-13): Do we need to make the path absolute here?
NEq -> pure $ ofVal $ p == Text.unpack s
NNEq -> pure $ ofVal $ p /= Text.unpack s
NEq -> pure $ toNix $ p == Text.unpack s
NNEq -> pure $ toNix $ p /= Text.unpack s
NPlus -> NVPath <$> makeAbsolutePath (p `mappend` Text.unpack s)
_ -> nverr unsupportedTypes

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

@ -319,7 +319,3 @@ stripPositionInfo = transport phi
clear (StaticKey name _) = StaticKey name Nothing
clear k = k
class ConvertValue v a where
ofVal :: a -> v
wantVal :: v -> Maybe a

46
src/Nix/Lint.hs
View file

@ -38,6 +38,7 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Eval
import qualified Nix.Eval as Eval
import Nix.Expr
@ -240,50 +241,17 @@ unify context (Symbolic x) (Symbolic y) = do
writeVar y (NMany m)
packSymbolic (NMany m)
instance MonadLint e m => ConvertValue (Symbolic m) Bool where
ofVal = const $ error "Should never need to make symbolic from bool"
wantVal = const $ error "Should never need bool value of a symbolic"
instance FromNix (AttrSet (SThunk m)) m (Symbolic m) where
instance ConvertValue (Symbolic m) Int where
ofVal = const $ error "Should never need to make symbolic from int"
wantVal = const $ error "Should never need int value of a symbolic"
instance FromNix (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
instance ConvertValue (Symbolic m) Integer where
ofVal = const $ error "Should never need to make symbolic from integer"
wantVal = const $ error "Should never need integer value of a symbolic"
instance ToNix (AttrSet (SThunk m)) (Symbolic m) where
instance ConvertValue (Symbolic m) Float where
ofVal = const $ error "Should never need to make symbolic from float"
wantVal = const $ error "Should never need float value of a symbolic"
instance ToNix (AttrSet (SThunk m), AttrSet SourcePos) (Symbolic m) where
instance ConvertValue (Symbolic m) Text where
ofVal = const $ error "Should never need to make symbolic from text"
wantVal = const $ error "Should never need text value of a symbolic"
instance ToNix [SThunk m] (Symbolic m) where
instance ConvertValue (Symbolic m) (Maybe Text) where
ofVal = const $ error "Should never need to make symbolic from maybe text"
wantVal = const $ error "Should never need maybe text value of a symbolic"
instance ConvertValue (Symbolic m) [SThunk m] where
ofVal = const $ error "NYI"
wantVal = const $ error "NYI"
instance ConvertValue (Symbolic m)
(AttrSet (SThunk m), AttrSet SourcePos) where
ofVal = const $ error "Should never need to make symbolic from set pair"
wantVal = const Nothing
instance ConvertValue (Symbolic m) (AttrSet (SThunk m)) where
ofVal = const $ error "Should never need to make symbolic from attrset"
wantVal = const Nothing
instance ConvertValue (Symbolic m) () where
ofVal = const $ error "Should never need to make symbolic from unit"
wantVal = const $ error "Should never need unit value of a symbolic"
instance ConvertValue (Symbolic m) (Maybe ()) where
ofVal = const $ error "Should never need to make symbolic from maybe unit"
wantVal = const $ error "Should never need maybe unit value of a symbolic"
instance ToNix Bool (Symbolic m) where
instance MonadLint e m => MonadThunk (Symbolic m) (SThunk m) m where
thunk = fmap coerce . buildThunk