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

Create Nix/Thunk/Standard.hs

Browse source
This commit is contained in:
John Wiegley 2019-03-15 17:59:38 -07:00
parent e9236aa55c
commit 209a9ae9a5
No known key found for this signature in database
GPG key ID: C144D8F4F19FE630
4 changed files with 111 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
hnix.cabal
View file

@ -466,6 +466,7 @@ library
Nix.TH
Nix.Thunk
Nix.Thunk.Basic
Nix.Thunk.Standard
Nix.Type.Assumption
Nix.Type.Env
Nix.Type.Infer

61
src/Nix/Exec.hs
View file

@ -38,7 +38,6 @@ import Control.Monad.State.Strict
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State.Strict (StateT(..))
import Data.Fix
-- import Data.GADT.Compare
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List
@ -57,16 +56,14 @@ import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
-- import Nix.Fresh
import Nix.String
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Pretty
import Nix.Render
import Nix.Scope
import Nix.String
import Nix.Thunk
-- import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
#ifdef MIN_VERSION_haskeline
@ -847,63 +844,10 @@ fetchTarball v = v >>= \case
++ "url = \"" ++ Text.unpack url ++ "\"; "
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
{-
instance MonadNix e t f m => MonadThunk (NThunk m) m (NValue t f m) where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (NThunk . NCited ps . coerce) . buildThunk $ mv
else
fmap (NThunk . NCited [] . coerce) . buildThunk $ mv
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
forceEff (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceEffects t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceEffects t f)
wrapValue = NThunk . NCited [] . coerce . valueRef
getValue (NThunk (NCited _ v)) = thunkValue (coerce v)
-}
-- instance Monad m => MonadFreshId Int (Lazy t f m) where
-- freshId = Lazy $ lift $ lift freshId
exec
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
-- , MonadFreshId Int m
-- , GEq (Ref m)
-- , MonadAtomicRef m
)
=> [String]
-> m (NValue t f m)
@ -913,9 +857,6 @@ nixInstantiateExpr
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
-- , MonadFreshId Int m
-- , GEq (Ref m)
-- , MonadAtomicRef m
)
=> String
-> m (NValue t f m)

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

@ -16,8 +16,6 @@ module Nix.Thunk.Basic (NThunkF, MonadBasicThunk) where
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Control.Monad.Ref
import Data.GADT.Compare
import Nix.Fresh
import Nix.Thunk
@ -36,10 +34,9 @@ instance Show v => Show (NThunkF m v) where
show (Value v) = show v
show (Thunk _ _ _) = "<thunk>"
type MonadBasicThunk m
= (MonadAtomicRef m, GEq (Ref m), MonadFreshId Int m, MonadCatch m)
type MonadBasicThunk m = (MonadFreshId Int m, MonadVar m)
instance (MonadAtomicRef m, GEq (Ref m), MonadFreshId Int m, MonadCatch m)
instance (MonadBasicThunk m, MonadCatch m)
=> MonadThunk (NThunkF m v) m v where
thunk = buildThunk
thunkId = \case
@ -59,18 +56,16 @@ thunkValue :: NThunkF m v -> Maybe v
thunkValue (Value v) = Just v
thunkValue _ = Nothing
buildThunk :: (MonadVar m, MonadFreshId Int m) => m v -> m (NThunkF m v)
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk action =do
freshThunkId <- freshId
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
queryValue :: (MonadVar m, MonadThrow m, MonadCatch m)
=> NThunkF m v -> a -> (v -> a) -> a
queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a
queryValue (Value v) _ k = k v
queryValue _ n _ = n
queryThunk :: (MonadVar m, MonadThrow m, MonadCatch m)
=> NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk (Value v) _ k = k v
queryThunk (Thunk _ active ref) n k = do
nowActive <- atomicModifyVar active (True,)

104
src/Nix/Thunk/Standard.hs Normal file
View file

@ -0,0 +1,104 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Thunk.Standard where
import Control.Monad.Catch hiding (catchJust)
import Control.Monad.Reader
import Control.Monad.Ref
import Data.Fix
import Data.GADT.Compare
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import Nix.Cited
import Nix.Convert
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.Options
import Nix.String
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
newtype NThunk f m = NThunk
{ _nThunk :: NCited (NThunk f m) (NValue (NThunk f m) f m) m
(NThunkF m (NValue (NThunk f m) f m)) }
instance (MonadNix e t f m, MonadFreshId Int m, MonadAtomicRef m, GEq (Ref m))
=> MonadThunk (NThunk f m) m (NValue (NThunk f m) f m) where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (NThunk . NCited ps) . thunk $ mv
else
fmap (NThunk . NCited []) . thunk $ mv
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(force t f)
forceEff (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceEff t f)
wrapValue = NThunk . NCited [] . wrapValue
getValue (NThunk (NCited _ v)) = getValue v
-- instance Monad m => MonadFreshId Int (Lazy t f m) where
-- freshId = Lazy $ lift $ lift freshId
instance FromValue NixString m (NThunk f m) where
instance FromValue Path m (NThunk f m) where
instance FromValue [NThunk f m] m (NThunk f m) where
instance FromValue (M.HashMap Text (NThunk f m)) m (NThunk f m) where
instance ToValue NixString m (NThunk f m) where
instance ToValue Int m (NThunk f m) where
instance ToValue () m (NThunk f m) where
instance FromValue [NixString] m (NThunk f m) where
instance FromNix [NixString] m (NThunk f m) where
instance ToValue (NThunk f m) m (NValue (NThunk f m) f m) where
instance ToNix (NThunk f m) m (NValue (NThunk f m) f m) where