clean-up: (return -> pure)
M main/Main.hs M main/Repl.hs M src/Nix/Builtins.hs M src/Nix/Convert.hs M src/Nix/Effects.hs M src/Nix/Effects/Basic.hs M src/Nix/Eval.hs M src/Nix/Exec.hs M src/Nix/Expr/Types.hs M src/Nix/Json.hs M src/Nix/Lint.hs M src/Nix/Normal.hs M src/Nix/Options/Parser.hs M src/Nix/Parser.hs M src/Nix/Scope.hs M src/Nix/String.hs M src/Nix/TH.hs M src/Nix/Thunk/Basic.hs M src/Nix/Utils.hs M src/Nix/Value.hs M src/Nix/Value/Equal.hs M src/Nix/XML.hs M tests/EvalTests.hs M tests/Main.hs M tests/NixLanguageTests.hs M tests/ParserTests.hs M tests/TestCommon.hs
This commit is contained in:
parent
dd6940fe7b
commit
0cb3946ee7
|
@ -183,10 +183,10 @@ main = do
|
||||||
when report $ do
|
when report $ do
|
||||||
liftIO $ putStrLn path
|
liftIO $ putStrLn path
|
||||||
when descend $ case mv of
|
when descend $ case mv of
|
||||||
Nothing -> return ()
|
Nothing -> pure ()
|
||||||
Just v -> case v of
|
Just v -> case v of
|
||||||
NVSet s' _ -> go (path ++ ".") s'
|
NVSet s' _ -> go (path ++ ".") s'
|
||||||
_ -> return ()
|
_ -> pure ()
|
||||||
where
|
where
|
||||||
filterEntry path k = case (path, k) of
|
filterEntry path k = case (path, k) of
|
||||||
("stdenv", "stdenv" ) -> (True, True)
|
("stdenv", "stdenv" ) -> (True, True)
|
||||||
|
@ -216,7 +216,7 @@ main = do
|
||||||
=<< renderFrames @(StdValue (StandardT (StdIdT IO)))
|
=<< renderFrames @(StdValue (StandardT (StdIdT IO)))
|
||||||
@(StdThunk (StandardT (StdIdT IO)))
|
@(StdThunk (StandardT (StdIdT IO)))
|
||||||
frames
|
frames
|
||||||
return Nothing
|
pure Nothing
|
||||||
|
|
||||||
reduction path mp x = do
|
reduction path mp x = do
|
||||||
eres <- Nix.withNixContext mp
|
eres <- Nix.withNixContext mp
|
||||||
|
@ -234,4 +234,4 @@ main = do
|
||||||
writeFile path $ show $ prettyNix (stripAnnotation expr')
|
writeFile path $ show $ prettyNix (stripAnnotation expr')
|
||||||
case eres of
|
case eres of
|
||||||
Left err -> throwM err
|
Left err -> throwM err
|
||||||
Right v -> return v
|
Right v -> pure v
|
||||||
|
|
16
main/Repl.hs
16
main/Repl.hs
|
@ -96,7 +96,7 @@ main' iniVal = initState iniVal >>= \s -> flip evalStateT s
|
||||||
<> ". For help type :help\n"
|
<> ". For help type :help\n"
|
||||||
finalizer = do
|
finalizer = do
|
||||||
liftIO $ putStrLn "Goodbye."
|
liftIO $ putStrLn "Goodbye."
|
||||||
return Exit
|
pure Exit
|
||||||
|
|
||||||
rcFile = do
|
rcFile = do
|
||||||
f <- liftIO $ Data.Text.IO.readFile ".hnixrc" `catch` handleMissing
|
f <- liftIO $ Data.Text.IO.readFile ".hnixrc" `catch` handleMissing
|
||||||
|
@ -107,7 +107,7 @@ main' iniVal = initState iniVal >>= \s -> flip evalStateT s
|
||||||
x -> cmd $ unwords x
|
x -> cmd $ unwords x
|
||||||
|
|
||||||
handleMissing e
|
handleMissing e
|
||||||
| System.IO.Error.isDoesNotExistError e = return ""
|
| System.IO.Error.isDoesNotExistError e = pure ""
|
||||||
| otherwise = throwIO e
|
| otherwise = throwIO e
|
||||||
|
|
||||||
-- Replicated and slightly adjusted `optMatcher` from `System.Console.Repline`
|
-- Replicated and slightly adjusted `optMatcher` from `System.Console.Repline`
|
||||||
|
@ -193,7 +193,7 @@ exec update source = do
|
||||||
case parseExprOrBinding source of
|
case parseExprOrBinding source of
|
||||||
(Failure err, _) -> do
|
(Failure err, _) -> do
|
||||||
liftIO $ print err
|
liftIO $ print err
|
||||||
return Nothing
|
pure Nothing
|
||||||
(Success expr, isBinding) -> do
|
(Success expr, isBinding) -> do
|
||||||
|
|
||||||
-- Type Inference ( returns Typing Environment )
|
-- Type Inference ( returns Typing Environment )
|
||||||
|
@ -209,7 +209,7 @@ exec update source = do
|
||||||
case mVal of
|
case mVal of
|
||||||
Left (NixException frames) -> do
|
Left (NixException frames) -> do
|
||||||
lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames
|
lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames
|
||||||
return Nothing
|
pure Nothing
|
||||||
Right val -> do
|
Right val -> do
|
||||||
-- Update the interpreter state
|
-- Update the interpreter state
|
||||||
when (update && isBinding) $ do
|
when (update && isBinding) $ do
|
||||||
|
@ -219,9 +219,9 @@ exec update source = do
|
||||||
-- If the result value is a set, update our context with it
|
-- If the result value is a set, update our context with it
|
||||||
case val of
|
case val of
|
||||||
NVSet xs _ -> put st { replCtx = Data.HashMap.Lazy.union xs (replCtx st) }
|
NVSet xs _ -> put st { replCtx = Data.HashMap.Lazy.union xs (replCtx st) }
|
||||||
_ -> return ()
|
_ -> pure ()
|
||||||
|
|
||||||
return $ Just val
|
pure $ Just val
|
||||||
where
|
where
|
||||||
-- If parsing fails, turn the input into singleton attribute set
|
-- If parsing fails, turn the input into singleton attribute set
|
||||||
-- and try again.
|
-- and try again.
|
||||||
|
@ -245,7 +245,7 @@ cmd
|
||||||
cmd source = do
|
cmd source = do
|
||||||
mVal <- exec True (Data.Text.pack source)
|
mVal <- exec True (Data.Text.pack source)
|
||||||
case mVal of
|
case mVal of
|
||||||
Nothing -> return ()
|
Nothing -> pure ()
|
||||||
Just val -> printValue val
|
Just val -> printValue val
|
||||||
|
|
||||||
printValue :: (MonadNix e t f m, MonadIO m)
|
printValue :: (MonadNix e t f m, MonadIO m)
|
||||||
|
@ -294,7 +294,7 @@ typeof
|
||||||
typeof args = do
|
typeof args = do
|
||||||
st <- get
|
st <- get
|
||||||
mVal <- case Data.HashMap.Lazy.lookup line (replCtx st) of
|
mVal <- case Data.HashMap.Lazy.lookup line (replCtx st) of
|
||||||
Just val -> return $ Just val
|
Just val -> pure $ Just val
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
exec False line
|
exec False line
|
||||||
|
|
||||||
|
|
|
@ -204,7 +204,7 @@ builtinsList = sequence
|
||||||
, add2 Normal "elem" elem_
|
, add2 Normal "elem" elem_
|
||||||
, add2 Normal "elemAt" elemAt_
|
, add2 Normal "elemAt" elemAt_
|
||||||
, add Normal "exec" exec_
|
, add Normal "exec" exec_
|
||||||
, add0 Normal "false" (return $ nvConstant $ NBool False)
|
, add0 Normal "false" (pure $ nvConstant $ NBool False)
|
||||||
, add Normal "fetchTarball" fetchTarball
|
, add Normal "fetchTarball" fetchTarball
|
||||||
, add Normal "fetchurl" fetchurl
|
, add Normal "fetchurl" fetchurl
|
||||||
, add2 Normal "filter" filter_
|
, add2 Normal "filter" filter_
|
||||||
|
@ -236,7 +236,7 @@ builtinsList = sequence
|
||||||
, add2 TopLevel "mapAttrs" mapAttrs_
|
, add2 TopLevel "mapAttrs" mapAttrs_
|
||||||
, add2 Normal "match" match_
|
, add2 Normal "match" match_
|
||||||
, add2 Normal "mul" mul_
|
, add2 Normal "mul" mul_
|
||||||
, add0 Normal "null" (return $ nvConstant NNull)
|
, add0 Normal "null" (pure $ nvConstant NNull)
|
||||||
, add Normal "parseDrvName" parseDrvName
|
, add Normal "parseDrvName" parseDrvName
|
||||||
, add2 Normal "partition" partition_
|
, add2 Normal "partition" partition_
|
||||||
, add Normal "pathExists" pathExists_
|
, add Normal "pathExists" pathExists_
|
||||||
|
@ -251,12 +251,12 @@ builtinsList = sequence
|
||||||
, add2 Normal "sort" sort_
|
, add2 Normal "sort" sort_
|
||||||
, add2 Normal "split" split_
|
, add2 Normal "split" split_
|
||||||
, add Normal "splitVersion" splitVersion_
|
, add Normal "splitVersion" splitVersion_
|
||||||
, add0 Normal "storeDir" (return $ nvStr $ principledMakeNixStringWithoutContext "/nix/store")
|
, add0 Normal "storeDir" (pure $ nvStr $ principledMakeNixStringWithoutContext "/nix/store")
|
||||||
, add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext)
|
, add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext)
|
||||||
, add' Normal "sub" (arity2 ((-) @Integer))
|
, add' Normal "sub" (arity2 ((-) @Integer))
|
||||||
, add' Normal "substring" (substring @e @t @f @m)
|
, add' Normal "substring" (substring @e @t @f @m)
|
||||||
, add Normal "tail" tail_
|
, add Normal "tail" tail_
|
||||||
, add0 Normal "true" (return $ nvConstant $ NBool True)
|
, add0 Normal "true" (pure $ nvConstant $ NBool True)
|
||||||
, add TopLevel "throw" throw_
|
, add TopLevel "throw" throw_
|
||||||
, add Normal "toJSON" prim_toJSON
|
, add Normal "toJSON" prim_toJSON
|
||||||
, add2 Normal "toFile" toFile
|
, add2 Normal "toFile" toFile
|
||||||
|
@ -306,11 +306,11 @@ foldNixPath
|
||||||
foldNixPath f z = do
|
foldNixPath f z = do
|
||||||
mres <- lookupVar "__includes"
|
mres <- lookupVar "__includes"
|
||||||
dirs <- case mres of
|
dirs <- case mres of
|
||||||
Nothing -> return []
|
Nothing -> pure []
|
||||||
Just v -> demand v $ fromValue . Deeper
|
Just v -> demand v $ fromValue . Deeper
|
||||||
mPath <- getEnvVar "NIX_PATH"
|
mPath <- getEnvVar "NIX_PATH"
|
||||||
mDataDir <- getEnvVar "NIX_DATA_DIR"
|
mDataDir <- getEnvVar "NIX_DATA_DIR"
|
||||||
dataDir <- maybe getDataDir return mDataDir
|
dataDir <- maybe getDataDir pure mDataDir
|
||||||
foldrM go z
|
foldrM go z
|
||||||
$ map (fromInclude . principledStringIgnoreContext) dirs
|
$ map (fromInclude . principledStringIgnoreContext) dirs
|
||||||
++ case mPath of
|
++ case mPath of
|
||||||
|
@ -438,10 +438,10 @@ div_ x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of
|
||||||
(_, _) -> throwError $ Division x' y'
|
(_, _) -> throwError $ Division x' y'
|
||||||
|
|
||||||
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||||
anyM _ [] = return False
|
anyM _ [] = pure False
|
||||||
anyM p (x : xs) = do
|
anyM p (x : xs) = do
|
||||||
q <- p x
|
q <- p x
|
||||||
if q then return True else anyM p xs
|
if q then pure True else anyM p xs
|
||||||
|
|
||||||
any_
|
any_
|
||||||
:: MonadNix e t f m
|
:: MonadNix e t f m
|
||||||
|
@ -451,10 +451,10 @@ any_
|
||||||
any_ f = toValue <=< anyM fromValue <=< mapM (f `callFunc`) <=< fromValue
|
any_ f = toValue <=< anyM fromValue <=< mapM (f `callFunc`) <=< fromValue
|
||||||
|
|
||||||
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||||
allM _ [] = return True
|
allM _ [] = pure True
|
||||||
allM p (x : xs) = do
|
allM p (x : xs) = do
|
||||||
q <- p x
|
q <- p x
|
||||||
if q then allM p xs else return False
|
if q then allM p xs else pure False
|
||||||
|
|
||||||
all_
|
all_
|
||||||
:: MonadNix e t f m
|
:: MonadNix e t f m
|
||||||
|
@ -481,7 +481,7 @@ head_ = fromValue >=> \case
|
||||||
tail_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
tail_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
||||||
tail_ = fromValue >=> \case
|
tail_ = fromValue >=> \case
|
||||||
[] -> throwError $ ErrorCall "builtins.tail: empty list"
|
[] -> throwError $ ErrorCall "builtins.tail: empty list"
|
||||||
_ : t -> return $ nvList t
|
_ : t -> pure $ nvList t
|
||||||
|
|
||||||
data VersionComponent
|
data VersionComponent
|
||||||
= VersionComponent_Pre -- ^ The string "pre"
|
= VersionComponent_Pre -- ^ The string "pre"
|
||||||
|
@ -525,7 +525,7 @@ splitVersion s = case Text.uncons s of
|
||||||
|
|
||||||
splitVersion_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
splitVersion_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
||||||
splitVersion_ = fromValue >=> fromStringNoContext >=> \s ->
|
splitVersion_ = fromValue >=> fromStringNoContext >=> \s ->
|
||||||
return
|
pure
|
||||||
$ nvList
|
$ nvList
|
||||||
$ flip map (splitVersion s)
|
$ flip map (splitVersion s)
|
||||||
$ nvStr
|
$ nvStr
|
||||||
|
@ -546,7 +546,7 @@ compareVersions_
|
||||||
-> m (NValue t f m)
|
-> m (NValue t f m)
|
||||||
compareVersions_ t1 t2 = fromValue t1 >>= fromStringNoContext >>= \s1 ->
|
compareVersions_ t1 t2 = fromValue t1 >>= fromStringNoContext >>= \s1 ->
|
||||||
fromValue t2 >>= fromStringNoContext >>= \s2 ->
|
fromValue t2 >>= fromStringNoContext >>= \s2 ->
|
||||||
return $ nvConstant $ NInt $ case compareVersions s1 s2 of
|
pure $ nvConstant $ NInt $ case compareVersions s1 s2 of
|
||||||
LT -> -1
|
LT -> -1
|
||||||
EQ -> 0
|
EQ -> 0
|
||||||
GT -> 1
|
GT -> 1
|
||||||
|
@ -624,7 +624,7 @@ split_ pat str = fromValue pat >>= fromStringNoContext >>= \p ->
|
||||||
let s = principledStringIgnoreContext ns
|
let s = principledStringIgnoreContext ns
|
||||||
let re = makeRegex (encodeUtf8 p) :: Regex
|
let re = makeRegex (encodeUtf8 p) :: Regex
|
||||||
haystack = encodeUtf8 s
|
haystack = encodeUtf8 s
|
||||||
return $ nvList $ splitMatches 0
|
pure $ nvList $ splitMatches 0
|
||||||
(map elems $ matchAllText re haystack)
|
(map elems $ matchAllText re haystack)
|
||||||
haystack
|
haystack
|
||||||
|
|
||||||
|
@ -925,7 +925,7 @@ replaceStrings tfrom tto ts = fromValue (Deeper tfrom) >>= \(nsFrom :: [NixStrin
|
||||||
(prefix, replacement) <- find ((`Text.isPrefixOf` s) . fst)
|
(prefix, replacement) <- find ((`Text.isPrefixOf` s) . fst)
|
||||||
$ zip from nsTo
|
$ zip from nsTo
|
||||||
let rest = Text.drop (Text.length prefix) s
|
let rest = Text.drop (Text.length prefix) s
|
||||||
return (prefix, replacement, rest)
|
pure (prefix, replacement, rest)
|
||||||
finish b =
|
finish b =
|
||||||
principledMakeNixString (LazyText.toStrict $ Builder.toLazyText b)
|
principledMakeNixString (LazyText.toStrict $ Builder.toLazyText b)
|
||||||
go orig result ctx = case lookupPrefix orig of
|
go orig result ctx = case lookupPrefix orig of
|
||||||
|
@ -977,7 +977,7 @@ intersectAttrs
|
||||||
intersectAttrs set1 set2 =
|
intersectAttrs set1 set2 =
|
||||||
fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 >>= \(s1, p1) ->
|
fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 >>= \(s1, p1) ->
|
||||||
fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 >>= \(s2, p2) ->
|
fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 >>= \(s2, p2) ->
|
||||||
return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
|
pure $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
|
||||||
|
|
||||||
functionArgs
|
functionArgs
|
||||||
:: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
:: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
|
||||||
|
@ -1086,10 +1086,10 @@ scopedImport asetArg pathArg = fromValue @(AttrSet (NValue t f m)) asetArg >>= \
|
||||||
path' <- case mres of
|
path' <- case mres of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
traceM "No known current directory"
|
traceM "No known current directory"
|
||||||
return path
|
pure path
|
||||||
Just p -> demand p $ fromValue >=> \(Path p') -> do
|
Just p -> demand p $ fromValue >=> \(Path p') -> do
|
||||||
traceM $ "Current file being evaluated is: " ++ show p'
|
traceM $ "Current file being evaluated is: " ++ show p'
|
||||||
return $ takeDirectory p' </> path
|
pure $ takeDirectory p' </> path
|
||||||
clearScopes @(NValue t f m)
|
clearScopes @(NValue t f m)
|
||||||
$ withNixContext (Just path')
|
$ withNixContext (Just path')
|
||||||
$ pushScope s
|
$ pushScope s
|
||||||
|
@ -1416,7 +1416,7 @@ currentSystem :: MonadNix e t f m => m (NValue t f m)
|
||||||
currentSystem = do
|
currentSystem = do
|
||||||
os <- getCurrentSystemOS
|
os <- getCurrentSystemOS
|
||||||
arch <- getCurrentSystemArch
|
arch <- getCurrentSystemArch
|
||||||
return $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os)
|
pure $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os)
|
||||||
|
|
||||||
currentTime_ :: MonadNix e t f m => m (NValue t f m)
|
currentTime_ :: MonadNix e t f m => m (NValue t f m)
|
||||||
currentTime_ = do
|
currentTime_ = do
|
||||||
|
@ -1451,12 +1451,12 @@ appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of
|
||||||
newContextValues <- forM attrs $ \attr -> demand attr $ \case
|
newContextValues <- forM attrs $ \attr -> demand attr $ \case
|
||||||
NVSet attrs _ -> do
|
NVSet attrs _ -> do
|
||||||
-- TODO: Fail for unexpected keys.
|
-- TODO: Fail for unexpected keys.
|
||||||
path <- maybe (return False) (demand ?? fromValue)
|
path <- maybe (pure False) (demand ?? fromValue)
|
||||||
$ M.lookup "path" attrs
|
$ M.lookup "path" attrs
|
||||||
allOutputs <- maybe (return False) (demand ?? fromValue)
|
allOutputs <- maybe (pure False) (demand ?? fromValue)
|
||||||
$ M.lookup "allOutputs" attrs
|
$ M.lookup "allOutputs" attrs
|
||||||
outputs <- case M.lookup "outputs" attrs of
|
outputs <- case M.lookup "outputs" attrs of
|
||||||
Nothing -> return []
|
Nothing -> pure []
|
||||||
Just os -> demand os $ \case
|
Just os -> demand os $ \case
|
||||||
NVList vs ->
|
NVList vs ->
|
||||||
forM vs $ fmap principledStringIgnoreContext . fromValue
|
forM vs $ fmap principledStringIgnoreContext . fromValue
|
||||||
|
@ -1465,7 +1465,7 @@ appendContext x y = demand x $ \x' -> demand y $ \y' -> case (x', y') of
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "Invalid types for context value outputs in builtins.appendContext: "
|
$ "Invalid types for context value outputs in builtins.appendContext: "
|
||||||
++ show x
|
++ show x
|
||||||
return $ NixLikeContextValue path allOutputs outputs
|
pure $ NixLikeContextValue path allOutputs outputs
|
||||||
x ->
|
x ->
|
||||||
throwError
|
throwError
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
|
@ -1501,4 +1501,4 @@ instance ( MonadNix e t f m
|
||||||
)
|
)
|
||||||
=> ToBuiltin t f m (a -> b) where
|
=> ToBuiltin t f m (a -> b) where
|
||||||
toBuiltin name f =
|
toBuiltin name f =
|
||||||
return $ nvBuiltin name (fromValue . Deeper >=> toBuiltin name . f)
|
pure $ nvBuiltin name (fromValue . Deeper >=> toBuiltin name . f)
|
||||||
|
|
|
@ -353,16 +353,16 @@ instance (Convertible e t f m, ToValue a m (NValue t f m))
|
||||||
instance Convertible e t f m
|
instance Convertible e t f m
|
||||||
=> ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where
|
=> ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where
|
||||||
toValue nlcv = do
|
toValue nlcv = do
|
||||||
path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing
|
path <- if nlcvPath nlcv then Just <$> toValue True else pure Nothing
|
||||||
allOutputs <- if nlcvAllOutputs nlcv
|
allOutputs <- if nlcvAllOutputs nlcv
|
||||||
then Just <$> toValue True
|
then Just <$> toValue True
|
||||||
else return Nothing
|
else pure Nothing
|
||||||
outputs <- do
|
outputs <- do
|
||||||
let outputs =
|
let outputs =
|
||||||
principledMakeNixStringWithoutContext <$> nlcvOutputs nlcv
|
principledMakeNixStringWithoutContext <$> nlcvOutputs nlcv
|
||||||
ts :: [NValue t f m] <- traverse toValue outputs
|
ts :: [NValue t f m] <- traverse toValue outputs
|
||||||
case ts of
|
case ts of
|
||||||
[] -> return Nothing
|
[] -> pure Nothing
|
||||||
_ -> Just <$> toValue ts
|
_ -> Just <$> toValue ts
|
||||||
pure $ flip nvSet' M.empty $ M.fromList $ catMaybes
|
pure $ flip nvSet' M.empty $ M.fromList $ catMaybes
|
||||||
[ ("path",) <$> path
|
[ ("path",) <$> path
|
||||||
|
|
|
@ -76,7 +76,7 @@ recursiveSize
|
||||||
\_ -> return 0
|
\_ -> return 0
|
||||||
#endif
|
#endif
|
||||||
#else
|
#else
|
||||||
\_ -> return 0
|
\_ -> pure 0
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
class Monad m => MonadExec m where
|
class Monad m => MonadExec m where
|
||||||
|
@ -87,26 +87,26 @@ class Monad m => MonadExec m where
|
||||||
|
|
||||||
instance MonadExec IO where
|
instance MonadExec IO where
|
||||||
exec' = \case
|
exec' = \case
|
||||||
[] -> return $ Left $ ErrorCall "exec: missing program"
|
[] -> pure $ Left $ ErrorCall "exec: missing program"
|
||||||
(prog : args) -> do
|
(prog : args) -> do
|
||||||
(exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args ""
|
(exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args ""
|
||||||
let t = T.strip (T.pack out)
|
let t = T.strip (T.pack out)
|
||||||
let emsg = "program[" ++ prog ++ "] args=" ++ show args
|
let emsg = "program[" ++ prog ++ "] args=" ++ show args
|
||||||
case exitCode of
|
case exitCode of
|
||||||
ExitSuccess -> if T.null t
|
ExitSuccess -> if T.null t
|
||||||
then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg
|
then pure $ Left $ ErrorCall $ "exec has no output :" ++ emsg
|
||||||
else case parseNixTextLoc t of
|
else case parseNixTextLoc t of
|
||||||
Failure err ->
|
Failure err ->
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "Error parsing output of exec: "
|
$ "Error parsing output of exec: "
|
||||||
++ show err
|
++ show err
|
||||||
++ " "
|
++ " "
|
||||||
++ emsg
|
++ emsg
|
||||||
Success v -> return $ Right v
|
Success v -> pure $ Right v
|
||||||
err ->
|
err ->
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "exec failed: "
|
$ "exec failed: "
|
||||||
|
@ -129,14 +129,14 @@ instance MonadInstantiate IO where
|
||||||
case exitCode of
|
case exitCode of
|
||||||
ExitSuccess -> case parseNixTextLoc (T.pack out) of
|
ExitSuccess -> case parseNixTextLoc (T.pack out) of
|
||||||
Failure e ->
|
Failure e ->
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "Error parsing output of nix-instantiate: "
|
$ "Error parsing output of nix-instantiate: "
|
||||||
++ show e
|
++ show e
|
||||||
Success v -> return $ Right v
|
Success v -> pure $ Right v
|
||||||
status ->
|
status ->
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "nix-instantiate failed: "
|
$ "nix-instantiate failed: "
|
||||||
|
@ -161,10 +161,10 @@ class Monad m => MonadEnv m where
|
||||||
instance MonadEnv IO where
|
instance MonadEnv IO where
|
||||||
getEnvVar = lookupEnv
|
getEnvVar = lookupEnv
|
||||||
|
|
||||||
getCurrentSystemOS = return $ T.pack System.Info.os
|
getCurrentSystemOS = pure $ T.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
|
||||||
getCurrentSystemArch = return $ T.pack $ case System.Info.arch of
|
getCurrentSystemArch = pure $ T.pack $ case System.Info.arch of
|
||||||
"i386" -> "i686"
|
"i386" -> "i686"
|
||||||
arch -> arch
|
arch -> arch
|
||||||
|
|
||||||
|
@ -194,7 +194,7 @@ instance MonadHttp IO where
|
||||||
let status = statusCode (responseStatus response)
|
let status = statusCode (responseStatus response)
|
||||||
if status /= 200
|
if status /= 200
|
||||||
then
|
then
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "fail, got "
|
$ "fail, got "
|
||||||
|
@ -203,7 +203,7 @@ instance MonadHttp IO where
|
||||||
++ urlstr
|
++ urlstr
|
||||||
else -- do
|
else -- do
|
||||||
-- let bstr = responseBody response
|
-- let bstr = responseBody response
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "success in downloading but hnix-store is not yet ready; url = "
|
$ "success in downloading but hnix-store is not yet ready; url = "
|
||||||
|
@ -239,9 +239,9 @@ instance MonadStore IO where
|
||||||
case exitCode of
|
case exitCode of
|
||||||
ExitSuccess -> do
|
ExitSuccess -> do
|
||||||
let dropTrailingLinefeed p = take (length p - 1) p
|
let dropTrailingLinefeed p = take (length p - 1) p
|
||||||
return $ Right $ StorePath $ dropTrailingLinefeed out
|
pure $ Right $ StorePath $ dropTrailingLinefeed out
|
||||||
_ ->
|
_ ->
|
||||||
return
|
pure
|
||||||
$ Left
|
$ Left
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
$ "addPath: failed: nix-store --add "
|
$ "addPath: failed: nix-store --add "
|
||||||
|
@ -252,10 +252,10 @@ instance MonadStore IO where
|
||||||
writeFile filepath content
|
writeFile filepath content
|
||||||
storepath <- addPath' filepath
|
storepath <- addPath' filepath
|
||||||
S.removeFile filepath
|
S.removeFile filepath
|
||||||
return storepath
|
pure storepath
|
||||||
|
|
||||||
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
|
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
|
||||||
addPath p = either throwError return =<< addPath' p
|
addPath p = either throwError pure =<< addPath' p
|
||||||
|
|
||||||
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
|
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
|
||||||
toFile_ p contents = either throwError return =<< toFile_' p contents
|
toFile_ p contents = either throwError pure =<< toFile_' p contents
|
||||||
|
|
|
@ -63,7 +63,7 @@ defaultMakeAbsolutePath origPath = do
|
||||||
case mres of
|
case mres of
|
||||||
Nothing -> getCurrentDirectory
|
Nothing -> getCurrentDirectory
|
||||||
Just v -> demand v $ \case
|
Just v -> demand v $ \case
|
||||||
NVPath s -> return $ takeDirectory s
|
NVPath s -> pure $ takeDirectory s
|
||||||
v ->
|
v ->
|
||||||
throwError
|
throwError
|
||||||
$ ErrorCall
|
$ ErrorCall
|
||||||
|
@ -76,7 +76,7 @@ defaultMakeAbsolutePath origPath = do
|
||||||
|
|
||||||
expandHomePath :: MonadFile m => FilePath -> m FilePath
|
expandHomePath :: MonadFile m => FilePath -> m FilePath
|
||||||
expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory
|
expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory
|
||||||
expandHomePath p = return p
|
expandHomePath p = pure p
|
||||||
|
|
||||||
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
|
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
|
||||||
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its
|
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its
|
||||||
|
@ -115,9 +115,9 @@ findEnvPathM name = do
|
||||||
exists <- doesDirectoryExist path
|
exists <- doesDirectoryExist path
|
||||||
path' <- if exists
|
path' <- if exists
|
||||||
then makeAbsolutePath @t @f $ path </> "default.nix"
|
then makeAbsolutePath @t @f $ path </> "default.nix"
|
||||||
else return path
|
else pure path
|
||||||
exists <- doesFileExist path'
|
exists <- doesFileExist path'
|
||||||
return $ if exists then Just path' else Nothing
|
pure $ if exists then Just path' else Nothing
|
||||||
|
|
||||||
findPathBy
|
findPathBy
|
||||||
:: forall e t f m
|
:: forall e t f m
|
||||||
|
@ -136,7 +136,7 @@ findPathBy finder l name = do
|
||||||
++ name
|
++ name
|
||||||
++ "' was not found in the Nix search path"
|
++ "' was not found in the Nix search path"
|
||||||
++ " (add it's using $NIX_PATH or -I)"
|
++ " (add it's using $NIX_PATH or -I)"
|
||||||
Just path -> return path
|
Just path -> pure path
|
||||||
where
|
where
|
||||||
go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath)
|
go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath)
|
||||||
go p@(Just _) _ = pure p
|
go p@(Just _) _ = pure p
|
||||||
|
@ -158,7 +158,7 @@ findPathBy finder l name = do
|
||||||
tryPath p _ = finder $ p <///> name
|
tryPath p _ = finder $ p <///> name
|
||||||
|
|
||||||
resolvePath s = case M.lookup "path" s of
|
resolvePath s = case M.lookup "path" s of
|
||||||
Just t -> return t
|
Just t -> pure t
|
||||||
Nothing -> case M.lookup "uri" s of
|
Nothing -> case M.lookup "uri" s of
|
||||||
Just ut -> defer $ fetchTarball ut
|
Just ut -> defer $ fetchTarball ut
|
||||||
Nothing ->
|
Nothing ->
|
||||||
|
@ -232,7 +232,7 @@ findPathM = findPathBy path
|
||||||
path path = do
|
path path = do
|
||||||
path <- makeAbsolutePath @t @f path
|
path <- makeAbsolutePath @t @f path
|
||||||
exists <- doesPathExist path
|
exists <- doesPathExist path
|
||||||
return $ if exists then Just path else Nothing
|
pure $ if exists then Just path else Nothing
|
||||||
|
|
||||||
defaultImportPath
|
defaultImportPath
|
||||||
:: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)
|
:: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)
|
||||||
|
@ -273,7 +273,7 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
|
||||||
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v')
|
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v')
|
||||||
where
|
where
|
||||||
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
|
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
|
||||||
mapMaybeM op = foldr f (return [])
|
mapMaybeM op = foldr f (pure [])
|
||||||
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
|
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
|
||||||
|
|
||||||
handleEntry :: Bool -> (Text, NValue t f m) -> m (Maybe (Text, NValue t f m))
|
handleEntry :: Bool -> (Text, NValue t f m) -> m (Maybe (Text, NValue t f m))
|
||||||
|
|
|
@ -201,7 +201,7 @@ attrSetAlter (k : ks) pos m p val = case M.lookup k m of
|
||||||
-> x >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(st, sp) ->
|
-> x >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(st, sp) ->
|
||||||
recurse (demand ?? pure <$> st) sp
|
recurse (demand ?? pure <$> st) sp
|
||||||
where
|
where
|
||||||
go = return (M.insert k val m, M.insert k pos p)
|
go = pure (M.insert k val m, M.insert k pos p)
|
||||||
|
|
||||||
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
|
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
|
||||||
( M.insert
|
( M.insert
|
||||||
|
@ -257,7 +257,7 @@ evalBinds recursive binds = do
|
||||||
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
|
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
|
||||||
finalValue >>= fromValue >>= \(o', p') ->
|
finalValue >>= fromValue >>= \(o', p') ->
|
||||||
-- jww (2018-05-09): What to do with the key position here?
|
-- jww (2018-05-09): What to do with the key position here?
|
||||||
return $ map
|
pure $ map
|
||||||
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand v pure))
|
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand v pure))
|
||||||
(M.toList o')
|
(M.toList o')
|
||||||
|
|
||||||
|
@ -306,7 +306,7 @@ evalBinds recursive binds = do
|
||||||
buildResult scope bindings = do
|
buildResult scope bindings = do
|
||||||
(s, p) <- foldM insert (M.empty, M.empty) bindings
|
(s, p) <- foldM insert (M.empty, M.empty) bindings
|
||||||
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
|
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
|
||||||
return (res, p)
|
pure (res, p)
|
||||||
where
|
where
|
||||||
mkThunk = defer . withScopes scope
|
mkThunk = defer . withScopes scope
|
||||||
|
|
||||||
|
@ -331,7 +331,7 @@ evalSelect aset attr = do
|
||||||
[] -> pure $ Right $ demand t pure
|
[] -> pure $ Right $ demand t pure
|
||||||
y : ys -> demand t $ extract ?? (y :| ys)
|
y : ys -> demand t $ extract ?? (y :| ys)
|
||||||
| otherwise -> Left . (, path) <$> toValue (s, p)
|
| otherwise -> Left . (, path) <$> toValue (s, p)
|
||||||
Nothing -> return $ Left (x, path)
|
Nothing -> pure $ Left (x, path)
|
||||||
|
|
||||||
-- | 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
|
||||||
|
|
|
@ -477,7 +477,7 @@ execBinaryOpForced scope span op lval rval = case op of
|
||||||
-- use 'throwError'.
|
-- use 'throwError'.
|
||||||
fromStringNoContext :: Framed e m => NixString -> m Text
|
fromStringNoContext :: Framed e m => NixString -> m Text
|
||||||
fromStringNoContext ns = case principledGetStringNoContext ns of
|
fromStringNoContext ns = case principledGetStringNoContext ns of
|
||||||
Just str -> return str
|
Just str -> pure str
|
||||||
Nothing -> throwError $ ErrorCall "expected string with no context"
|
Nothing -> throwError $ ErrorCall "expected string with no context"
|
||||||
|
|
||||||
addTracing
|
addTracing
|
||||||
|
@ -489,7 +489,7 @@ addTracing k v = do
|
||||||
guard (depth < 2000)
|
guard (depth < 2000)
|
||||||
local succ $ do
|
local succ $ do
|
||||||
v'@(Compose (Ann span x)) <- sequence v
|
v'@(Compose (Ann span x)) <- sequence v
|
||||||
return $ do
|
pure $ do
|
||||||
opts :: Options <- asks (view hasLens)
|
opts :: Options <- asks (view hasLens)
|
||||||
let rendered = if verbose opts >= Chatty
|
let rendered = if verbose opts >= Chatty
|
||||||
#ifdef MIN_VERSION_pretty_show
|
#ifdef MIN_VERSION_pretty_show
|
||||||
|
@ -503,7 +503,7 @@ addTracing k v = do
|
||||||
putStr $ show loc
|
putStr $ show loc
|
||||||
res <- k v'
|
res <- k v'
|
||||||
print $ msg rendered <> " ...done"
|
print $ msg rendered <> " ...done"
|
||||||
return res
|
pure res
|
||||||
|
|
||||||
evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m)
|
evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m)
|
||||||
evalExprLoc expr = do
|
evalExprLoc expr = do
|
||||||
|
|
|
@ -601,7 +601,7 @@ ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = case g
|
||||||
j : js -> do
|
j : js -> do
|
||||||
NamedVar ns v _p <- xs
|
NamedVar ns v _p <- xs
|
||||||
guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
|
guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
|
||||||
return (v, rest)
|
pure (v, rest)
|
||||||
|
|
||||||
ekey _ _ f e = fromMaybe e <$> f Nothing
|
ekey _ _ f e = fromMaybe e <$> f Nothing
|
||||||
|
|
||||||
|
|
|
@ -43,14 +43,14 @@ nvalueToJSON = \case
|
||||||
NVList l ->
|
NVList l ->
|
||||||
A.Array
|
A.Array
|
||||||
. V.fromList
|
. V.fromList
|
||||||
<$> traverse (join . lift . flip demand (return . nvalueToJSON)) l
|
<$> traverse (join . lift . flip demand (pure . nvalueToJSON)) l
|
||||||
NVSet m _ -> case HM.lookup "outPath" m of
|
NVSet m _ -> case HM.lookup "outPath" m of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
A.Object
|
A.Object
|
||||||
<$> traverse (join . lift . flip demand (return . nvalueToJSON)) m
|
<$> traverse (join . lift . flip demand (pure . nvalueToJSON)) m
|
||||||
Just outPath -> join $ lift $ demand outPath (return . nvalueToJSON)
|
Just outPath -> join $ lift $ demand outPath (pure . nvalueToJSON)
|
||||||
NVPath p -> do
|
NVPath p -> do
|
||||||
fp <- lift $ unStorePath <$> addPath p
|
fp <- lift $ unStorePath <$> addPath p
|
||||||
addSingletonStringContext $ StringContext (Text.pack fp) DirectPath
|
addSingletonStringContext $ StringContext (Text.pack fp) DirectPath
|
||||||
return $ A.toJSON fp
|
pure $ A.toJSON fp
|
||||||
v -> lift $ throwError $ CoercionToJson v
|
v -> lift $ throwError $ CoercionToJson v
|
||||||
|
|
|
@ -130,30 +130,30 @@ symerr = evalError @(Symbolic m) . ErrorCall
|
||||||
|
|
||||||
renderSymbolic :: MonadLint e m => Symbolic m -> m String
|
renderSymbolic :: MonadLint e m => Symbolic m -> m String
|
||||||
renderSymbolic = unpackSymbolic >=> \case
|
renderSymbolic = unpackSymbolic >=> \case
|
||||||
NAny -> return "<any>"
|
NAny -> pure "<any>"
|
||||||
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
|
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
|
||||||
TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case
|
TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case
|
||||||
TInt -> return "int"
|
TInt -> pure "int"
|
||||||
TFloat -> return "float"
|
TFloat -> pure "float"
|
||||||
TBool -> return "bool"
|
TBool -> pure "bool"
|
||||||
TNull -> return "null"
|
TNull -> pure "null"
|
||||||
TStr -> return "string"
|
TStr -> pure "string"
|
||||||
TList r -> do
|
TList r -> do
|
||||||
x <- demand r renderSymbolic
|
x <- demand r renderSymbolic
|
||||||
return $ "[" ++ x ++ "]"
|
pure $ "[" ++ x ++ "]"
|
||||||
TSet Nothing -> return "<any set>"
|
TSet Nothing -> pure "<any set>"
|
||||||
TSet (Just s) -> do
|
TSet (Just s) -> do
|
||||||
x <- traverse (`demand` renderSymbolic) s
|
x <- traverse (`demand` renderSymbolic) s
|
||||||
return $ "{" ++ show x ++ "}"
|
pure $ "{" ++ show x ++ "}"
|
||||||
f@(TClosure p) -> do
|
f@(TClosure p) -> do
|
||||||
(args, sym) <- do
|
(args, sym) <- do
|
||||||
f' <- mkSymbolic [f]
|
f' <- mkSymbolic [f]
|
||||||
lintApp (NAbs (void p) ()) f' everyPossible
|
lintApp (NAbs (void p) ()) f' everyPossible
|
||||||
args' <- traverse renderSymbolic args
|
args' <- traverse renderSymbolic args
|
||||||
sym' <- renderSymbolic sym
|
sym' <- renderSymbolic sym
|
||||||
return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
|
pure $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
|
||||||
TPath -> return "path"
|
TPath -> pure "path"
|
||||||
TBuiltin _n _f -> return "<builtin function>"
|
TBuiltin _n _f -> pure "<builtin function>"
|
||||||
|
|
||||||
-- This function is order and uniqueness preserving (of types).
|
-- This function is order and uniqueness preserving (of types).
|
||||||
merge
|
merge
|
||||||
|
@ -169,8 +169,8 @@ merge context = go
|
||||||
:: [NTypeF m (Symbolic m)]
|
:: [NTypeF m (Symbolic m)]
|
||||||
-> [NTypeF m (Symbolic m)]
|
-> [NTypeF m (Symbolic m)]
|
||||||
-> m [NTypeF m (Symbolic m)]
|
-> m [NTypeF m (Symbolic m)]
|
||||||
go [] _ = return []
|
go [] _ = pure []
|
||||||
go _ [] = return []
|
go _ [] = pure []
|
||||||
go (x : xs) (y : ys) = case (x, y) of
|
go (x : xs) (y : ys) = case (x, y) of
|
||||||
(TStr , TStr ) -> (TStr :) <$> go xs ys
|
(TStr , TStr ) -> (TStr :) <$> go xs ys
|
||||||
(TPath, TPath) -> (TPath :) <$> go xs ys
|
(TPath, TPath) -> (TPath :) <$> go xs ys
|
||||||
|
@ -188,8 +188,8 @@ merge context = go
|
||||||
>>= \j' -> demand i'
|
>>= \j' -> demand i'
|
||||||
$ \i'' -> demand j' $ \j'' -> defer $ unify context i'' j''
|
$ \i'' -> demand j' $ \j'' -> defer $ unify context i'' j''
|
||||||
)
|
)
|
||||||
(return <$> l)
|
(pure <$> l)
|
||||||
(return <$> r)
|
(pure <$> r)
|
||||||
if M.null m then go xs ys else (TSet (Just m) :) <$> go xs ys
|
if M.null m then go xs ys else (TSet (Just m) :) <$> go xs ys
|
||||||
(TClosure{}, TClosure{}) ->
|
(TClosure{}, TClosure{}) ->
|
||||||
throwError $ ErrorCall "Cannot unify functions"
|
throwError $ ErrorCall "Cannot unify functions"
|
||||||
|
@ -232,10 +232,10 @@ unify context (SV x) (SV y) = do
|
||||||
case (x', y') of
|
case (x', y') of
|
||||||
(NAny, _) -> do
|
(NAny, _) -> do
|
||||||
writeVar x y'
|
writeVar x y'
|
||||||
return $ SV y
|
pure $ SV y
|
||||||
(_, NAny) -> do
|
(_, NAny) -> do
|
||||||
writeVar y x'
|
writeVar y x'
|
||||||
return $ SV x
|
pure $ SV x
|
||||||
(NMany xs, NMany ys) -> do
|
(NMany xs, NMany ys) -> do
|
||||||
m <- merge context xs ys
|
m <- merge context xs ys
|
||||||
if null m
|
if null m
|
||||||
|
@ -321,7 +321,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
|
||||||
evalWith scope body = do
|
evalWith scope body = do
|
||||||
s <- defer scope
|
s <- defer scope
|
||||||
pushWeakScope ?? body $ demand s $ unpackSymbolic >=> \case
|
pushWeakScope ?? body $ demand s $ unpackSymbolic >=> \case
|
||||||
NMany [TSet (Just s')] -> return s'
|
NMany [TSet (Just s')] -> pure s'
|
||||||
NMany [TSet Nothing] -> error "NYI: with unknown"
|
NMany [TSet Nothing] -> error "NYI: with unknown"
|
||||||
_ -> throwError $ ErrorCall "scope must be a set in with statement"
|
_ -> throwError $ ErrorCall "scope must be a set in with statement"
|
||||||
|
|
||||||
|
@ -437,7 +437,7 @@ runLintM opts action = do
|
||||||
runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action
|
runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action
|
||||||
|
|
||||||
symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m))
|
symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m))
|
||||||
symbolicBaseEnv = return emptyScopes
|
symbolicBaseEnv = pure emptyScopes
|
||||||
|
|
||||||
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
|
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
|
||||||
lint opts expr =
|
lint opts expr =
|
||||||
|
|
|
@ -57,7 +57,7 @@ normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
||||||
go t k = do
|
go t k = do
|
||||||
b <- seen t
|
b <- seen t
|
||||||
if b
|
if b
|
||||||
then return $ Pure t
|
then pure $ Pure t
|
||||||
else do
|
else do
|
||||||
i <- ask
|
i <- ask
|
||||||
when (i > 2000)
|
when (i > 2000)
|
||||||
|
@ -69,7 +69,7 @@ normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
||||||
lift $ do
|
lift $ do
|
||||||
res <- gets (member tid)
|
res <- gets (member tid)
|
||||||
unless res $ modify (insert tid)
|
unless res $ modify (insert tid)
|
||||||
return res
|
pure res
|
||||||
|
|
||||||
normalForm
|
normalForm
|
||||||
:: ( Framed e m
|
:: ( Framed e m
|
||||||
|
|
|
@ -28,7 +28,7 @@ argPair :: Mod OptionFields (Text, Text) -> Parser (Text, Text)
|
||||||
argPair = option $ str >>= \s -> case Text.findIndex (== '=') s of
|
argPair = option $ str >>= \s -> case Text.findIndex (== '=') s of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr"
|
errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr"
|
||||||
Just i -> return $ second Text.tail $ Text.splitAt i s
|
Just i -> pure $ second Text.tail $ Text.splitAt i s
|
||||||
|
|
||||||
nixOptions :: UTCTime -> Parser Options
|
nixOptions :: UTCTime -> Parser Options
|
||||||
nixOptions current =
|
nixOptions current =
|
||||||
|
|
|
@ -127,7 +127,7 @@ nixSelect term = do
|
||||||
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
|
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
|
||||||
nixSelector = annotateLocation $ do
|
nixSelector = annotateLocation $ do
|
||||||
(x : xs) <- keyName `sepBy1` selDot
|
(x : xs) <- keyName `sepBy1` selDot
|
||||||
return $ x :| xs
|
pure $ x :| xs
|
||||||
|
|
||||||
nixTerm :: Parser NExprLoc
|
nixTerm :: Parser NExprLoc
|
||||||
nixTerm = do
|
nixTerm = do
|
||||||
|
@ -291,7 +291,7 @@ nixUri = lexeme $ annotateLocation1 $ try $ do
|
||||||
_ <- string ":"
|
_ <- string ":"
|
||||||
address <- some $ satisfy $ \x ->
|
address <- some $ satisfy $ \x ->
|
||||||
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
|
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
|
||||||
return $ NStr $ DoubleQuoted
|
pure $ NStr $ DoubleQuoted
|
||||||
[Plain $ pack $ start : protocol ++ ':' : address]
|
[Plain $ pack $ start : protocol ++ ':' : address]
|
||||||
|
|
||||||
nixString' :: Parser (NString NExprLoc)
|
nixString' :: Parser (NString NExprLoc)
|
||||||
|
@ -361,18 +361,18 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
|
||||||
atLeft = try $ do
|
atLeft = try $ do
|
||||||
name <- identifier <* symbol "@"
|
name <- identifier <* symbol "@"
|
||||||
(variadic, params) <- params
|
(variadic, params) <- params
|
||||||
return $ ParamSet params variadic (Just name)
|
pure $ ParamSet params variadic (Just name)
|
||||||
|
|
||||||
-- Parameters named by an identifier on the right, or none (`{x, y} @ args`)
|
-- Parameters named by an identifier on the right, or none (`{x, y} @ args`)
|
||||||
atRight = do
|
atRight = do
|
||||||
(variadic, params) <- params
|
(variadic, params) <- params
|
||||||
name <- optional $ symbol "@" *> identifier
|
name <- optional $ symbol "@" *> identifier
|
||||||
return $ ParamSet params variadic name
|
pure $ ParamSet params variadic name
|
||||||
|
|
||||||
-- Return the parameters set.
|
-- Return the parameters set.
|
||||||
params = do
|
params = do
|
||||||
(args, dotdots) <- braces getParams
|
(args, dotdots) <- braces getParams
|
||||||
return (dotdots, args)
|
pure (dotdots, args)
|
||||||
|
|
||||||
-- Collects the parameters within curly braces. Returns the parameters and
|
-- Collects the parameters within curly braces. Returns the parameters and
|
||||||
-- a boolean indicating if the parameters are variadic.
|
-- a boolean indicating if the parameters are variadic.
|
||||||
|
@ -488,7 +488,7 @@ identifier = lexeme $ try $ do
|
||||||
<$> satisfy (\x -> isAlpha x || x == '_')
|
<$> satisfy (\x -> isAlpha x || x == '_')
|
||||||
<*> takeWhileP Nothing identLetter
|
<*> takeWhileP Nothing identLetter
|
||||||
guard (not (ident `HashSet.member` reservedNames))
|
guard (not (ident `HashSet.member` reservedNames))
|
||||||
return ident
|
pure ident
|
||||||
where
|
where
|
||||||
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-'
|
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-'
|
||||||
|
|
||||||
|
@ -520,7 +520,7 @@ data Result a = Success a | Failure (Doc Void) deriving (Show, Functor)
|
||||||
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
|
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
|
||||||
parseFromFileEx p path = do
|
parseFromFileEx p path = do
|
||||||
txt <- decodeUtf8 <$> readFile path
|
txt <- decodeUtf8 <$> readFile path
|
||||||
return $ either (Failure . pretty . errorBundlePretty) Success $ parse p
|
pure $ either (Failure . pretty . errorBundlePretty) Success $ parse p
|
||||||
path
|
path
|
||||||
txt
|
txt
|
||||||
|
|
||||||
|
@ -564,7 +564,7 @@ opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a
|
||||||
opWithLoc name op f = do
|
opWithLoc name op f = do
|
||||||
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -}
|
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -}
|
||||||
operator name
|
operator name
|
||||||
return $ f (Ann ann op)
|
pure $ f (Ann ann op)
|
||||||
|
|
||||||
binaryN name op =
|
binaryN name op =
|
||||||
(NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary))
|
(NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary))
|
||||||
|
|
|
@ -78,17 +78,17 @@ lookupVarReader
|
||||||
lookupVarReader k = do
|
lookupVarReader k = do
|
||||||
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
|
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
|
||||||
case mres of
|
case mres of
|
||||||
Just sym -> return $ Just sym
|
Just sym -> pure $ Just sym
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
ws <- asks (dynamicScopes . view hasLens)
|
ws <- asks (dynamicScopes . view hasLens)
|
||||||
foldr
|
foldr
|
||||||
(\x rest -> do
|
(\x rest -> do
|
||||||
mres' <- M.lookup k . getScope <$> x
|
mres' <- M.lookup k . getScope <$> x
|
||||||
case mres' of
|
case mres' of
|
||||||
Just sym -> return $ Just sym
|
Just sym -> pure $ Just sym
|
||||||
Nothing -> rest
|
Nothing -> rest
|
||||||
)
|
)
|
||||||
(return Nothing)
|
(pure Nothing)
|
||||||
ws
|
ws
|
||||||
|
|
||||||
withScopes :: Scoped a m => Scopes m a -> m r -> m r
|
withScopes :: Scoped a m => Scopes m a -> m r -> m r
|
||||||
|
|
|
@ -224,7 +224,7 @@ addSingletonStringContext = WithStringContextT . tell . S.singleton
|
||||||
|
|
||||||
-- | Get the contents of a 'NixString' and write its context into the resulting set.
|
-- | Get the contents of a 'NixString' and write its context into the resulting set.
|
||||||
extractNixString :: Monad m => NixString -> WithStringContextT m Text
|
extractNixString :: Monad m => NixString -> WithStringContextT m Text
|
||||||
extractNixString (NixString s c) = WithStringContextT $ tell c >> return s
|
extractNixString (NixString s c) = WithStringContextT $ tell c >> pure s
|
||||||
|
|
||||||
-- | Run an action producing a string with a context and put those into a 'NixString'.
|
-- | Run an action producing a string with a context and put those into a 'NixString'.
|
||||||
runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString
|
runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString
|
||||||
|
|
|
@ -26,14 +26,14 @@ quoteExprExp :: String -> ExpQ
|
||||||
quoteExprExp s = do
|
quoteExprExp s = do
|
||||||
expr <- case parseNixText (Text.pack s) of
|
expr <- case parseNixText (Text.pack s) of
|
||||||
Failure err -> fail $ show err
|
Failure err -> fail $ show err
|
||||||
Success e -> return e
|
Success e -> pure e
|
||||||
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
|
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
|
||||||
|
|
||||||
quoteExprPat :: String -> PatQ
|
quoteExprPat :: String -> PatQ
|
||||||
quoteExprPat s = do
|
quoteExprPat s = do
|
||||||
expr <- case parseNixText (Text.pack s) of
|
expr <- case parseNixText (Text.pack s) of
|
||||||
Failure err -> fail $ show err
|
Failure err -> fail $ show err
|
||||||
Success e -> return e
|
Success e -> pure e
|
||||||
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
|
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
|
||||||
|
|
||||||
freeVars :: NExpr -> Set VarName
|
freeVars :: NExpr -> Set VarName
|
||||||
|
|
|
@ -58,7 +58,7 @@ queryThunk (Thunk _ active ref) n k = do
|
||||||
Computed v -> k v
|
Computed v -> k v
|
||||||
_ -> n
|
_ -> n
|
||||||
_ <- atomicModifyVar active (False, )
|
_ <- atomicModifyVar active (False, )
|
||||||
return res
|
pure res
|
||||||
|
|
||||||
forceThunk
|
forceThunk
|
||||||
:: forall m v a
|
:: forall m v a
|
||||||
|
@ -87,7 +87,7 @@ forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
|
||||||
forceEffects (Thunk _ active ref) k = do
|
forceEffects (Thunk _ active ref) k = do
|
||||||
nowActive <- atomicModifyVar active (True, )
|
nowActive <- atomicModifyVar active (True, )
|
||||||
if nowActive
|
if nowActive
|
||||||
then return $ error "Loop detected"
|
then pure $ error "Loop detected"
|
||||||
else do
|
else do
|
||||||
eres <- readVar ref
|
eres <- readVar ref
|
||||||
case eres of
|
case eres of
|
||||||
|
@ -103,4 +103,4 @@ furtherThunk t@(Thunk _ _ ref) k = do
|
||||||
_ <- atomicModifyVar ref $ \x -> case x of
|
_ <- atomicModifyVar ref $ \x -> case x of
|
||||||
Computed _ -> (x, x)
|
Computed _ -> (x, x)
|
||||||
Deferred d -> (Deferred (k d), x)
|
Deferred d -> (Deferred (k d), x)
|
||||||
return t
|
pure t
|
||||||
|
|
|
@ -45,7 +45,7 @@ import Prelude as X
|
||||||
trace :: String -> a -> a
|
trace :: String -> a -> a
|
||||||
trace = const id
|
trace = const id
|
||||||
traceM :: Monad m => String -> m ()
|
traceM :: Monad m => String -> m ()
|
||||||
traceM = const (return ())
|
traceM = const (pure ())
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix)
|
$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix)
|
||||||
|
@ -95,7 +95,7 @@ lifted
|
||||||
=> ((a -> m (StT u b)) -> m (StT u b))
|
=> ((a -> m (StT u b)) -> m (StT u b))
|
||||||
-> (a -> u m b)
|
-> (a -> u m b)
|
||||||
-> u m b
|
-> u m b
|
||||||
lifted f k = liftWith (\run -> f (run . k)) >>= restoreT . return
|
lifted f k = liftWith (\run -> f (run . k)) >>= restoreT . pure
|
||||||
|
|
||||||
freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f
|
freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f
|
||||||
freeToFix f = go
|
freeToFix f = go
|
||||||
|
|
|
@ -373,7 +373,7 @@ builtin
|
||||||
=> String
|
=> String
|
||||||
-> (NValue t f m -> m (NValue t f m))
|
-> (NValue t f m -> m (NValue t f m))
|
||||||
-> m (NValue t f m)
|
-> m (NValue t f m)
|
||||||
builtin name f = return $ nvBuiltin name $ \a -> f a
|
builtin name f = pure $ nvBuiltin name $ \a -> f a
|
||||||
|
|
||||||
builtin2
|
builtin2
|
||||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||||
|
|
|
@ -71,7 +71,7 @@ alignEqM
|
||||||
-> m Bool
|
-> m Bool
|
||||||
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
|
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
|
||||||
pairs <- forM (Data.Align.align fa fb) $ \case
|
pairs <- forM (Data.Align.align fa fb) $ \case
|
||||||
These a b -> return (a, b)
|
These a b -> pure (a, b)
|
||||||
_ -> throwE ()
|
_ -> throwE ()
|
||||||
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
|
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
|
||||||
|
|
||||||
|
@ -171,7 +171,7 @@ valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
|
||||||
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
|
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
|
||||||
thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
|
thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||||
let unsafePtrEq = case (lt, rt) of
|
let unsafePtrEq = case (lt, rt) of
|
||||||
(thunkId -> lid, thunkId -> rid) | lid == rid -> return True
|
(thunkId -> lid, thunkId -> rid) | lid == rid -> pure True
|
||||||
_ -> valueEqM lv rv
|
_ -> valueEqM lv rv
|
||||||
in case (lv, rv) of
|
in case (lv, rv) of
|
||||||
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
||||||
|
|
|
@ -18,7 +18,7 @@ import Text.XML.Light
|
||||||
toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString
|
toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString
|
||||||
toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi
|
toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi
|
||||||
where
|
where
|
||||||
cyc = return $ mkElem "string" "value" "<CYCLE>"
|
cyc = pure $ mkElem "string" "value" "<CYCLE>"
|
||||||
|
|
||||||
pp =
|
pp =
|
||||||
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
|
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
|
||||||
|
@ -30,18 +30,18 @@ toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi
|
||||||
phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
|
phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
|
||||||
phi = \case
|
phi = \case
|
||||||
NVConstant' a -> case a of
|
NVConstant' a -> case a of
|
||||||
NURI t -> return $ mkElem "string" "value" (Text.unpack t)
|
NURI t -> pure $ mkElem "string" "value" (Text.unpack t)
|
||||||
NInt n -> return $ mkElem "int" "value" (show n)
|
NInt n -> pure $ mkElem "int" "value" (show n)
|
||||||
NFloat f -> return $ mkElem "float" "value" (show f)
|
NFloat f -> pure $ mkElem "float" "value" (show f)
|
||||||
NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false")
|
NBool b -> pure $ mkElem "bool" "value" (if b then "true" else "false")
|
||||||
NNull -> return $ Element (unqual "null") [] [] Nothing
|
NNull -> pure $ Element (unqual "null") [] [] Nothing
|
||||||
|
|
||||||
NVStr' str ->
|
NVStr' str ->
|
||||||
mkElem "string" "value" . Text.unpack <$> extractNixString str
|
mkElem "string" "value" . Text.unpack <$> extractNixString str
|
||||||
NVList' l -> sequence l
|
NVList' l -> sequence l
|
||||||
>>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing
|
>>= \els -> pure $ Element (unqual "list") [] (Elem <$> els) Nothing
|
||||||
|
|
||||||
NVSet' s _ -> sequence s >>= \kvs -> return $ Element
|
NVSet' s _ -> sequence s >>= \kvs -> pure $ Element
|
||||||
(unqual "attrs")
|
(unqual "attrs")
|
||||||
[]
|
[]
|
||||||
(map
|
(map
|
||||||
|
@ -57,9 +57,9 @@ toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi
|
||||||
Nothing
|
Nothing
|
||||||
|
|
||||||
NVClosure' p _ ->
|
NVClosure' p _ ->
|
||||||
return $ Element (unqual "function") [] (paramsXML p) Nothing
|
pure $ Element (unqual "function") [] (paramsXML p) Nothing
|
||||||
NVPath' fp -> return $ mkElem "path" "value" fp
|
NVPath' fp -> pure $ mkElem "path" "value" fp
|
||||||
NVBuiltin' name _ -> return $ mkElem "function" "name" name
|
NVBuiltin' name _ -> pure $ mkElem "function" "name" name
|
||||||
_ -> error "Pattern synonyms mask coverage"
|
_ -> error "Pattern synonyms mask coverage"
|
||||||
|
|
||||||
mkElem :: String -> String -> String -> Element
|
mkElem :: String -> String -> String -> Element
|
||||||
|
|
|
@ -441,7 +441,7 @@ genEvalCompareTests = do
|
||||||
let unmaskedFiles = filter ((==".nix") . takeExtension) td
|
let unmaskedFiles = filter ((==".nix") . takeExtension) td
|
||||||
let files = unmaskedFiles \\ maskedFiles
|
let files = unmaskedFiles \\ maskedFiles
|
||||||
|
|
||||||
return $ testGroup "Eval comparison tests" $ map (mkTestCase testDir) files
|
pure $ testGroup "Eval comparison tests" $ map (mkTestCase testDir) files
|
||||||
where
|
where
|
||||||
mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> f)
|
mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> f)
|
||||||
|
|
||||||
|
@ -454,7 +454,7 @@ constantEqual expected actual = do
|
||||||
expectedNF <- normalForm =<< nixEvalExprLoc Nothing expected
|
expectedNF <- normalForm =<< nixEvalExprLoc Nothing expected
|
||||||
actualNF <- normalForm =<< nixEvalExprLoc Nothing actual
|
actualNF <- normalForm =<< nixEvalExprLoc Nothing actual
|
||||||
eq <- valueEqM expectedNF actualNF
|
eq <- valueEqM expectedNF actualNF
|
||||||
return (eq, expectedNF, actualNF)
|
pure (eq, expectedNF, actualNF)
|
||||||
let message =
|
let message =
|
||||||
"Inequal normal forms:\n"
|
"Inequal normal forms:\n"
|
||||||
<> "Expected: " <> printNix expectedNF <> "\n"
|
<> "Expected: " <> printNix expectedNF <> "\n"
|
||||||
|
|
|
@ -74,7 +74,7 @@ ensureNixpkgsCanParse =
|
||||||
-- Parse and deepseq the resulting expression tree, to ensure the
|
-- Parse and deepseq the resulting expression tree, to ensure the
|
||||||
-- parser is fully executed.
|
-- parser is fully executed.
|
||||||
_ <- consider file (parseNixFileLoc file) $ Exc.evaluate . force
|
_ <- consider file (parseNixFileLoc file) $ Exc.evaluate . force
|
||||||
return ()
|
pure ()
|
||||||
v -> error $ "Unexpected parse from default.nix: " ++ show v
|
v -> error $ "Unexpected parse from default.nix: " ++ show v
|
||||||
where
|
where
|
||||||
getExpr k m = let Just (Just r) = lookup k m in r
|
getExpr k m = let Just (Just r) = lookup k m in r
|
||||||
|
|
|
@ -86,7 +86,7 @@ genTests = do
|
||||||
let testsByName = groupBy (takeFileName . dropExtensions) testFiles
|
let testsByName = groupBy (takeFileName . dropExtensions) testFiles
|
||||||
let testsByType = groupBy testType (Map.toList testsByName)
|
let testsByType = groupBy testType (Map.toList testsByName)
|
||||||
let testGroups = map mkTestGroup (Map.toList testsByType)
|
let testGroups = map mkTestGroup (Map.toList testsByType)
|
||||||
return $ localOption (mkTimeout 2000000) $ testGroup
|
pure $ localOption (mkTimeout 2000000) $ testGroup
|
||||||
"Nix (upstream) language tests"
|
"Nix (upstream) language tests"
|
||||||
testGroups
|
testGroups
|
||||||
where
|
where
|
||||||
|
@ -105,7 +105,7 @@ genTests = do
|
||||||
|
|
||||||
assertParse :: Options -> FilePath -> Assertion
|
assertParse :: Options -> FilePath -> Assertion
|
||||||
assertParse _opts file = parseNixFileLoc file >>= \case
|
assertParse _opts file = parseNixFileLoc file >>= \case
|
||||||
Success _expr -> return () -- pure $! runST $ void $ lint opts expr
|
Success _expr -> pure () -- pure $! runST $ void $ lint opts expr
|
||||||
Failure err ->
|
Failure err ->
|
||||||
assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
|
assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
|
||||||
|
|
||||||
|
@ -121,9 +121,9 @@ assertParseFail opts file = do
|
||||||
++ file
|
++ file
|
||||||
++ ":\nParsed value: "
|
++ ":\nParsed value: "
|
||||||
++ show expr
|
++ show expr
|
||||||
Failure _ -> return ()
|
Failure _ -> pure ()
|
||||||
)
|
)
|
||||||
$ \(_ :: SomeException) -> return ()
|
$ \(_ :: SomeException) -> pure ()
|
||||||
|
|
||||||
assertLangOk :: Options -> FilePath -> Assertion
|
assertLangOk :: Options -> FilePath -> Assertion
|
||||||
assertLangOk opts file = do
|
assertLangOk opts file = do
|
||||||
|
@ -147,8 +147,8 @@ assertEval _opts files = do
|
||||||
[] -> () <$ hnixEvalFile opts (name ++ ".nix")
|
[] -> () <$ hnixEvalFile opts (name ++ ".nix")
|
||||||
[".exp" ] -> assertLangOk opts name
|
[".exp" ] -> assertLangOk opts name
|
||||||
[".exp.xml" ] -> assertLangOkXml opts name
|
[".exp.xml" ] -> assertLangOkXml opts name
|
||||||
[".exp.disabled"] -> return ()
|
[".exp.disabled"] -> pure ()
|
||||||
[".exp-disabled"] -> return ()
|
[".exp-disabled"] -> pure ()
|
||||||
[".exp", ".flags"] -> do
|
[".exp", ".flags"] -> do
|
||||||
liftIO $ setEnv "NIX_PATH" "lang/dir4:lang/dir5"
|
liftIO $ setEnv "NIX_PATH" "lang/dir4:lang/dir5"
|
||||||
flags <- Text.readFile (name ++ ".flags")
|
flags <- Text.readFile (name ++ ".flags")
|
||||||
|
@ -179,7 +179,7 @@ assertEval _opts files = do
|
||||||
fixup [] = []
|
fixup [] = []
|
||||||
|
|
||||||
assertEvalFail :: FilePath -> Assertion
|
assertEvalFail :: FilePath -> Assertion
|
||||||
assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do
|
assertEvalFail file = catch ?? (\(_ :: SomeException) -> pure ()) $ do
|
||||||
time <- liftIO getCurrentTime
|
time <- liftIO getCurrentTime
|
||||||
evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file
|
evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file
|
||||||
evalResult
|
evalResult
|
||||||
|
|
|
@ -383,7 +383,7 @@ assertParseFile file expected = do
|
||||||
|
|
||||||
assertParseFail :: Text -> Assertion
|
assertParseFail :: Text -> Assertion
|
||||||
assertParseFail str = case parseNixText str of
|
assertParseFail str = case parseNixText str of
|
||||||
Failure _ -> return ()
|
Failure _ -> pure ()
|
||||||
Success r ->
|
Success r ->
|
||||||
assertFailure $ "Unexpected success parsing `"
|
assertFailure $ "Unexpected success parsing `"
|
||||||
++ unpack str ++ ":\nParsed value: " ++ show r
|
++ unpack str ++ ":\nParsed value: " ++ show r
|
||||||
|
|
|
@ -58,7 +58,7 @@ nixEvalString expr = do
|
||||||
hClose h
|
hClose h
|
||||||
res <- nixEvalFile fp
|
res <- nixEvalFile fp
|
||||||
removeLink fp
|
removeLink fp
|
||||||
return res
|
pure res
|
||||||
|
|
||||||
nixEvalFile :: FilePath -> IO String
|
nixEvalFile :: FilePath -> IO String
|
||||||
nixEvalFile fp = readProcess "nix-instantiate" ["--eval", "--strict", fp] ""
|
nixEvalFile fp = readProcess "nix-instantiate" ["--eval", "--strict", fp] ""
|
||||||
|
|
Loading…
Reference in New Issue