Finish implementation of cycle detection during normalization
This commit is contained in:
John Wiegley
parent
f0b6b6b223
commit
0613d1d604
|
|
@ -53,7 +53,6 @@ import Data.ByteString (ByteString)
|
|||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Char (isDigit)
|
||||
import Data.Coerce
|
||||
import Data.Fix
|
||||
import Data.Foldable (foldrM)
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
|
|
@ -600,7 +599,7 @@ seq_ a b = a >> b
|
|||
deepSeq :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
||||
deepSeq a b = do
|
||||
-- We evaluate 'a' only for its effects, so data cycles are ignored.
|
||||
_ <- normalFormBy (forceEffects . coerce . _baseThunk) 0 =<< a
|
||||
normalForm_ =<< a
|
||||
|
||||
-- Then we evaluate the other argument to deepseq, thus this function
|
||||
-- should always produce a result (unlike applying 'deepseq' on infinitely
|
||||
|
|
|
|||
|
|
@ -508,7 +508,8 @@ instance Convertible e m => FromNix (HashMap Text (NThunk m), HashMap Text Sourc
|
|||
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueNF m) where
|
||||
|
||||
instance (Convertible e m, MonadEffects m,
|
||||
MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValue m) where
|
||||
MonadThunk (NValue m) (NThunk m) m)
|
||||
=> FromNix A.Value m (NValue m) where
|
||||
fromNixMay = fromNixMay <=< normalForm
|
||||
fromNix = fromNix <=< normalForm
|
||||
|
||||
|
|
|
|||
|
|
@ -476,6 +476,7 @@ newtype Lazy m a = Lazy
|
|||
instance MonadIO m => MonadVar (Lazy m) where
|
||||
type Var (Lazy m) = IORef
|
||||
|
||||
eqVar = (==)
|
||||
newVar = liftIO . newIORef
|
||||
readVar = liftIO . readIORef
|
||||
writeVar = (liftIO .) . writeIORef
|
||||
|
|
|
|||
|
|
@ -14,7 +14,11 @@ module Nix.Normal where
|
|||
|
||||
import Control.Monad
|
||||
import Control.Monad.Free
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List (find)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Nix.Atoms
|
||||
|
|
@ -32,35 +36,65 @@ instance Typeable m => Exception (NormalLoop m)
|
|||
|
||||
normalFormBy
|
||||
:: forall e m. (Framed e m, MonadVar m, Typeable m)
|
||||
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
|
||||
=> (forall r. NThunk m -> (NValue m -> StateT [Var m Bool] m r)
|
||||
-> StateT [Var m Bool] m r)
|
||||
-> Int
|
||||
-> NValue m
|
||||
-> m (NValueNF m)
|
||||
normalFormBy k n v = do
|
||||
-- doc <- prettyNValue v
|
||||
-- traceM $ show n ++ ": normalFormBy: " ++ show doc
|
||||
if n > 2000
|
||||
then return $ Pure v
|
||||
else case v of
|
||||
NVConstant a -> return $ Free $ NVConstantF a
|
||||
NVStr t s -> return $ Free $ NVStrF t s
|
||||
NVList l ->
|
||||
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
|
||||
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
|
||||
t `k` normalFormBy k (succ n)
|
||||
NVSet s p ->
|
||||
fmap (Free . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
|
||||
traceM $ show n ++ ": normalFormBy: Set{" ++ show ky ++ "}"
|
||||
t `k` normalFormBy k (succ n)
|
||||
NVClosure p f -> return $ Free $ NVClosureF p f
|
||||
NVPath fp -> return $ Free $ NVPathF fp
|
||||
NVBuiltin name f -> return $ Free $ NVBuiltinF name f
|
||||
_ -> error "Pattern synonyms mask complete matches"
|
||||
-> StateT [Var m Bool] m (NValueNF m)
|
||||
normalFormBy k n v = case v of
|
||||
NVConstant a -> return $ Free $ NVConstantF a
|
||||
NVStr t s -> return $ Free $ NVStrF t s
|
||||
NVList l ->
|
||||
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
|
||||
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
|
||||
k t (next t)
|
||||
NVSet s p ->
|
||||
fmap (Free . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
|
||||
traceM $ show n ++ ": normalFormBy: Set{" ++ show ky ++ "}"
|
||||
k t (next t)
|
||||
NVClosure p f -> return $ Free $ NVClosureF p f
|
||||
NVPath fp -> return $ Free $ NVPathF fp
|
||||
NVBuiltin name f -> return $ Free $ NVBuiltinF name f
|
||||
_ -> error "Pattern synonyms mask complete matches"
|
||||
where
|
||||
next t val = do
|
||||
b <- seen t
|
||||
if b
|
||||
then return $ Pure val
|
||||
else normalFormBy k (succ n) val
|
||||
|
||||
normalForm :: (Framed e m, MonadVar m, Typeable m,
|
||||
seen (NThunk _ (Thunk _ b _)) = do
|
||||
res <- gets (isJust . find (eqVar @m b))
|
||||
unless res $
|
||||
modify (b:)
|
||||
return res
|
||||
seen _ = pure False
|
||||
|
||||
normalForm' :: forall e m. (Framed e m, MonadVar m, Typeable m,
|
||||
MonadThunk (NValue m) (NThunk m) m)
|
||||
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
|
||||
-> NValue m -> m (NValueNF m)
|
||||
normalForm' f = flip evalStateT mempty . normalFormBy go 0
|
||||
where
|
||||
go :: NThunk m
|
||||
-> (NValue m -> StateT [Var m Bool] m r)
|
||||
-> StateT [Var m Bool] m r
|
||||
go t k = do
|
||||
s <- get
|
||||
(res, s') <- lift $ f t $ \v -> runStateT (k v) s
|
||||
put s'
|
||||
return res
|
||||
|
||||
normalForm :: forall e m. (Framed e m, MonadVar m, Typeable m,
|
||||
MonadThunk (NValue m) (NThunk m) m)
|
||||
=> NValue m -> m (NValueNF m)
|
||||
normalForm = normalFormBy force 0
|
||||
normalForm = normalForm' force
|
||||
|
||||
normalForm_
|
||||
:: forall e m. (Framed e m, MonadVar m, Typeable m,
|
||||
MonadThunk (NValue m) (NThunk m) m)
|
||||
=> NValue m -> m ()
|
||||
normalForm_ = void . normalForm' (forceEffects . _baseThunk)
|
||||
|
||||
embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
|
||||
=> NValueNF m -> m (NValue m)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
|
|
@ -35,6 +36,7 @@ data Deferred m v = Deferred (m v) | Computed v
|
|||
|
||||
class Monad m => MonadVar m where
|
||||
type Var m :: * -> *
|
||||
eqVar :: Var m a -> Var m a -> Bool
|
||||
newVar :: a -> m (Var m a)
|
||||
readVar :: Var m a -> m a
|
||||
writeVar :: Var m a -> a -> m ()
|
||||
|
|
|
|||
|
|
@ -305,11 +305,12 @@ binops u1 = \case
|
|||
|
||||
instance MonadVar (Infer s) where
|
||||
type Var (Infer s) = STRef s
|
||||
eqVar = (==)
|
||||
|
||||
newVar x = Infer $ lift $ lift $ lift $ newSTRef x
|
||||
readVar x = Infer $ lift $ lift $ lift $ readSTRef x
|
||||
writeVar x y = Infer $ lift $ lift $ lift $ writeSTRef x y
|
||||
atomicModifyVar x f = Infer $ lift $ lift $ lift $ do
|
||||
newVar x = Infer . lift . lift . lift $ newSTRef x
|
||||
readVar x = Infer . lift . lift . lift $ readSTRef x
|
||||
writeVar x y = Infer . lift . lift . lift $ writeSTRef x y
|
||||
atomicModifyVar x f = Infer . lift . lift . lift $ do
|
||||
res <- snd . f <$> readSTRef x
|
||||
_ <- modifySTRef x (fst . f)
|
||||
return res
|
||||
|
|
|
|||
|
|
@ -181,8 +181,8 @@ instance Eq (NValue m) where
|
|||
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
|
||||
NVConstant (NInt x) == NVConstant (NInt y) = x == y
|
||||
NVConstant (NFloat x) == NVConstant (NFloat y) = x == y
|
||||
NVStr x _ == NVStr y _ = x < y
|
||||
NVPath x == NVPath y = x < y
|
||||
NVStr x _ == NVStr y _ = x == y
|
||||
NVPath x == NVPath y = x == y
|
||||
_ == _ = False
|
||||
|
||||
instance Ord (NValue m) where
|
||||
|
|
@ -190,8 +190,8 @@ instance Ord (NValue m) where
|
|||
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
|
||||
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
|
||||
NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y
|
||||
NVStr x _ <= NVStr y _ = x < y
|
||||
NVPath x <= NVPath y = x < y
|
||||
NVStr x _ <= NVStr y _ = x <= y
|
||||
NVPath x <= NVPath y = x <= y
|
||||
_ <= _ = False
|
||||
|
||||
checkComparable :: (Framed e m, Typeable m) => NValue m -> NValue m -> m ()
|
||||
|
|
@ -323,9 +323,11 @@ instance Show (NThunk m) where
|
|||
show (NThunk _ _) = "<thunk>"
|
||||
|
||||
instance Eq1 (NValueF m) where
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
liftEq _ (NVStrF x _) (NVStrF y _) = x == y
|
||||
liftEq _ (NVPathF x) (NVPathF y) = x == y
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
liftEq _ (NVStrF x _) (NVStrF y _) = x == y
|
||||
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
|
||||
liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y
|
||||
liftEq _ (NVPathF x) (NVPathF y) = x == y
|
||||
liftEq _ _ _ = False
|
||||
|
||||
instance Show1 (NValueF m) where
|
||||
|
|
|
|||
Loading…
Reference in a new issue