Add a constant-folding tree transformer: Reduce.reduceExpr
This commit is contained in:
parent
bf0dd66624
commit
986a3043da
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: aff8893297c028f78cd881c18224a6acbd05d797c4eb702bdcabcbb2341a0891
|
-- hash: 2b1afd3f4604aa1943b1ff294fdcebd3f08c880354229c9005b9d44c0c40794d
|
||||||
|
|
||||||
name: hnix
|
name: hnix
|
||||||
version: 0.5.0
|
version: 0.5.0
|
||||||
|
@ -53,6 +53,7 @@ library
|
||||||
Nix.Parser.Library
|
Nix.Parser.Library
|
||||||
Nix.Parser.Operators
|
Nix.Parser.Operators
|
||||||
Nix.Pretty
|
Nix.Pretty
|
||||||
|
Nix.Reduce
|
||||||
Nix.Scope
|
Nix.Scope
|
||||||
Nix.Stack
|
Nix.Stack
|
||||||
Nix.StringOperations
|
Nix.StringOperations
|
||||||
|
|
204
src/Nix/Reduce.hs
Normal file
204
src/Nix/Reduce.hs
Normal file
|
@ -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
|
|
@ -24,57 +24,19 @@ import Control.Monad
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
import Control.Monad.Trans.State
|
|
||||||
import Data.Fix
|
import Data.Fix
|
||||||
import Data.Functor.Compose
|
import Data.Functor.Compose
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import Data.HashMap.Lazy (HashMap)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import Data.Maybe (maybe, fromMaybe, mapMaybe)
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Nix.Atoms
|
import Nix.Atoms
|
||||||
import Nix.Exec
|
|
||||||
import Nix.Expr
|
import Nix.Expr
|
||||||
import Nix.Parser
|
import Nix.Reduce
|
||||||
import Nix.Stack
|
import Nix.Stack
|
||||||
import Nix.Utils
|
import Nix.Utils
|
||||||
import System.Directory
|
|
||||||
import System.FilePath
|
|
||||||
import Text.Megaparsec.Pos
|
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) }
|
newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) }
|
||||||
deriving (Functor, Foldable, Traversable)
|
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
|
=> (NExprF (m v) -> m v) -> Maybe FilePath -> NExprLoc
|
||||||
-> n (m (NExprLoc, Either r v))
|
-> n (m (NExprLoc, Either r v))
|
||||||
tracingEvalExpr eval mpath expr = do
|
tracingEvalExpr eval mpath expr = do
|
||||||
expr' <- flagExprLoc
|
expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)
|
||||||
=<< liftIO (evalStateT (processImports mpath expr) M.empty)
|
|
||||||
res <- flip runReaderT (0 :: Int) $
|
res <- flip runReaderT (0 :: Int) $
|
||||||
adiM (pure <$> eval . annotated . getCompose . snd . flagged)
|
adiM (pure <$> eval . annotated . getCompose . snd . flagged)
|
||||||
psi expr'
|
psi expr'
|
||||||
|
@ -215,10 +176,12 @@ tracingEvalExpr eval mpath expr = do
|
||||||
guard (depth < 200)
|
guard (depth < 200)
|
||||||
local succ $ do
|
local succ $ do
|
||||||
action <- k v
|
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
|
return $ withExprContext (stripFlags v) $ do
|
||||||
liftIO $ putStrLn $ "eval: " ++ replicate depth ' '
|
-- liftIO $ putStrLn $ "eval: " ++ replicate depth ' '
|
||||||
++ show (void (unFix (stripAnnotation (stripFlags v))))
|
-- ++ show (void (unFix (stripAnnotation (stripFlags v))))
|
||||||
liftIO $ writeIORef b True
|
liftIO $ writeIORef b True
|
||||||
res <- action
|
res <- action
|
||||||
liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' ++ "."
|
-- liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' ++ "."
|
||||||
return res
|
return res
|
||||||
|
|
Loading…
Reference in a new issue