hnix/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