diff --git a/hnix.cabal b/hnix.cabal index 59b4357..ed47e83 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: aff8893297c028f78cd881c18224a6acbd05d797c4eb702bdcabcbb2341a0891 +-- hash: 2b1afd3f4604aa1943b1ff294fdcebd3f08c880354229c9005b9d44c0c40794d name: hnix version: 0.5.0 @@ -53,6 +53,7 @@ library Nix.Parser.Library Nix.Parser.Operators Nix.Pretty + Nix.Reduce Nix.Scope Nix.Stack Nix.StringOperations diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs new file mode 100644 index 0000000..e60b6ad --- /dev/null +++ b/src/Nix/Reduce.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module provides a "reducing" expression evaluator, which reduces +-- away pure, non self-referential aspects of an expression tree, yielding a +-- new expression tree. It does not yet attempt to reduce everything +-- possible, and will always yield a tree with the same meaning as the +-- original. It should be seen as an opportunistic simplifier, but which +-- gives up easily if faced with any potential for ambiguity in the result. + +module Nix.Reduce (reduceExpr) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) +import Data.Fix +-- import Data.Foldable (foldrM) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as M +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (catMaybes) +import Nix.Atoms +import Nix.Exec +import Nix.Expr +import Nix.Parser +import Nix.Scope +import Nix.Utils +import System.Directory +import System.FilePath +import Text.Megaparsec.Pos + +newtype Reducer m a = Reducer + { runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc) + (StateT (HashMap FilePath NExprLoc) m) a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, + MonadFix, MonadIO, + MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc), + MonadState (HashMap FilePath NExprLoc)) + +instance Has (Maybe FilePath, Scopes m v) (Scopes m v) where + hasLens f (x, y) = (x,) <$> f y + +reduceExpr :: MonadIO m => Maybe FilePath -> NExprLoc -> m NExprLoc +reduceExpr mpath expr + = (`evalStateT` M.empty) + . (`runReaderT` (mpath, emptyScopes)) + . runReducer + $ cata reduce expr + +reduce :: forall e m. + (MonadIO m, Scoped e NExprLoc m, + MonadReader (Maybe FilePath, Scopes m NExprLoc) m, + MonadState (HashMap FilePath NExprLoc) m) + => NExprLocF (m NExprLoc) -> m NExprLoc + +reduce (NSym_ ann var) = lookupVar var <&> \case + Nothing -> Fix (NSym_ ann var) + Just v -> v + +reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of + (NNeg, Fix (NConstant_ cann (NInt n))) -> + return $ Fix $ NConstant_ cann (NInt (negate n)) + (NNot, Fix (NConstant_ cann (NBool b))) -> + return $ Fix $ NConstant_ cann (NBool (not b)) + _ -> return $ Fix $ NUnary_ uann op x + +reduce (NBinary_ bann NApp fun arg) = fun >>= \case + f@(Fix (NSym_ _ "import")) -> do + mfile <- asks fst + imports <- get + arg >>= \case + Fix (NLiteralPath_ pann origPath) + | Just expr <- M.lookup origPath imports -> pure expr + | otherwise -> do + path <- liftIO $ pathToDefaultNixFile origPath + path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath + (maybe path (\p -> takeDirectory p path) mfile) + + liftIO $ putStrLn $ "Importing file " ++ path' + + eres <- liftIO $ parseNixFileLoc path' + case eres of + Failure err -> error $ "Parse failed: " ++ show err + Success x -> do + let pos = SourcePos "Trace.hs" (mkPos 1) (mkPos 1) + span = SrcSpan pos pos + cur = NamedVar + (StaticKey "__cur_file" (Just pos) :| []) + (Fix (NLiteralPath_ pann path')) + x' = Fix (NLet_ span [cur] x) + modify (M.insert origPath x') + local (const (Just path', + emptyScopes @m @NExprLoc)) $ do + x'' <- cata reduce x' + modify (M.insert origPath x'') + return x'' + v -> return $ Fix $ NBinary_ bann NApp f v + + Fix (NAbs_ _ (Param name) body) -> do + x <- arg + pushScope (M.singleton name x) (cata reduce body) + + -- jww (2018-04-19): Reduce function application on sets + + f -> Fix . NBinary_ bann NApp f <$> arg + +-- jww (2018-04-19): Reduce more binary operations on constants +reduce (NBinary_ bann op larg rarg) = do + lval <- larg + rval <- rarg + case (op, lval, rval) of + (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> + return $ Fix (NConstant_ ann (NInt (x + y))) + _ -> pure $ Fix $ NBinary_ bann op lval rval + +-- jww (2018-04-19): Reduce selection if we can see it all +-- reduce (NSelect aset attr alt) = do + +-- jww (2018-04-19): If aset is known to be a set, and attr is a static path, +-- see if we can do the lookup now. +-- reduce (NHasAttr aset attr) = + +reduce e@(NSet_ ann binds) = do + let usesInherit = flip any binds $ \case + Inherit _ _ -> True + _ -> False + if usesInherit + then do + -- mv <- lookupVar "callLibs" + clearScopes @NExprLoc $ + -- (case mv of + -- Nothing -> id + -- Just v -> pushScope @NExprLoc (M.singleton "callLibs" v)) $ + Fix . NSet_ ann <$> traverse sequence binds + else Fix <$> sequence e + +-- Encountering a 'rec set' construction eliminates any hope of inlining +-- definitions. +reduce (NRecSet_ ann binds) = + clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds + +-- Encountering a 'with' construction eliminates any hope of inlining +-- definitions. +reduce (NWith_ ann scope body) = do + -- mv <- lookupVar "callLibs" + clearScopes @NExprLoc $ + -- (case mv of + -- Nothing -> id + -- Just v -> pushScope @NExprLoc (M.singleton "callLibs" v)) $ + fmap Fix $ NWith_ ann <$> scope <*> body + +reduce (NLet_ ann binds body) = do + -- We only handle in order definitions... + -- s <- go M.empty binds -- jww (2018-04-20): too slow + s <- fmap (M.fromList . catMaybes) $ forM binds $ \case + NamedVar (StaticKey name _ :| []) def -> def >>= \case + d@(Fix NAbs_ {}) -> pure $ Just (name, d) + d@(Fix NConstant_ {}) -> pure $ Just (name, d) + d@(Fix NStr_ {}) -> pure $ Just (name, d) + _ -> pure Nothing + _ -> pure Nothing + fmap Fix $ NLet_ ann <$> traverse sequence binds <*> pushScope s body + -- where + -- go m [] = pure m + -- go m (x:xs) = case x of + -- NamedVar (StaticKey name _ :| []) def -> do + -- v <- pushScope m def + -- go (M.insert name v m) xs + -- _ -> go m xs + +reduce e@(NIf_ _ b t f) = b >>= \case + Fix (NConstant_ _ (NBool b')) -> if b' then t else f + _ -> Fix <$> sequence e + +reduce e@(NAssert_ _ b body) = b >>= \case + Fix (NConstant_ _ (NBool b')) | b' -> body + _ -> Fix <$> sequence e + +reduce (NAbs_ ann params body) = do + params' <- sequence params + -- Make sure that variable definitions in scope do not override function + -- arguments. + let args = case params' of + Param name -> M.singleton name (Fix (NSym_ ann name)) + ParamSet pset _ _ -> + M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset + Fix . NAbs_ ann params' <$> pushScope args body + +reduce v = Fix <$> sequence v diff --git a/src/Nix/Trace.hs b/src/Nix/Trace.hs index 451a434..a671932 100644 --- a/src/Nix/Trace.hs +++ b/src/Nix/Trace.hs @@ -24,57 +24,19 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Control.Monad.Trans.State import Data.Fix import Data.Functor.Compose import Data.IORef -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.Maybe (maybe, fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Nix.Atoms -import Nix.Exec import Nix.Expr -import Nix.Parser +import Nix.Reduce import Nix.Stack import Nix.Utils -import System.Directory -import System.FilePath import Text.Megaparsec.Pos -processImports :: Maybe FilePath - -> NExprLoc - -> StateT (HashMap FilePath NExprLoc) IO NExprLoc -processImports mfile expr = do - imports <- get - flip cataM expr $ \case - Compose (Ann _ (NBinary NApp - (Fix (Compose (Ann _ (NSym "import")))) - (Fix (Compose (Ann _ (NLiteralPath origPath)))))) - | Just expr <- M.lookup origPath imports -> pure expr - | otherwise -> do - path <- liftIO $ pathToDefaultNixFile origPath - path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath - (maybe path (\p -> takeDirectory p path) mfile) - - traceM $ "Importing file " ++ path' - - eres <- liftIO $ parseNixFileLoc path' - case eres of - Failure err -> error $ "Parse failed: " ++ show err - Success x -> do - let pos = SourcePos "Trace.hs" (mkPos 1) (mkPos 1) - span = SrcSpan pos pos - cur = NamedVar - (StaticKey "__cur_file" (Just pos) :| []) - (Fix (Compose (Ann span (NLiteralPath path')))) - x' = Fix (Compose (Ann span (NLet [cur] x))) - modify (M.insert origPath x') - processImports (Just path') x' - x -> pure $ Fix x - newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) } deriving (Functor, Foldable, Traversable) @@ -200,8 +162,7 @@ tracingEvalExpr :: (Framed e m, Exception r, MonadCatch m, MonadIO m, => (NExprF (m v) -> m v) -> Maybe FilePath -> NExprLoc -> n (m (NExprLoc, Either r v)) tracingEvalExpr eval mpath expr = do - expr' <- flagExprLoc - =<< liftIO (evalStateT (processImports mpath expr) M.empty) + expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) res <- flip runReaderT (0 :: Int) $ adiM (pure <$> eval . annotated . getCompose . snd . flagged) psi expr' @@ -215,10 +176,12 @@ tracingEvalExpr eval mpath expr = do guard (depth < 200) local succ $ do action <- k v + -- jww (2018-04-20): We should be able to compose this evaluator + -- with framedEvalExpr, rather than replicating its behavior here. return $ withExprContext (stripFlags v) $ do - liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' - ++ show (void (unFix (stripAnnotation (stripFlags v)))) + -- liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' + -- ++ show (void (unFix (stripAnnotation (stripFlags v)))) liftIO $ writeIORef b True res <- action - liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' ++ "." + -- liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' ++ "." return res