Merge pull request #757 from layus/fix-a-lot

Various fixes and bugfixes encountered while testing

Author: layus

src/Nix/Builtins.hs

@@ -145,18 +145,19 @@ builtinsList = sequence
     version <- toValue (5 :: Int)
     pure $ Builtin Normal ("langVersion", version)
 
-  , add0 Normal   "nixPath"          nixPath
   , add  TopLevel "abort"            throw_ -- for now
   , add2 Normal   "add"              add_
   , add2 Normal   "addErrorContext"  addErrorContext
   , add2 Normal   "all"              all_
   , add2 Normal   "any"              any_
+  , add2 Normal   "appendContext"    appendContext
   , add  Normal   "attrNames"        attrNames
   , add  Normal   "attrValues"       attrValues
   , add  TopLevel "baseNameOf"       baseNameOf
   , add2 Normal   "bitAnd"           bitAnd
   , add2 Normal   "bitOr"            bitOr
   , add2 Normal   "bitXor"           bitXor
+  , add0 Normal   "builtins"         builtinsBuiltin
   , add2 Normal   "catAttrs"         catAttrs
   , add2 Normal   "compareVersions"  compareVersions_
   , add  Normal   "concatLists"      concatLists
@@ -205,15 +206,21 @@ builtinsList = sequence
   , add2 Normal   "elemAt"           elemAt_
   , add  Normal   "exec"             exec_
   , add0 Normal   "false"            (pure $ nvConstant $ NBool False)
+  --, add  Normal   "fetchGit"         fetchGit
+  --, add  Normal   "fetchMercurial"   fetchMercurial
   , add  Normal   "fetchTarball"     fetchTarball
   , add  Normal   "fetchurl"         fetchurl
   , add2 Normal   "filter"           filter_
+  --, add  Normal   "filterSource"     filterSource
+  , add2 Normal   "findFile"         findFile_
   , add3 Normal   "foldl'"           foldl'_
   , add  Normal   "fromJSON"         fromJSON
+  --, add  Normal   "fromTOML"         fromTOML
   , add  Normal   "functionArgs"     functionArgs
-  , add2 Normal   "genList"          genList
   , add  Normal   "genericClosure"   genericClosure
+  , add2 Normal   "genList"          genList
   , add2 Normal   "getAttr"          getAttr
+  , add  Normal   "getContext"       getContext
   , add  Normal   "getEnv"           getEnv_
   , add2 Normal   "hasAttr"          hasAttr
   , add  Normal   "hasContext"       hasContext
@@ -236,14 +243,15 @@ builtinsList = sequence
   , add2 TopLevel "mapAttrs"         mapAttrs_
   , add2 Normal   "match"            match_
   , add2 Normal   "mul"              mul_
+  , add0 Normal   "nixPath"          nixPath
   , add0 Normal   "null"             (pure $ nvConstant NNull)
   , add  Normal   "parseDrvName"     parseDrvName
   , add2 Normal   "partition"        partition_
+  --, add  Normal   "path"             path
   , add  Normal   "pathExists"       pathExists_
   , add  TopLevel "placeholder"      placeHolder
   , add  Normal   "readDir"          readDir_
   , add  Normal   "readFile"         readFile_
-  , add2 Normal   "findFile"         findFile_
   , add2 TopLevel "removeAttrs"      removeAttrs
   , add3 Normal   "replaceStrings"   replaceStrings
   , add2 TopLevel "scopedImport"     scopedImport
@@ -252,26 +260,25 @@ builtinsList = sequence
   , add2 Normal   "split"            split_
   , add  Normal   "splitVersion"     splitVersion_
   , add0 Normal   "storeDir"         (pure $ nvStr $ principledMakeNixStringWithoutContext "/nix/store")
+  --, add  Normal   "storePath"        storePath
   , add' Normal   "stringLength"     (arity1 $ Text.length . principledStringIgnoreContext)
   , add' Normal   "sub"              (arity2 ((-) @Integer))
-  , add' Normal   "substring"        (substring @e @t @f @m)
+  , add' Normal   "substring"        substring
   , add  Normal   "tail"             tail_
-  , add0 Normal   "true"             (pure $ nvConstant $ NBool True)
   , add  TopLevel "throw"            throw_
-  , add  Normal   "toJSON"           prim_toJSON
   , add2 Normal   "toFile"           toFile
+  , add  Normal   "toJSON"           prim_toJSON
   , add  Normal   "toPath"           toPath
   , add  TopLevel "toString"         toString
   , add  Normal   "toXML"            toXML_
   , add2 TopLevel "trace"            trace_
+  , add0 Normal   "true"             (pure $ nvConstant $ NBool True)
   , add  Normal   "tryEval"          tryEval
   , add  Normal   "typeOf"           typeOf
+  --, add0 Normal   "unsafeDiscardOutputDependency" unsafeDiscardOutputDependency
+  , add  Normal   "unsafeDiscardStringContext"    unsafeDiscardStringContext
+  , add2 Normal   "unsafeGetAttrPos"              unsafeGetAttrPos
   , add  Normal   "valueSize"        getRecursiveSize
-  , add  Normal   "getContext"                 getContext
-  , add2 Normal   "appendContext"              appendContext
-
-  , add2 Normal   "unsafeGetAttrPos"           unsafeGetAttrPos
-  , add  Normal   "unsafeDiscardStringContext" unsafeDiscardStringContext
   ]
  where
   wrap :: BuiltinType -> Text -> v -> Builtin v
@@ -652,13 +659,13 @@ splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack =
 thunkStr s = nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s))
 
 substring :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString
-substring start len str = Prim $ if start < 0 --NOTE: negative values of 'len' are OK
-  then
-    throwError
-    $  ErrorCall
-    $  "builtins.substring: negative start position: "
-    ++ show start
-  else pure $ principledModifyNixContents (Text.take len . Text.drop start) str
+substring start len str = Prim $
+  if start < 0
+  then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start
+  else pure $ principledModifyNixContents (take . Text.drop start) str
+ where
+  --NOTE: negative values of 'len' are OK, and mean "take everything"
+  take = if len < 0 then id else Text.take len
 
 attrNames
   :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
@@ -766,6 +773,12 @@ bitXor
 bitXor x y = fromValue @Integer x
   >>= \a -> fromValue @Integer y >>= \b -> toValue (a `xor` b)
 
+builtinsBuiltin
+  :: forall e t f m
+   . MonadNix e t f m
+  => m (NValue t f m)
+builtinsBuiltin = (throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred")
+
 dirOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
 dirOf x = demand x $ \case
   NVStr ns -> pure $ nvStr
@@ -1040,10 +1053,6 @@ isList
   :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
 isList = hasKind @[NValue t f m]
 
-isString
-  :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
-isString = hasKind @NixString
-
 isInt
   :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
 isInt = hasKind @Int
@@ -1060,6 +1069,12 @@ isNull
   :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
 isNull = hasKind @()
 
+-- isString cannot use `hasKind` because it coerces derivations to strings.
+isString :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
+isString v = demand v $ \case
+  NVStr{} -> toValue True
+  _       -> toValue False
+
 isFunction :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
 isFunction func = demand func $ \case
   NVClosure{} -> toValue True

src/Nix/Effects.hs

@@ -145,7 +145,7 @@ instance MonadInstantiate IO where
           ++ err
 
 pathExists :: MonadFile m => FilePath -> m Bool
-pathExists = doesFileExist
+pathExists = doesPathExist
 
 class Monad m => MonadEnv m where
     getEnvVar :: String -> m (Maybe String)

src/Nix/Effects/Basic.hs

@@ -64,13 +64,13 @@ defaultMakeAbsolutePath origPath = do
           Nothing -> getCurrentDirectory
           Just v  -> demand v $ \case
             NVPath s -> pure $ takeDirectory s
-            v ->
+            val ->
               throwError
                 $  ErrorCall
                 $  "when resolving relative path,"
                 ++ " __cur_file is in scope,"
                 ++ " but is not a path; it is: "
-                ++ show v
+                ++ show val
       pure $ cwd <///> origPathExpanded
   removeDotDotIndirections <$> canonicalizePath absPath
 
@@ -111,13 +111,13 @@ findEnvPathM name = do
  where
   nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
   nixFilePath path = do
-    path   <- makeAbsolutePath @t @f path
-    exists <- doesDirectoryExist path
-    path'  <- if exists
-      then makeAbsolutePath @t @f $ path </> "default.nix"
-      else pure path
-    exists <- doesFileExist path'
-    pure $ if exists then Just path' else Nothing
+    absPath <- makeAbsolutePath @t @f path
+    isDir   <- doesDirectoryExist absPath
+    absFile <- if isDir
+      then makeAbsolutePath @t @f $ absPath </> "default.nix"
+      else return absPath
+    exists <- doesFileExist absFile
+    pure $ if exists then Just absFile else Nothing
 
 findPathBy
   :: forall e t f m
@@ -226,13 +226,13 @@ findPathM
   => [NValue t f m]
   -> FilePath
   -> m FilePath
-findPathM = findPathBy path
+findPathM = findPathBy existingPath
  where
-  path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
-  path path = do
-    path   <- makeAbsolutePath @t @f path
-    exists <- doesPathExist path
-    pure $ if exists then Just path else Nothing
+  existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
+  existingPath path = do
+    apath  <- makeAbsolutePath @t @f path
+    exists <- doesPathExist apath
+    pure $ if exists then Just apath else Nothing
 
 defaultImportPath
   :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)

src/Nix/Exec.hs

@@ -297,14 +297,12 @@ callFunc fun arg = demand fun $ \fun' -> do
   when (length frames > 2000) $ throwError $ ErrorCall
     "Function call stack exhausted"
   case fun' of
-    NVClosure params f -> do
-      traceM $ "callFunc:NVFunction taking " ++ show params
+    NVClosure _params f -> do
       f arg
     NVBuiltin name f -> do
       span <- currentPos
       withFrame Info (Calling @m @t name span) (f arg)
     s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
-      traceM "callFunc:__functor"
       demand f $ (`callFunc` s) >=> (`callFunc` arg)
     x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
 
@@ -316,7 +314,6 @@ execUnaryOp
   -> NValue t f m
   -> m (NValue t f m)
 execUnaryOp scope span op arg = do
-  traceM "NUnary"
   case arg of
     NVConstant c -> case (op, c) of
       (NNeg, NInt i  ) -> unaryOp $ NInt (-i)
@@ -478,7 +475,7 @@ execBinaryOpForced scope span op lval rval = case op of
 fromStringNoContext :: Framed e m => NixString -> m Text
 fromStringNoContext ns = case principledGetStringNoContext ns of
   Just str -> pure str
-  Nothing  -> throwError $ ErrorCall "expected string with no context"
+  Nothing  -> throwError $ ErrorCall $ "expected string with no context, but got " ++ show ns
 
 addTracing
   :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n)

src/Nix/Parser.hs

@@ -268,7 +268,7 @@ nixIf = annotateLocation1
 nixAssert :: Parser NExprLoc
 nixAssert = annotateLocation1
   (   NAssert
-  <$> (reserved "assert" *> nixExpr)
+  <$> (reserved "assert" *> nixToplevelForm)
   <*> (semi *> nixToplevelForm)
   <?> "assert"
   )

src/Nix/Render.hs

@@ -77,6 +77,9 @@ posAndMsg (SourcePos _ lineNo _) msg = FancyError
 
 renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
 renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg
+  | file == file' && file == "<string>" && begLine == endLine
+  = pure $ "In raw input string at position " <> pretty (unPos begCol)
+
   | file /= "<string>" && file == file'
   = do
     exist <- doesFileExist file

src/Nix/Thunk/Basic.hs

@@ -15,7 +15,6 @@ import           Control.Exception       hiding ( catch )
 import           Control.Monad.Catch
 
 import           Nix.Thunk
-import           Nix.Utils
 import           Nix.Var
 
 data Deferred m v = Deferred (m v) | Computed v
@@ -75,7 +74,6 @@ forceThunk (Thunk n active ref) k = do
       if nowActive
         then throwM $ ThunkLoop $ show n
         else do
-          traceM $ "Forcing " ++ show n
           v <- catch action $ \(e :: SomeException) -> do
             _ <- atomicModifyVar active (False, )
             throwM e