Remove the NValueNF type, as it provides little utility
This commit is contained in:
John Wiegley
parent
3d89159ee4
commit
4607639774
11
main/Main.hs
11
main/Main.hs
|
|
@ -151,14 +151,15 @@ main = do
|
|||
. principledStringIgnoreContext
|
||||
<=< nvalueToJSONNixString
|
||||
| strict opts
|
||||
= liftIO . print . prettyNValueNF <=< normalForm
|
||||
= liftIO . print . prettyNValue <=< normalForm
|
||||
| values opts
|
||||
= liftIO . print <=< prettyNValueProv
|
||||
= liftIO . print . prettyNValueProv <=< removeEffects
|
||||
| otherwise
|
||||
= liftIO . print <=< prettyNValue
|
||||
= liftIO . print . prettyNValue <=< removeEffects
|
||||
where
|
||||
findAttrs :: AttrSet (StdValue (StandardT (StdIdT IO)))
|
||||
-> StandardT (StdIdT IO) ()
|
||||
findAttrs
|
||||
:: AttrSet (StdValue (StandardT (StdIdT IO)))
|
||||
-> StandardT (StdIdT IO) ()
|
||||
findAttrs = go ""
|
||||
where
|
||||
go prefix s = do
|
||||
|
|
|
|||
|
|
@ -138,9 +138,9 @@ cmd source = do
|
|||
lift $ lift $ do
|
||||
opts :: Nix.Options <- asks (view hasLens)
|
||||
if
|
||||
| strict opts -> liftIO . print . prettyNValueNF =<< normalForm val
|
||||
| values opts -> liftIO . print =<< prettyNValueProv val
|
||||
| otherwise -> liftIO . print =<< prettyNValue val
|
||||
| strict opts -> liftIO . print . prettyNValue =<< normalForm val
|
||||
| values opts -> liftIO . print . prettyNValueProv =<< removeEffects val
|
||||
| otherwise -> liftIO . print . prettyNValue =<< removeEffects val
|
||||
-------------------------------------------------------------------------------
|
||||
-- Commands
|
||||
-------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -118,8 +118,7 @@ evaluateExpression mpath evaluator handler expr = do
|
|||
|
||||
eval' = (normalForm =<<) . nixEvalExpr mpath
|
||||
|
||||
argmap args = nvSet (M.fromList args') mempty
|
||||
where args' = map (fmap nValueFromNF) args
|
||||
argmap args = nvSet (M.fromList args) mempty
|
||||
|
||||
compute ev x args p = ev mpath x >>= \f -> demand f $ \f' ->
|
||||
processResult p =<< case f' of
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ import Data.ByteString ( ByteString )
|
|||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Base16 as Base16
|
||||
import Data.Char ( isDigit )
|
||||
import Data.Fix
|
||||
import Data.Fix ( cata )
|
||||
import Data.Foldable ( foldrM )
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@ module Nix.Convert where
|
|||
|
||||
import Control.Monad.Free
|
||||
import Data.ByteString
|
||||
import Data.Fix
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
|
|
@ -77,14 +76,6 @@ class FromValue a m v where
|
|||
type Convertible e t f m
|
||||
= (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m))
|
||||
|
||||
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 (Fix v) = fromValueMay v
|
||||
fromValue (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))
|
||||
|
|
@ -97,14 +88,6 @@ instance ( Convertible e t f m
|
|||
Pure t -> force t fromValue
|
||||
Free v -> fromValue v
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, MonadValue (NValueNF t f m) m
|
||||
, FromValue a m (Deeper (NValue' t f m (NValueNF t f m)))
|
||||
)
|
||||
=> FromValue a m (Deeper (NValueNF t f m)) where
|
||||
fromValueMay (Deeper (Fix v)) = fromValueMay (Deeper v)
|
||||
fromValue (Deeper (Fix v)) = fromValue (Deeper v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, MonadValue (NValue t f m) m
|
||||
, FromValue a m (Deeper (NValue' t f m (NValue t f m)))
|
||||
|
|
@ -117,68 +100,57 @@ instance ( Convertible e t f m
|
|||
Pure t -> force t (fromValue . Deeper)
|
||||
Free v -> fromValue (Deeper v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue () m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue () m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVConstant' NNull -> pure $ Just ()
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TNull (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TNull (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue Bool m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue Bool m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVConstant' (NBool b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TBool (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TBool (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue Int m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue Int m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVConstant' (NInt b) -> pure $ Just (fromInteger b)
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TInt (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TInt (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue Integer m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue Integer m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVConstant' (NInt b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TInt (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TInt (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue Float m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue Float m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
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 @t @f @m TFloat (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TFloat (Free v)
|
||||
|
||||
instance (Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
instance ( Convertible e t f m
|
||||
, MonadValue (NValue t f m) m
|
||||
, MonadEffects t f m
|
||||
, FromValue NixString m r
|
||||
)
|
||||
=> FromValue NixString m (NValue' t f m r) where
|
||||
=> FromValue NixString m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVStr' ns -> pure $ Just ns
|
||||
NVPath' p ->
|
||||
|
|
@ -193,27 +165,24 @@ instance (Convertible e t f m
|
|||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue ByteString m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue ByteString m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v)
|
||||
|
||||
newtype Path = Path { getPath :: FilePath }
|
||||
deriving Show
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
, FromValue Path m r
|
||||
, MonadValue (NValue t f m) m
|
||||
)
|
||||
=> FromValue Path m (NValue' t f m r) where
|
||||
=> FromValue Path m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVPath' p -> pure $ Just (Path p)
|
||||
NVStr' ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
|
||||
|
|
@ -223,76 +192,69 @@ instance ( Convertible e t f m
|
|||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TPath (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TPath (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue [r] m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVList' l -> pure $ Just l
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TList (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TList (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
, FromValue a m r
|
||||
, FromValue a m (NValue t f m)
|
||||
)
|
||||
=> FromValue [a] m (Deeper (NValue' t f m r)) where
|
||||
=> FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where
|
||||
fromValueMay = \case
|
||||
Deeper (NVList' l) -> sequence <$> traverse fromValueMay l
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TList (embedValue (getDeeper v))
|
||||
_ -> throwError $ Expectation @t @f @m TList (Free (getDeeper v))
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue (AttrSet r) m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVSet' s _ -> pure $ Just s
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TSet (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TSet (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
, FromValue a m r
|
||||
, FromValue a m (NValue t f m)
|
||||
)
|
||||
=> FromValue (AttrSet a) m (Deeper (NValue' t f m r)) where
|
||||
=> FromValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where
|
||||
fromValueMay = \case
|
||||
Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TSet (embedValue (getDeeper v))
|
||||
_ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v))
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
)
|
||||
=> FromValue (AttrSet r, AttrSet SourcePos) m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m
|
||||
(NValue' t f m (NValue t f m)) where
|
||||
fromValueMay = \case
|
||||
NVSet' s p -> pure $ Just (s, p)
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TSet (embedValue v)
|
||||
_ -> throwError $ Expectation @t @f @m TSet (Free v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
, FromValue a m r
|
||||
, FromValue a m (NValue t f m)
|
||||
)
|
||||
=> FromValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m r)) where
|
||||
=> FromValue (AttrSet a, AttrSet SourcePos) m
|
||||
(Deeper (NValue' t f m (NValue t f m))) where
|
||||
fromValueMay = \case
|
||||
Deeper (NVSet' s p) -> fmap (, p) <$> sequence <$> traverse fromValueMay s
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> throwError $ Expectation @t @f @m TSet (embedValue (getDeeper v))
|
||||
_ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v))
|
||||
|
||||
-- This instance needs IncoherentInstances, and only because of ToBuiltin
|
||||
instance ( Convertible e t f m
|
||||
|
|
@ -309,58 +271,55 @@ instance ( Convertible e t f m
|
|||
class ToValue a m v where
|
||||
toValue :: a -> m v
|
||||
|
||||
instance (Convertible e t f m, ToValue a m (NValue' t f m (NValueNF t f m)))
|
||||
=> ToValue a m (NValueNF t f m) where
|
||||
toValue = fmap Fix . toValue
|
||||
|
||||
instance (Convertible e t f m, ToValue a m (NValue' t f m (NValue t f m)))
|
||||
=> ToValue a m (NValue t f m) where
|
||||
toValue = fmap Free . toValue
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, ToValue a m (Deeper (NValue' t f m (NValueNF t f m)))
|
||||
)
|
||||
=> ToValue a m (Deeper (NValueNF t f m)) where
|
||||
toValue = fmap (fmap Fix) . toValue
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, ToValue a m (Deeper (NValue' t f m (NValue t f m)))
|
||||
)
|
||||
=> ToValue a m (Deeper (NValue t f m)) where
|
||||
toValue = fmap (fmap Free) . toValue
|
||||
|
||||
instance Convertible e t f m => ToValue () m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue () m (NValue' t f m (NValue t f m)) where
|
||||
toValue _ = pure . nvConstant' $ NNull
|
||||
|
||||
instance Convertible e t f m => ToValue Bool m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue Bool m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvConstant' . NBool
|
||||
|
||||
instance Convertible e t f m => ToValue Int m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue Int m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvConstant' . NInt . toInteger
|
||||
|
||||
instance Convertible e t f m => ToValue Integer m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue Integer m (NValue' t f 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
|
||||
instance Convertible e t f m
|
||||
=> ToValue Float m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvConstant' . NFloat
|
||||
|
||||
instance Convertible e t f m => ToValue NixString m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue NixString m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvStr'
|
||||
|
||||
instance Convertible e t f m => ToValue ByteString m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue ByteString m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvStr' . hackyMakeNixStringWithoutContext . decodeUtf8
|
||||
|
||||
instance Convertible e t f m => ToValue Path m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue Path m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvPath' . getPath
|
||||
|
||||
instance Convertible e t f m => ToValue StorePath m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue StorePath m (NValue' t f m (NValue t f m)) where
|
||||
toValue = toValue . Path . unStorePath
|
||||
|
||||
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 m (NValue' t f m (NValue t f m)) where
|
||||
toValue (SourcePos f l c) = do
|
||||
f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f))
|
||||
l' <- toValue (unPos l)
|
||||
|
|
@ -369,37 +328,34 @@ instance ( Convertible e t f m
|
|||
pure $ nvSet' pos mempty
|
||||
|
||||
-- | With 'ToValue', we can always act recursively
|
||||
instance Convertible e t f m => ToValue [r] m (NValue' t f m r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where
|
||||
toValue = pure . nvList'
|
||||
|
||||
instance (Convertible e t f m, ToValue a m r)
|
||||
=> ToValue [a] m (Deeper (NValue' t f m r)) where
|
||||
instance (Convertible e t f m, ToValue a m (NValue t f m))
|
||||
=> ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where
|
||||
toValue = fmap (Deeper . nvList') . traverse toValue
|
||||
|
||||
instance Convertible e t f m
|
||||
=> ToValue (AttrSet r) m (NValue' t f m r) where
|
||||
=> ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where
|
||||
toValue s = pure $ nvSet' s mempty
|
||||
|
||||
instance (Convertible e t f m, ToValue a m r)
|
||||
=> ToValue (AttrSet a) m (Deeper (NValue' t f m r)) where
|
||||
instance (Convertible e t f m, ToValue a m (NValue t f m))
|
||||
=> ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where
|
||||
toValue s = (Deeper .) . nvSet' <$> traverse toValue s <*> pure mempty
|
||||
|
||||
instance Convertible e t f m
|
||||
=> ToValue (AttrSet r, AttrSet SourcePos) m (NValue' t f m r) where
|
||||
=> ToValue (AttrSet (NValue t f m), AttrSet SourcePos) m
|
||||
(NValue' t f m (NValue t f m)) where
|
||||
toValue (s, p) = pure $ nvSet' s p
|
||||
|
||||
instance (Convertible e t f m, ToValue a m r)
|
||||
=> ToValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m r)) where
|
||||
instance (Convertible e t f m, ToValue a m (NValue t f m))
|
||||
=> ToValue (AttrSet a, AttrSet SourcePos) m
|
||||
(Deeper (NValue' t f m (NValue t f m))) where
|
||||
toValue (s, p) = (Deeper .) . nvSet' <$> traverse toValue s <*> pure p
|
||||
|
||||
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 r) where
|
||||
instance Convertible e t f m
|
||||
=> ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where
|
||||
toValue nlcv = do
|
||||
path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing
|
||||
allOutputs <- if nlcvAllOutputs nlcv
|
||||
|
|
@ -408,7 +364,7 @@ instance ( MonadValue (NValue t f m) m
|
|||
outputs <- do
|
||||
let outputs =
|
||||
fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv
|
||||
ts :: [r] <- traverse toValue outputs
|
||||
ts :: [NValue t f m] <- traverse toValue outputs
|
||||
case ts of
|
||||
[] -> return Nothing
|
||||
_ -> Just <$> toValue ts
|
||||
|
|
@ -418,8 +374,8 @@ instance ( MonadValue (NValue t f m) m
|
|||
, (\os -> ("outputs", os)) <$> outputs
|
||||
]
|
||||
|
||||
instance Convertible e t f m => ToValue () m (NExprF r) where
|
||||
instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where
|
||||
toValue _ = pure . NConstant $ NNull
|
||||
|
||||
instance Convertible e t f m => ToValue Bool m (NExprF r) where
|
||||
instance Convertible e t f m => ToValue Bool m (NExprF (NValue t f m)) where
|
||||
toValue = pure . NConstant . NBool
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
|
|||
nn <- maybe (pure False) (demand ?? fromValue) (M.lookup "__ignoreNulls" s)
|
||||
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
|
||||
v' <- normalForm =<< toValue @(AttrSet (NValue t f m)) @_ @(NValue t f m) s'
|
||||
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
|
||||
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v')
|
||||
where
|
||||
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
|
||||
mapMaybeM op = foldr f (return [])
|
||||
|
|
|
|||
|
|
@ -182,14 +182,13 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
|
|||
$ "Inheriting unknown attribute: "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
|
||||
attrMissing ks (Just s) = do
|
||||
s' <- prettyNValue s
|
||||
attrMissing ks (Just s) =
|
||||
evalError @(NValue t f m)
|
||||
$ ErrorCall
|
||||
$ "Could not look up attribute "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
++ " in "
|
||||
++ show s'
|
||||
++ show (prettyNValue s)
|
||||
|
||||
evalCurPos = do
|
||||
scope <- currentScopes
|
||||
|
|
|
|||
|
|
@ -17,7 +17,6 @@ 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
|
||||
|
|
@ -32,7 +31,7 @@ newtype NormalLoop t f m = NormalLoop (NValue t f m)
|
|||
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
|
||||
|
||||
-- | Normalize the value as much as possible, leaving only detected cycles.
|
||||
normalize
|
||||
normalizeValue
|
||||
:: forall e t m f
|
||||
. ( Framed e m
|
||||
, MonadThunk t m (NValue t f m)
|
||||
|
|
@ -42,7 +41,7 @@ normalize
|
|||
=> (forall r . t -> (NValue t f m -> m r) -> m r)
|
||||
-> NValue t f m
|
||||
-> m (NValue t f m)
|
||||
normalize f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
||||
normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
||||
where
|
||||
start = 0 :: Int
|
||||
table = mempty
|
||||
|
|
@ -73,24 +72,6 @@ normalize f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
|||
unless res $ modify (insert tid)
|
||||
return res
|
||||
|
||||
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)
|
||||
|
|
@ -100,8 +81,8 @@ normalForm
|
|||
, Ord (ThunkId m)
|
||||
)
|
||||
=> NValue t f m
|
||||
-> m (NValueNF t f m)
|
||||
normalForm = fmap stubCycles . normalize force
|
||||
-> m (NValue t f m)
|
||||
normalForm = fmap stubCycles . normalizeValue force
|
||||
|
||||
normalForm_
|
||||
:: ( Framed e m
|
||||
|
|
@ -111,20 +92,40 @@ normalForm_
|
|||
)
|
||||
=> NValue t f m
|
||||
-> m ()
|
||||
normalForm_ = void <$> normalize forceEff
|
||||
normalForm_ = void <$> normalizeValue forceEff
|
||||
|
||||
stubCycles
|
||||
:: forall t f m
|
||||
. ( MonadDataContext f m
|
||||
, HasCitations m (NValue t f m) t
|
||||
, HasCitations1 m (NValue t f m) f
|
||||
)
|
||||
=> NValue t f m
|
||||
-> NValue t f m
|
||||
stubCycles = flip iterNValue Free $ \t _ ->
|
||||
Free
|
||||
$ NValue
|
||||
$ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc
|
||||
$ reverse
|
||||
$ citations @m @(NValue t f m) t
|
||||
where
|
||||
Free (NValue cyc) = opaque
|
||||
|
||||
removeEffects
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m
|
||||
-> m (NValueNF t f m)
|
||||
removeEffects = nValueToNFM id (flip queryM (pure opaque))
|
||||
-> m (NValue t f m)
|
||||
removeEffects =
|
||||
iterNValueM
|
||||
id
|
||||
(flip queryM (pure opaque))
|
||||
(fmap Free . sequenceNValue' id)
|
||||
|
||||
opaque
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m
|
||||
opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
opaque :: Applicative f => NValue t f m
|
||||
opaque = nvStr $ principledMakeNixStringWithoutContext "<CYCLE>"
|
||||
|
||||
dethunk
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> t
|
||||
-> m (NValueNF t f m)
|
||||
-> m (NValue t f m)
|
||||
dethunk t = queryM t (pure opaque) removeEffects
|
||||
|
|
|
|||
|
|
@ -205,10 +205,6 @@ instance (HasCitations1 m v f, HasCitations m v t)
|
|||
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 m (NValue t f m) f
|
||||
|
|
@ -325,9 +321,11 @@ exprFNixDoc = \case
|
|||
NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
|
||||
where recPrefix = "rec" <> space
|
||||
|
||||
valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr
|
||||
valueToExpr = iterNValueNF phi
|
||||
valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr
|
||||
valueToExpr = iterNValue (\_ _ -> thk) phi
|
||||
where
|
||||
thk = Fix . NSym . pack $ "<CYCLE>"
|
||||
|
||||
phi :: NValue' t f m NExpr -> NExpr
|
||||
phi (NVConstant' a ) = Fix $ NConstant a
|
||||
phi (NVStr' ns) = mkStr ns
|
||||
|
|
@ -343,14 +341,62 @@ valueToExpr = iterNValueNF phi
|
|||
|
||||
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
|
||||
|
||||
prettyNValueNF
|
||||
:: forall t f m ann . MonadDataContext f m => NValueNF t f m -> Doc ann
|
||||
prettyNValueNF = prettyNix . valueToExpr
|
||||
prettyNValue
|
||||
:: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann
|
||||
prettyNValue = prettyNix . valueToExpr
|
||||
|
||||
prettyNValueProv
|
||||
:: forall t f m ann
|
||||
. ( 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
|
||||
-> Doc ann
|
||||
prettyNValueProv v = do
|
||||
let ps = citations @m @(NValue t f m) v
|
||||
case ps of
|
||||
[] -> prettyNValue v
|
||||
ps ->
|
||||
let v' = prettyNValue v in
|
||||
fillSep
|
||||
[ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
||||
prettyNThunk
|
||||
:: forall t f m ann
|
||||
. ( 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 @m @(NValue t f m) @t t
|
||||
v' <- prettyNValue <$> dethunk t
|
||||
pure
|
||||
$ fillSep
|
||||
$ [ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "thunk from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
||||
-- | This function is used only by the testing code.
|
||||
printNix :: forall t f m . MonadDataContext f m => NValueNF t f m -> String
|
||||
printNix = iterNValueNF phi
|
||||
printNix :: forall t f m . MonadDataContext f m => NValue t f m -> String
|
||||
printNix = iterNValue (\_ _ -> thk) phi
|
||||
where
|
||||
thk = "<thunk>"
|
||||
|
||||
phi :: NValue' t f m String -> String
|
||||
phi (NVConstant' a ) = unpack $ atomText a
|
||||
phi (NVStr' ns) = show $ hackyStringIgnoreContext ns
|
||||
|
|
@ -373,56 +419,3 @@ printNix = iterNValueNF phi
|
|||
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 . removeEffects
|
||||
|
||||
prettyNValueProv
|
||||
:: forall t f m ann
|
||||
. ( 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 = do
|
||||
let ps = citations @m @(NValue t f m) v
|
||||
case ps of
|
||||
[] -> prettyNValue v
|
||||
ps -> do
|
||||
v' <- prettyNValue v
|
||||
pure
|
||||
$ fillSep
|
||||
$ [ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
||||
prettyNThunk
|
||||
:: forall t f m ann
|
||||
. ( 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 @m @(NValue t f m) @t t
|
||||
v' <- prettyNValueNF <$> dethunk t
|
||||
pure
|
||||
$ fillSep
|
||||
$ [ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "thunk from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
|
|
|||
|
|
@ -181,13 +181,9 @@ renderValueFrame level = fmap (: []) . \case
|
|||
v' <- renderValue level "" "" v
|
||||
pure $ "CoercionToJson " <> v'
|
||||
CoercionFromJson _j -> pure "CoercionFromJson"
|
||||
Expectation t r -> case getEitherOr r of
|
||||
Left nf -> do
|
||||
let v' = prettyNValueNF @t @f @m nf
|
||||
pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
|
||||
Right v -> do
|
||||
v' <- renderValue @_ @t @f @m level "" "" v
|
||||
pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
|
||||
Expectation t v -> do
|
||||
v' <- renderValue @_ @t @f @m level "" "" v
|
||||
pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
|
||||
|
||||
renderValue
|
||||
:: forall e t f m ann
|
||||
|
|
@ -199,7 +195,9 @@ renderValue
|
|||
-> m (Doc ann)
|
||||
renderValue _level _longLabel _shortLabel v = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
if values opts then prettyNValueProv v else prettyNValue v
|
||||
(if values opts
|
||||
then prettyNValueProv
|
||||
else prettyNValue) <$> removeEffects v
|
||||
|
||||
renderExecFrame
|
||||
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
|
||||
|
|
|
|||
|
|
@ -73,14 +73,14 @@ deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t
|
|||
-- For whatever reason, using the default StateT instance provided by
|
||||
-- haskeline does not work.
|
||||
instance MonadException m
|
||||
=> MonadException (StateT (HashMap FilePath NExprLoc) m) where
|
||||
=> MonadException(StateT(HashMap FilePath NExprLoc) m) where
|
||||
controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let
|
||||
run' = RunIO (fmap (StateT . const) . run . flip runStateT s)
|
||||
in fmap (flip runStateT s) $ f run'
|
||||
run' = RunIO(fmap(StateT . const) . run . flip runStateT s)
|
||||
in fmap(flip runStateT s) $ f run'
|
||||
|
||||
instance MonadException m => MonadException (Fix1T StandardTF m) where
|
||||
instance MonadException m => MonadException(Fix1T StandardTF m) where
|
||||
controlIO f = mkStandardT $ controlIO $ \(RunIO run) ->
|
||||
let run' = RunIO (fmap mkStandardT . run . runStandardT)
|
||||
let run' = RunIO(fmap mkStandardT . run . runStandardT)
|
||||
in runStandardT <$> f run'
|
||||
#endif
|
||||
|
||||
|
|
@ -119,8 +119,7 @@ newtype StdCited m a = StdCited
|
|||
newtype StdThunk (m :: * -> *) = StdThunk
|
||||
{ _stdThunk :: StdCited m (NThunkF m (StdValue m)) }
|
||||
|
||||
type StdValue m = NValue (StdThunk m) (StdCited m) m
|
||||
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) m
|
||||
type StdValue m = NValue (StdThunk m) (StdCited m) m
|
||||
|
||||
instance Show (StdThunk m) where
|
||||
show _ = "<thunk>"
|
||||
|
|
@ -243,25 +242,25 @@ instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where
|
|||
type ThunkId (Fix1T StandardTF m) = ThunkId m
|
||||
|
||||
mkStandardT
|
||||
:: ReaderT (Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
m) a
|
||||
:: ReaderT
|
||||
(Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc) m)
|
||||
a
|
||||
-> StandardT m a
|
||||
mkStandardT = Fix1T . StandardTF
|
||||
|
||||
runStandardT
|
||||
:: StandardT m a
|
||||
-> ReaderT (Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
m) a
|
||||
-> ReaderT
|
||||
(Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc) m)
|
||||
a
|
||||
runStandardT (Fix1T (StandardTF m)) = m
|
||||
|
||||
runWithBasicEffects :: (MonadIO m, MonadAtomicRef m)
|
||||
=> Options -> StandardT (StdIdT m) a -> m a
|
||||
runWithBasicEffects
|
||||
:: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a
|
||||
runWithBasicEffects opts =
|
||||
go . (`evalStateT` mempty)
|
||||
. (`runReaderT` newContext opts)
|
||||
. runStandardT
|
||||
go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
|
||||
where
|
||||
go action = do
|
||||
i <- newVar (1 :: Int)
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ import Control.Monad.Reader
|
|||
import Control.Monad.Ref
|
||||
import Control.Monad.ST
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Fix
|
||||
import Data.Fix ( cata )
|
||||
import Data.Foldable
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List ( delete
|
||||
|
|
@ -257,7 +257,7 @@ inferExpr env ex = case runInfer (inferType env ex) of
|
|||
|
||||
-- | Canonicalize and return the polymorphic toplevel type.
|
||||
closeOver :: Type -> Scheme
|
||||
closeOver = normalize . generalize Set.empty
|
||||
closeOver = normalizeScheme . generalize Set.empty
|
||||
|
||||
extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a
|
||||
extendMSet x = InferT . local (first (Set.insert x)) . getInfer
|
||||
|
|
@ -578,8 +578,8 @@ inferTop env ((name, ex) : xs) = case inferExpr env ex of
|
|||
Left err -> Left err
|
||||
Right ty -> inferTop (extend env (name, ty)) xs
|
||||
|
||||
normalize :: Scheme -> Scheme
|
||||
normalize (Forall _ body) = Forall (map snd ord) (normtype body)
|
||||
normalizeScheme :: Scheme -> Scheme
|
||||
normalizeScheme (Forall _ body) = Forall (map snd ord) (normtype body)
|
||||
where
|
||||
ord = zip (nub $ fv body) (map TV letters)
|
||||
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@ 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
|
||||
|
|
@ -107,7 +106,7 @@ freeToFix f = go
|
|||
go (Pure a) = f a
|
||||
go (Free v) = Fix (fmap go v)
|
||||
|
||||
fixToFree :: Functor f => Fix f -> Free f Void
|
||||
fixToFree :: Functor f => Fix f -> Free f a
|
||||
fixToFree = Free . go where go (Fix f) = fmap (Free . go) f
|
||||
|
||||
-- | adi is Abstracting Definitional Interpreters:
|
||||
|
|
|
|||
|
|
@ -9,13 +9,13 @@
|
|||
|
||||
module Nix.Utils.Fix1 where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
-- | The fixpoint combinator, courtesy of Gregory Malecha.
|
||||
-- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced
|
||||
|
|
|
|||
|
|
@ -36,12 +36,10 @@ 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
|
||||
|
|
@ -255,8 +253,7 @@ iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f))
|
|||
-- The 'Free' structure is used here to represent the possibility that
|
||||
-- cycles may appear during normalization.
|
||||
|
||||
type NValue t f m = Free (NValue' t f m) t
|
||||
type NValueNF t f m = Fix (NValue' t f m)
|
||||
type NValue t f m = Free (NValue' t f m) t
|
||||
|
||||
hoistNValue
|
||||
:: (Functor m, Functor n, Functor f)
|
||||
|
|
@ -302,35 +299,6 @@ iterNValueM transform k f =
|
|||
go (Pure x) = Pure <$> x
|
||||
go (Free fa) = Free <$> bindNValue' transform go fa
|
||||
|
||||
iterNValueNF
|
||||
:: MonadDataContext f m
|
||||
=> (NValue' t f m r -> r)
|
||||
-> NValueNF t f m
|
||||
-> r
|
||||
iterNValueNF = cata
|
||||
|
||||
nValueFromNF
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValueNF t f m
|
||||
-> NValue t f m
|
||||
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 Fix
|
||||
|
||||
nValueToNFM
|
||||
:: (MonadDataContext f m, Monad n)
|
||||
=> (forall x . n x -> m x)
|
||||
-> (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 $ fmap Fix . sequenceNValue' transform
|
||||
|
||||
pattern NVThunk t <- Pure t
|
||||
|
||||
nvThunk :: Applicative f => t -> NValue t f m
|
||||
|
|
@ -338,51 +306,38 @@ 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 = Free (NValue (pure (NVConstantF x)))
|
||||
nvConstantNF :: Applicative f => NAtom -> NValueNF t f m
|
||||
nvConstantNF x = Fix (NValue (pure (NVConstantF x)))
|
||||
|
||||
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 = Free (NValue (pure (NVStrF ns)))
|
||||
nvStrNF :: Applicative f => NixString -> NValueNF t f m
|
||||
nvStrNF ns = Fix (NValue (pure (NVStrF ns)))
|
||||
|
||||
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 = Free (NValue (pure (NVPathF x)))
|
||||
nvPathNF :: Applicative f => FilePath -> NValueNF t f m
|
||||
nvPathNF x = Fix (NValue (pure (NVPathF x)))
|
||||
|
||||
pattern NVList' l <- NValue (extract -> NVListF l)
|
||||
pattern NVList l <- Free (NVList' l)
|
||||
pattern NVListNF l <- Fix (NVList' 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 = Fix (NValue (pure (NVListF l)))
|
||||
|
||||
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
|
||||
|
|
@ -390,14 +345,9 @@ nvSet' s x = NValue (pure (NVSetF s x))
|
|||
nvSet :: Applicative f
|
||||
=> 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 = Fix (NValue (pure (NVSetF s x)))
|
||||
|
||||
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, Functor m)
|
||||
=> Params () -> (NValue t f m -> m r) -> NValue' t f m r
|
||||
|
|
@ -405,14 +355,9 @@ 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 () -> (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 NVBuiltin name f <- Free (NVBuiltin' name f)
|
||||
pattern NVBuiltinNF name f <- Fix (NVBuiltin' name f)
|
||||
|
||||
nvBuiltin' :: (Applicative f, Functor m)
|
||||
=> String -> (NValue t f m -> m r) -> NValue' t f m r
|
||||
|
|
@ -421,10 +366,6 @@ 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 -> (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
|
||||
|
|
@ -453,10 +394,6 @@ builtin3
|
|||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
isClosureNF :: Comonad f => NValueNF t f m -> Bool
|
||||
isClosureNF NVClosureNF{} = True
|
||||
isClosureNF _ = False
|
||||
|
||||
data TStringContext = NoContext | HasContext
|
||||
deriving Show
|
||||
|
||||
|
|
@ -508,18 +445,6 @@ showValueType (Pure t) = force t showValueType
|
|||
showValueType (Free (NValue (extract -> v))) =
|
||||
pure $ describeValue $ valueType $ v
|
||||
|
||||
class Show r => EmbedValue t f m r where
|
||||
embedValue :: NValue' t f m r -> r
|
||||
getEitherOr :: r -> Either (NValueNF t f m) (NValue t f m)
|
||||
|
||||
instance Comonad f => EmbedValue t f m (NValueNF t f m) where
|
||||
embedValue = Fix
|
||||
getEitherOr = Left
|
||||
|
||||
instance (Comonad f, Show t) => EmbedValue t f m (NValue t f m) where
|
||||
embedValue = Free
|
||||
getEitherOr = Right
|
||||
|
||||
data ValueFrame t f m
|
||||
= ForcingThunk t
|
||||
| ConcerningValue (NValue t f m)
|
||||
|
|
@ -530,7 +455,7 @@ data ValueFrame t f m
|
|||
| Coercion ValueType ValueType
|
||||
| CoercionToJson (NValue t f m)
|
||||
| CoercionFromJson A.Value
|
||||
| forall r. EmbedValue t f m r => Expectation ValueType r
|
||||
| Expectation ValueType (NValue t f m)
|
||||
deriving Typeable
|
||||
|
||||
deriving instance (Comonad f, Show t) => Show (ValueFrame t f m)
|
||||
|
|
|
|||
|
|
@ -38,7 +38,6 @@ 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
|
||||
|
|
@ -183,14 +182,6 @@ thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
|
|||
(NVSet _ _ , NVSet _ _ ) -> unsafePtrEq
|
||||
_ -> valueEqM lv rv
|
||||
|
||||
valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool
|
||||
valueNFEq (Fix (NValue (extract -> x))) (Fix (NValue (extract -> y))) =
|
||||
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
|
||||
where
|
||||
f = \case
|
||||
NVStrNF s -> Just s
|
||||
_ -> Nothing
|
||||
|
||||
instance Eq1 (NValueF p m) where
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
liftEq _ (NVStrF x) (NVStrF y) = x == y
|
||||
|
|
|
|||
|
|
@ -15,9 +15,11 @@ import Nix.String
|
|||
import Nix.Value
|
||||
import Text.XML.Light
|
||||
|
||||
toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString
|
||||
toXML = runWithStringContext . fmap pp . iterNValueNF phi
|
||||
toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString
|
||||
toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi
|
||||
where
|
||||
cyc = return $ mkElem "string" "value" "<CYCLE>"
|
||||
|
||||
pp =
|
||||
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
|
||||
. (<> "\n")
|
||||
|
|
|
|||
|
|
@ -427,7 +427,7 @@ constantEqual a b = do
|
|||
res <- runWithBasicEffectsIO opts $ do
|
||||
a' <- normalForm =<< nixEvalExprLoc Nothing a
|
||||
b' <- normalForm =<< nixEvalExprLoc Nothing b
|
||||
return $ valueNFEq a' b'
|
||||
valueEqM a' b'
|
||||
assertBool "" res
|
||||
|
||||
constantEqualText' :: Text -> Text -> Assertion
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ import System.Posix.Temp
|
|||
import System.Process
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF (StandardT (StdIdT IO)))
|
||||
hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT (StdIdT IO)))
|
||||
hnixEvalFile opts file = do
|
||||
parseResult <- parseNixFileLoc file
|
||||
case parseResult of
|
||||
|
|
@ -40,7 +40,7 @@ hnixEvalFile opts file = do
|
|||
@(StdThunk (StandardT (StdIdT IO)))
|
||||
frames
|
||||
|
||||
hnixEvalText :: Options -> Text -> IO (StdValueNF (StandardT (StdIdT IO)))
|
||||
hnixEvalText :: Options -> Text -> IO (StdValue (StandardT (StdIdT IO)))
|
||||
hnixEvalText opts src = case parseNixText src of
|
||||
Failure err ->
|
||||
error
|
||||
|
|
|
|||
Loading…
Reference in New Issue