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

Begin work on harmonizing the two different value representations

This commit is contained in:
John Wiegley 2019-03-18 11:41:46 -07:00
parent f5d070af16
commit 522585a7f1
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
17 changed files with 669 additions and 808 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
README-design.md
View File

@ -41,15 +41,3 @@ points in the code are generic over both.
Having said that, I should mention that there are two different types of
values: `NValue` and `NValueNF`. The former is created by evaluating an
`NExpr`, and then latter by calling `normalForm` on an `NValue`.
However, not every term can be reduced to normal form. There are cases where
Nix allows a cycle to exist in the data, so that it can printed simply as
`<CYCLE>`. To represent this, we use a simple recursive type for `NValue`, but
a `Free` construction for `NValueNF`:
type NValueNF t f m = Free (NValue' t f m) t
The idea here is that `Free` values are those we were able to normalize (since
it has its own terminating base cases of constants, strings, etc), while the
`Pure` thunk is the thunk we'd seen before while normalizing, indicating the
beginning of the cycle.

1
hnix.cabal
View File

@ -475,6 +475,7 @@ library
Nix.Utils
Nix.Value
Nix.Value.Equal
Nix.Value.Monad
Nix.Var
Nix.XML
other-modules:

3
src/Nix/Builtins.hs
View File

@ -126,7 +126,8 @@ withNixContext mpath action = do
let ref = wrapValue @t @m @(NValue t f m) $ nvPath path
pushScope (M.singleton "__cur_file" ref) action
builtins :: (MonadNix e t f m, Scoped t m) => m (Scopes m t)
builtins :: (MonadNix e t f m, Scoped (NValue t f m) m)
=> m (Scopes m (NValue t f m))
builtins = do
ref <- thunk $ flip nvSet M.empty <$> buildMap
lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins

28
src/Nix/Cited.hs
View File

@ -21,8 +21,8 @@ import Lens.Family2.TH
import Nix.Expr.Types.Annotated
import Nix.Scope
data Provenance t m v = Provenance
{ _lexicalScope :: Scopes m t
data Provenance m v = Provenance
{ _lexicalScope :: Scopes m v
, _originExpr :: NExprLocF (Maybe v)
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
@ -31,34 +31,34 @@ data Provenance t m v = Provenance
}
deriving (Generic, Typeable, Show)
data NCited t m v a = NCited
{ _provenance :: [Provenance t m v]
data NCited m v a = NCited
{ _provenance :: [Provenance m v]
, _cited :: a
}
deriving (Generic, Typeable, Functor, Foldable, Traversable, Show)
instance Applicative (NCited t m v) where
instance Applicative (NCited m v) where
pure = NCited []
NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)
instance Comonad (NCited t m v) where
instance Comonad (NCited m v) where
duplicate p = NCited (_provenance p) p
extract = _cited
instance ComonadEnv [Provenance t m v] (NCited t m v) where
instance ComonadEnv [Provenance m v] (NCited m v) where
ask = _provenance
$(makeLenses ''Provenance)
$(makeLenses ''NCited)
class HasCitations t m v a where
citations :: a -> [Provenance t m v]
addProvenance :: Provenance t m v -> a -> a
class HasCitations m v a where
citations :: a -> [Provenance m v]
addProvenance :: Provenance m v -> a -> a
instance HasCitations t m v (NCited t m v a) where
instance HasCitations m v (NCited m v a) where
citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v)
class HasCitations1 t m v f where
citations1 :: f a -> [Provenance t m v]
addProvenance1 :: Provenance t m v -> f a -> f a
class HasCitations1 m v f where
citations1 :: f a -> [Provenance m v]
addProvenance1 :: Provenance m v -> f a -> f a

483
src/Nix/Convert.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@ -27,10 +28,9 @@
module Nix.Convert where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Free
import Data.ByteString
import Data.HashMap.Lazy ( HashMap )
import Data.Fix
import qualified Data.HashMap.Lazy as M
import Data.Maybe
import Data.Text ( Text )
@ -44,8 +44,9 @@ import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
import Nix.Value.Monad
import Nix.Utils
{-
@ -60,144 +61,104 @@ Do not add these instances back!
-}
{-----------------------------------------------------------------------
FromValue
-----------------------------------------------------------------------}
class FromValue a m v where
fromValue :: v -> m a
fromValueMay :: v -> m (Maybe a)
type Convertible e t f m
= (Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
type Convertible e t f m = (Framed e m, MonadDataErrorContext t f m)
instance Convertible e t f m => FromValue () m (NValueNF t f m) where
fromValueMay = \case
NVConstantNF NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TNull v
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
instance Convertible e t f m => FromValue () m (NValue t f m) where
instance ( Convertible e t f m
, MonadValue (NValueNF t f m) m
, FromValue a m (NValue' t f m (NValueNF t f m))
)
=> FromValue a m (NValueNF t f m) where
fromValueMay = flip demand $ \(Fix v) -> fromValueMay v
fromValue = flip demand $ \(Fix v) -> fromValue v
instance ( Convertible e t f m
, MonadValue (NValue t f m) m
, FromValue a m (NValue' t f m (NValue t f m))
)
=> FromValue a m (NValue t f m) where
fromValueMay = flip demand $ \case
Pure _ -> pure Nothing
Free v -> fromValueMay v
fromValue = flip demand $ \case
Pure t -> throwError $ ForcingThunk @t @f @m t
Free v -> fromValue v
instance (Convertible e t f m, Show r) => FromValue () m (NValue' t f m r) where
fromValueMay = \case
NVConstant NNull -> pure $ Just ()
_ -> pure Nothing
NVConstant' NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TNull v
instance Convertible e t f m => FromValue Bool m (NValueNF t f m) where
instance (Convertible e t f m, Show r) => FromValue Bool m (NValue' t f m r) where
fromValueMay = \case
NVConstantNF (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TBool v
instance Convertible e t f m => FromValue Bool m (NValue t f m) where
fromValueMay = \case
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
NVConstant' (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TBool v
instance Convertible e t f m => FromValue Int m (NValueNF t f m) where
instance (Convertible e t f m, Show r) => FromValue Int m (NValue' t f m r) where
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e t f m => FromValue Int m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
NVConstant' (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e t f m => FromValue Integer m (NValueNF t f m) where
instance (Convertible e t f m, Show r) => FromValue Integer m (NValue' t f m r) where
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e t f m => FromValue Integer m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
NVConstant' (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e t f m => FromValue Float m (NValueNF t f m) where
instance (Convertible e t f m, Show r) => FromValue Float m (NValue' t f m r) where
fromValueMay = \case
NVConstantNF (NFloat b) -> pure $ Just b
NVConstantNF (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TFloat v
instance Convertible e t f m => FromValue Float m (NValue t f m) where
fromValueMay = \case
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
NVConstant' (NFloat b) -> pure $ Just b
NVConstant' (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TFloat v
instance (Convertible e t f m, MonadEffects t f m)
=> FromValue NixString m (NValueNF t f m) where
instance (Convertible e t f m, Show r, MonadEffects t f m,
FromValue NixString m r)
=> FromValue NixString m (NValue' t f m r) where
fromValueMay = \case
NVStrNF ns -> pure $ Just ns
NVPathNF p ->
NVStr' ns -> pure $ Just ns
NVPath' p ->
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSetNF s _ -> case M.lookup "outPath" s of
NVSet' s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance (Convertible e t f m, MonadEffects t f m)
=> FromValue NixString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ Just ns
NVPath p ->
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> force p fromValueMay
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
instance Convertible e t f m
=> FromValue ByteString m (NValueNF t f m) where
instance (Convertible e t f m, Show r)
=> FromValue ByteString m (NValue' t f m r) where
fromValueMay = \case
NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance Convertible e t f m
=> FromValue ByteString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -206,191 +167,125 @@ instance Convertible e t f m
newtype Path = Path { getPath :: FilePath }
deriving Show
instance Convertible e t f m => FromValue Path m (NValueNF t f m) where
instance (Convertible e t f m, Show r, FromValue Path m r)
=> FromValue Path m (NValue' t f m r) where
fromValueMay = \case
NVPathNF p -> pure $ Just (Path p)
NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSetNF s _ -> case M.lookup "outPath" s of
NVPath' p -> pure $ Just (Path p)
NVStr' ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet' s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TPath v
instance Convertible e t f m => FromValue Path m (NValue t f m) where
fromValueMay = \case
NVPath p -> pure $ Just (Path p)
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> force p $ fromValueMay @Path
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TPath v
instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)
=> FromValue [a] m (NValueNF t f m) where
instance (Convertible e t f m, Show r)
=> FromValue [r] m (NValue' t f m r) where
fromValueMay = \case
NVListNF l -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TList v
instance Convertible e t f m => FromValue [t] m (NValue t f m) where
fromValueMay = \case
NVList l -> pure $ Just l
_ -> pure Nothing
NVList' l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
instance (Convertible e t f m, Show r)
=> FromValue (AttrSet r) m (NValue' t f m r) where
fromValueMay = \case
NVSetNF s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e t f m
=> FromValue (HashMap Text t) m (NValue t f m) where
fromValueMay = \case
NVSet s _ -> pure $ Just s
_ -> pure Nothing
NVSet' s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
instance (Convertible e t f m, Show r)
=> FromValue (AttrSet r, AttrSet SourcePos) m (NValue' t f m r) where
fromValueMay = \case
NVSetNF s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e t f m
=> FromValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
fromValueMay = \case
NVSet s p -> pure $ Just (s, p)
_ -> pure Nothing
NVSet' s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
{-----------------------------------------------------------------------
ToValue
-----------------------------------------------------------------------}
class ToValue a m v where
toValue :: a -> m v
instance Convertible e t f m => ToValue () m (NValueNF t f m) where
toValue _ = pure . nvConstantNF $ NNull
instance (Monad m, ToValue a m v) => ToValue a m (m v) where
toValue = pure . toValue
instance Convertible e t f m => ToValue () m (NValue t f m) where
toValue _ = pure . nvConstant $ NNull
instance (Convertible e t f m, forall r. Show r => ToValue a m (NValue' t f m r))
=> ToValue a m (NValueNF t f m) where
toValue = fmap Fix . toValue
instance Convertible e t f m => ToValue Bool m (NValueNF t f m) where
toValue = pure . nvConstantNF . NBool
instance (Convertible e t f m, forall r. Show r => ToValue a m (NValue' t f m r))
=> ToValue a m (NValue t f m) where
toValue = fmap Free . toValue
instance Convertible e t f m => ToValue Bool m (NValue t f m) where
toValue = pure . nvConstant . NBool
instance Convertible e t f m => ToValue () m (NValue' t f m r) where
toValue _ = pure . nvConstant' $ NNull
instance Convertible e t f m => ToValue Int m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt . toInteger
instance Convertible e t f m => ToValue Bool m (NValue' t f m r) where
toValue = pure . nvConstant' . NBool
instance Convertible e t f m => ToValue Int m (NValue t f m) where
toValue = pure . nvConstant . NInt . toInteger
instance Convertible e t f m => ToValue Int m (NValue' t f m r) where
toValue = pure . nvConstant' . NInt . toInteger
instance Convertible e t f m => ToValue Integer m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt
instance Convertible e t f m => ToValue Integer m (NValue' t f m r) where
toValue = pure . nvConstant' . NInt
instance Convertible e t f m => ToValue Integer m (NValue t f m) where
toValue = pure . nvConstant . NInt
instance Convertible e t f m => ToValue Float m (NValue' t f m r) where
toValue = pure . nvConstant' . NFloat
instance Convertible e t f m => ToValue Float m (NValueNF t f m) where
toValue = pure . nvConstantNF . NFloat
instance Convertible e t f m => ToValue NixString m (NValue' t f m r) where
toValue = pure . nvStr'
instance Convertible e t f m => ToValue Float m (NValue t f m) where
toValue = pure . nvConstant . NFloat
instance Convertible e t f m => ToValue ByteString m (NValue' t f m r) where
toValue = pure . nvStr' . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue NixString m (NValueNF t f m) where
toValue = pure . nvStrNF
instance Convertible e t f m => ToValue Path m (NValue' t f m r) where
toValue = pure . nvPath' . getPath
instance Convertible e t f m => ToValue NixString m (NValue t f m) where
toValue = pure . nvStr
instance Convertible e t f m => ToValue ByteString m (NValueNF t f m) where
toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue ByteString m (NValue t f m) where
toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue Path m (NValueNF t f m) where
toValue = pure . nvPathNF . getPath
instance Convertible e t f m => ToValue Path m (NValue t f m) where
toValue = pure . nvPath . getPath
instance Convertible e t f m => ToValue StorePath m (NValueNF t f m) where
instance Convertible e t f m => ToValue StorePath m (NValue' t f m r) where
toValue = toValue . Path . unStorePath
instance Convertible e t f m => ToValue StorePath m (NValue t f m) where
toValue = toValue . Path . unStorePath
instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
instance ( Convertible e t f m
, ToValue NixString m r
, ToValue Int m r
)
=> ToValue SourcePos m (NValue' t f m r) where
toValue (SourcePos f l c) = do
f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f)
f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f))
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, wrapValue f')
, ("line" , wrapValue l')
, ("column" , wrapValue c')
[ ("file" :: Text, f')
, ("line" , l')
, ("column" , c')
]
pure $ nvSet pos mempty
pure $ nvSet' pos mempty
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
=> ToValue [a] m (NValueNF t f m) where
toValue = fmap nvListNF . traverse toValue
instance Convertible e t f m => ToValue [r] m (NValue' t f m r) where
toValue = pure . nvList'
instance Convertible e t f m => ToValue [t] m (NValue t f m) where
toValue = pure . nvList
instance Convertible e t f m => ToValue (AttrSet r) m (NValue' t f m r) where
toValue = pure . flip nvSet' M.empty
instance Convertible e t f m
=> ToValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
toValue = pure . flip nvSetNF M.empty
=> ToValue (AttrSet r, AttrSet SourcePos) m (NValue' t f m r) where
toValue (s, p) = pure $ nvSet' s p
instance Convertible e t f m => ToValue (HashMap Text t) m (NValue t f m) where
toValue = pure . flip nvSet M.empty
instance Convertible e t f m => ToValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
toValue (s, p) = pure $ nvSetNF s p
instance Convertible e t f m => ToValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
toValue (s, p) = pure $ nvSet s p
instance Convertible e t f m => ToValue Bool m (NExprF r) where
toValue = pure . NConstant . NBool
instance Convertible e t f m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
instance ( MonadThunk t m (NValue t f m)
instance ( MonadValue (NValue t f m) m
, MonadDataErrorContext t f m
, Framed e m
, ToValue NixString m r
, ToValue Bool m r
, ToValue [r] m r
)
=> ToValue NixLikeContextValue m (NValue t f m) where
=> ToValue NixLikeContextValue m (NValue' t f m r) where
toValue nlcv = do
path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing
allOutputs <- if nlcvAllOutputs nlcv
@ -399,130 +294,18 @@ instance ( MonadThunk t m (NValue t f m)
outputs <- do
let outputs =
fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv
outputsM :: [NValue t f m] <- traverse toValue outputs
let ts :: [t] = fmap wrapValue outputsM
ts :: [r] <- traverse toValue outputs
case ts of
[] -> return Nothing
_ -> Just <$> toValue ts
pure $ flip nvSet M.empty $ M.fromList $ catMaybes
[ (\p -> ("path", wrapValue p)) <$> path
, (\ao -> ("allOutputs", wrapValue ao)) <$> allOutputs
, (\os -> ("outputs", wrapValue os)) <$> outputs
pure $ flip nvSet' M.empty $ M.fromList $ catMaybes
[ (\p -> ("path", p)) <$> path
, (\ao -> ("allOutputs", ao)) <$> allOutputs
, (\os -> ("outputs", os)) <$> outputs
]
whileForcingThunk
:: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
whileForcingThunk frame =
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
instance Convertible e t f m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
class FromNix a m v where
fromNix :: v -> m a
default fromNix :: FromValue a m v => v -> m a
fromNix = fromValue
fromNixMay :: v -> m (Maybe a)
default fromNixMay :: FromValue a m v => v -> m (Maybe a)
fromNixMay = fromValueMay
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix [a] m (NValue t f m) where
fromNixMay = \case
NVList l -> sequence <$> traverse (`force` fromNixMay) l
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix (HashMap Text a) m (NValue t f m) where
fromNixMay = \case
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e t f m => FromNix () m (NValueNF t f m) where
instance Convertible e t f m => FromNix () m (NValue t f m) where
instance Convertible e t f m => FromNix Bool m (NValueNF t f m) where
instance Convertible e t f m => FromNix Bool m (NValue t f m) where
instance Convertible e t f m => FromNix Int m (NValueNF t f m) where
instance Convertible e t f m => FromNix Int m (NValue t f m) where
instance Convertible e t f m => FromNix Integer m (NValueNF t f m) where
instance Convertible e t f m => FromNix Integer m (NValue t f m) where
instance Convertible e t f m => FromNix Float m (NValueNF t f m) where
instance Convertible e t f m => FromNix Float m (NValue t f m) where
instance (Convertible e t f m, MonadEffects t f m)
=> FromNix NixString m (NValueNF t f m) where
instance (Convertible e t f m, MonadEffects t f m)
=> FromNix NixString m (NValue t f m) where
instance Convertible e t f m => FromNix ByteString m (NValueNF t f m) where
instance Convertible e t f m => FromNix ByteString m (NValue t f m) where
instance Convertible e t f m => FromNix Path m (NValueNF t f m) where
instance Convertible e t f m => FromNix Path m (NValue t f m) where
instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)
=> FromNix [a] m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
instance Convertible e t f m
=> FromNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
fromNix = (>>= fromNix)
class ToNix a m v where
toNix :: a -> m v
default toNix :: ToValue a m v => a -> m v
toNix = toValue
instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix [a] m (NValue t f m) where
toNix = fmap nvList . traverse (thunk . go)
where
go =
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix (HashMap Text a) m (NValue t f m) where
toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)
where
go =
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
instance Convertible e t f m => ToNix () m (NValueNF t f m) where
instance Convertible e t f m => ToNix () m (NValue t f m) where
instance Convertible e t f m => ToNix Bool m (NValueNF t f m) where
instance Convertible e t f m => ToNix Bool m (NValue t f m) where
instance Convertible e t f m => ToNix Int m (NValueNF t f m) where
instance Convertible e t f m => ToNix Int m (NValue t f m) where
instance Convertible e t f m => ToNix Integer m (NValueNF t f m) where
instance Convertible e t f m => ToNix Integer m (NValue t f m) where
instance Convertible e t f m => ToNix Float m (NValueNF t f m) where
instance Convertible e t f m => ToNix Float m (NValue t f m) where
instance Convertible e t f m => ToNix NixString m (NValueNF t f m) where
instance Convertible e t f m => ToNix NixString m (NValue t f m) where
instance Convertible e t f m => ToNix ByteString m (NValueNF t f m) where
instance Convertible e t f m => ToNix ByteString m (NValue t f m) where
instance Convertible e t f m => ToNix Path m (NValueNF t f m) where
instance Convertible e t f m => ToNix Path m (NValue t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
instance Convertible e t f m
=> ToNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance Convertible e t f m => ToNix Bool m (NExprF r) where
toNix = pure . NConstant . NBool
instance Convertible e t f m => ToNix () m (NExprF r) where
toNix _ = pure $ NConstant NNull
instance (Convertible e t f m, ToNix a m (NValueNF t f m))
=> ToNix [a] m (NValueNF t f m) where
toNix = fmap nvListNF . traverse toNix
instance Convertible e t f m => ToValue Bool m (NExprF r) where
toValue = pure . NConstant . NBool

2
src/Nix/Effects.hs
View File

@ -51,7 +51,7 @@ class (MonadFile m,
-- | Having an explicit list of sets corresponding to the NIX_PATH
-- and a file path try to find an existing path
findPath :: [t] -> FilePath -> m FilePath
findPath :: [NValue t f m] -> FilePath -> m FilePath
importPath :: FilePath -> m (NValue t f m)
pathToDefaultNix :: FilePath -> m FilePath

207
src/Nix/Eval.hs
View File

@ -38,81 +38,89 @@ import Nix.Frames
import Nix.String
import Nix.Scope
import Nix.Strings ( runAntiquoted )
import Nix.Thunk
import Nix.Utils
import Nix.Value.Monad
-- instance MonadThunk t m (NValue t f m) => MonadValue (NValue t f m) m where
-- defer = fmap Pure . thunk
-- demand (Pure t) f = force t f
-- demand v@(Free _) f = f v
class (Show v, Monad m) => MonadEval v m where
freeVariable :: Text -> m v
synHole :: Text -> m v
attrMissing :: NonEmpty Text -> Maybe v -> m v
evaledSym :: Text -> v -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: NString (m v) -> m v
evalLiteralPath :: FilePath -> m v
evalEnvPath :: FilePath -> m v
evalUnary :: NUnaryOp -> v -> m v
evalBinary :: NBinaryOp -> v -> m v -> m v
-- ^ The second argument is an action because operators such as boolean &&
-- and || may not evaluate the second argument.
evalWith :: m v -> m v -> m v
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
evalAbs :: Params (m v)
-> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v))
-> m v
freeVariable :: Text -> m v
synHole :: Text -> m v
attrMissing :: NonEmpty Text -> Maybe v -> m v
evaledSym :: Text -> v -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: NString (m v) -> m v
evalLiteralPath :: FilePath -> m v
evalEnvPath :: FilePath -> m v
evalUnary :: NUnaryOp -> v -> m v
evalBinary :: NBinaryOp -> v -> m v -> m v
-- ^ The second argument is an action because operators such as boolean &&
-- and || may not evaluate the second argument.
evalWith :: m v -> m v -> m v
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
evalAbs :: Params (m v)
-> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v))
-> m v
{-
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
evalHasAttr :: v -> NonEmpty Text -> m v
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
evalHasAttr :: v -> NonEmpty Text -> m v
-- | This and the following methods are intended to allow things like
-- adding provenance information.
evalListElem :: [m v] -> Int -> m v -> m v
evalList :: [t] -> m v
evalSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalSet :: AttrSet t -> AttrSet SourcePos -> m v
evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalRecSet :: AttrSet t -> AttrSet SourcePos -> m v
evalLetElem :: Text -> m v -> m v
evalLet :: m v -> m v
-- | This and the following methods are intended to allow things like
-- adding provenance information.
evalListElem :: [m v] -> Int -> m v -> m v
evalList :: [v] -> m v
evalSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalSet :: AttrSet v -> AttrSet SourcePos -> m v
evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalRecSet :: AttrSet v -> AttrSet SourcePos -> m v
evalLetElem :: Text -> m v -> m v
evalLet :: m v -> m v
-}
evalError :: Exception s => s -> m a
evalError :: Exception s => s -> m a
type MonadNixEval v t m
type MonadNixEval v m
= ( MonadEval v m
, Scoped t m
, MonadThunk t m v
, Scoped v m
, MonadValue v m
, MonadFix m
, ToValue Bool m v
, ToValue [t] m v
, ToValue [v] m v
, FromValue NixString m v
, ToValue (AttrSet t, AttrSet SourcePos) m v
, FromValue (AttrSet t, AttrSet SourcePos) m v
, ToValue (AttrSet v, AttrSet SourcePos) m v
, FromValue (AttrSet v, AttrSet SourcePos) m v
)
data EvalFrame m t
= EvaluatingExpr (Scopes m t) NExprLoc
| ForcingExpr (Scopes m t) NExprLoc
data EvalFrame m v
= EvaluatingExpr (Scopes m v) NExprLoc
| ForcingExpr (Scopes m v) NExprLoc
| Calling String SrcSpan
| SynHole (SynHoleInfo m t)
| SynHole (SynHoleInfo m v)
deriving (Show, Typeable)
instance (Typeable m, Typeable t) => Exception (EvalFrame m t)
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
data SynHoleInfo m t = SynHoleInfo
data SynHoleInfo m v = SynHoleInfo
{ _synHoleInfo_expr :: NExprLoc
, _synHoleInfo_scope :: Scopes m t
, _synHoleInfo_scope :: Scopes m v
} deriving (Show, Typeable)
instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t)
instance (Typeable m, Typeable v) => Exception (SynHoleInfo m v)
eval :: forall v t m . MonadNixEval v t m => NExprF (m v) -> m v
-- jww (2019-03-18): By deferring only those things which must wait until
-- context of us, this can be written as:
-- eval :: forall v m . MonadNixEval v m => NExprF v -> m v
eval :: forall v m . MonadNixEval v m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var ) = (lookupVar var :: m (Maybe t))
>>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NSym var ) = (lookupVar var :: m (Maybe v))
>>= maybe (freeVariable var) (demand ?? evaledSym var)
eval (NConstant x ) = evalConstant x
eval (NStr str ) = evalString str
@ -121,7 +129,7 @@ eval (NEnvPath p ) = evalEnvPath p
eval (NUnary op arg ) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes :: m (Scopes m t)
scope <- currentScopes :: m (Scopes m v)
fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
@ -133,7 +141,7 @@ eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l ) = do
scope <- currentScopes
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
for l (defer @v @m . withScopes @v scope) >>= toValue
eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
@ -154,32 +162,32 @@ eval (NAbs params body) = do
-- needs to be used when evaluating the body and default arguments, hence
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes :: m (Scopes m t)
scope <- currentScopes :: m (Scopes m v)
evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
pushScope args (k (M.map (`demand` pure) args) body)
eval (NSynHole name) = synHole name
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- | If you know that the 'scope' action will result in an 'AttrSet v', then
-- this implementation may be used as an implementation for 'evalWith'.
evalWithAttrSet :: forall v t m . MonadNixEval v t m => m v -> m v -> m v
evalWithAttrSet :: forall v m . MonadNixEval v m => m v -> m v -> m v
evalWithAttrSet aset body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
scope <- currentScopes :: m (Scopes m t)
s <- thunk @t @m @v $ withScopes scope aset
scope <- currentScopes :: m (Scopes m v)
s <- defer @v @m $ withScopes scope aset
pushWeakScope
?? body
$ force s
$ demand s
$ fmap fst
. fromValue @(AttrSet t, AttrSet SourcePos)
. fromValue @(AttrSet v, AttrSet SourcePos)
attrSetAlter
:: forall v t m
. MonadNixEval v t m
:: forall v m
. MonadNixEval v m
=> [Text]
-> SourcePos
-> AttrSet (m v)
@ -196,17 +204,16 @@ attrSetAlter (k : ks) pos m p val = case M.lookup k m of
| null ks
-> go
| otherwise
-> x >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(st, sp) ->
recurse (force ?? pure <$> st) sp
-> x >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(st, sp) ->
recurse (demand ?? pure <$> st) sp
where
go = return (M.insert k val m, M.insert k pos p)
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
( M.insert
k
( toValue @(AttrSet t, AttrSet SourcePos)
( toValue @(AttrSet v, AttrSet SourcePos)
=<< (, mempty)
. fmap wrapValue
<$> sequence st'
)
st
@ -240,13 +247,13 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds
:: forall v t m
. MonadNixEval v t m
:: forall v m
. MonadNixEval v m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
-> m (AttrSet v, AttrSet SourcePos)
evalBinds recursive binds = do
scope <- currentScopes :: m (Scopes m t)
scope <- currentScopes :: m (Scopes m v)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) . partition
@ -255,12 +262,12 @@ evalBinds recursive binds = do
_ -> True
)
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
go :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
finalValue >>= fromValue >>= \(o', p') ->
-- jww (2018-05-09): What to do with the key position here?
return $ map
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure))
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand @v @m v pure))
(M.toList o')
go _ (NamedVar pathExpr finalValue pos) = do
@ -271,7 +278,7 @@ evalBinds recursive binds = do
pure
( []
, nullPos
, toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)
, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)
)
Just k -> case t of
[] -> pure ([k], pos, finalValue)
@ -294,31 +301,31 @@ evalBinds recursive binds = do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s ->
s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) ->
clearScopes @t $ pushScope s $ lookupVar key
s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(s, _) ->
clearScopes @v $ pushScope s $ lookupVar key
case mv of
Nothing -> attrMissing (key :| []) Nothing
Just v -> force v pure
Just v -> demand v pure
)
buildResult
:: Scopes m t
:: Scopes m v
-> [([Text], SourcePos, m v)]
-> m (AttrSet t, AttrSet SourcePos)
-> m (AttrSet v, AttrSet SourcePos)
buildResult scope bindings = do
(s, p) <- foldM insert (M.empty, M.empty) bindings
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
return (res, p)
where
mkThunk = thunk . withScopes scope
mkThunk = defer . withScopes scope
encapsulate f attrs = mkThunk . pushScope attrs $ f
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect
:: forall v t m
. MonadNixEval v t m
:: forall v m
. MonadNixEval v m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
@ -328,10 +335,10 @@ evalSelect aset attr = do
extract s path
where
extract x path@(k :| ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos)
Just (s :: AttrSet v, p :: AttrSet SourcePos)
| Just t <- M.lookup k s -> case ks of
[] -> pure $ Right $ force t pure
y : ys -> force t $ extract ?? (y :| ys)
[] -> pure $ Right $ demand t pure
y : ys -> demand t $ extract ?? (y :| ys)
| otherwise -> Left . (, path) <$> toValue (s, p)
Nothing -> return $ Left (x, path)
@ -376,16 +383,16 @@ assembleString = \case
(>>= fromValueMay)
buildArgument
:: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t)
:: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v)
buildArgument params arg = do
scope <- currentScopes :: m (Scopes m t)
scope <- currentScopes :: m (Scopes m v)
case params of
Param name -> M.singleton name <$> thunk (withScopes scope arg)
Param name -> M.singleton name <$> defer (withScopes scope arg)
ParamSet s isVariadic m ->
arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do
arg >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(args, _) -> do
let inject = case m of
Nothing -> id
Just n -> M.insert n $ const $ thunk (withScopes scope arg)
Just n -> M.insert n $ const $ defer (withScopes scope arg)
loebM
(inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
args
@ -393,11 +400,11 @@ buildArgument params arg = do
)
where
assemble
:: Scopes m t
:: Scopes m v
-> Bool
-> Text
-> These t (Maybe (m v))
-> Maybe (AttrSet t -> m t)
-> These v (Maybe (m v))
-> Maybe (AttrSet v -> m v)
assemble scope isVariadic k = \case
That Nothing ->
Just
@ -407,7 +414,7 @@ buildArgument params arg = do
$ "Missing value for parameter: "
++ show k
That (Just f) ->
Just $ \args -> thunk $ withScopes scope $ pushScope args f
Just $ \args -> defer $ withScopes scope $ pushScope args f
This _
| isVariadic
-> Nothing
@ -426,17 +433,17 @@ addSourcePositions f v@(Fix (Compose (Ann ann _))) =
local (set hasLens ann) (f v)
addStackFrames
:: forall t e m a
. (Scoped t m, Framed e m, Typeable t, Typeable m)
:: forall v e m a
. (Scoped v m, Framed e m, Typeable v, Typeable m)
=> Transform NExprLocF (m a)
addStackFrames f v = do
scopes <- currentScopes :: m (Scopes m t)
scopes <- currentScopes :: m (Scopes m v)
withFrame Info (EvaluatingExpr scopes v) (f v)
framedEvalExprLoc
:: forall t e v m
. (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m)
:: forall e v m
. (MonadNixEval v m, Framed e m, Has e SrcSpan, Typeable m, Typeable v)
=> NExprLoc
-> m v
framedEvalExprLoc =
adi (eval . annotated . getCompose) (addStackFrames @t . addSourcePositions)
adi (eval . annotated . getCompose) (addStackFrames @v . addSourcePositions)

150
src/Nix/Exec.hs
View File

@ -35,6 +35,7 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Catch hiding ( catchJust )
import Control.Monad.Fix
import Control.Monad.Free
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.State.Strict
@ -71,6 +72,7 @@ import Nix.Thunk
import Nix.Utils
import Nix.Value
import Nix.Value.Equal
import Nix.Value.Monad
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding(catch)
#endif
@ -86,64 +88,69 @@ import GHC.DataSize
#endif
type MonadCited t f m
= (HasCitations1 t m (NValue t f m) f, MonadDataContext f m)
= ( HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, MonadDataContext f m
)
nvConstantP
:: MonadCited t f m => Provenance t m (NValue t f m) -> NAtom -> NValue t f m
:: MonadCited t f m => Provenance m (NValue t f m) -> NAtom -> NValue t f m
nvConstantP p x = addProvenance p (nvConstant x)
nvStrP
:: MonadCited t f m
=> Provenance t m (NValue t f m)
=> Provenance m (NValue t f m)
-> NixString
-> NValue t f m
nvStrP p ns = addProvenance p (nvStr ns)
nvPathP
:: MonadCited t f m
=> Provenance t m (NValue t f m)
=> Provenance m (NValue t f m)
-> FilePath
-> NValue t f m
nvPathP p x = addProvenance p (nvPath x)
nvListP
:: MonadCited t f m => Provenance t m (NValue t f m) -> [t] -> NValue t f m
nvListP :: MonadCited t f m
=> Provenance m (NValue t f m) -> [NValue t f m] -> NValue t f m
nvListP p l = addProvenance p (nvList l)
nvSetP
:: MonadCited t f m
=> Provenance t m (NValue t f m)
-> AttrSet t
=> Provenance m (NValue t f m)
-> AttrSet (NValue t f m)
-> AttrSet SourcePos
-> NValue t f m
nvSetP p s x = addProvenance p (nvSet s x)
nvClosureP
:: MonadCited t f m
=> Provenance t m (NValue t f m)
=> Provenance m (NValue t f m)
-> Params ()
-> (m (NValue t f m) -> m t)
-> (NValue t f m -> m (NValue t f m))
-> NValue t f m
nvClosureP p x f = addProvenance p (nvClosure x f)
nvBuiltinP
:: MonadCited t f m
=> Provenance t m (NValue t f m)
=> Provenance m (NValue t f m)
-> String
-> (m (NValue t f m) -> m t)
-> (NValue t f m -> m (NValue t f m))
-> NValue t f m
nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
type MonadCitedThunks t f m
= ( MonadThunk t m (NValue t f m)
= ( MonadValue (NValue t f m) m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations1 t m (NValue t f m) f
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
)
type MonadNix e t f m
= ( Has e SrcSpan
, Has e Options
, Scoped t m
, Scoped (NValue t f m) m
, Framed e m
, MonadFix m
, MonadCatch m
@ -151,6 +158,7 @@ type MonadNix e t f m
, Alternative m
, MonadEffects t f m
, MonadCitedThunks t f m
, MonadValue (NValue t f m) m
)
data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
@ -288,7 +296,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
scope <- currentScopes
span <- currentPos
addProvenance (Provenance scope (NBinary_ span NApp (Just f) Nothing))
<$> callFunc f x
<$> (callFunc f =<< defer x)
evalAbs p k = do
scope <- currentScopes
@ -296,7 +304,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
pure $ nvClosureP
(Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
(void p)
(\arg -> wrapValue . snd <$> k arg (\_ b -> ((), ) <$> b))
(\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b))
evalError = throwError
@ -305,27 +313,27 @@ callFunc
:: forall e t f m
. MonadNix e t f m
=> NValue t f m
-> NValue t f m
-> m (NValue t f m)
-> m (NValue t f m)
callFunc fun arg = do
callFunc fun arg = demand fun $ \fun' -> do
frames :: Frames <- asks (view hasLens)
when (length frames > 2000) $ throwError $ ErrorCall
"Function call stack exhausted"
case fun of
case fun' of
NVClosure params f -> do
traceM $ "callFunc:NVFunction taking " ++ show params
force ?? pure =<< f arg
f arg
NVBuiltin name f -> do
span <- currentPos
force ?? pure =<< withFrame Info (Calling @m @t name span) (f arg)
withFrame Info (Calling @m @t name span) (f arg)
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
demand f $ (`callFunc` s) >=> (`callFunc` arg)
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp
:: (Framed e m, MonadCited t f m, Show t)
=> Scopes m t
=> Scopes m (NValue t f m)
-> SrcSpan
-> NUnaryOp
-> NValue t f m
@ -354,23 +362,23 @@ execUnaryOp scope span op arg = do
execBinaryOp
:: forall e t f m
. (MonadNix e t f m, MonadEval (NValue t f m) m)
=> Scopes m t
=> Scopes m (NValue t f m)
-> SrcSpan
-> NBinaryOp
-> NValue t f m
-> m (NValue t f m)
-> m (NValue t f m)
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> if l
execBinaryOp scope span NOr larg rarg = fromValue larg >>= \l -> if l
then orOp Nothing True
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
else rarg >>= \rval -> fromValue @Bool rval >>= orOp (Just rval)
where
orOp r b = pure $ nvConstantP
(Provenance scope (NBinary_ span NOr (Just larg) r))
(NBool b)
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l
then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)
execBinaryOp scope span NAnd larg rarg = fromValue larg >>= \l -> if l
then rarg >>= \rval -> fromValue @Bool rval >>= andOp (Just rval)
else andOp Nothing False
where
andOp r b = pure $ nvConstantP
@ -379,7 +387,7 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l
execBinaryOp scope span op lval rarg = do
rval <- rarg
let bin :: (Provenance t m (NValue t f m) -> a) -> a
let bin :: (Provenance m (NValue t f m) -> a) -> a
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
toBool = pure . bin nvConstantP . NBool
case (lval, rval) of
@ -499,7 +507,7 @@ execBinaryOp scope span op lval rarg = do
++ show rval
numBinOp
:: (forall r . (Provenance t m (NValue t f m) -> r) -> r)
:: (forall r . (Provenance m (NValue t f m) -> r) -> r)
-> (forall a . Num a => a -> a -> a)
-> NAtom
-> NAtom
@ -507,7 +515,7 @@ execBinaryOp scope span op lval rarg = do
numBinOp bin f = numBinOp' bin f f
numBinOp'
:: (forall r . (Provenance t m (NValue t f m) -> r) -> r)
:: (forall r . (Provenance m (NValue t f m) -> r) -> r)
-> (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom
@ -565,12 +573,12 @@ coerceToString ctsm clevel = go
| ctsm == CopyToStore -> storePathToNixString <$> addPath p
| otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p
NVList l | clevel == CoerceAny ->
nixStringUnwords <$> traverse (`force` go) l
nixStringUnwords <$> traverse (`demand` go) l
v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
force p $ (`callFunc` pure v) >=> go
demand p $ (`callFunc` v) >=> go
NVSet s _ | Just p <- M.lookup "outPath" s -> force p go
NVSet s _ | Just p <- M.lookup "outPath" s -> demand p go
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
@ -588,7 +596,7 @@ fromStringNoContext ns = case principledGetStringNoContext ns of
Nothing -> throwError $ ErrorCall "expected string with no context"
newtype Lazy t (f :: * -> *) m a = Lazy
{ runLazy :: ReaderT (Context (Lazy t f m) t)
{ runLazy :: ReaderT (Context (Lazy t f m) (NValue t f (Lazy t f m)))
(StateT (HashMap FilePath NExprLoc) m) a }
deriving
( Functor
@ -600,7 +608,7 @@ newtype Lazy t (f :: * -> *) m a = Lazy
, MonadIO
, MonadCatch
, MonadThrow
, MonadReader (Context (Lazy t f m) t)
, MonadReader (Context (Lazy t f m) (NValue t f (Lazy t f m)))
)
instance MonadTrans (Lazy t f) where
@ -662,7 +670,7 @@ instance ( MonadFix m
mres <- lookupVar "__cur_file"
case mres of
Nothing -> getCurrentDirectory
Just v -> force v $ \case
Just v -> demand v $ \case
NVPath s -> return $ takeDirectory s
v ->
throwError
@ -699,17 +707,18 @@ instance ( MonadFix m
Lazy $ ReaderT $ const $ modify (M.insert path expr)
pure expr
derivationStrict = fromValue @(AttrSet t) >=> \s -> do
nn <- maybe (pure False) (force ?? fromNix) (M.lookup "__ignoreNulls" s)
derivationStrict = fromValue @(AttrSet (NValue t f (Lazy t f m))) >=> \s -> do
nn <- maybe (pure False) (force ?? fromValue) (M.lookup "__ignoreNulls" s)
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
v' <- normalForm =<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
v' <- normalForm =<< toValue @(AttrSet (NValue t f (Lazy t f m))) @_ @(NValue t f (Lazy t f m)) s'
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
where
mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b]
mapMaybeM op = foldr f (return [])
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
handleEntry :: Bool -> (Text, t) -> Lazy t f m (Maybe (Text, t))
handleEntry :: Bool -> (Text, NValue t f (Lazy t f m))
-> Lazy t f m (Maybe (Text, NValue t f (Lazy t f m)))
handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of
-- The `args' attribute is special: it supplies the command-line
-- arguments to the builder.
@ -721,16 +730,15 @@ instance ( MonadFix m
NVConstant NNull | ignoreNulls -> pure Nothing
v' -> Just <$> coerceNix v'
where
coerceNix :: NValue t f (Lazy t f m) -> Lazy t f m t
coerceNix =
fmap wrapValue . toNix <=< coerceToString CopyToStore CoerceAny
coerceNix :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m))
coerceNix = toValue <=< coerceToString CopyToStore CoerceAny
coerceNixList :: NValue t f (Lazy t f m) -> Lazy t f m t
coerceNixList :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m))
coerceNixList v = do
xs :: [t] <- fromValue @[t] v
ys :: [t] <- traverse (\x -> force x coerceNix) xs
v' :: NValue t f (Lazy t f m) <- toValue @[t] ys
return $ wrapValue v'
xs :: [NValue t f (Lazy t f m)] <- fromValue @[NValue t f (Lazy t f m)] v
ys :: [NValue t f (Lazy t f m)] <- traverse (\x -> demand x coerceNix) xs
v' :: NValue t f (Lazy t f m) <- toValue @[NValue t f (Lazy t f m)] ys
return v'
traceEffect = putStrLn
@ -775,7 +783,7 @@ findPathBy
:: forall e t f m
. MonadNix e t f m
=> (FilePath -> m (Maybe FilePath))
-> [t]
-> [NValue t f m]
-> FilePath
-> m FilePath
findPathBy finder l name = do
@ -790,13 +798,13 @@ findPathBy finder l name = do
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
where
go :: Maybe FilePath -> t -> m (Maybe FilePath)
go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath)
go p@(Just _) _ = pure p
go Nothing l = force l $ fromValue >=> \(s :: HashMap Text t) -> do
go Nothing l = demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do
p <- resolvePath s
force p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
Nothing -> tryPath path Nothing
Just pf -> force pf $ fromValueMay >=> \case
Just pf -> demand pf $ fromValueMay >=> \case
Just (nsPfx :: NixString) ->
let pfx = hackyStringIgnoreContext nsPfx
in if not (Text.null pfx)
@ -811,7 +819,7 @@ findPathBy finder l name = do
resolvePath s = case M.lookup "path" s of
Just t -> return t
Nothing -> case M.lookup "uri" s of
Just ut -> thunk $ fetchTarball (force ut pure)
Just ut -> defer $ fetchTarball (demand ut pure)
Nothing ->
throwError
$ ErrorCall
@ -819,7 +827,8 @@ findPathBy finder l name = do
++ " with 'path' elements, but saw: "
++ show s
findPathM :: forall e t f m . MonadNix e t f m => [t] -> FilePath -> m FilePath
findPathM :: forall e t f m . MonadNix e t f m
=> [NValue t f m] -> FilePath -> m FilePath
findPathM l name = findPathBy path l name
where
path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
@ -833,8 +842,8 @@ findEnvPathM name = do
mres <- lookupVar "__nixPath"
case mres of
Nothing -> error "impossible"
Just x ->
force x $ fromValue >=> \(l :: [t]) -> findPathBy nixFilePath l name
Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) ->
findPathBy nixFilePath l name
where
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
nixFilePath path = do
@ -877,9 +886,9 @@ evalExprLoc expr = do
if tracing opts
then join . (`runReaderT` (0 :: Int)) $ adi
(addTracing phi)
(raise (addStackFrames @t . addSourcePositions))
(raise (addStackFrames @(NValue t f m) . addSourcePositions))
expr
else adi phi (addStackFrames @t . addSourcePositions) expr
else adi phi (addStackFrames @(NValue t f m) . addSourcePositions) expr
where
phi = Eval.eval . annotated . getCompose
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
@ -890,7 +899,7 @@ fetchTarball v = v >>= \case
NVSet s _ -> case M.lookup "url" s of
Nothing ->
throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute"
Just url -> force url $ go (M.lookup "sha256" s)
Just url -> demand url $ go (M.lookup "sha256" s)
v@NVStr{} -> go Nothing v
v ->
throwError
@ -898,7 +907,7 @@ fetchTarball v = v >>= \case
$ "builtins.fetchTarball: Expected URI or set, got "
++ show v
where
go :: Maybe t -> NValue t f m -> m (NValue t f m)
go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m)
go msha = \case
NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
v ->
@ -919,10 +928,10 @@ fetchTarball v = v >>= \case
++ ext ++ "'"
-}
fetch :: Text -> Maybe t -> m (NValue t f m)
fetch :: Text -> Maybe (NValue t f m) -> m (NValue t f m)
fetch uri Nothing =
nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\""
fetch url (Just t) = force t $ fromValue >=> \nsSha ->
fetch url (Just t) = demand t $ fromValue >=> \nsSha ->
let sha = hackyStringIgnoreContext nsSha
in nixInstantiateExpr
$ "builtins.fetchTarball { "
@ -940,15 +949,8 @@ nixInstantiateExpr
:: (MonadNix e t f m, MonadInstantiate m) => String -> m (NValue t f m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
instance Monad m => Scoped t (Lazy t f m) where
instance Monad m => Scoped (NValue t f (Lazy t f m)) (Lazy t f m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lazy t f m) @t
clearScopes = clearScopesReader @(Lazy t f m) @(NValue t f (Lazy t f m))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

62
src/Nix/Normal.hs
View File

@ -13,21 +13,26 @@
module Nix.Normal where
import Control.Monad
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Fix
import Data.Set
import Nix.Cited
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
import Nix.Utils
newtype NormalLoop t f m = NormalLoop (NValue t f m)
deriving Show
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalForm'
-- | Normalize the value as much as possible, leaving only detected cycles.
normalize
:: forall e t m f
. ( Framed e m
, MonadThunk t m (NValue t f m)
@ -36,8 +41,8 @@ normalForm'
)
=> (forall r . t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValueNF t f m)
normalForm' f = run . nValueToNFM run go
-> m (NValue t f m)
normalize f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
where
start = 0 :: Int
table = mempty
@ -48,39 +53,54 @@ normalForm' f = run . nValueToNFM run go
go
:: t
-> ( NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go t k = do
b <- seen t
if b
then return $ pure t
then return $ Pure t
else do
i <- ask
when (i > 2000)
$ error "Exceeded maximum normalization depth of 2000 levels"
s <- lift get
(res, s') <- lift $ lift $ f t $ \v ->
(`runStateT` s) . (`runReaderT` i) $ local succ $ k v
lift $ put s'
return res
lifted (lifted (f t)) $ local succ . k
seen t = case thunkId t of
Just tid -> lift $ do
seen t = do
let tid = thunkId t
lift $ do
res <- gets (member tid)
unless res $ modify (insert tid)
return res
Nothing -> return False
stubCycles
:: forall t f m
. ( Applicative f
, Functor m
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
)
=> NValue t f m -> NValueNF t f m
stubCycles = freeToFix $ \t -> Fix
$ NValue
$ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc
$ reverse
$ citations @m @(NValue t f m) t
where
Fix (NValue cyc) =
nvStrNF (principledMakeNixStringWithoutContext "<CYCLE>")
normalForm
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, Ord (ThunkId m)
)
=> NValue t f m
-> m (NValueNF t f m)
normalForm = normalForm' force
normalForm = fmap stubCycles . normalize force
normalForm_
:: ( Framed e m
@ -90,19 +110,13 @@ normalForm_
)
=> NValue t f m
-> m ()
normalForm_ = void <$> normalForm' forceEff
normalForm_ = void <$> normalize forceEff
removeEffects
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> NValueNF t f m
removeEffects = nValueToNF (flip query opaque)
removeEffectsM
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> m (NValueNF t f m)
removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
removeEffects = nValueToNFM id (flip queryM (pure opaque))
opaque
:: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m
@ -112,4 +126,4 @@ dethunk
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t
-> m (NValueNF t f m)
dethunk t = queryM t (pure opaque) removeEffectsM
dethunk t = queryM t (pure opaque) removeEffects

69
src/Nix/Pretty.hs
View File

@ -18,6 +18,7 @@ module Nix.Pretty where
import Control.Applicative ( (<|>) )
import Control.Comonad
import Control.Monad.Free
import Data.Fix
import Data.HashMap.Lazy ( toList )
import qualified Data.HashMap.Lazy as M
@ -192,14 +193,25 @@ prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom
prettyNix :: NExpr -> Doc ann
prettyNix = withoutParens . cata exprFNixDoc
instance HasCitations1 t m v f
=> HasCitations t m v (NValue' t f m a) where
instance HasCitations1 m v f
=> HasCitations m v (NValue' t f m a) where
citations (NValue f) = citations1 f
addProvenance x (NValue f) = NValue (addProvenance1 x f)
instance (HasCitations1 m v f, HasCitations m v t)
=> HasCitations m v (NValue t f m) where
citations (Pure t) = citations t
citations (Free v) = citations v
addProvenance x (Pure t) = Pure (addProvenance x t)
addProvenance x (Free v) = Free (addProvenance x v)
instance HasCitations1 m v f => HasCitations m v (NValueNF t f m) where
citations (Fix v) = citations v
addProvenance x (Fix v) = Fix (addProvenance x v)
prettyOriginExpr
:: forall t f m ann
. HasCitations1 t m (NValue t f m) f
. HasCitations1 m (NValue t f m) f
=> NExprLocF (Maybe (NValue t f m))
-> Doc ann
prettyOriginExpr = withoutParens . go
@ -208,7 +220,7 @@ prettyOriginExpr = withoutParens . go
render :: Maybe (NValue t f m) -> NixDoc ann
render Nothing = simpleExpr $ "_"
render (Just (reverse . citations @t @m -> p:_)) = go (_originExpr p)
render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p)
render _ = simpleExpr "?"
-- render (Just (NValue (citations -> ps))) =
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
@ -314,21 +326,19 @@ exprFNixDoc = \case
where recPrefix = "rec" <> space
valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr
valueToExpr = iterNValueNF
(const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))
phi
valueToExpr = iterNValueNF phi
where
phi :: NValue' t f m NExpr -> NExpr
phi (NVConstant a ) = Fix $ NConstant a
phi (NVStr ns) = mkStr ns
phi (NVList l ) = Fix $ NList l
phi (NVSet s p ) = Fix $ NSet
phi (NVConstant' a ) = Fix $ NConstant a
phi (NVStr' ns) = mkStr ns
phi (NVList' l ) = Fix $ NList l
phi (NVSet' s p ) = Fix $ NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s
]
phi (NVClosure _ _ ) = Fix . NSym . pack $ "<closure>"
phi (NVPath p ) = Fix $ NLiteralPath p
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
phi (NVClosure' _ _ ) = Fix . NSym . pack $ "<closure>"
phi (NVPath' p ) = Fix $ NLiteralPath p
phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." ++ name
phi _ = error "Pattern synonyms foil completeness check"
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
@ -337,13 +347,13 @@ prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann
prettyNValueNF = prettyNix . valueToExpr
printNix :: forall t f m . MonadDataContext f m => NValueNF t f m -> String
printNix = iterNValueNF (const "<CYCLE>") phi
printNix = iterNValueNF phi
where
phi :: NValue' t f m String -> String
phi (NVConstant a ) = unpack $ atomText a
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
phi (NVList l ) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
phi (NVConstant' a ) = unpack $ atomText a
phi (NVStr' ns) = show $ hackyStringIgnoreContext ns
phi (NVList' l ) = "[ " ++ unwords l ++ " ]"
phi (NVSet' s _) =
"{ "
++ concat
[ check (unpack k) ++ " = " ++ v ++ "; "
@ -357,27 +367,28 @@ printNix = iterNValueNF (const "<CYCLE>") phi
<|> (fmap (surround . show) (readMaybe v :: Maybe Float))
)
where surround s = "\"" ++ s ++ "\""
phi NVClosure{} = "<<lambda>>"
phi (NVPath fp ) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
phi NVClosure'{} = "<<lambda>>"
phi (NVPath' fp ) = fp
phi (NVBuiltin' name _) = "<<builtin " ++ name ++ ">>"
phi _ = error "Pattern synonyms foil completeness check"
prettyNValue
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> m (Doc ann)
prettyNValue = fmap prettyNValueNF . removeEffectsM
prettyNValue = fmap prettyNValueNF . removeEffects
prettyNValueProv
:: forall t f m ann
. ( HasCitations1 t m (NValue t f m) f
. ( HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> NValue t f m
-> m (Doc ann)
prettyNValueProv v@(NValue nv) = do
let ps = citations1 @t @m @(NValue t f m) @f nv
prettyNValueProv v = do
let ps = citations @m @(NValue t f m) v
case ps of
[] -> prettyNValue v
ps -> do
@ -394,15 +405,15 @@ prettyNValueProv v@(NValue nv) = do
prettyNThunk
:: forall t f m ann
. ( HasCitations t m (NValue t f m) t
, HasCitations1 t m (NValue t f m) f
. ( HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> t
-> m (Doc ann)
prettyNThunk t = do
let ps = citations @t @m @(NValue t f m) @t t
let ps = citations @m @(NValue t f m) @t t
v' <- prettyNValueNF <$> dethunk t
pure
$ fillSep

52
src/Nix/Scope.hs
View File

@ -20,64 +20,64 @@ import Data.Text ( Text )
import Lens.Family2
import Nix.Utils
newtype Scope t = Scope { getScope :: AttrSet t }
newtype Scope a = Scope { getScope :: AttrSet a }
deriving (Functor, Foldable, Traversable, Eq)
instance Show (Scope t) where
instance Show (Scope a) where
show (Scope m) = show (M.keys m)
newScope :: AttrSet t -> Scope t
newScope :: AttrSet a -> Scope a
newScope = Scope
scopeLookup :: Text -> [Scope t] -> Maybe t
scopeLookup :: Text -> [Scope a] -> Maybe a
scopeLookup key = foldr go Nothing
where go (Scope m) rest = M.lookup key m <|> rest
data Scopes m t = Scopes
{ lexicalScopes :: [Scope t]
, dynamicScopes :: [m (Scope t)]
data Scopes m a = Scopes
{ lexicalScopes :: [Scope a]
, dynamicScopes :: [m (Scope a)]
}
instance Show (Scopes m t) where
show (Scopes m t) =
"Scopes: " ++ show m ++ ", and " ++ show (length t) ++ " with-scopes"
instance Show (Scopes m a) where
show (Scopes m a) =
"Scopes: " ++ show m ++ ", and " ++ show (length a) ++ " with-scopes"
instance Semigroup (Scopes m t) where
instance Semigroup (Scopes m a) where
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
instance Monoid (Scopes m t) where
instance Monoid (Scopes m a) where
mempty = emptyScopes
mappend = (<>)
emptyScopes :: forall m t . Scopes m t
emptyScopes :: forall m a . Scopes m a
emptyScopes = Scopes [] []
class Scoped t m | m -> t where
currentScopes :: m (Scopes m t)
clearScopes :: m a -> m a
pushScopes :: Scopes m t -> m a -> m a
lookupVar :: Text -> m (Maybe t)
class Scoped a m | m -> a where
currentScopes :: m (Scopes m a)
clearScopes :: m r -> m r
pushScopes :: Scopes m a -> m r -> m r
lookupVar :: Text -> m (Maybe a)
currentScopesReader
:: forall m t e . (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)
:: forall m a e . (MonadReader e m, Has e (Scopes m a)) => m (Scopes m a)
currentScopesReader = asks (view hasLens)
clearScopesReader
:: forall m t e a . (MonadReader e m, Has e (Scopes m t)) => m a -> m a
clearScopesReader = local (set hasLens (emptyScopes @m @t))
:: forall m a e r . (MonadReader e m, Has e (Scopes m a)) => m r -> m r
clearScopesReader = local (set hasLens (emptyScopes @m @a))
pushScope :: Scoped t m => AttrSet t -> m a -> m a
pushScope :: Scoped a m => AttrSet a -> m r -> m r
pushScope s = pushScopes (Scopes [Scope s] [])
pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a
pushWeakScope :: (Functor m, Scoped a m) => m (AttrSet a) -> m r -> m r
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
pushScopesReader
:: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a
:: (MonadReader e m, Has e (Scopes m a)) => Scopes m a -> m r -> m r
pushScopesReader s = local (over hasLens (s <>))
lookupVarReader
:: forall m t e . (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)
:: forall m a e . (MonadReader e m, Has e (Scopes m a)) => Text -> m (Maybe a)
lookupVarReader k = do
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
case mres of
@ -94,5 +94,5 @@ lookupVarReader k = do
(return Nothing)
ws
withScopes :: Scoped t m => Scopes m t -> m a -> m a
withScopes :: Scoped a m => Scopes m a -> m r -> m r
withScopes scope = clearScopes . pushScopes scope

17
src/Nix/Thunk.hs
View File

@ -29,18 +29,15 @@ class ( Monad m
=> m (ThunkId m)
freshId = lift freshId
class MonadThunkId m => MonadThunk t m v | t -> m, t -> v where
thunk :: m v -> m t
class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where
thunk :: m a -> 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
-- strictly an encapsulation of some 'a' without any additional
-- structure). For pure values represented as thunks, returns Nothing.
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
forceEff :: t -> (v -> m r) -> m r
wrapValue :: v -> t
getValue :: t -> Maybe v
thunkId :: t -> ThunkId m
queryM :: t -> m r -> (a -> m r) -> m r
force :: t -> (a -> m r) -> m r
forceEff :: t -> (a -> m r) -> m r
newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
deriving Typeable

27
src/Nix/Thunk/Basic.hs
View File

@ -27,16 +27,12 @@ data Deferred m v = Deferred (m v) | Computed v
-- | The type of very basic thunks
data NThunkF m v
= Value v
| Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))
= Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))
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...
instance Show v => Show (NThunkF m v) where
show (Value v ) = show v
show (Thunk _ _ _) = "<thunk>"
type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
@ -44,34 +40,17 @@ type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
instance (MonadBasicThunk m, MonadCatch m)
=> MonadThunk (NThunkF m v) m v where
thunk = buildThunk
thunkId = \case
Value _ -> Nothing
Thunk n _ _ -> Just n
query = queryValue
thunkId (Thunk n _ _) = n
queryM = queryThunk
force = forceThunk
forceEff = forceEffects
wrapValue = valueRef
getValue = thunkValue
valueRef :: v -> NThunkF m v
valueRef = Value
thunkValue :: NThunkF m v -> Maybe v
thunkValue (Value v) = Just v
thunkValue _ = Nothing
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk action = do
freshThunkId <- freshId
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a
queryValue (Value v) _ k = k v
queryValue _ n _ = n
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, )
if nowActive
@ -90,7 +69,6 @@ forceThunk
=> NThunkF m v
-> (v -> m a)
-> m a
forceThunk (Value v ) k = k v
forceThunk (Thunk n active ref) k = do
eres <- readVar ref
case eres of
@ -109,7 +87,6 @@ forceThunk (Thunk n active ref) k = do
k v
forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
forceEffects (Value v ) k = k v
forceEffects (Thunk _ active ref) k = do
nowActive <- atomicModifyVar active (True, )
if nowActive

22
src/Nix/Utils.hs
View File

@ -15,6 +15,8 @@ module Nix.Utils (module Nix.Utils, module X) where
import Control.Arrow ( (&&&) )
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Free
import Control.Monad.Trans.Control ( MonadTransControl(..) )
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix
@ -28,6 +30,7 @@ import Data.Monoid ( Endo
import Data.Text ( Text )
import qualified Data.Text as Text
import qualified Data.Vector as V
import Data.Void
import Lens.Family2 as X
import Lens.Family2.Stock ( _1
, _2
@ -90,6 +93,25 @@ cataPM f x = f x <=< traverse (cataPM f) . unFix $ x
transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g
transport f (Fix x) = Fix $ fmap (transport f) (f x)
lifted
:: ( MonadTransControl u
, Monad (u m)
, Monad m
)
=> ((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted f k = liftWith (\run -> f (run . k)) >>= restoreT . return
freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f
freeToFix f = go
where
go (Pure a) = f a
go (Free v) = Fix (fmap go v)
fixToFree :: Functor f => Fix f -> Free f Void
fixToFree = Free . go
where
go (Fix f) = fmap (Free . go) f
-- | adi is Abstracting Definitional Interpreters:
--
-- https://arxiv.org/abs/1707.04755

303
src/Nix/Value.hs
View File

@ -36,10 +36,12 @@ import Control.Monad
import Control.Monad.Free
import Control.Monad.Trans.Class
import qualified Data.Aeson as A
import Data.Fix
import Data.Functor.Classes
import Data.HashMap.Lazy ( HashMap )
import Data.Text ( Text )
import Data.Typeable ( Typeable )
import Data.Void
import GHC.Generics
import Lens.Family2
import Lens.Family2.Stock
@ -62,7 +64,7 @@ data NValueF p m r
| NVPathF FilePath
| NVListF [r]
| NVSetF (AttrSet r) (AttrSet SourcePos)
| NVClosureF (Params ()) (m p -> m r)
| NVClosureF (Params ()) (p -> m r)
-- ^ A function is a closed set of parameters representing the "call
-- signature", used at application time to check the type of arguments
-- passed to the function. Since it supports default values which may
@ -74,7 +76,7 @@ data NValueF p m r
-- Note that 'm r' is being used here because effectively a function
-- and its set of default arguments is "never fully evaluated". This
-- enforces in the type that it must be re-evaluated for each call.
| NVBuiltinF String (m p -> m r)
| NVBuiltinF String (p -> m r)
-- ^ A builtin function is itself already in normal form. Also, it may
-- or may not choose to evaluate its argument in the production of a
-- result.
@ -92,6 +94,20 @@ instance Foldable (NValueF p m) where
NVClosureF _ _ -> mempty
NVBuiltinF _ _ -> mempty
instance Show r => Show (NValueF p m r) where
showsPrec = flip go where
go (NVConstantF atom ) = showsCon1 "NVConstant" atom
go (NVStrF ns ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
go (NVListF lst ) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p ) = showsCon1 "NVPath" p
go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
lmapNValueF f = \case
NVConstantF a -> NVConstantF a
@ -99,22 +115,21 @@ lmapNValueF f = \case
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p (g . fmap f)
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
NVClosureF p g -> NVClosureF p (g . f)
NVBuiltinF s g -> NVBuiltinF s (g . f)
hoistNValueF
:: (forall x . n x -> m x)
-> (forall x . m x -> n x)
:: (forall x . m x -> n x)
-> NValueF p m a
-> NValueF p n a
hoistNValueF run lft = \case
hoistNValueF lft = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p (lft . g . run)
NVBuiltinF s g -> NVBuiltinF s (lft . g . run)
NVClosureF p g -> NVClosureF p (lft . g)
NVBuiltinF s g -> NVBuiltinF s (lft . g)
sequenceNValueF
:: (Functor n, Monad m, Applicative n)
@ -147,17 +162,16 @@ bindNValueF transform f = \case
liftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p m a
=> NValueF p m a
-> NValueF p (u m) a
liftNValueF run = hoistNValueF run lift
liftNValueF = hoistNValueF lift
unliftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p (u m) a
-> NValueF p m a
unliftNValueF run = hoistNValueF lift run
unliftNValueF = hoistNValueF
type MonadDataContext f (m :: * -> *)
= (Comonad f, Applicative f, Traversable f, Monad m)
@ -167,76 +181,69 @@ type MonadDataContext f (m :: * -> *)
newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
deriving (Generic, Typeable, Functor, Foldable)
instance Show r => Show (NValueF p m r) where
showsPrec = flip go where
go (NVConstantF atom ) = showsCon1 "NVConstant" atom
go (NVStrF ns ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
go (NVListF lst ) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p ) = showsCon1 "NVPath" p
go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
instance (Comonad f, Show a) => Show (NValue' t f m a) where
show (NValue (extract -> v)) = show v
instance Comonad f => Show1 (NValue' t f m) where
liftShowsPrec sp sl p = \case
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStr ns ->
NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStr' ns ->
showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
NVList lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSet attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVPath path -> showsUnaryWith showsPrec "NVPathF" p path
NVClosure c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
_ -> error "Pattern synonyms mask coverage"
NVList' lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSet' attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVPath' path -> showsUnaryWith showsPrec "NVPathF" p path
NVClosure' c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVBuiltin' name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
_ -> error "Pattern synonyms mask coverage"
type NValue t f m = NValue' t f m t
sequenceNValue
sequenceNValue'
:: (Functor n, Traversable f, Monad m, Applicative n)
=> (forall x . n x -> m x)
-> NValue' t f m (n a)
-> n (NValue' t f m a)
sequenceNValue transform (NValue v) =
sequenceNValue' transform (NValue v) =
NValue <$> traverse (sequenceNValueF transform) v
bindNValue
bindNValue'
:: (Traversable f, Monad m, Monad n)
=> (forall x . n x -> m x)
-> (a -> n b)
-> NValue' t f m a
-> n (NValue' t f m b)
bindNValue transform f (NValue v) =
bindNValue' transform f (NValue v) =
NValue <$> traverse (bindNValueF transform f) v
hoistNValue
hoistNValue'
:: (Functor m, Functor n, Functor f)
=> (forall x . n x -> m x)
-> (forall x . m x -> n x)
-> NValue' t f m a
-> NValue' t f n a
hoistNValue run lft (NValue v) =
NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF run lft) v)
hoistNValue' run lft (NValue v) =
NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF lft) v)
liftNValue
liftNValue'
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue' t f m a
-> NValue' t f (u m) a
liftNValue run = hoistNValue run lift
liftNValue' run = hoistNValue' run lift
unliftNValue
unliftNValue'
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue' t f (u m) a
-> NValue' t f m a
unliftNValue run = hoistNValue lift run
unliftNValue' run = hoistNValue' lift run
iterNValue'
:: forall t f m a r
. MonadDataContext f m
=> (a -> (NValue' t f m a -> r) -> r)
-> (NValue' t f m r -> r)
-> NValue' t f m a
-> r
iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f))
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is
-- a value in head normal form, where only the "top layer" has been
@ -248,64 +255,72 @@ unliftNValue run = hoistNValue lift run
-- The 'Free' structure is used here to represent the possibility that
-- cycles may appear during normalization.
type NValueNF t f m = Free (NValue' t f m) t
type NValue t f m = Free (NValue' t f m) t
type NValueNF t f m = Fix (NValue' t f m)
hoistNValue
:: (Functor m, Functor n, Functor f)
=> (forall x . n x -> m x)
-> (forall x . m x -> n x)
-> NValue t f m
-> NValue t f n
hoistNValue run lft = hoistFree (hoistNValue' run lft)
liftNValue
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue t f m
-> NValue t f (u m)
liftNValue run = hoistNValue run lift
unliftNValue
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue t f (u m)
-> NValue t f m
unliftNValue run = hoistNValue lift run
iterNValue
:: forall t f m a r
:: forall t f m r
. MonadDataContext f m
=> (a -> (NValue' t f m a -> r) -> r)
=> (t -> (NValue t f m -> r) -> r)
-> (NValue' t f m r -> r)
-> NValue' t f m a
-> NValue t f m
-> r
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
iterNValue k f = iter f . fmap (\t -> k t (iterNValue k f))
iterNValueM
:: (MonadDataContext f m, Monad n)
=> (forall x . n x -> m x)
-> (a -> (NValue' t f m a -> n r) -> n r)
-> (NValue' t f m r -> n r)
-> NValue' t f m a
-> (t -> (NValue t f m -> n r) -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValue t f m
-> n r
iterNValueM transform k f =
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
iterM f <=< go . fmap (\t -> k t (iterNValueM transform k f))
where
go (Pure x) = Pure <$> x
go (Free fa) = Free <$> bindNValue' transform go fa
iterNValueNF
:: MonadDataContext f m
=> (t -> r)
-> (NValue' t f m r -> r)
=> (NValue' t f m r -> r)
-> NValueNF t f m
-> r
iterNValueNF k f = iter f . fmap k
iterNValueNFM
:: forall f m n t r
. (MonadDataContext f m, Monad n)
=> (forall x . n x -> m x)
-> (t -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValueNF t f m
-> n r
iterNValueNFM transform k f v =
iterM f =<< go (fmap k v)
where
go (Pure a ) = Pure <$> a
go (Free fa) = Free <$> bindNValue transform go fa
iterNValueNF = cata
nValueFromNF
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m
-> NValue t f m
nValueFromNF = iterNValueNF f (fmap wrapValue)
where
f t = query t cyc id
cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")
nValueFromNF = fmap absurd . fixToFree
nValueToNF
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
-> NValue t f m
-> NValueNF t f m
nValueToNF k = iterNValue k Free
nValueToNF k = iterNValue k Fix
nValueToNFM
:: (MonadDataContext f m, Monad n)
@ -313,91 +328,124 @@ nValueToNFM
-> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
-> NValue t f m
-> n (NValueNF t f m)
nValueToNFM transform k = iterNValueM transform k $ pure . Free
nValueToNFM transform k = iterNValueM transform k undefined
pattern NVConstant x <- NValue (extract -> NVConstantF x)
pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))
pattern NVThunk t <- Pure t
nvThunk :: Applicative f => t -> NValue t f m
nvThunk = Pure
pattern NVConstant' x <- NValue (extract -> NVConstantF x)
pattern NVConstant x <- Free (NVConstant' x)
pattern NVConstantNF x <- Fix (NVConstant' x)
nvConstant' :: Applicative f => NAtom -> NValue' t f m r
nvConstant' x = NValue (pure (NVConstantF x))
nvConstant :: Applicative f => NAtom -> NValue t f m
nvConstant x = NValue (pure (NVConstantF x))
nvConstant x = Free (NValue (pure (NVConstantF x)))
nvConstantNF :: Applicative f => NAtom -> NValueNF t f m
nvConstantNF x = Free (NValue (pure (NVConstantF x)))
nvConstantNF x = Fix (NValue (pure (NVConstantF x)))
pattern NVStr ns <- NValue (extract -> NVStrF ns)
pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))
pattern NVStr' ns <- NValue (extract -> NVStrF ns)
pattern NVStr ns <- Free (NVStr' ns)
pattern NVStrNF ns <- Fix (NVStr' ns)
nvStr' :: Applicative f => NixString -> NValue' t f m r
nvStr' ns = NValue (pure (NVStrF ns))
nvStr :: Applicative f => NixString -> NValue t f m
nvStr ns = NValue (pure (NVStrF ns))
nvStr ns = Free (NValue (pure (NVStrF ns)))
nvStrNF :: Applicative f => NixString -> NValueNF t f m
nvStrNF ns = Free (NValue (pure (NVStrF ns)))
nvStrNF ns = Fix (NValue (pure (NVStrF ns)))
pattern NVPath x <- NValue (extract -> NVPathF x)
pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))
pattern NVPath' x <- NValue (extract -> NVPathF x)
pattern NVPath x <- Free (NVPath' x)
pattern NVPathNF x <- Fix (NVPath' x)
nvPath' :: Applicative f => FilePath -> NValue' t f m r
nvPath' x = NValue (pure (NVPathF x))
nvPath :: Applicative f => FilePath -> NValue t f m
nvPath x = NValue (pure (NVPathF x))
nvPath x = Free (NValue (pure (NVPathF x)))
nvPathNF :: Applicative f => FilePath -> NValueNF t f m
nvPathNF x = Free (NValue (pure (NVPathF x)))
nvPathNF x = Fix (NValue (pure (NVPathF x)))
pattern NVList l <- NValue (extract -> NVListF l)
pattern NVListNF l <- Free (NValue (extract -> NVListF l))
pattern NVList' l <- NValue (extract -> NVListF l)
pattern NVList l <- Free (NVList' l)
pattern NVListNF l <- Fix (NVList' l)
nvList :: Applicative f => [t] -> NValue t f m
nvList l = NValue (pure (NVListF l))
nvList' :: Applicative f => [r] -> NValue' t f m r
nvList' l = NValue (pure (NVListF l))
nvList :: Applicative f => [NValue t f m] -> NValue t f m
nvList l = Free (NValue (pure (NVListF l)))
nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m
nvListNF l = Free (NValue (pure (NVListF l)))
nvListNF l = Fix (NValue (pure (NVListF l)))
pattern NVSet s x <- NValue (extract -> NVSetF s x)
pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))
pattern NVSet' s x <- NValue (extract -> NVSetF s x)
pattern NVSet s x <- Free (NVSet' s x)
pattern NVSetNF s x <- Fix (NVSet' s x)
nvSet' :: Applicative f
=> HashMap Text r -> HashMap Text SourcePos -> NValue' t f m r
nvSet' s x = NValue (pure (NVSetF s x))
nvSet :: Applicative f
=> HashMap Text t -> HashMap Text SourcePos -> NValue t f m
nvSet s x = NValue (pure (NVSetF s x))
=> HashMap Text (NValue t f m) -> HashMap Text SourcePos -> NValue t f m
nvSet s x = Free (NValue (pure (NVSetF s x)))
nvSetNF :: Applicative f
=> HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m
nvSetNF s x = Free (NValue (pure (NVSetF s x)))
=> HashMap Text (NValueNF t f m) -> HashMap Text SourcePos
-> NValueNF t f m
nvSetNF s x = Fix (NValue (pure (NVSetF s x)))
pattern NVClosure x f <- NValue (extract -> NVClosureF x f)
pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))
pattern NVClosure' x f <- NValue (extract -> NVClosureF x f)
pattern NVClosure x f <- Free (NVClosure' x f)
pattern NVClosureNF x f <- Fix (NVClosure' x f)
nvClosure :: Applicative f
=> Params () -> (m (NValue t f m) -> m t) -> NValue t f m
nvClosure x f = NValue (pure (NVClosureF x f))
nvClosure' :: (Applicative f, Functor m)
=> Params () -> (NValue t f m -> m r) -> NValue' t f m r
nvClosure' x f = NValue (pure (NVClosureF x f))
nvClosure :: (Applicative f, Functor m)
=> Params () -> (NValue t f m -> m (NValue t f m)) -> NValue t f m
nvClosure x f = Free (NValue (pure (NVClosureF x f)))
nvClosureNF :: Applicative f
=> Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvClosureNF x f = Free (NValue (pure (NVClosureF x f)))
=> Params () -> (NValue t f m -> m (NValueNF t f m))
-> NValueNF t f m
nvClosureNF x f = Fix (NValue (pure (NVClosureF x f)))
pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)
pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))
pattern NVBuiltin' name f <- NValue (extract -> NVBuiltinF name f)
pattern NVBuiltin name f <- Free (NVBuiltin' name f)
pattern NVBuiltinNF name f <- Fix (NVBuiltin' name f)
nvBuiltin :: Applicative f
=> String -> (m (NValue t f m) -> m t) -> NValue t f m
nvBuiltin name f = NValue (pure (NVBuiltinF name f))
nvBuiltin' :: (Applicative f, Functor m)
=> String -> (NValue t f m -> m r) -> NValue' t f m r
nvBuiltin' name f = NValue (pure (NVBuiltinF name f))
nvBuiltin :: (Applicative f, Functor m)
=> String -> (NValue t f m -> m (NValue t f m)) -> NValue t f m
nvBuiltin name f =
Free (NValue (pure (NVBuiltinF name f)))
nvBuiltinNF :: Applicative f
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
=> String -> (NValue t f m -> m (NValueNF t f m))
-> NValueNF t f m
nvBuiltinNF name f = Fix (NValue (pure (NVBuiltinF name f)))
builtin
:: forall m f t
. (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue t f m) -> m (NValue t f m))
-> (NValue t f m -> m (NValue t f m))
-> m (NValue t f m)
builtin name f = return $ nvBuiltin name $ \a -> thunk $ f a
builtin name f = return $ nvBuiltin name $ \a -> f a
builtin2
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
-> (NValue t f m -> NValue t f m -> m (NValue t f m))
-> m (NValue t f m)
builtin2 name f = builtin name $ \a -> builtin name $ \b -> f a b
builtin3
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> ( m (NValue t f m)
-> m (NValue t f m)
-> m (NValue t f m)
-> ( NValue t f m
-> NValue t f m
-> NValue t f m
-> m (NValue t f m)
)
-> m (NValue t f m)
@ -454,7 +502,7 @@ describeValue = \case
TBuiltin -> "a builtin function"
data ValueFrame t f m
= ForcingThunk
= ForcingThunk t
| ConcerningValue (NValue t f m)
| Comparison (NValue t f m) (NValue t f m)
| Addition (NValue t f m) (NValue t f m)
@ -463,9 +511,10 @@ data ValueFrame t f m
| Coercion ValueType ValueType
| CoercionToJson (NValue t f m)
| CoercionFromJson A.Value
| ExpectationNF ValueType (NValueNF t f m)
| Expectation ValueType (NValue t f m)
deriving (Show, Typeable)
| forall r. Show r => Expectation ValueType (NValue' t f m r)
deriving Typeable
deriving instance (Comonad f, Show t) => Show (ValueFrame t f m)
type MonadDataErrorContext t f m
= (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)

31
src/Nix/Value/Equal.hs
View File

@ -38,6 +38,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Align
import Data.Eq.Deriving
import Data.Fix
import Data.Functor.Classes
import Data.Functor.Identity
import qualified Data.HashMap.Lazy as M
@ -164,30 +165,30 @@ compareAttrSets f eq lm rm = runIdentity
$ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm
valueEqM
:: (MonadThunk t m (NValue t f m), Comonad f)
:: forall t f m. (MonadThunk t m (NValue t f m), Comonad f)
=> NValue t f m
-> NValue t f m
-> m Bool
valueEqM (NValue (extract -> x)) (NValue (extract -> y)) = valueFEqM
(compareAttrSetsM f thunkEqM)
thunkEqM
x
y
where
f t = force t $ \case
valueEqM (Pure x) (Pure y) = thunkEqM x y
valueEqM (Pure _) _ = pure False
valueEqM _ (Pure _) = pure False
valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y
where
f (Pure t) = force t $ \case
NVStr s -> pure $ Just s
_ -> pure Nothing
f (Free v) = case v of
NVStr' s -> pure $ Just s
_ -> pure Nothing
valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool
valueNFEq (Pure _) (Pure _) = False
valueNFEq (Pure _) (Free _) = False
valueNFEq (Free _) (Pure _) = False
valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
valueNFEq (Fix (NValue (extract -> x))) (Fix (NValue (extract -> y))) =
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
where
f (Pure _ ) = Nothing
f (Free (NVStr s)) = Just s
f _ = Nothing
f = \case
NVStrNF s -> Just s
_ -> Nothing
instance Eq1 (NValueF p m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y

8
src/Nix/Value/Monad.hs Normal file
View File

@ -0,0 +1,8 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Nix.Value.Monad where
class MonadValue v m where
defer :: m v -> m v
demand :: v -> (v -> m r) -> m r