Begin work on harmonizing the two different value representations
This commit is contained in:
parent
f5d070af16
commit
522585a7f1
|
@ -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.
|
||||
|
|
|
@ -475,6 +475,7 @@ library
|
|||
Nix.Utils
|
||||
Nix.Value
|
||||
Nix.Value.Equal
|
||||
Nix.Value.Monad
|
||||
Nix.Var
|
||||
Nix.XML
|
||||
other-modules:
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
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
|
||||
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)
|
||||
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
|
||||
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)
|
||||
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
|
||||
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
|
||||
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)
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
147
src/Nix/Eval.hs
147
src/Nix/Eval.hs
|
@ -38,8 +38,13 @@ 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
|
||||
|
@ -69,50 +74,53 @@ class (Show v, Monad m) => MonadEval v m where
|
|||
-- | 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
|
||||
evalList :: [v] -> m v
|
||||
evalSetElem :: AttrSet (m v) -> Text -> m v -> m v
|
||||
evalSet :: AttrSet t -> AttrSet SourcePos -> m v
|
||||
evalSet :: AttrSet v -> AttrSet SourcePos -> m v
|
||||
evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v
|
||||
evalRecSet :: AttrSet t -> AttrSet SourcePos -> 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
|
||||
|
||||
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
150
src/Nix/Exec.hs
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,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
|
||||
|
|
|
@ -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
|
||||
|
|
301
src/Nix/Value.hs
301
src/Nix/Value.hs
|
@ -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
|
||||
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)
|
||||
|
|
|
@ -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
|
||||
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 t = force t $ \case
|
||||
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
|
||||
|
|
|
@ -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
|
Loading…
Reference in New Issue