picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Factor out thunk id representation into its own class, MonadThunkId

Browse source
This commit is contained in:
John Wiegley 2019-03-16 16:23:40 -07:00
parent 6e4a3de15c
commit 492a3ae0bc
No known key found for this signature in database
GPG key ID: C144D8F4F19FE630
11 changed files with 163 additions and 121 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Nix/Builtins.hs
View file

@ -1038,7 +1038,7 @@ readDir_ pathThunk = do
pure (Text.pack item, t)
toNix (M.fromList itemsWithTypes)
fromJSON :: forall e t f m. (MonadBuiltins e t f m, Typeable m)
fromJSON :: forall e t f m. MonadBuiltins e t f m
=> m (NValue t f m) -> m (NValue t f m)
fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of

40
src/Nix/Exec.hs
View file

@ -56,7 +56,6 @@ import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Fresh (MonadFreshId(..))
import Nix.Normal
import Nix.Options
import Nix.Parser
@ -135,7 +134,6 @@ type MonadNix e t f m =
, MonadFix m
, MonadCatch m
, MonadThrow m
, Typeable m
, Alternative m
, MonadEffects t f m
, MonadCitedThunks t f m
@ -264,7 +262,7 @@ instance ( MonadNix e t f m
evalError = throwError
infixl 1 `callFunc`
callFunc :: forall e t f m. (MonadNix e t f m, Typeable m)
callFunc :: forall e t f m. MonadNix e t f m
=> NValue t f m -> m (NValue t f m) -> m (NValue t f m)
callFunc fun arg = do
frames :: Frames <- asks (view hasLens)
@ -573,21 +571,29 @@ instance MonadExec m => MonadExec (Lazy t f m)
instance MonadIntrospect m => MonadIntrospect (Lazy t f m)
instance MonadFreshId Int m => MonadFreshId Int (Lazy t f m) where
freshId = Lazy $ lift $ lift freshId
instance MonadThunkId m => MonadThunkId (Lazy t f m) where
type ThunkId (Lazy t f m) = ThunkId m
instance (MonadFix m, MonadCatch m, MonadFile m,
MonadStore m, MonadPutStr m, MonadHttp m,
MonadEnv m, MonadInstantiate m,
MonadExec m, MonadIntrospect m,
Alternative m, MonadPlus m, Typeable m,
MonadCitedThunks t f (Lazy t f m),
FromNix Bool (Lazy t f m) t,
FromValue NixString (Lazy t f m) t,
FromValue Path (Lazy t f m) t,
ToNix NixString (Lazy t f m) t,
ToNix [t] (Lazy t f m) t)
=> MonadEffects t f (Lazy t f m) where
instance ( MonadFix m
, MonadCatch m
, MonadFile m
, MonadStore m
, MonadPutStr m
, MonadHttp m
, MonadEnv m
, MonadInstantiate m
, MonadExec m
, MonadIntrospect m
, Alternative m
, MonadPlus m
, MonadCitedThunks t f (Lazy t f m)
, FromNix Bool (Lazy t f m) t
, FromValue NixString (Lazy t f m) t
, FromValue Path (Lazy t f m) t
, ToNix NixString (Lazy t f m) t
, ToNix [t] (Lazy t f m) t
)
=> MonadEffects t f (Lazy t f m) where
makeAbsolutePath origPath = do
origPathExpanded <- expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do

34
src/Nix/Fresh.hs
View file

@ -6,6 +6,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
@ -22,16 +23,13 @@ import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Writer
import Data.Typeable
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
#endif
import Nix.Var
-- TODO better fresh name supply
class Monad m => MonadFreshId i m | m -> i where
freshId :: m i
default freshId :: (MonadFreshId i m', MonadTrans t, m ~ (t m')) => m i
freshId = lift freshId
import Nix.Var
import Nix.Thunk
newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a }
deriving
@ -67,18 +65,30 @@ instance MonadBase b m => MonadBase b (FreshIdT i m) where
-- liftBaseWith = defaultLiftBaseWith
-- restoreM = defaultRestoreM
instance (MonadVar m, Num i) => MonadFreshId i (FreshIdT i m) where
instance ( MonadVar m
, Eq i
, Ord i
, Show i
, Enum i
, Typeable i
)
=> MonadThunkId (FreshIdT i m) where
type ThunkId (FreshIdT i m) = i
freshId = FreshIdT $ do
v <- ask
atomicModifyVar v (\i -> (i + 1, i))
atomicModifyVar v (\i -> (succ i, i))
runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a
runFreshIdT i m = runReaderT (unFreshIdT m) i
instance MonadFreshId i m => MonadFreshId i (ReaderT r m)
instance (Monoid w, MonadFreshId i m) => MonadFreshId i (WriterT w m)
instance MonadFreshId i m => MonadFreshId i (ExceptT e m)
instance MonadFreshId i m => MonadFreshId i (StateT s m)
instance MonadThunkId m => MonadThunkId (ReaderT r m) where
type ThunkId (ReaderT r m) = ThunkId m
instance (Monoid w, MonadThunkId m) => MonadThunkId (WriterT w m) where
type ThunkId (WriterT w m) = ThunkId m
instance MonadThunkId m => MonadThunkId (ExceptT e m) where
type ThunkId (ExceptT e m) = ThunkId m
instance MonadThunkId m => MonadThunkId (StateT s m) where
type ThunkId (StateT s m) = ThunkId m
-- Orphan instance needed by Infer.hs and Lint.hs

4
src/Nix/Lint.hs
View file

@ -120,7 +120,7 @@ unpackSymbolic :: MonadVar m
unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
MonadCatch m, MonadFreshId Int m)
MonadCatch m, MonadThunkId m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m) . ErrorCall
@ -403,7 +403,7 @@ newtype Lint s a = Lint
, Monad
, MonadFix
, MonadReader (Context (Lint s) (SThunk (Lint s)))
, MonadFreshId Int
, MonadThunkId
, MonadRef
, MonadAtomicRef
)

36
src/Nix/Normal.hs
View file

@ -29,9 +29,11 @@ instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalForm'
:: forall e t m f.
(Framed e m,
MonadThunk t m (NValue t f m),
MonadDataErrorContext t f m)
( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> (forall r. t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValueNF t f m)
@ -40,12 +42,12 @@ normalForm' f = run . nValueToNFM run go
start = 0 :: Int
table = mempty
run :: ReaderT Int (StateT (Set Int) m) r -> m r
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
go :: t
-> (NValue t f m -> ReaderT Int (StateT (Set Int) m) (NValueNF t f m))
-> ReaderT Int (StateT (Set Int) m) (NValueNF t f m)
-> (NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
go t k = do
i <- ask
when (i > 2000) $
@ -68,16 +70,22 @@ normalForm' f = run . nValueToNFM run go
Nothing ->
return False
normalForm :: (Framed e m,
MonadThunk t m (NValue t f m),
MonadDataErrorContext t f m)
=> NValue t f m -> m (NValueNF t f m)
normalForm
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m (NValueNF t f m)
normalForm = normalForm' force
normalForm_ :: (Framed e m,
MonadThunk t m (NValue t f m),
MonadDataErrorContext t f m)
=> NValue t f m -> m ()
normalForm_
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m ()
normalForm_ = void <$> normalForm' forceEff
removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m)

11
src/Nix/Render/Frame.hs
View file

@ -65,8 +65,8 @@ renderFrames (x:xs) = do
<> colon]
Nothing -> []
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
-> Maybe SourcePos
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v)
=> NixFrame -> Maybe SourcePos
framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
@ -211,10 +211,11 @@ renderExecFrame level = \case
=<< ((\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v)
renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop _level = pure . (:[]) . \case
ThunkLoop n -> pretty $ "Infinite recursion in thunk #" ++ show n
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n
renderNormalLoop
:: ( MonadReader e m

32
src/Nix/Thunk.hs
View file

@ -1,19 +1,40 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Nix.Thunk where
import Control.Exception (Exception)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Typeable (Typeable)
class Monad m => MonadThunk t m v | t -> m, t -> v where
class ( Monad m
, Eq (ThunkId m)
, Ord (ThunkId m)
, Show (ThunkId m)
, Typeable (ThunkId m)
)
=> MonadThunkId m where
type ThunkId m :: *
freshId :: m (ThunkId m)
default freshId
:: ( MonadThunkId m'
, MonadTrans t
, m ~ t m'
, ThunkId m ~ ThunkId m'
)
=> m (ThunkId m)
freshId = lift freshId
class MonadThunkId m => MonadThunk t m v | t -> m, t -> v where
thunk :: m v -> m t
-- | Return an identifier for the thunk unless it is a pure value (i.e.,
-- strictly an encapsulation of some 'v' without any additional
-- structure). For pure values represented as thunks, returns Nothing.
thunkId :: t -> Maybe Int
thunkId :: t -> Maybe (ThunkId m)
query :: t -> r -> (v -> r) -> r
queryM :: t -> m r -> (v -> m r) -> m r
force :: t -> (v -> m r) -> m r
@ -21,7 +42,10 @@ class Monad m => MonadThunk t m v | t -> m, t -> v where
wrapValue :: v -> t
getValue :: t -> Maybe v
newtype ThunkLoop = ThunkLoop Int
deriving (Show, Typeable)
newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
deriving Typeable
instance Show ThunkLoop where
show (ThunkLoop i) = "ThunkLoop " ++ i
instance Exception ThunkLoop

20
src/Nix/Thunk/Basic.hs
View file

@ -8,6 +8,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
@ -17,7 +18,6 @@ module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Nix.Fresh
import Nix.Thunk
import Nix.Utils
import Nix.Var
@ -28,9 +28,9 @@ data Deferred m v = Deferred (m v) | Computed v
-- | The type of very basic thunks
data NThunkF m v
= Value v
| Thunk Int (Var m Bool) (Var m (Deferred m v))
| Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))
instance Eq v => Eq (NThunkF m v) where
instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where
Value x == Value y = x == y
Thunk x _ _ == Thunk y _ _ = x == y
_ == _ = False -- jww (2019-03-16): not accurate...
@ -39,7 +39,7 @@ instance Show v => Show (NThunkF m v) where
show (Value v) = show v
show (Thunk _ _ _) = "<thunk>"
type MonadBasicThunk m = (MonadFreshId Int m, MonadVar m)
type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
instance (MonadBasicThunk m, MonadCatch m)
=> MonadThunk (NThunkF m v) m v where
@ -84,8 +84,14 @@ queryThunk (Thunk _ active ref) n k = do
_ <- atomicModifyVar active (False,)
return res
forceThunk :: (MonadVar m, MonadThrow m, MonadCatch m)
=> NThunkF m v -> (v -> m a) -> m a
forceThunk
:: forall m v a.
( MonadVar m
, MonadThrow m
, MonadCatch m
, Show (ThunkId m)
)
=> NThunkF m v -> (v -> m a) -> m a
forceThunk (Value v) k = k v
forceThunk (Thunk n active ref) k = do
eres <- readVar ref
@ -95,7 +101,7 @@ forceThunk (Thunk n active ref) k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then
throwM $ ThunkLoop n
throwM $ ThunkLoop $ show n
else do
traceM $ "Forcing " ++ show n
v <- catch action $ \(e :: SomeException) -> do

96
src/Nix/Type/Infer.hs
View file

@ -1,3 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -40,7 +42,6 @@ import Data.List (delete, find, nub, intersect, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.STRef
import qualified Data.Set as Set
import Data.Text (Text)
import Nix.Atoms
@ -71,10 +72,24 @@ newtype InferT s m a = InferT
ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
(StateT InferState (ExceptT InferError m)) a
}
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)), MonadFail,
MonadState InferState, MonadError InferError,
MonadFreshId i)
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadFix
, MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
, MonadFail
, MonadState InferState
, MonadError InferError
)
instance MonadTrans (InferT s) where
lift = InferT . lift . lift . lift
instance MonadThunkId m => MonadThunkId (InferT s m) where
type ThunkId (InferT s m) = ThunkId m
-- | Inference state
newtype InferState = InferState { count :: Int }
@ -190,12 +205,7 @@ instance Monoid InferError where
-------------------------------------------------------------------------------
-- | Run the inference monad
runInfer' ::
( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => InferT s m a -> m (Either InferError a)
runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a)
runInfer' = runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
@ -206,12 +216,8 @@ runInfer m = runST $ do
i <- newVar (1 :: Int)
runFreshIdT i (runInfer' m)
inferType ::
( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => Env -> NExpr -> InferT s m [(Subst, Type)]
inferType :: forall s m. MonadInfer m
=> Env -> NExpr -> InferT s m [(Subst, Type)]
inferType env ex = do
Judgment as cs t <- infer ex
let unbounds = Set.fromList (As.keys as) `Set.difference`
@ -328,13 +334,13 @@ binops u1 = \case
liftInfer :: Monad m => m a -> InferT s m a
liftInfer = InferT . lift . lift . lift
instance (MonadRef m, Ref m ~ STRef s) => MonadRef (InferT s m) where
instance MonadRef m => MonadRef (InferT s m) where
type Ref (InferT s m) = Ref m
newRef x = liftInfer $ newRef x
readRef x = liftInfer $ readRef x
writeRef x y = liftInfer $ writeRef x y
instance (MonadAtomicRef m, Ref m ~ STRef s) => MonadAtomicRef (InferT s m) where
instance MonadAtomicRef m => MonadAtomicRef (InferT s m) where
atomicModifyRef x f = liftInfer $ do
res <- snd . f <$> readRef x
_ <- modifyRef x (fst . f)
@ -352,10 +358,14 @@ instance Monad m => MonadCatch (InferT s m) where
(fromException (toException e))
err -> error $ "Unexpected error: " ++ show err
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
) => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
type MonadInfer m
= ( MonadThunkId m
, MonadVar m
, MonadFix m
)
instance MonadInfer m
=> MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
thunk = fmap JThunk . thunk
thunkId (JThunk x) = thunkId x
@ -372,11 +382,7 @@ instance ( MonadFreshId Int m
wrapValue = JThunk . wrapValue
getValue (JThunk x) = getValue x
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => MonadEval (Judgment s) (InferT s m) where
instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
freeVariable var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
@ -493,11 +499,9 @@ instance Monad m => FromValue NixString (InferT s m) (Judgment s) where
fromValueMay _ = return Nothing
fromValue _ = error "Unused"
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => FromValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
instance MonadInfer m
=> FromValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
fromValueMay (Judgment _ _ (TSet _ xs)) = do
let sing _ = Judgment As.empty []
pure $ Just (M.mapWithKey (\k v -> wrapValue (sing k v)) xs, M.empty)
@ -506,11 +510,9 @@ instance ( MonadFreshId Int m
Just v -> pure v
Nothing -> pure (M.empty, M.empty)
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
instance MonadInfer m
=> ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
toValue (xs, _) = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@ -518,11 +520,7 @@ instance ( MonadFreshId Int m
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
toValue xs = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@ -530,18 +528,10 @@ instance ( MonadFreshId Int m
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => ToValue Bool (InferT s m) (Judgment s) where
instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where
toValue _ = pure $ Judgment As.empty [] typeBool
infer :: ( MonadFreshId Int m
, MonadAtomicRef m
, Ref m ~ STRef s
, MonadFix m
) => NExpr -> InferT s m (Judgment s)
infer :: MonadInfer m => NExpr -> InferT s m (Judgment s)
infer = cata Eval.eval
inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env

3
src/Nix/Value.hs
View file

@ -355,7 +355,8 @@ checkComparable x y = case (x, y) of
(NVPath _, NVPath _) -> pure ()
_ -> throwError $ Comparison x y
thunkEq :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
thunkEq :: (MonadThunk t m (NValue t f m), Comonad f)
=> t -> t -> m Bool
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
let unsafePtrEq = case (lt, rt) of
(thunkId -> lid, thunkId -> rid)

6
src/Nix/Var.hs
View file

@ -20,11 +20,7 @@ import Unsafe.Coerce
type Var m = Ref m
--TODO: Eliminate the old MonadVar shims
type MonadVar m =
( MonadAtomicRef m
, GEq (Ref m)
)
type MonadVar m = MonadAtomicRef m
eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
eqVar a b = isJust $ geq a b