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

Merge pull request #289 from gbwey9/string_context_255

Browse source 
add string context 255
This commit is contained in:
John Wiegley 2018-10-15 15:07:55 -07:00 committed by GitHub
parent 2f418b26aa 54492e3905
commit a34dddb669
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 220 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
hnix.cabal
View file

@ -1,11 +1,10 @@
cabal-version: >= 1.10 -- This file has been generated from package.yaml by hpack version 0.28.2.
-- This file has been generated from package.yaml by hpack version 0.29.7.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: db047ec647c1294d48f00efbf9730dd31e90dd93940ce25df499b90fa85e8626 -- hash: 7e613ce82a3337411d625301abd33a6d7f1c400edadbd602287027f2af1e4fdf
cabal-version: >= 1.10
name: hnix name: hnix
version: 0.5.2 version: 0.5.2
synopsis: Haskell implementation of the Nix language synopsis: Haskell implementation of the Nix language
@ -469,6 +468,7 @@ library
Nix.Render Nix.Render
Nix.Render.Frame Nix.Render.Frame
Nix.Scope Nix.Scope
Nix.String
Nix.Strings Nix.Strings
Nix.TH Nix.TH
Nix.Thunk Nix.Thunk

2
src/Nix.hs
View file

@ -11,6 +11,7 @@ module Nix (module Nix.Cache,
module Nix.Render.Frame, module Nix.Render.Frame,
module Nix.Normal, module Nix.Normal,
module Nix.Options, module Nix.Options,
module Nix.String,
module Nix.Parser, module Nix.Parser,
module Nix.Pretty, module Nix.Pretty,
module Nix.Reduce, module Nix.Reduce,
@ -35,6 +36,7 @@ import qualified Nix.Eval as Eval
import Nix.Exec import Nix.Exec
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Normal import Nix.Normal
import Nix.Options import Nix.Options
import Nix.Parser import Nix.Parser

43
src/Nix/Builtins.hs
View file

@ -79,6 +79,7 @@ import Nix.Exec
import Nix.Expr.Types import Nix.Expr.Types
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Normal import Nix.Normal
import Nix.Options import Nix.Options
import Nix.Parser hiding (nixPath) import Nix.Parser hiding (nixPath)
@ -100,7 +101,7 @@ withNixContext mpath action = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
let i = value @(NValue m) @(NThunk m) @m $ nvList $ let i = value @(NValue m) @(NThunk m) @m $ nvList $
map (value @(NValue m) @(NThunk m) @m map (value @(NValue m) @(NThunk m) @m
. flip nvStr mempty . Text.pack) (include opts) . nvStr . hackyMakeNixStringWithoutContext . Text.pack) (include opts)
pushScope (M.singleton "__includes" i) $ pushScope (M.singleton "__includes" i) $
pushScopes base $ case mpath of pushScopes base $ case mpath of
Nothing -> action Nothing -> action
@ -318,9 +319,9 @@ nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest ->
(flip nvSet mempty $ M.fromList (flip nvSet mempty $ M.fromList
[ case ty of [ case ty of
PathEntryPath -> ("path", valueThunk $ nvPath p) PathEntryPath -> ("path", valueThunk $ nvPath p)
PathEntryURI -> ("uri", valueThunk $ nvStr (Text.pack p) mempty) PathEntryURI -> ("uri", valueThunk $ nvStr (hackyMakeNixStringWithoutContext (Text.pack p)))
, ("prefix", valueThunk $ , ("prefix", valueThunk $
nvStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest nvStr (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn))) ]) : rest
toString :: MonadNix e m => m (NValue m) -> m (NValue m) toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString str = str >>= coerceToString False True >>= toNix . Text.pack toString str = str >>= coerceToString False True >>= toNix . Text.pack
@ -339,7 +340,7 @@ attrsetGet k s = case M.lookup k s of
hasContext :: MonadNix e m => m (NValue m) -> m (NValue m) hasContext :: MonadNix e m => m (NValue m) -> m (NValue m)
hasContext = hasContext =
toNix . not . null . (appEndo ?? []) . snd <=< fromValue @(Text, DList Text) toNix . stringHasContext <=< fromValue
getAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) getAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
getAttr x y = getAttr x y =
@ -350,7 +351,7 @@ getAttr x y =
unsafeGetAttrPos :: forall e m. MonadNix e m unsafeGetAttrPos :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m) => m (NValue m) -> m (NValue m) -> m (NValue m)
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of (NVStr ns, NVSet _ apos) -> case M.lookup (hackyStringIgnoreContext ns) apos of
Nothing -> pure $ nvConstant NNull Nothing -> pure $ nvConstant NNull
Just delta -> toValue delta Just delta -> toValue delta
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: " (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: "
@ -469,7 +470,7 @@ splitVersion s = case Text.uncons s of
splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m) splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m)
splitVersion_ = fromValue >=> \s -> do splitVersion_ = fromValue >=> \s -> do
let vals = flip map (splitVersion s) $ \c -> let vals = flip map (splitVersion s) $ \c ->
valueThunk $ nvStr (versionComponentToString c) mempty valueThunk $ nvStr $ hackyMakeNixStringWithoutContext $ versionComponentToString c
return $ nvList vals return $ nvList vals
compareVersions :: Text -> Text -> Ordering compareVersions :: Text -> Text -> Ordering
@ -552,7 +553,7 @@ splitMatches numDropped (((_,(start,len)):captures):mts) haystack =
caps = valueThunk $ nvList (map f captures) caps = valueThunk $ nvList (map f captures)
f (a,(s,_)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a f (a,(s,_)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a
thunkStr s = valueThunk (nvStr (decodeUtf8 s) mempty) thunkStr s = valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)))
substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text
substring start len str = Prim $ substring start len str = Prim $
@ -583,7 +584,7 @@ mapAttrs_ fun xs = fun >>= \f ->
values <- for pairs $ \(key, value) -> values <- for pairs $ \(key, value) ->
thunk $ thunk $
withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $ withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $
callFunc ?? force' value =<< callFunc f (pure (nvStr key mempty)) callFunc ?? force' value =<< callFunc f (pure (nvStr (hackyMakeNixStringWithoutContext key)))
toNix . M.fromList . zip (map fst pairs) $ values toNix . M.fromList . zip (map fst pairs) $ values
filter_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) filter_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
@ -600,7 +601,7 @@ catAttrs attrName xs =
baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m) baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf x = x >>= \case baseNameOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx NVStr ns -> pure $ nvStr (hackyModifyNixContents (Text.pack . takeFileName . Text.unpack) ns)
NVPath path -> pure $ nvPath $ takeFileName path NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
@ -621,7 +622,7 @@ bitXor x y =
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m) dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case dirOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx NVStr ns -> pure $ nvStr (hackyModifyNixContents (Text.pack . takeDirectory . Text.unpack) ns)
NVPath path -> pure $ nvPath $ takeDirectory path NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
@ -775,7 +776,7 @@ toPath = fromValue @Path >=> toNix @Path
pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m) pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m)
pathExists_ path = path >>= \case pathExists_ path = path >>= \case
NVPath p -> toNix =<< pathExists p NVPath p -> toNix =<< pathExists p
NVStr s _ -> toNix =<< pathExists (Text.unpack s) NVStr ns -> toNix =<< pathExists (Text.unpack (hackyStringIgnoreContext ns))
v -> throwError $ ErrorCall $ v -> throwError $ ErrorCall $
"builtins.pathExists: expected path, got " ++ show v "builtins.pathExists: expected path, got " ++ show v
@ -867,7 +868,7 @@ lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
(NInt a, NFloat b) -> pure $ fromInteger a < b (NInt a, NFloat b) -> pure $ fromInteger a < b
(NFloat a, NFloat b) -> pure $ a < b (NFloat a, NFloat b) -> pure $ a < b
_ -> badType _ -> badType
(NVStr a _, NVStr b _) -> pure $ a < b (NVStr a, NVStr b) -> pure $ hackyStringIgnoreContext a < hackyStringIgnoreContext b
_ -> badType _ -> badType
concatLists :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) concatLists :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
@ -920,8 +921,8 @@ placeHolder = fromValue @Text >=> \_ -> do
absolutePathFromValue :: MonadNix e m => NValue m -> m FilePath absolutePathFromValue :: MonadNix e m => NValue m -> m FilePath
absolutePathFromValue = \case absolutePathFromValue = \case
NVStr pathText _ -> do NVStr ns -> do
let path = Text.unpack pathText let path = Text.unpack $ hackyStringIgnoreContext ns
unless (isAbsolute path) $ unless (isAbsolute path) $
throwError $ ErrorCall $ "string " ++ show path ++ " doesn't represent an absolute path" throwError $ ErrorCall $ "string " ++ show path ++ " doesn't represent an absolute path"
pure path pure path
@ -938,11 +939,11 @@ findFile_ aset filePath =
aset >>= \aset' -> aset >>= \aset' ->
filePath >>= \filePath' -> filePath >>= \filePath' ->
case (aset', filePath') of case (aset', filePath') of
(NVList x, NVStr name _) -> do (NVList x, NVStr ns) -> do
mres <- findPath x (Text.unpack name) mres <- findPath x (Text.unpack (hackyStringIgnoreContext ns))
pure $ nvPath mres pure $ nvPath mres
(NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " ++ show y (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " ++ show y
(x, NVStr _ _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x (x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show (x, y) (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show (x, y)
data FileType data FileType
@ -982,7 +983,7 @@ fromJSON = fromValue >=> \encoded ->
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m) toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
toXML_ v = v >>= normalForm >>= \x -> toXML_ v = v >>= normalForm >>= \x ->
pure $ nvStr (Text.pack (toXML x)) mempty pure $ nvStr $ hackyMakeNixStringWithoutContext $ Text.pack (toXML x)
typeOf :: MonadNix e m => m (NValue m) -> m (NValue m) typeOf :: MonadNix e m => m (NValue m) -> m (NValue m)
typeOf v = v >>= toNix @Text . \case typeOf v = v >>= toNix @Text . \case
@ -991,7 +992,7 @@ typeOf v = v >>= toNix @Text . \case
NFloat _ -> "float" NFloat _ -> "float"
NBool _ -> "bool" NBool _ -> "bool"
NNull -> "null" NNull -> "null"
NVStr _ _ -> "string" NVStr _ -> "string"
NVList _ -> "list" NVList _ -> "list"
NVSet _ _ -> "set" NVSet _ _ -> "set"
NVClosure {} -> "lambda" NVClosure {} -> "lambda"
@ -1037,7 +1038,7 @@ fetchurl v = v >>= \case
where where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m) go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go _msha = \case go _msha = \case
NVStr uri _ -> getURL uri -- msha NVStr ns -> getURL (hackyStringIgnoreContext ns) -- msha
v -> throwError $ ErrorCall $ v -> throwError $ ErrorCall $
"builtins.fetchurl: Expected URI or string, got " ++ show v "builtins.fetchurl: Expected URI or string, got " ++ show v
@ -1056,7 +1057,7 @@ currentSystem :: MonadNix e m => m (NValue m)
currentSystem = do currentSystem = do
os <- getCurrentSystemOS os <- getCurrentSystemOS
arch <- getCurrentSystemArch arch <- getCurrentSystemArch
return $ nvStr (arch <> "-" <> os) mempty return $ nvStr $ hackyMakeNixStringWithoutContext (arch <> "-" <> os)
currentTime_ :: MonadNix e m => m (NValue m) currentTime_ :: MonadNix e m => m (NValue m)
currentTime_ = do currentTime_ = do

57
src/Nix/Convert.hs
View file

@ -42,6 +42,7 @@ import Nix.Effects
import Nix.Expr.Types import Nix.Expr.Types
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Normal import Nix.Normal
import Nix.Thunk import Nix.Thunk
import Nix.Utils import Nix.Utils
@ -147,7 +148,7 @@ instance Convertible e m
instance (Convertible e m, MonadEffects m) instance (Convertible e m, MonadEffects m)
=> FromValue Text m (NValueNF m) where => FromValue Text m (NValueNF m) where
fromValueMay = \case fromValueMay = \case
Free (NVStrF t _) -> pure $ Just t Free (NVStrF ns) -> pure $ hackyStringIgnoreContextMaybe ns
Free (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p Free (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
@ -160,7 +161,7 @@ instance (Convertible e m, MonadEffects m)
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m) instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue Text m (NValue m) where => FromValue Text m (NValue m) where
fromValueMay = \case fromValueMay = \case
NVStr t _ -> pure $ Just t NVStr ns -> pure $ hackyStringIgnoreContextMaybe ns
NVPath p -> Just . Text.pack . unStorePath <$> addPath p NVPath p -> Just . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
@ -171,26 +172,26 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
_ -> throwError $ Expectation TString v _ -> throwError $ Expectation TString v
instance (Convertible e m, MonadEffects m) instance (Convertible e m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValueNF m) where => FromValue NixString m (NValueNF m) where
fromValueMay = \case fromValueMay = \case
Free (NVStrF t d) -> pure $ Just (t, d) Free (NVStrF ns) -> pure $ Just ns
Free (NVPathF p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p Free (NVPathF p) -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p Just p -> fmap hackyMakeNixStringWithoutContext <$> fromValueMay @Text p
_ -> pure Nothing _ -> pure Nothing
fromValue v = fromValueMay v >>= \case fromValue v = fromValueMay v >>= \case
Just b -> pure b Just b -> pure b
_ -> throwError $ ExpectationNF TString v _ -> throwError $ ExpectationNF TString v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m) instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValue m) where => FromValue NixString m (NValue m) where
fromValueMay = \case fromValueMay = \case
NVStr t d -> pure $ Just (t, d) NVStr ns -> pure $ Just ns
NVPath p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p NVPath p -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p Just p -> fmap hackyMakeNixStringWithoutContext <$> fromValueMay @Text p
_ -> pure Nothing _ -> pure Nothing
fromValue v = fromValueMay v >>= \case fromValue v = fromValueMay v >>= \case
Just b -> pure b Just b -> pure b
@ -199,7 +200,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
instance Convertible e m instance Convertible e m
=> FromValue ByteString m (NValueNF m) where => FromValue ByteString m (NValueNF m) where
fromValueMay = \case fromValueMay = \case
Free (NVStrF t _) -> pure $ Just (encodeUtf8 t) Free (NVStrF ns) -> pure $ encodeUtf8 <$> hackyStringIgnoreContextMaybe ns
_ -> pure Nothing _ -> pure Nothing
fromValue v = fromValueMay v >>= \case fromValue v = fromValueMay v >>= \case
Just b -> pure b Just b -> pure b
@ -208,7 +209,7 @@ instance Convertible e m
instance Convertible e m instance Convertible e m
=> FromValue ByteString m (NValue m) where => FromValue ByteString m (NValue m) where
fromValueMay = \case fromValueMay = \case
NVStr t _ -> pure $ Just (encodeUtf8 t) NVStr ns -> pure $ encodeUtf8 <$> hackyStringIgnoreContextMaybe ns
_ -> pure Nothing _ -> pure Nothing
fromValue v = fromValueMay v >>= \case fromValue v = fromValueMay v >>= \case
Just b -> pure b Just b -> pure b
@ -220,7 +221,7 @@ newtype Path = Path { getPath :: FilePath }
instance Convertible e m => FromValue Path m (NValueNF m) where instance Convertible e m => FromValue Path m (NValueNF m) where
fromValueMay = \case fromValueMay = \case
Free (NVPathF p) -> pure $ Just (Path p) Free (NVPathF p) -> pure $ Just (Path p)
Free (NVStrF s _) -> pure $ Just (Path (Text.unpack s)) Free (NVStrF ns) -> pure $ Path . Text.unpack <$> hackyStringIgnoreContextMaybe ns
Free (NVSetF s _) -> case M.lookup "outPath" s of Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
Just p -> fromValueMay @Path p Just p -> fromValueMay @Path p
@ -233,7 +234,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue Path m (NValue m) where => FromValue Path m (NValue m) where
fromValueMay = \case fromValueMay = \case
NVPath p -> pure $ Just (Path p) NVPath p -> pure $ Just (Path p)
NVStr s _ -> pure $ Just (Path (Text.unpack s)) NVStr ns -> pure $ Path . Text.unpack <$> hackyStringIgnoreContextMaybe ns
NVSet s _ -> case M.lookup "outPath" s of NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing Nothing -> pure Nothing
Just p -> fromValueMay @Path p Just p -> fromValueMay @Path p
@ -321,7 +322,7 @@ instance (Convertible e m, MonadEffects m)
NFloat n -> toJSON n NFloat n -> toJSON n
NBool b -> toJSON b NBool b -> toJSON b
NNull -> A.Null NNull -> A.Null
Free (NVStrF s _) -> pure $ Just $ toJSON s Free (NVStrF ns) -> pure $ toJSON <$> hackyStringIgnoreContextMaybe ns
Free (NVListF l) -> Free (NVListF l) ->
fmap (A.Array . V.fromList) . sequence fmap (A.Array . V.fromList) . sequence
<$> traverse fromValueMay l <$> traverse fromValueMay l
@ -367,22 +368,22 @@ instance Applicative m => ToValue Float m (NValue m) where
toValue = pure . nvConstant . NFloat toValue = pure . nvConstant . NFloat
instance Applicative m => ToValue Text m (NValueNF m) where instance Applicative m => ToValue Text m (NValueNF m) where
toValue = pure . Free . flip NVStrF mempty toValue = pure . Free . NVStrF . hackyMakeNixStringWithoutContext
instance Applicative m => ToValue Text m (NValue m) where instance Applicative m => ToValue Text m (NValue m) where
toValue = pure . flip nvStr mempty toValue = pure . nvStr . hackyMakeNixStringWithoutContext
instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where instance Applicative m => ToValue NixString m (NValueNF m) where
toValue = pure . Free . uncurry NVStrF toValue = pure . Free . NVStrF
instance Applicative m => ToValue (Text, DList Text) m (NValue m) where instance Applicative m => ToValue NixString m (NValue m) where
toValue = pure . uncurry nvStr toValue = pure . nvStr
instance Applicative m => ToValue ByteString m (NValueNF m) where instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Free . flip NVStrF mempty . decodeUtf8 toValue = pure . Free . NVStrF . hackyMakeNixStringWithoutContext . decodeUtf8
instance Applicative m => ToValue ByteString m (NValue m) where instance Applicative m => ToValue ByteString m (NValue m) where
toValue = pure . flip nvStr mempty . decodeUtf8 toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8
instance Applicative m => ToValue Path m (NValueNF m) where instance Applicative m => ToValue Path m (NValueNF m) where
toValue = pure . Free . NVPathF . getPath toValue = pure . Free . NVPathF . getPath
@ -447,7 +448,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
A.Array l -> nvList <$> A.Array l -> nvList <$>
traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x) traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x)
. toValue $ x) (V.toList l) . toValue $ x) (V.toList l)
A.String s -> pure $ nvStr s mempty A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s
A.Number n -> pure $ nvConstant $ case floatingOrInteger n of A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
Left r -> NFloat r Left r -> NFloat r
Right i -> NInt i Right i -> NInt i
@ -495,8 +496,8 @@ instance Convertible e m => FromNix Float m (NValueNF m) where
instance Convertible e m => FromNix Float m (NValue m) where instance Convertible e m => FromNix Float m (NValue m) where
instance (Convertible e m, MonadEffects m) => FromNix Text m (NValueNF m) where instance (Convertible e m, MonadEffects m) => FromNix Text m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix Text m (NValue m) where instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix Text m (NValue m) where
instance (Convertible e m, MonadEffects m) => FromNix (Text, DList Text) m (NValueNF m) where instance (Convertible e m, MonadEffects m) => FromNix NixString m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix (Text, DList Text) m (NValue m) where instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix NixString m (NValue m) where
instance Convertible e m => FromNix ByteString m (NValueNF m) where instance Convertible e m => FromNix ByteString m (NValueNF m) where
instance Convertible e m => FromNix ByteString m (NValue m) where instance Convertible e m => FromNix ByteString m (NValue m) where
instance Convertible e m => FromNix Path m (NValueNF m) where instance Convertible e m => FromNix Path m (NValueNF m) where
@ -558,8 +559,8 @@ instance Applicative m => ToNix Float m (NValueNF m) where
instance Applicative m => ToNix Float m (NValue m) where instance Applicative m => ToNix Float m (NValue m) where
instance Applicative m => ToNix Text m (NValueNF m) where instance Applicative m => ToNix Text m (NValueNF m) where
instance Applicative m => ToNix Text m (NValue m) where instance Applicative m => ToNix Text m (NValue m) where
instance Applicative m => ToNix (Text, DList Text) m (NValueNF m) where instance Applicative m => ToNix NixString m (NValueNF m) where
instance Applicative m => ToNix (Text, DList Text) m (NValue m) where instance Applicative m => ToNix NixString m (NValue m) where
instance Applicative m => ToNix ByteString m (NValueNF m) where instance Applicative m => ToNix ByteString m (NValueNF m) where
instance Applicative m => ToNix ByteString m (NValue m) where instance Applicative m => ToNix ByteString m (NValue m) where
instance Applicative m => ToNix Path m (NValueNF m) where instance Applicative m => ToNix Path m (NValueNF m) where

21
src/Nix/Eval.hs
View file

@ -33,6 +33,7 @@ import Nix.Atoms
import Nix.Convert import Nix.Convert
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Scope import Nix.Scope
import Nix.Strings (runAntiquoted) import Nix.Strings (runAntiquoted)
import Nix.Thunk import Nix.Thunk
@ -82,7 +83,7 @@ type MonadNixEval e v t m =
MonadFix m, MonadFix m,
ToValue Bool m v, ToValue Bool m v,
ToValue [t] m v, ToValue [t] m v,
FromValue (Text, DList Text) m v, FromValue NixString m v,
ToValue (AttrSet t, AttrSet SourcePos) m v, ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v) FromValue (AttrSet t, AttrSet SourcePos) m v)
@ -296,7 +297,7 @@ evalSelect aset attr = do
-- | Evaluate a component of an attribute path in a context where we are -- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value -- *retrieving* a value
evalGetterKeyName :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v) evalGetterKeyName :: forall v m. (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v) -> m Text => NKeyName (m v) -> m Text
evalGetterKeyName = evalSetterKeyName >=> \case evalGetterKeyName = evalSetterKeyName >=> \case
Just k -> pure k Just k -> pure k
@ -304,22 +305,24 @@ evalGetterKeyName = evalSetterKeyName >=> \case
-- | Evaluate a component of an attribute path in a context where we are -- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value -- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v) evalSetterKeyName :: (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v) -> m (Maybe Text) => NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName = \case evalSetterKeyName = \case
StaticKey k -> pure (Just k) StaticKey k -> pure (Just k)
DynamicKey k -> DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> fmap fst runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
\case Just ns -> Just (hackyStringIgnoreContext ns)
_ -> Nothing
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v) assembleString :: forall v m. (MonadEval v m, FromValue NixString m v)
=> NString (m v) -> m (Maybe (Text, DList Text)) => NString (m v) -> m (Maybe NixString)
assembleString = \case assembleString = \case
Indented _ parts -> fromParts parts Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts DoubleQuoted parts -> fromParts parts
where where
fromParts = fmap (fmap mconcat . sequence) . traverse go fromParts = fmap (fmap hackyStringMConcat . sequence) . traverse go
go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay) go = runAntiquoted "\n" (pure . Just . hackyMakeNixStringWithoutContext) (>>= fromValueMay)
buildArgument :: forall e v t m. MonadNixEval e v t m buildArgument :: forall e v t m. MonadNixEval e v t m
=> Params (m v) -> m v -> m (AttrSet t) => Params (m v) -> m v -> m (AttrSet t)

42
src/Nix/Exec.hs
View file

@ -60,6 +60,7 @@ import Nix.Effects
import Nix.Eval as Eval import Nix.Eval as Eval
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Normal import Nix.Normal
import Nix.Options import Nix.Options
import Nix.Parser import Nix.Parser
@ -189,11 +190,11 @@ instance MonadNix e m => MonadEval (NValue m) m where
pure $ nvConstantP (Provenance scope (NConstant_ span c)) c pure $ nvConstantP (Provenance scope (NConstant_ span c)) c
evalString = assembleString >=> \case evalString = assembleString >=> \case
Just (s, c) -> do Just ns -> do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
pure $ nvStrP (Provenance scope pure $ nvStrP (Provenance scope
(NStr_ span (DoubleQuoted [Plain s]))) s c (NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)]))) ns
Nothing -> nverr $ ErrorCall "Failed to assemble string" Nothing -> nverr $ ErrorCall "Failed to assemble string"
evalLiteralPath p = do evalLiteralPath p = do
@ -334,8 +335,8 @@ execBinaryOp scope span op lval rarg = do
NBool l, NBool r) -> toBool $ not l || r NBool l, NBool r) -> toBool $ not l || r
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls lc, NVStr rs rc) -> case op of (NVStr ls, NVStr rs) -> case op of
NPlus -> pure $ bin nvStrP (ls `mappend` rs) (lc `mappend` rc) NPlus -> pure $ bin nvStrP (ls `hackyStringMappend` rs)
NEq -> toBool =<< valueEq lval rval NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval NNEq -> toBool . not =<< valueEq lval rval
NLt -> toBool $ ls < rs NLt -> toBool $ ls < rs
@ -344,14 +345,14 @@ execBinaryOp scope span op lval rarg = do
NGte -> toBool $ ls >= rs NGte -> toBool $ ls >= rs
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr _ _, NVConstant NNull) -> case op of (NVStr _, NVConstant NNull) -> case op of
NEq -> toBool =<< valueEq lval (nvStr "" mempty) NEq -> toBool =<< valueEq lval (nvStr (hackyMakeNixStringWithoutContext ""))
NNEq -> toBool . not =<< valueEq lval (nvStr "" mempty) NNEq -> toBool . not =<< valueEq lval (nvStr (hackyMakeNixStringWithoutContext ""))
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVStr _ _) -> case op of (NVConstant NNull, NVStr _) -> case op of
NEq -> toBool =<< valueEq (nvStr "" mempty) rval NEq -> toBool =<< valueEq (nvStr (hackyMakeNixStringWithoutContext "")) rval
NNEq -> toBool . not =<< valueEq (nvStr "" mempty) rval NNEq -> toBool . not =<< valueEq (nvStr (hackyMakeNixStringWithoutContext "")) rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVSet rs rp) -> case op of (NVSet ls lp, NVSet rs rp) -> case op of
@ -372,15 +373,15 @@ execBinaryOp scope span op lval rarg = do
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(ls@NVSet {}, NVStr rs rc) -> case op of (ls@NVSet {}, NVStr rs) -> case op of
NPlus -> (\ls -> bin nvStrP (Text.pack ls `mappend` rs) rc) NPlus -> (\ls -> bin nvStrP (hackyModifyNixContents (Text.pack ls `mappend`) rs))
<$> coerceToString False False ls <$> coerceToString False False ls
NEq -> toBool =<< valueEq lval rval NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls lc, rs@NVSet {}) -> case op of (NVStr ls, rs@NVSet {}) -> case op of
NPlus -> (\rs -> bin nvStrP (ls `mappend` Text.pack rs) lc) NPlus -> (\rs -> bin nvStrP (hackyModifyNixContents (`mappend` Text.pack rs) ls))
<$> coerceToString False False rs <$> coerceToString False False rs
NEq -> toBool =<< valueEq lval rval NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval NNEq -> toBool . not =<< valueEq lval rval
@ -404,10 +405,10 @@ execBinaryOp scope span op lval rarg = do
NNEq -> toBool . not =<< valueEq (nvList []) rval NNEq -> toBool . not =<< valueEq (nvList []) rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath p, NVStr s _) -> case op of (NVPath p, NVStr ns) -> case op of
NEq -> toBool $ p == Text.unpack s NEq -> toBool $ Just p == fmap Text.unpack (hackyStringIgnoreContextMaybe ns)
NNEq -> toBool $ p /= Text.unpack s NNEq -> toBool $ Just p /= fmap Text.unpack (hackyStringIgnoreContextMaybe ns)
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack s) NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack (hackyStringIgnoreContext ns))
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath ls, NVPath rs) -> case op of (NVPath ls, NVPath rs) -> case op of
@ -453,7 +454,7 @@ coerceToString copyToStore coerceMore = go
NVConstant (NFloat n) | coerceMore -> pure $ show n NVConstant (NFloat n) | coerceMore -> pure $ show n
NVConstant NNull | coerceMore -> pure "" NVConstant NNull | coerceMore -> pure ""
NVStr t _ -> pure $ Text.unpack t NVStr ns -> pure $ Text.unpack (hackyStringIgnoreContext ns)
NVPath p | copyToStore -> unStorePath <$> addPath p NVPath p | copyToStore -> unStorePath <$> addPath p
| otherwise -> pure p | otherwise -> pure p
NVList l | coerceMore -> unwords <$> traverse (`force` go) l NVList l | coerceMore -> unwords <$> traverse (`force` go) l
@ -565,6 +566,7 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
pure expr pure expr
getEnvVar = liftIO . lookupEnv getEnvVar = liftIO . lookupEnv
getCurrentSystemOS = return $ Text.pack System.Info.os getCurrentSystemOS = return $ Text.pack System.Info.os
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
@ -817,7 +819,7 @@ fetchTarball v = v >>= \case
where where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m) go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go msha = \case go msha = \case
NVStr uri _ -> fetch uri msha NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
v -> throwError $ ErrorCall $ v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or string, got " ++ show v "builtins.fetchTarball: Expected URI or string, got " ++ show v

3
src/Nix/Lint.hs
View file

@ -44,6 +44,7 @@ import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval import qualified Nix.Eval as Eval
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Options import Nix.Options
import Nix.Scope import Nix.Scope
import Nix.Thunk import Nix.Thunk
@ -237,7 +238,7 @@ instance ToValue Bool m (Symbolic m) where
instance ToValue [SThunk m] m (Symbolic m) where instance ToValue [SThunk m] m (Symbolic m) where
instance FromValue (Text, DList Text) m (Symbolic m) where instance FromValue NixString m (Symbolic m) where
instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where

23
src/Nix/Normal.hs
View file

@ -25,6 +25,7 @@ import Nix.Atoms
import Nix.Effects import Nix.Effects
import Nix.Frames import Nix.Frames
-- import Nix.Pretty -- import Nix.Pretty
import Nix.String
import Nix.Thunk import Nix.Thunk
import Nix.Utils import Nix.Utils
import Nix.Value import Nix.Value
@ -43,7 +44,7 @@ normalFormBy
-> StateT [Var m Bool] m (NValueNF m) -> StateT [Var m Bool] m (NValueNF m)
normalFormBy k n v = case v of normalFormBy k n v = case v of
NVConstant a -> return $ Free $ NVConstantF a NVConstant a -> return $ Free $ NVConstantF a
NVStr t s -> return $ Free $ NVStrF t s NVStr ns -> return $ Free $ NVStrF ns
NVList l -> NVList l ->
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]" traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
@ -101,7 +102,7 @@ embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
embed (Pure v) = return v embed (Pure v) = return v
embed (Free x) = case x of embed (Free x) = case x of
NVConstantF a -> return $ nvConstant a NVConstantF a -> return $ nvConstant a
NVStrF t s -> return $ nvStr t s NVStrF ns -> return $ nvStr ns
NVListF l -> nvList . fmap (value @_ @_ @m) <$> traverse embed l NVListF l -> nvList . fmap (value @_ @_ @m) <$> traverse embed l
NVSetF s p -> flip nvSet p . fmap (value @_ @_ @m) <$> traverse embed s NVSetF s p -> flip nvSet p . fmap (value @_ @_ @m) <$> traverse embed s
NVClosureF p f -> return $ nvClosure p f NVClosureF p f -> return $ nvClosure p f
@ -109,15 +110,15 @@ embed (Free x) = case x of
NVBuiltinF n f -> return $ nvBuiltin n f NVBuiltinF n f -> return $ nvBuiltin n f
valueText :: forall e m. (Framed e m, MonadEffects m, Typeable m) valueText :: forall e m. (Framed e m, MonadEffects m, Typeable m)
=> Bool -> NValueNF m -> m (Text, DList Text) => Bool -> NValueNF m -> m NixString
valueText addPathsToStore = iter phi . check valueText addPathsToStore = iter phi . check
where where
check :: NValueNF m -> Free (NValueF m) (m (Text, DList Text)) check :: NValueNF m -> Free (NValueF m) (m NixString)
check = fmap (const $ pure ("<CYCLE>", mempty)) check = fmap (const $ pure (hackyMakeNixStringWithoutContext "<CYCLE>"))
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text) phi :: NValueF m (m NixString) -> m NixString
phi (NVConstantF a) = pure (atomText a, mempty) phi (NVConstantF a) = pure (hackyMakeNixStringWithoutContext (atomText a))
phi (NVStrF t c) = pure (t, c) phi (NVStrF ns) = pure ns
phi v@(NVListF _) = coercionFailed v phi v@(NVListF _) = coercionFailed v
phi v@(NVSetF s _) phi v@(NVSetF s _)
| Just asString <- M.lookup "__asString" s = asString | Just asString <- M.lookup "__asString" s = asString
@ -126,8 +127,8 @@ valueText addPathsToStore = iter phi . check
phi (NVPathF originalPath) phi (NVPathF originalPath)
| addPathsToStore = do | addPathsToStore = do
storePath <- addPath originalPath storePath <- addPath originalPath
pure (Text.pack $ unStorePath storePath, mempty) pure (hackyMakeNixStringWithoutContext $ Text.pack $ unStorePath storePath)
| otherwise = pure (Text.pack originalPath, mempty) | otherwise = pure (hackyMakeNixStringWithoutContext (Text.pack originalPath))
phi v@(NVBuiltinF _ _) = coercionFailed v phi v@(NVBuiltinF _ _) = coercionFailed v
coercionFailed v = coercionFailed v =
@ -135,4 +136,4 @@ valueText addPathsToStore = iter phi . check
valueTextNoContext :: (Framed e m, MonadEffects m, Typeable m) valueTextNoContext :: (Framed e m, MonadEffects m, Typeable m)
=> Bool -> NValueNF m -> m Text => Bool -> NValueNF m -> m Text
valueTextNoContext addPathsToStore = fmap fst . valueText addPathsToStore valueTextNoContext addPathsToStore = fmap hackyStringIgnoreContext . valueText addPathsToStore

15
src/Nix/Pretty.hs
View file

@ -27,6 +27,7 @@ import qualified Data.Text as Text
import Nix.Atoms import Nix.Atoms
import Nix.Expr import Nix.Expr
import Nix.Parser import Nix.Parser
import Nix.String
import Nix.Strings import Nix.Strings
import Nix.Thunk import Nix.Thunk
#if ENABLE_TRACING #if ENABLE_TRACING
@ -246,13 +247,13 @@ prettyNValueNF :: Functor m => NValueNF m -> Doc
prettyNValueNF = prettyNix . valueToExpr prettyNValueNF = prettyNix . valueToExpr
where where
check :: NValueNF m -> Fix (NValueF m) check :: NValueNF m -> Fix (NValueF m)
check = fixate (const (NVStrF "<CYCLE>" mempty)) check = fixate (const (NVStrF (hackyMakeNixStringWithoutContext "<CYCLE>")))
valueToExpr :: Functor m => NValueNF m -> NExpr valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check valueToExpr = transport go . check
go (NVConstantF a) = NConstant a go (NVConstantF a) = NConstant a
go (NVStrF t _) = NStr (DoubleQuoted [Plain t]) go (NVStrF ns) = NStr (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])
go (NVListF l) = NList l go (NVListF l) = NList l
go (NVSetF s p) = NSet go (NVSetF s p) = NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p)) [ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
@ -269,7 +270,7 @@ printNix = iter phi . check
phi :: NValueF m String -> String phi :: NValueF m String -> String
phi (NVConstantF a) = unpack $ atomText a phi (NVConstantF a) = unpack $ atomText a
phi (NVStrF t _) = show t phi (NVStrF ns) = show $ hackyStringIgnoreContext ns
phi (NVListF l) = "[ " ++ unwords l ++ " ]" phi (NVListF l) = "[ " ++ unwords l ++ " ]"
phi (NVSetF s _) = phi (NVSetF s _) =
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; " "{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
@ -282,7 +283,7 @@ removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
removeEffects = Free . fmap dethunk removeEffects = Free . fmap dethunk
where where
dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v) dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
dethunk (NThunk _ _) = Free $ NVStrF "<thunk>" mempty dethunk (NThunk _ _) = Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m) removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
removeEffectsM = fmap Free . traverse dethunk removeEffectsM = fmap Free . traverse dethunk
@ -314,11 +315,11 @@ dethunk = \case
NThunk _ (Thunk _ active ref) -> do NThunk _ (Thunk _ active ref) -> do
nowActive <- atomicModifyVar active (True,) nowActive <- atomicModifyVar active (True,)
if nowActive if nowActive
then pure $ Free $ NVStrF "<thunk>" mempty then pure $ Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
else do else do
eres <- readVar ref eres <- readVar ref
res <- case eres of res <- case eres of
Computed v -> removeEffectsM (_baseValue v) Computed v -> removeEffectsM (_baseValue v)
_ -> pure $ Free $ NVStrF "<thunk>" mempty _ -> pure $ Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
_ <- atomicModifyVar active (False,) _ <- atomicModifyVar active (False,)
return res return res

81
src/Nix/String.hs Normal file
View file

@ -0,0 +1,81 @@
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Nix.String (
NixString
, stringHasContext
, hackyStringIgnoreContextMaybe
, hackyStringIgnoreContext
, hackyMakeNixStringWithoutContext
, hackyModifyNixContents
, hackyStringMappend
, hackyStringMConcat
) where
import qualified Data.HashSet as S
import Data.Hashable
import Data.Text (Text)
import GHC.Generics
import Data.Semigroup
-- {-# WARNING hackyStringMappend, hackyStringMConcat, hackyStringIgnoreContextMaybe, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext, hackyModifyNixContents "This NixString function needs to be replaced" #-}
-- | A 'ContextFlavor' describes the sum of possible derivations for string contexts
data ContextFlavor =
DirectPath
| DerivationOutput !Text
deriving (Show, Eq, Ord, Generic)
instance Hashable ContextFlavor
-- | A 'StringContext' ...
data StringContext =
StringContext { scPath :: !Text
, scFlavor :: !ContextFlavor
} deriving (Eq, Ord, Show, Generic)
instance Hashable StringContext
data NixString = NixString
{ nsContents :: !Text
, nsContext :: !(S.HashSet StringContext)
} deriving (Eq, Ord, Show, Generic)
instance Hashable NixString
-- | Combine two NixStrings using mappend
hackyStringMappend :: NixString -> NixString -> NixString
hackyStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
-- | Combine NixStrings using mconcat
hackyStringMConcat :: [NixString] -> NixString
hackyStringMConcat = foldr hackyStringMappend (NixString mempty mempty)
--instance Semigroup NixString where
--NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
--instance Monoid NixString where
-- mempty = NixString mempty mempty
-- mappend = (<>)
-- | Extract the string contents from a NixString that has no context
hackyStringIgnoreContextMaybe :: NixString -> Maybe Text
hackyStringIgnoreContextMaybe (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString even if the NixString has an associated context
hackyStringIgnoreContext :: NixString -> Text
hackyStringIgnoreContext (NixString s _) = s
-- | Returns True if the NixString has an associated context
stringHasContext :: NixString -> Bool
stringHasContext (NixString _ c) = not (null c)
-- | Constructs a NixString without a context
hackyMakeNixStringWithoutContext :: Text -> NixString
hackyMakeNixStringWithoutContext = flip NixString mempty
-- | Modify the string part of the NixString -- ignores the context
hackyModifyNixContents :: (Text -> Text) -> NixString -> NixString
hackyModifyNixContents f (NixString s c) = NixString (f s) c

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

@ -47,6 +47,7 @@ import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval import qualified Nix.Eval as Eval
import Nix.Expr.Types import Nix.Expr.Types
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.String
import Nix.Scope import Nix.Scope
import Nix.Thunk import Nix.Thunk
import qualified Nix.Type.Assumption as As import qualified Nix.Type.Assumption as As
@ -444,7 +445,7 @@ data Judgment s = Judgment
} }
deriving Show deriving Show
instance FromValue (Text, DList Text) (Infer s) (Judgment s) where instance FromValue NixString (Infer s) (Judgment s) where
fromValueMay _ = return Nothing fromValueMay _ = return Nothing
fromValue _ = error "Unused" fromValue _ = error "Unused"

35
src/Nix/Value.hs
View file

@ -38,8 +38,6 @@ import Data.Functor.Classes
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
import Data.Hashable import Data.Hashable
import Data.Monoid (appEndo)
import Data.Text (Text)
import Data.These import Data.These
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.Generics import GHC.Generics
@ -50,6 +48,7 @@ import Nix.Atoms
import Nix.Expr.Types import Nix.Expr.Types
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.Frames import Nix.Frames
import Nix.String
import Nix.Scope import Nix.Scope
import Nix.Thunk import Nix.Thunk
import Nix.Utils import Nix.Utils
@ -61,7 +60,7 @@ data NValueF m r
= NVConstantF NAtom = NVConstantF NAtom
-- | A string has a value and a context, which can be used to record what a -- | A string has a value and a context, which can be used to record what a
-- string has been build from -- string has been build from
| NVStrF Text (DList Text) | NVStrF NixString
| NVPathF FilePath | NVPathF FilePath
| NVListF [r] | NVListF [r]
| NVSetF (AttrSet r) (AttrSet SourcePos) | NVSetF (AttrSet r) (AttrSet SourcePos)
@ -123,10 +122,10 @@ pattern NVConstant x <- NValue _ (NVConstantF x)
nvConstant x = NValue [] (NVConstantF x) nvConstant x = NValue [] (NVConstantF x)
nvConstantP p x = NValue [p] (NVConstantF x) nvConstantP p x = NValue [p] (NVConstantF x)
pattern NVStr s d <- NValue _ (NVStrF s d) pattern NVStr ns <- NValue _ (NVStrF ns)
nvStr s d = NValue [] (NVStrF s d) nvStr ns = NValue [] (NVStrF ns)
nvStrP p s d = NValue [p] (NVStrF s d) nvStrP p ns = NValue [p] (NVStrF ns)
pattern NVPath x <- NValue _ (NVPathF x) pattern NVPath x <- NValue _ (NVPathF x)
@ -156,7 +155,7 @@ nvBuiltinP p name f = NValue [p] (NVBuiltinF name f)
instance Show (NValueF m (Fix (NValueF m))) where instance Show (NValueF m (Fix (NValueF m))) where
showsPrec = flip go where showsPrec = flip go where
go (NVConstantF atom) = showsCon1 "NVConstant" atom go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF txt ctxt) = showsCon2 "NVStr" txt (appEndo ctxt []) go (NVStrF ns) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
go (NVListF lst) = showsCon1 "NVList" lst go (NVListF lst) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p go (NVClosureF p _) = showsCon1 "NVClosure" p
@ -166,7 +165,7 @@ instance Show (NValueF m (Fix (NValueF m))) where
showsCon1 :: Show a => String -> a -> Int -> String -> String showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d = showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
{-
showsCon2 :: (Show a, Show b) showsCon2 :: (Show a, Show b)
=> String -> a -> b -> Int -> String -> String => String -> a -> b -> Int -> String -> String
showsCon2 con a b d = showsCon2 con a b d =
@ -175,13 +174,13 @@ instance Show (NValueF m (Fix (NValueF m))) where
. showsPrec 11 a . showsPrec 11 a
. showString " " . showString " "
. showsPrec 11 b . showsPrec 11 b
-}
instance Eq (NValue m) where instance Eq (NValue m) where
NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
NVConstant (NInt x) == NVConstant (NInt y) = x == y NVConstant (NInt x) == NVConstant (NInt y) = x == y
NVConstant (NFloat x) == NVConstant (NFloat y) = x == y NVConstant (NFloat x) == NVConstant (NFloat y) = x == y
NVStr x _ == NVStr y _ = x == y NVStr x == NVStr y = hackyStringIgnoreContext x == hackyStringIgnoreContext y
NVPath x == NVPath y = x == y NVPath x == NVPath y = x == y
_ == _ = False _ == _ = False
@ -190,7 +189,7 @@ instance Ord (NValue m) where
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y
NVStr x _ <= NVStr y _ = x <= y NVStr x <= NVStr y = hackyStringIgnoreContext x <= hackyStringIgnoreContext y
NVPath x <= NVPath y = x <= y NVPath x <= NVPath y = x <= y
_ <= _ = False _ <= _ = False
@ -200,7 +199,7 @@ checkComparable x y = case (x, y) of
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure () (NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
(NVConstant (NInt _), NVConstant (NInt _)) -> pure () (NVConstant (NInt _), NVConstant (NInt _)) -> pure ()
(NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure ()
(NVStr _ _, NVStr _ _) -> pure () (NVStr _, NVStr _) -> pure ()
(NVPath _, NVPath _) -> pure () (NVPath _, NVPath _) -> pure ()
_ -> throwError $ Comparison x y _ -> throwError $ Comparison x y
@ -250,15 +249,15 @@ isDerivation :: MonadThunk (NValue m) (NThunk m) m
=> AttrSet (NThunk m) -> m Bool => AttrSet (NThunk m) -> m Bool
isDerivation m = case M.lookup "type" m of isDerivation m = case M.lookup "type" m of
Nothing -> pure False Nothing -> pure False
Just t -> force t $ valueEq (nvStr "derivation" mempty) Just t -> force t $ valueEq (nvStr (hackyMakeNixStringWithoutContext "derivation"))
valueEq :: MonadThunk (NValue m) (NThunk m) m valueEq :: MonadThunk (NValue m) (NThunk m) m
=> NValue m -> NValue m -> m Bool => NValue m -> NValue m -> m Bool
valueEq l r = case (l, r) of valueEq l r = case (l, r) of
(NVConstant lc, NVConstant rc) -> pure $ lc == rc (NVConstant lc, NVConstant rc) -> pure $ lc == rc
(NVStr ls _, NVStr rs _) -> pure $ ls == rs (NVStr ls, NVStr rs) -> pure (ls == rs)
(NVStr ls _, NVConstant NNull) -> pure $ ls == "" (NVStr ns, NVConstant NNull) -> pure (hackyStringIgnoreContextMaybe ns == Just "")
(NVConstant NNull, NVStr rs _) -> pure $ "" == rs (NVConstant NNull, NVStr ns) -> pure (Just "" == hackyStringIgnoreContextMaybe ns)
(NVList ls, NVList rs) -> alignEqM thunkEq ls rs (NVList ls, NVList rs) -> alignEqM thunkEq ls rs
(NVSet lm _, NVSet rm _) -> do (NVSet lm _, NVSet rm _) -> do
let compareAttrs = alignEqM thunkEq lm rm let compareAttrs = alignEqM thunkEq lm rm
@ -324,7 +323,7 @@ instance Show (NThunk m) where
instance Eq1 (NValueF m) where instance Eq1 (NValueF m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x _) (NVStrF y _) = x == y liftEq _ (NVStrF x) (NVStrF y) = x == y
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y
liftEq _ (NVPathF x) (NVPathF y) = x == y liftEq _ (NVPathF x) (NVPathF y) = x == y
@ -333,7 +332,7 @@ instance Eq1 (NValueF m) where
instance Show1 (NValueF m) where instance Show1 (NValueF m) where
liftShowsPrec sp sl p = \case liftShowsPrec sp sl p = \case
NVConstantF atom -> showsUnaryWith showsPrec "NVConstantF" p atom NVConstantF atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStrF txt _ -> showsUnaryWith showsPrec "NVStrF" p txt NVStrF ns -> showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
NVListF lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst NVListF lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSetF attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs NVSetF attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVClosureF c _ -> showsUnaryWith showsPrec "NVClosureF" p c NVClosureF c _ -> showsUnaryWith showsPrec "NVClosureF" p c

3
src/Nix/XML.hs
View file

@ -9,6 +9,7 @@ import Data.Ord
import qualified Data.Text as Text import qualified Data.Text as Text
import Nix.Atoms import Nix.Atoms
import Nix.Expr.Types import Nix.Expr.Types
import Nix.String
import Nix.Value import Nix.Value
import Text.XML.Light import Text.XML.Light
@ -31,7 +32,7 @@ toXML = ("<?xml version='1.0' encoding='utf-8'?>\n" ++)
NBool b -> mkElem "bool" "value" (if b then "true" else "false") NBool b -> mkElem "bool" "value" (if b then "true" else "false")
NNull -> Element (unqual "null") [] [] Nothing NNull -> Element (unqual "null") [] [] Nothing
NVStrF t _ -> mkElem "string" "value" (Text.unpack t) NVStrF ns -> mkElem "string" "value" (Text.unpack $ hackyStringIgnoreContext ns)
NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing
NVSetF s _ -> Element (unqual "attrs") [] NVSetF s _ -> Element (unqual "attrs") []

2
tests/EvalTests.hs
View file

@ -366,7 +366,7 @@ genEvalCompareTests = do
instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
NVConstantF x == NVConstantF y = x == y NVConstantF x == NVConstantF y = x == y
NVStrF x _ == NVStrF y _ = x == y NVStrF ls == NVStrF rs = hackyStringIgnoreContext ls == hackyStringIgnoreContext rs
NVListF x == NVListF y = and (zipWith (==) x y) NVListF x == NVListF y = and (zipWith (==) x y)
NVSetF x _ == NVSetF y _ = NVSetF x _ == NVSetF y _ =
M.keys x == M.keys y && M.keys x == M.keys y &&

5
tests/Main.hs
View file

@ -20,6 +20,7 @@ import qualified EvalTests
import qualified Nix import qualified Nix
import Nix.Exec import Nix.Exec
import Nix.Expr.Types import Nix.Expr.Types
import Nix.String
import Nix.Options import Nix.Options
import Nix.Parser import Nix.Parser
import Nix.Value import Nix.Value
@ -63,9 +64,10 @@ ensureNixpkgsCanParse =
url = "https://github.com/NixOS/nixpkgs/archive/#{rev}.tar.gz"; url = "https://github.com/NixOS/nixpkgs/archive/#{rev}.tar.gz";
sha256 = "#{sha256}"; sha256 = "#{sha256}";
}|]) $ \expr -> do }|]) $ \expr -> do
NVStr dir _ <- do NVStr ns <- do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
runLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr runLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
let dir = hackyStringIgnoreContext ns
exists <- fileExist (unpack dir) exists <- fileExist (unpack dir)
unless exists $ unless exists $
errorWithoutStackTrace $ errorWithoutStackTrace $
@ -118,3 +120,4 @@ main = do
, nixLanguageTests ] ++ , nixLanguageTests ] ++
[ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse [ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse
| isJust nixpkgsTestsEnv ] | isJust nixpkgsTestsEnv ]