hnix-0.17.0: main/Main.hs
{-# language MultiWayIf #-}
{-# language TypeFamilies #-}
{-# language RecordWildCards #-}
module Main ( main ) where
import Nix.Prelude
import Relude as Prelude ( force )
import Control.Comonad ( extract )
import qualified Control.Exception as Exception
import GHC.Err ( errorWithoutStackTrace )
import Control.Monad.Free
import Control.Monad.Ref ( MonadRef(readRef) )
import Control.Monad.Catch
import System.IO ( hPutStrLn )
import qualified Data.HashMap.Lazy as M
import qualified Data.Map as Map
import Data.Time
import qualified Data.Text.IO as Text
import Text.Show.Pretty ( ppShow )
import Nix hiding ( force )
import Nix.Convert
import Nix.Json
import Nix.Options.Parser
import Nix.Standard
import Nix.Thunk.Basic
import Nix.Type.Env ( Env(..) )
import Nix.Type.Type ( Scheme )
import qualified Nix.Type.Infer as HM
import Nix.Value.Monad
import Options.Applicative hiding ( ParserResult(..) )
import Prettyprinter hiding ( list )
import Prettyprinter.Render.Text ( renderIO )
import qualified Repl
import Nix.Eval
main :: IO ()
main =
do
currentTime <- getCurrentTime
opts <- execParser $ nixOptionsInfo currentTime
main' opts
main' :: Options -> IO ()
main' opts@Options{..} = runWithBasicEffectsIO opts execContentsFilesOrRepl
where
-- 2021-07-15: NOTE: This logic should be weaved stronger through CLI options logic (OptParse-Applicative code)
-- As this logic is not stated in the CLI documentation, for example. So user has no knowledge of these.
execContentsFilesOrRepl :: StdIO
execContentsFilesOrRepl =
fromMaybe
loadFromCliFilePathList
$ loadBinaryCacheFile <|>
loadLiteralExpression <|>
loadExpressionFromFile
where
-- | The base case: read expressions from the last CLI directive (@[FILE]@) listed on the command line.
loadFromCliFilePathList :: StdIO
loadFromCliFilePathList =
case getFilePaths of
[] -> runRepl
["-"] -> readExpressionFromStdin
_paths -> processSeveralFiles (coerce _paths)
where
-- | Fall back to running the REPL
runRepl = withEmptyNixContext Repl.main
readExpressionFromStdin =
processExpr =<< liftIO Text.getContents
processSeveralFiles :: [Path] -> StdIO
processSeveralFiles = traverse_ processFile
where
processFile path = handleResult (pure path) =<< parseNixFileLoc path
-- | The `--read` option: load expression from a serialized file.
loadBinaryCacheFile :: Maybe StdIO
loadBinaryCacheFile =
(\ (binaryCacheFile :: Path) ->
do
let file = replaceExtension binaryCacheFile "nixc"
processCLIOptions (pure file) =<< liftIO (readCache binaryCacheFile)
) <$> getReadFrom
-- | The `--expr` option: read expression from the argument string
loadLiteralExpression :: Maybe StdIO
loadLiteralExpression = processExpr <$> getExpression
-- | The `--file` argument: read expressions from the files listed in the argument file
loadExpressionFromFile :: Maybe StdIO
loadExpressionFromFile =
-- We can start use Text as in the base case, requires changing Path -> Text
-- But that is a gradual process:
-- https://github.com/haskell-nix/hnix/issues/912
(processSeveralFiles . (coerce . toString <$>) . lines <=< liftIO) .
(\case
"-" -> Text.getContents
_fp -> readFile _fp
) <$> getFromFile
processExpr :: Text -> StdIO
processExpr = handleResult mempty . parseNixTextLoc
withEmptyNixContext = withNixContext mempty
-- 2021-07-15: NOTE: @handleResult@ & @process@ - have atrocious size & compexity, they need to be decomposed & refactored.
handleResult mpath =
either
(\ err ->
bool
errorWithoutStackTrace
(liftIO . hPutStrLn stderr)
isIgnoreErrors
$ "Parse failed: " <> show err
)
(\ expr ->
do
when isCheck $
do
expr' <- liftIO $ reduceExpr mpath expr
either
(\ err -> errorWithoutStackTrace $ "Type error: " <> ppShow err)
(liftIO . putStrLn . (<>) "Type of expression: " .
ppShow . maybeToMonoid . Map.lookup @VarName @[Scheme] "it" . coerce
)
$ HM.inferTop mempty $ curry one "it" $ stripAnnotation expr'
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (processCLIOptions mpath expr) $
\case
NixException frames ->
errorWithoutStackTrace . show =<<
renderFrames
@StdVal
@StdThun
frames
when isRepl $
withEmptyNixContext $
bool
Repl.main
((Repl.main' . pure) =<< nixEvalExprLoc (coerce mpath) expr)
isEvaluate
)
-- 2021-07-15: NOTE: Logic of CLI Option processing is scattered over several functions, needs to be consolicated.
processCLIOptions :: Maybe Path -> NExprLoc -> StdIO
processCLIOptions mpath expr
| isEvaluate =
if
| isTrace -> evaluateExprWith nixTracingEvalExprLoc expr
| Just path <- getReduce -> evaluateExprWith (reduction path . coerce) expr
| null getArg || null getArgstr -> evaluateExprWith nixEvalExprLoc expr
| otherwise -> processResult printer <=< nixEvalExprLoc (coerce mpath) $ expr
| isXml = fail "Rendering expression trees to XML is not yet implemented"
| isJson = fail "Rendering expression trees to JSON is not implemented"
| getVerbosity >= DebugInfo = liftIO . putStr . ppShow . stripAnnotation $ expr
| isCache , Just path <- mpath = liftIO . writeCache (replaceExtension path "nixc") $ expr
| isParseOnly = void . liftIO . Exception.evaluate . force $ expr
| otherwise =
liftIO .
renderIO
stdout
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
. prettyNix
. stripAnnotation
$ expr
where
evaluateExprWith evaluator = evaluateExpression (coerce mpath) evaluator printer
printer
:: StdVal
-> StdIO
printer
| isFinder = findAttrs <=< fromValue @(AttrSet StdVal)
| otherwise = printer'
where
-- 2021-05-27: NOTE: With naive fix of the #941
-- This is overall a naive printer implementation, as options should interact/respect one another.
-- A nice question: "Should respect one another to what degree?": Go full combinator way, for which
-- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI),
-- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys.
printer'
| isXml = out (ignoreContext . toXML) normalForm
| isJson = out (ignoreContext . mempty . toJSONNixString) normalForm
| isStrict = out (show . prettyNValue) normalForm
| isValues = out (show . prettyNValueProv) removeEffects
| otherwise = out (show . prettyNValue) removeEffects
where
out
:: (b -> Text)
-> (a -> StandardIO b)
-> a
-> StdIO
out transform val = liftIO . Text.putStrLn . transform <=< val
findAttrs
:: AttrSet StdVal
-> StdIO
findAttrs = go mempty
where
go :: Text -> AttrSet StdVal -> StdIO
go prefix s =
traverse_
(\ (k, mv) ->
do
let
path = prefix <> k
(report, descend) = filterEntry path k
when report $
do
liftIO $ Text.putStrLn path
when descend $
maybe
stub
(\case
NVSet _ s' -> go (path <> ".") s'
_ -> stub
)
mv
)
=<< traverse
(\ (k, nv) ->
(k, ) <$>
free
(\ (StdThunk (extract -> Thunk _ _ ref)) ->
do
let
path = prefix <> k
(_, descend) = filterEntry path k
val <- readRef @StandardIO ref
bool
(pure Nothing)
(forceEntry path nv)
(descend &&
deferred
(const False)
(const True)
val
)
)
(pure . pure . Free)
nv
)
(sortWith fst $ M.toList $ M.mapKeys coerce s)
where
filterEntry path k = case (path, k) of
("stdenv", "stdenv" ) -> (True , True )
(_ , "stdenv" ) -> (False, False)
(_ , "out" ) -> (True , False)
(_ , "src" ) -> (True , False)
(_ , "mirrorsFile" ) -> (True , False)
(_ , "buildPhase" ) -> (True , False)
(_ , "builder" ) -> (False, False)
(_ , "drvPath" ) -> (False, False)
(_ , "outPath" ) -> (False, False)
(_ , "__impureHostDeps") -> (False, False)
(_ , "__sandboxProfile") -> (False, False)
("pkgs" , "pkgs" ) -> (True , True )
(_ , "pkgs" ) -> (False, False)
(_ , "drvAttrs" ) -> (False, False)
_ -> (True , True )
forceEntry
:: MonadValue a StandardIO
=> Text
-> a
-> StandardIO (Maybe a)
forceEntry k v =
catch
(pure <$> demand v)
fun
where
fun :: NixException -> StandardIO (Maybe a)
fun (coerce -> frames) =
do
liftIO
. Text.putStrLn
. (("Exception forcing " <> k <> ": ") <>)
. show =<<
renderFrames
@StdVal
@StdThun
frames
pure Nothing
reduction path mpathToContext annExpr =
do
eres <-
withNixContext
mpathToContext
$ reducingEvalExpr
evalContent
mpathToContext
annExpr
handleReduced path eres
handleReduced
:: (MonadThrow m, MonadIO m)
=> Path
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced (coerce -> path) (expr', eres) =
do
liftIO $
do
putStrLn $ "Wrote sifted expression tree to " <> path
writeFile path $ show $ prettyNix $ stripAnnotation expr'
either throwM pure eres