hnix-0.10.0: main/Main.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import Control.Comonad ( extract )
import qualified Control.DeepSeq as Deep
import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Free
import Control.Monad.IO.Class
-- import Control.Monad.ST
import qualified Data.HashMap.Lazy as M
import qualified Data.Map as Map
import Data.List ( sortOn )
import Data.Maybe ( fromJust )
import Data.Time
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Nix
import Nix.Convert
import qualified Nix.Eval as Eval
import Nix.Fresh.Basic
import Nix.Json
-- import Nix.Lint
import Nix.Options.Parser
import Nix.Standard
import Nix.Thunk.Basic
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import Nix.Utils
import Nix.Var
import Nix.Value.Monad
import Options.Applicative hiding ( ParserResult(..) )
import Prettyprinter
import Prettyprinter.Render.Text
import qualified Repl
import System.FilePath
import System.IO
import qualified Text.Show.Pretty as PS
main :: IO ()
main = do
time <- getCurrentTime
opts <- execParser (nixOptionsInfo time)
runWithBasicEffectsIO opts $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
Nothing -> case expression opts of
Just s -> handleResult opts Nothing (parseNixTextLoc s)
Nothing -> case fromFile opts of
Just "-" -> mapM_ (processFile opts) =<< (lines <$> liftIO getContents)
Just path ->
mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path))
Nothing -> case filePaths opts of
[] -> withNixContext Nothing $ Repl.main
["-"] ->
handleResult opts Nothing
. parseNixTextLoc
=<< liftIO Text.getContents
paths -> mapM_ (processFile opts) paths
where
processFile opts path = do
eres <- parseNixFileLoc path
handleResult opts (Just path) eres
handleResult opts mpath = \case
Failure err ->
(if ignoreErrors opts
then liftIO . hPutStrLn stderr
else errorWithoutStackTrace
)
$ "Parse failed: "
++ show err
Success expr -> do
when (check opts) $ do
expr' <- liftIO (reduceExpr mpath expr)
case HM.inferTop Env.empty [("it", stripAnnotation expr')] of
Left err -> errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
Right ty -> liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow
(fromJust (Map.lookup "it" (Env.types ty)))
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (process opts mpath expr) $ \case
NixException frames ->
errorWithoutStackTrace
. show
=<< renderFrames @(StdValue (StandardT (StdIdT IO)))
@(StdThunk (StandardT (StdIdT IO)))
frames
when (repl opts) $
if evaluate opts
then do
val <- Nix.nixEvalExprLoc mpath expr
withNixContext Nothing (Repl.main' $ Just val)
else withNixContext Nothing Repl.main
process opts mpath expr
| evaluate opts
, tracing opts
= evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr
| evaluate opts
, Just path <- reduce opts
= evaluateExpression mpath (reduction path) printer expr
| evaluate opts
, not (null (arg opts) && null (argstr opts))
= evaluateExpression mpath Nix.nixEvalExprLoc printer expr
| evaluate opts
= processResult printer =<< Nix.nixEvalExprLoc mpath expr
| xml opts
= error "Rendering expression trees to XML is not yet implemented"
| json opts
= error "Rendering expression trees to JSON is not implemented"
| verbose opts >= DebugInfo
= liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
| cache opts
, Just path <- mpath
= liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
| parseOnly opts
= void $ liftIO $ Exc.evaluate $ Deep.force expr
| otherwise
= liftIO
$ renderIO stdout
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
. prettyNix
. stripAnnotation
$ expr
where
printer
| finder opts
= fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) >=> findAttrs
| xml opts
= liftIO
. putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts
= liftIO
. Text.putStrLn
. principledStringIgnoreContext
<=< nvalueToJSONNixString
| strict opts
= liftIO . print . prettyNValue <=< normalForm
| values opts
= liftIO . print . prettyNValueProv <=< removeEffects
| otherwise
= liftIO . print . prettyNValue <=< removeEffects
where
findAttrs
:: AttrSet (StdValue (StandardT (StdIdT IO)))
-> StandardT (StdIdT IO) ()
findAttrs = go ""
where
go prefix s = do
xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of
Free v -> pure (k, Just (Free v))
Pure (StdThunk (extract -> Thunk _ _ ref)) -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar @(StandardT (StdIdT IO)) ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k, ) <$> forceEntry path nv
| otherwise -> pure (k, Nothing)
forM_ xs $ \(k, mv) -> do
let path = prefix ++ Text.unpack k
(report, descend) = filterEntry path k
when report $ do
liftIO $ putStrLn path
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ -> go (path ++ ".") s'
_ -> return ()
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 k v =
catch (Just <$> demand v pure) $ \(NixException frames) -> do
liftIO
. putStrLn
. ("Exception forcing " ++)
. (k ++)
. (": " ++)
. show
=<< renderFrames @(StdValue (StandardT (StdIdT IO)))
@(StdThunk (StandardT (StdIdT IO)))
frames
return Nothing
reduction path mp x = do
eres <- Nix.withNixContext mp
$ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
handleReduced path eres
handleReduced
:: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path
writeFile path $ show $ prettyNix (stripAnnotation expr')
case eres of
Left err -> throwM err
Right v -> return v