hnix-0.15.0: main/Main.hs
{-# language MultiWayIf #-}
{-# language TypeFamilies #-}
{-# language RecordWildCards #-}
module Main ( main ) where
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.Fresh.Basic
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
time <- getCurrentTime
opts <- execParser $ nixOptionsInfo time
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 :: StandardT (StdIdT IO) ()
execContentsFilesOrRepl =
fromMaybe
loadFromCliFilePathList
( loadBinaryCacheFile <|>
loadLiteralExpression <|>
loadExpressionFromFile
)
where
-- | The base case: read expressions from the last CLI directive (@[FILE]@) listed on the command line.
loadFromCliFilePathList =
case filePaths of
[] -> runRepl
["-"] -> readExpressionFromStdin
_paths -> processSeveralFiles (coerce _paths)
where
-- | Fall back to running the REPL
runRepl = withEmptyNixContext Repl.main
readExpressionFromStdin =
do
expr <- liftIO Text.getContents
processExpr expr
processSeveralFiles :: [Path] -> StandardT (StdIdT IO) ()
processSeveralFiles = traverse_ processFile
where
processFile path = handleResult (pure path) =<< parseNixFileLoc path
-- | The `--read` option: load expression from a serialized file.
loadBinaryCacheFile =
(\ (binaryCacheFile :: Path) ->
do
let file = replaceExtension binaryCacheFile "nixc"
processCLIOptions (Just file) =<< liftIO (readCache binaryCacheFile)
) <$> readFrom
-- | The `--expr` option: read expression from the argument string
loadLiteralExpression = processExpr <$> expression
-- | The `--file` argument: read expressions from the files listed in the argument file
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
) <$> fromFile
processExpr text = handleResult Nothing $ parseNixTextLoc text
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)
ignoreErrors
$ "Parse failed: " <> show err
)
(\ expr ->
do
when check $
do
expr' <- liftIO $ reduceExpr mpath expr
either
(\ err -> errorWithoutStackTrace $ "Type error: " <> ppShow err)
(\ ty -> liftIO $ putStrLn $ "Type of expression: " <>
ppShow (maybeToMonoid $ Map.lookup @VarName @[Scheme] "it" $ coerce ty)
)
(HM.inferTop mempty (one ("it", stripAnnotation expr')))
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (processCLIOptions mpath expr) $
\case
NixException frames ->
errorWithoutStackTrace . show =<<
renderFrames
@(StdValue (StandardT (StdIdT IO)))
@(StdThunk (StandardT (StdIdT IO)))
frames
when repl $
withEmptyNixContext $
bool
Repl.main
(do
val <- nixEvalExprLoc (coerce mpath) expr
Repl.main' $ pure val
)
evaluate
)
-- 2021-07-15: NOTE: Logic of CLI Option processing is scattered over several functions, needs to be consolicated.
processCLIOptions :: Maybe Path -> NExprLoc -> StandardT (StdIdT IO) ()
processCLIOptions mpath expr
| evaluate =
if
| tracing -> evaluateExprWithEvaluator nixTracingEvalExprLoc expr
| Just path <- reduce -> evaluateExprWithEvaluator (reduction path . coerce) expr
| null arg || null argstr -> evaluateExprWithEvaluator nixEvalExprLoc expr
| otherwise -> processResult printer <=< nixEvalExprLoc (coerce mpath) $ expr
| xml = fail "Rendering expression trees to XML is not yet implemented"
| json = fail "Rendering expression trees to JSON is not implemented"
| verbose >= DebugInfo = liftIO . putStr . ppShow . stripAnnotation $ expr
| cache , Just path <- mpath = liftIO . writeCache (replaceExtension path "nixc") $ expr
| parseOnly = void . liftIO . Exception.evaluate . force $ expr
| otherwise =
liftIO .
renderIO
stdout
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
. prettyNix
. stripAnnotation
$ expr
where
evaluateExprWithEvaluator evaluator = evaluateExpression (coerce mpath) evaluator printer
printer
| finder = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO))))
| otherwise = printer'
where
printer'
| xml = go (stringIgnoreContext . toXML) normalForm
-- 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.
| json = go (stringIgnoreContext . mempty . nvalueToJSONNixString) normalForm
| strict = go (show . prettyNValue) normalForm
| values = go (show . prettyNValueProv) removeEffects
| otherwise = go (show . prettyNValue) removeEffects
where
go
:: (b -> Text)
-> (a -> StandardT (StdIdT IO) b)
-> a
-> StandardT (StdIdT IO) ()
go g f = liftIO . Text.putStrLn . g <=< f
findAttrs
:: AttrSet (StdValue (StandardT (StdIdT IO)))
-> StandardT (StdIdT IO) ()
findAttrs = go mempty
where
go prefix s =
do
xs <-
traverse
(\ (k, nv) ->
(k, ) <$>
free
(\ (StdThunk (extract -> Thunk _ _ ref)) ->
do
let
path = prefix <> k
(_, descend) = filterEntry path k
val <- readRef @(StandardT (StdIdT IO)) 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)
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
)
xs
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 (StandardT (StdIdT IO))
=> Text
-> a
-> StandardT (StdIdT IO) (Maybe a)
forceEntry k v =
catch
(pure <$> demand v)
(\ (NixException frames) ->
do
liftIO
. Text.putStrLn
. (("Exception forcing " <> k <> ": ") <>)
. show =<<
renderFrames
@(StdValue (StandardT (StdIdT IO)))
@(StdThunk (StandardT (StdIdT IO)))
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