Further progress
This commit is contained in:
John Wiegley
parent
f5726cd015
commit
ace0fc10d5
|
|
@ -64,7 +64,7 @@ class FromValue a m v where
|
|||
type Convertible e t f m =
|
||||
(Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
|
||||
|
||||
instance Convertible GAMARI e t f m => FromValue () m (NValueNF t f m) where
|
||||
instance Convertible e t f m => FromValue () m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstantNF NNull -> pure $ Just ()
|
||||
_ -> pure Nothing
|
||||
|
|
@ -72,8 +72,7 @@ instance Convertible GAMARI e t f m => FromValue () m (NValueNF t f m) where
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TNull v
|
||||
|
||||
instance Convertible e t f m
|
||||
=> FromValue () m (NValue t f m) where
|
||||
instance Convertible e t f m => FromValue () m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstant NNull -> pure $ Just ()
|
||||
_ -> pure Nothing
|
||||
|
|
@ -81,8 +80,7 @@ instance Convertible e t f m
|
|||
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 => FromValue Bool m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstantNF (NBool b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
|
|
@ -90,8 +88,7 @@ instance Convertible e t f m
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TBool v
|
||||
|
||||
instance Convertible e t f m
|
||||
=> FromValue Bool m (NValue t f m) where
|
||||
instance Convertible e t f m => FromValue Bool m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstant (NBool b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
|
|
@ -99,8 +96,7 @@ instance Convertible e t f m
|
|||
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 => FromValue Int m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstantNF (NInt b) -> pure $ Just (fromInteger b)
|
||||
_ -> pure Nothing
|
||||
|
|
@ -108,8 +104,7 @@ instance Convertible e t f m
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TInt v
|
||||
|
||||
instance Convertible e t f m
|
||||
=> FromValue Int m (NValue t f m) where
|
||||
instance Convertible e t f m => FromValue Int m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstant (NInt b) -> pure $ Just (fromInteger b)
|
||||
_ -> pure Nothing
|
||||
|
|
@ -117,8 +112,7 @@ instance Convertible e t f m
|
|||
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 => FromValue Integer m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstantNF (NInt b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
|
|
@ -126,8 +120,7 @@ instance Convertible e t f m
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TInt v
|
||||
|
||||
instance Convertible e t f m
|
||||
=> FromValue Integer m (NValue t f m) where
|
||||
instance Convertible e t f m => FromValue Integer m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstant (NInt b) -> pure $ Just b
|
||||
_ -> pure Nothing
|
||||
|
|
@ -135,8 +128,7 @@ instance Convertible e t f m
|
|||
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 => FromValue Float m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVConstantNF (NFloat b) -> pure $ Just b
|
||||
NVConstantNF (NInt i) -> pure $ Just (fromInteger i)
|
||||
|
|
@ -145,8 +137,7 @@ instance Convertible e t f m
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TFloat v
|
||||
|
||||
instance Convertible e t f m
|
||||
=> FromValue Float m (NValue t f m) where
|
||||
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)
|
||||
|
|
@ -159,7 +150,9 @@ instance (Convertible e t f m, MonadEffects t f m)
|
|||
=> FromValue NixString m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
NVStrNF ns -> pure $ Just ns
|
||||
NVPathNF p -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
|
||||
NVPathNF p ->
|
||||
Just . hackyMakeNixStringWithoutContext
|
||||
. Text.pack . unStorePath <$> addPath p
|
||||
NVSetNF s _ -> case M.lookup "outPath" s of
|
||||
Nothing -> pure Nothing
|
||||
Just p -> fromValueMay p
|
||||
|
|
@ -168,11 +161,13 @@ instance (Convertible e t f m, MonadEffects t f m)
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF (TString NoContext) v
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m), MonadEffects t f m)
|
||||
instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
|
||||
=> FromValue NixString m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVStr ns -> pure $ Just ns
|
||||
NVPath p -> Just . hackyMakeNixStringWithoutContext . Text.pack . unStorePath <$> addPath p
|
||||
NVPath p ->
|
||||
Just . hackyMakeNixStringWithoutContext
|
||||
. Text.pack . unStorePath <$> addPath p
|
||||
NVSet s _ -> case M.lookup "outPath" s of
|
||||
Nothing -> pure Nothing
|
||||
Just p -> fromValueMay p
|
||||
|
|
@ -214,8 +209,8 @@ instance Convertible e t f m => FromValue Path m (NValueNF t f m) where
|
|||
Just b -> pure b
|
||||
_ -> throwError $ ExpectationNF TPath v
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m))
|
||||
=> FromValue Path m (NValue t f m) where
|
||||
instance (Convertible e t f m, FromValue Path m t)
|
||||
=> FromValue Path m (NValue t f m) where
|
||||
fromValueMay = \case
|
||||
NVPath p -> pure $ Just (Path p)
|
||||
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
|
||||
|
|
@ -282,21 +277,19 @@ instance Convertible e t f m
|
|||
Just b -> pure b
|
||||
_ -> throwError $ Expectation TSet v
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m))
|
||||
=> FromValue t m (NValue t f m) where
|
||||
fromValueMay = pure . Just . wrapValue @_ @_ @m
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
_ -> error "Impossible, see fromValueMay"
|
||||
-- instance Convertible e t f m => FromValue t m (NValue t f m) where
|
||||
-- fromValueMay = pure . Just . wrapValue @_ @_ @m
|
||||
-- fromValue v = fromValueMay v >>= \case
|
||||
-- Just b -> pure b
|
||||
-- _ -> error "Impossible, see fromValueMay"
|
||||
|
||||
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
|
||||
fromValueMay = (>>= fromValueMay)
|
||||
fromValue = (>>= fromValue)
|
||||
|
||||
instance (MonadThunk t m (NValue t f m), FromValue a m (NValue t f m))
|
||||
=> FromValue a m t where
|
||||
fromValueMay = force ?? fromValueMay
|
||||
fromValue = force ?? fromValue
|
||||
-- instance FromValue a m (NValue t f m) => FromValue a m t where
|
||||
-- fromValueMay = force ?? fromValueMay
|
||||
-- fromValue = force ?? fromValue
|
||||
|
||||
class ToValue a m v where
|
||||
toValue :: a -> m v
|
||||
|
|
@ -361,9 +354,9 @@ instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
|
|||
l' <- toValue (unPos l)
|
||||
c' <- toValue (unPos c)
|
||||
let pos = M.fromList
|
||||
[ ("file" :: Text, wrapValue @_ @_ @m f')
|
||||
, ("line", wrapValue @_ @_ @m l')
|
||||
, ("column", wrapValue @_ @_ @m c') ]
|
||||
[ ("file" :: Text, wrapValue f')
|
||||
, ("line", wrapValue l')
|
||||
, ("column", wrapValue c') ]
|
||||
pure $ nvSet pos mempty
|
||||
|
||||
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
|
||||
|
|
@ -388,9 +381,9 @@ 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 (MonadThunk t m (NValue t f m), ToValue a m (NValue t f m))
|
||||
=> ToValue a m t where
|
||||
toValue = fmap (wrapValue @(NValue t f m) @_ @m) . toValue
|
||||
-- instance (MonadThunk t m (NValue t f m), ToValue a m (NValue t f m))
|
||||
-- => ToValue a m t where
|
||||
-- toValue = fmap (wrapValue @(NValue t f m) @_ @m) . toValue
|
||||
|
||||
instance Convertible e t f m => ToValue Bool m (NExprF r) where
|
||||
toValue = pure . NConstant . NBool
|
||||
|
|
@ -401,7 +394,7 @@ instance Convertible e t f m => ToValue () m (NExprF r) where
|
|||
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 . withFrame Debug frame
|
||||
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
|
||||
|
||||
class FromNix a m v where
|
||||
fromNix :: v -> m a
|
||||
|
|
@ -412,8 +405,7 @@ class FromNix a m v where
|
|||
default fromNixMay :: FromValue a m v => v -> m (Maybe a)
|
||||
fromNixMay = fromValueMay
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m),
|
||||
FromNix a m (NValue t f m))
|
||||
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
|
||||
|
|
@ -422,8 +414,7 @@ instance (Convertible e t f m, MonadThunk t m (NValue t f m),
|
|||
Just b -> pure b
|
||||
_ -> throwError $ Expectation TList v
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m),
|
||||
FromNix a m (NValue t f m))
|
||||
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
|
||||
|
|
@ -442,28 +433,35 @@ 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, MonadThunk t m (NValue t f m)) => FromNix NixString 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, FromValue NixString m t)
|
||||
=> 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, MonadThunk t m (NValue 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 (Convertible e t f m, FromValue Path m t)
|
||||
=> 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)
|
||||
|
||||
instance (MonadThunk t m (NValue t f m), FromNix a m (NValue t f m))
|
||||
=> FromNix a m t where
|
||||
fromNixMay = force ?? fromNixMay
|
||||
fromNix = force ?? fromNix
|
||||
-- instance (MonadThunk t m (NValue t f m), FromNix a m (NValue t f m))
|
||||
-- => FromNix a m t where
|
||||
-- fromNixMay = force ?? fromNixMay
|
||||
-- fromNix = force ?? fromNix
|
||||
|
||||
instance MonadThunk t m (NValue t f m)
|
||||
=> FromNix t m (NValue t f m) where
|
||||
instance MonadThunk t m (NValue t f m) => FromNix t m (NValue t f m) where
|
||||
fromNixMay = pure . Just . wrapValue
|
||||
fromNix = pure . wrapValue
|
||||
|
||||
|
|
@ -472,19 +470,19 @@ class ToNix a m v where
|
|||
default toNix :: ToValue a m v => a -> m v
|
||||
toNix = toValue
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m),
|
||||
ToNix a m (NValue t f m))
|
||||
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 . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
|
||||
<=< toNix))
|
||||
toNix = fmap nvList . traverse (thunk . go)
|
||||
where
|
||||
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
|
||||
<=< toNix
|
||||
|
||||
instance (Convertible e t f m, MonadThunk t m (NValue t f m),
|
||||
ToNix a m (NValue t f m))
|
||||
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 . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
|
||||
<=< toNix))
|
||||
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
|
||||
|
|
@ -502,9 +500,13 @@ 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 (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
|
||||
|
|
@ -512,11 +514,12 @@ instance Convertible e t f m => ToNix Bool m (NExprF r) where
|
|||
instance Convertible e t f m => ToNix () m (NExprF r) where
|
||||
toNix _ = pure $ NConstant NNull
|
||||
|
||||
instance (MonadThunk t m (NValue t f m), ToNix a m (NValue t f m))
|
||||
=> ToNix a m t where
|
||||
toNix = thunk . toNix
|
||||
-- instance (MonadThunk t m (NValue t f m), ToNix a m (NValue t f m))
|
||||
-- => ToNix a m t where
|
||||
-- toNix = thunk . toNix
|
||||
|
||||
instance (Convertible e t f m, ToNix a m (NValueNF t f m)) => ToNix [a] m (NValueNF t f m) where
|
||||
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 MonadThunk t m (NValue t f m) => ToNix t m (NValue t f m) where
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ class (Show v, Monad m) => MonadEval v m where
|
|||
type MonadNixEval v t m =
|
||||
(MonadEval v m,
|
||||
Scoped t m,
|
||||
MonadThunk v t m,
|
||||
MonadThunk t m v,
|
||||
MonadFix m,
|
||||
ToValue Bool m v,
|
||||
ToValue [t] m v,
|
||||
|
|
@ -88,14 +88,14 @@ type MonadNixEval v t m =
|
|||
ToValue (AttrSet t, AttrSet SourcePos) m v,
|
||||
FromValue (AttrSet t, AttrSet SourcePos) m v)
|
||||
|
||||
data EvalFrame m v
|
||||
= EvaluatingExpr (Scopes m v) NExprLoc
|
||||
| ForcingExpr (Scopes m v) NExprLoc
|
||||
data EvalFrame m t
|
||||
= EvaluatingExpr (Scopes m t) NExprLoc
|
||||
| ForcingExpr (Scopes m t) NExprLoc
|
||||
| Calling String SrcSpan
|
||||
| SynHole (SynHoleInfo m v)
|
||||
| SynHole (SynHoleInfo m t)
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
|
||||
instance (Typeable m, Typeable t) => Exception (EvalFrame m t)
|
||||
|
||||
data SynHoleInfo m t = SynHoleInfo
|
||||
{ _synHoleInfo_expr :: NExprLoc
|
||||
|
|
@ -131,7 +131,7 @@ eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
|
|||
|
||||
eval (NList l) = do
|
||||
scope <- currentScopes
|
||||
for l (thunk @v @t . withScopes @t scope) >>= toValue
|
||||
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
|
||||
|
||||
eval (NSet binds) =
|
||||
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
|
||||
|
|
@ -168,7 +168,7 @@ evalWithAttrSet aset body = do
|
|||
-- 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 @v @t $ withScopes scope aset
|
||||
s <- thunk @t @m @v $ withScopes scope aset
|
||||
pushWeakScope ?? body $ force s $
|
||||
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
|
||||
|
|
@ -241,7 +241,7 @@ evalBinds recursive binds = do
|
|||
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 @v @t v pure))
|
||||
force @t @m @v v pure))
|
||||
(M.toList o')
|
||||
|
||||
go _ (NamedVar pathExpr finalValue pos) = do
|
||||
|
|
|
|||
|
|
@ -84,10 +84,9 @@ import GHC.DataSize
|
|||
#endif
|
||||
#endif
|
||||
|
||||
type MonadNix e m =
|
||||
(Scoped (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
|
||||
Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
|
||||
Alternative m, MonadFreshId Int m)
|
||||
type MonadNix e t m =
|
||||
(Scoped t m, Framed e m, Has e SrcSpan, Has e Options,
|
||||
MonadEffects m, MonadFix m, MonadCatch m, Typeable m, Alternative m)
|
||||
|
||||
data ExecFrame m = Assertion SrcSpan (NValue m)
|
||||
deriving (Show, Typeable)
|
||||
|
|
@ -103,7 +102,8 @@ currentPos = asks (view hasLens)
|
|||
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
|
||||
wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
|
||||
|
||||
instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
|
||||
{-
|
||||
instance MonadNix e m => MonadThunk (NThunk m) m (NValue m) where
|
||||
thunk mv = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
|
||||
|
|
@ -147,6 +147,7 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
|
|||
|
||||
wrapValue = NThunk . NCited [] . coerce . valueRef
|
||||
getValue (NThunk (NCited _ v)) = thunkValue (coerce v)
|
||||
-}
|
||||
|
||||
{-
|
||||
prov :: MonadNix e m
|
||||
|
|
@ -262,7 +263,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
|
|||
evalError = throwError
|
||||
|
||||
infixl 1 `callFunc`
|
||||
callFunc :: forall e m. (MonadNix e m, Typeable m)
|
||||
callFunc :: forall e t m. (MonadNix e m, Typeable m)
|
||||
=> NValue m -> m (NValue m) -> m (NValue m)
|
||||
callFunc fun arg = do
|
||||
frames :: Frames <- asks (view hasLens)
|
||||
|
|
@ -274,14 +275,14 @@ callFunc fun arg = do
|
|||
f arg
|
||||
NVBuiltin name f -> do
|
||||
span <- currentPos
|
||||
withFrame Info (Calling @m @(NThunk m) 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)
|
||||
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
|
||||
|
||||
execUnaryOp :: (Framed e m, MonadVar m)
|
||||
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
|
||||
execUnaryOp :: Framed e m
|
||||
=> Scopes m t -> SrcSpan -> NUnaryOp -> NValue m
|
||||
-> m (NValue m)
|
||||
execUnaryOp scope span op arg = do
|
||||
traceM "NUnary"
|
||||
|
|
@ -298,8 +299,8 @@ execUnaryOp scope span op arg = do
|
|||
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
|
||||
|
||||
execBinaryOp
|
||||
:: forall e m. (MonadNix e m, MonadEval (NValue m) m)
|
||||
=> Scopes m (NThunk m)
|
||||
:: forall e t m. (MonadNix e m, MonadEval (NValue m) m)
|
||||
=> Scopes m t
|
||||
-> SrcSpan
|
||||
-> NBinaryOp
|
||||
-> NValue m
|
||||
|
|
@ -510,11 +511,15 @@ fromStringNoContext ns =
|
|||
"expected string with no context"
|
||||
|
||||
newtype Lazy m a = Lazy
|
||||
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
|
||||
{ runLazy :: ReaderT (Context (Lazy m) (NThunkF (Lazy m) (NValue m)))
|
||||
(StateT (HashMap FilePath NExprLoc) (FreshIdT Int m)) a }
|
||||
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
|
||||
MonadFix, MonadIO,
|
||||
MonadReader (Context (Lazy m) (NThunk (Lazy m))))
|
||||
MonadReader (Context (Lazy m) (NThunkF (Lazy m) (NValue m))))
|
||||
|
||||
type LazyThunk m = NThunkF m (NValue m)
|
||||
|
||||
type ValueSet m = AttrSet (LazyThunk m)
|
||||
|
||||
instance MonadTrans Lazy where
|
||||
lift = Lazy . lift . lift . lift
|
||||
|
|
@ -618,7 +623,7 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
|
|||
mapMaybeM op = foldr f (return [])
|
||||
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
|
||||
|
||||
handleEntry :: Bool -> (Text, NThunk (Lazy m)) -> Lazy m (Maybe (Text, NThunk (Lazy m)))
|
||||
handleEntry :: Bool -> (Text, t) -> Lazy m (Maybe (Text, t))
|
||||
handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of
|
||||
-- The `args' attribute is special: it supplies the command-line
|
||||
-- arguments to the builder.
|
||||
|
|
@ -631,7 +636,9 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
|
|||
v' -> Just <$> coerceNix v'
|
||||
where
|
||||
coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
|
||||
coerceNixList = toNix <=< traverse (\x -> force x coerceNix) <=< fromValue @[NThunk (Lazy m)]
|
||||
coerceNixList =
|
||||
toNix <=< traverse (\x -> force x coerceNix)
|
||||
<=< fromValue @[LazyThunk m]
|
||||
|
||||
traceEffect = putStrLn
|
||||
|
||||
|
|
@ -673,9 +680,9 @@ x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
|
|||
joinPath $ head [ xs ++ drop (length tx) ys
|
||||
| tx <- tails xs, tx `elem` inits ys ]
|
||||
|
||||
findPathBy :: forall e m. MonadNix e m =>
|
||||
(FilePath -> m (Maybe FilePath)) ->
|
||||
[NThunk m] -> FilePath -> m FilePath
|
||||
findPathBy :: forall e t m. MonadNix e m
|
||||
=> (FilePath -> m (Maybe FilePath))
|
||||
-> [t] -> FilePath -> m FilePath
|
||||
findPathBy finder l name = do
|
||||
mpath <- foldM go Nothing l
|
||||
case mpath of
|
||||
|
|
@ -685,10 +692,10 @@ findPathBy finder l name = do
|
|||
++ " (add it using $NIX_PATH or -I)"
|
||||
Just path -> return path
|
||||
where
|
||||
go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
|
||||
go :: Maybe FilePath -> t -> m (Maybe FilePath)
|
||||
go p@(Just _) _ = pure p
|
||||
go Nothing l = force l $ fromValue >=>
|
||||
\(s :: HashMap Text (NThunk m)) -> do
|
||||
\(s :: HashMap Text t) -> do
|
||||
p <- resolvePath s
|
||||
force p $ fromValue >=> \(Path path) ->
|
||||
case M.lookup "prefix" s of
|
||||
|
|
@ -713,8 +720,8 @@ findPathBy finder l name = do
|
|||
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
|
||||
++ " with 'path' elements, but saw: " ++ show s
|
||||
|
||||
findPathM :: forall e m. MonadNix e m =>
|
||||
[NThunk m] -> FilePath -> m FilePath
|
||||
findPathM :: forall e t m. MonadNix e m =>
|
||||
[t] -> FilePath -> m FilePath
|
||||
findPathM l name = findPathBy path l name
|
||||
where
|
||||
path :: MonadEffects m => FilePath -> m (Maybe FilePath)
|
||||
|
|
@ -729,7 +736,7 @@ findEnvPathM name = do
|
|||
mres <- lookupVar "__nixPath"
|
||||
case mres of
|
||||
Nothing -> error "impossible"
|
||||
Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
|
||||
Just x -> force x $ fromValue >=> \(l :: [t]) ->
|
||||
findPathBy nixFilePath l name
|
||||
where
|
||||
nixFilePath :: MonadEffects m => FilePath -> m (Maybe FilePath)
|
||||
|
|
@ -767,16 +774,16 @@ addTracing k v = do
|
|||
print $ msg rendered <> " ...done"
|
||||
return res
|
||||
|
||||
evalExprLoc :: forall e m. (MonadNix e m, Has e Options)
|
||||
evalExprLoc :: forall e t m. (MonadNix e m, Has e Options)
|
||||
=> NExprLoc -> m (NValue m)
|
||||
evalExprLoc expr = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
if tracing opts
|
||||
then join . (`runReaderT` (0 :: Int)) $
|
||||
adi (addTracing phi)
|
||||
(raise (addStackFrames @(NThunk m) . addSourcePositions))
|
||||
(raise (addStackFrames @t . addSourcePositions))
|
||||
expr
|
||||
else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr
|
||||
else adi phi (addStackFrames @t . addSourcePositions) expr
|
||||
where
|
||||
phi = Eval.eval . annotated . getCompose
|
||||
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|
||||
|
|
@ -791,7 +798,7 @@ fetchTarball v = v >>= \case
|
|||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or set, got " ++ show v
|
||||
where
|
||||
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
|
||||
go :: Maybe t -> NValue m -> m (NValue m)
|
||||
go msha = \case
|
||||
NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
|
||||
v -> throwError $ ErrorCall $
|
||||
|
|
@ -809,7 +816,7 @@ fetchTarball v = v >>= \case
|
|||
++ ext ++ "'"
|
||||
-}
|
||||
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
||||
fetch :: Text -> Maybe t -> m (NValue m)
|
||||
fetch uri Nothing =
|
||||
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
|
||||
Text.unpack uri ++ "\""
|
||||
|
|
@ -833,7 +840,7 @@ exec
|
|||
, Typeable m
|
||||
, Has e Options
|
||||
, Has e SrcSpan
|
||||
, Scoped (NThunk m) m
|
||||
, Scoped t m
|
||||
)
|
||||
=> [String]
|
||||
-> m (NValue m)
|
||||
|
|
@ -853,14 +860,14 @@ nixInstantiateExpr
|
|||
, Typeable m
|
||||
, Has e Options
|
||||
, Has e SrcSpan
|
||||
, Scoped (NThunk m) m
|
||||
, Scoped t m
|
||||
)
|
||||
=> String
|
||||
-> m (NValue m)
|
||||
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
|
||||
|
||||
instance Monad m => Scoped (NThunk (Lazy m)) (Lazy m) where
|
||||
instance Monad m => Scoped t (Lazy m) where
|
||||
currentScopes = currentScopesReader
|
||||
clearScopes = clearScopesReader @(Lazy m) @(NThunk (Lazy m))
|
||||
clearScopes = clearScopesReader @(Lazy m) @t
|
||||
pushScopes = pushScopesReader
|
||||
lookupVar = lookupVarReader
|
||||
|
|
|
|||
|
|
@ -248,12 +248,15 @@ instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
|
|||
|
||||
instance ToValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
|
||||
|
||||
instance MonadLint e m => MonadThunk (Symbolic m) (SThunk m) m where
|
||||
thunk = fmap coerce . buildThunk
|
||||
force = forceThunk . coerce
|
||||
forceEff = forceEffects . coerce
|
||||
wrapValue = coerce . valueRef
|
||||
getValue = thunkValue . coerce
|
||||
instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where
|
||||
thunk = fmap SThunk . thunk
|
||||
thunkId = thunkId . getSThunk
|
||||
query x b f = query (getSThunk x) b f
|
||||
queryM x b f = queryM (getSThunk x) b f
|
||||
force = force . getSThunk
|
||||
forceEff = forceEff . getSThunk
|
||||
wrapValue = SThunk . wrapValue
|
||||
getValue = getValue . getSThunk
|
||||
|
||||
instance MonadLint e m => MonadEval (Symbolic m) m where
|
||||
freeVariable var = symerr $
|
||||
|
|
@ -303,7 +306,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
|
|||
-- 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.
|
||||
s <- thunk @(Symbolic m) @(SThunk m) scope
|
||||
s <- thunk @(SThunk m) @m @(Symbolic m) scope
|
||||
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
|
||||
NMany [TSet (Just s')] -> return s'
|
||||
NMany [TSet Nothing] -> error "NYI: with unknown"
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Nix.Thunk.Basic (MonadBasicThunk) where
|
||||
module Nix.Thunk.Basic (NThunkF, MonadBasicThunk) where
|
||||
|
||||
import Control.Exception hiding (catch)
|
||||
import Control.Monad.Catch
|
||||
|
|
|
|||
|
|
@ -352,18 +352,22 @@ instance Monad m => MonadCatch (InferT s m) where
|
|||
instance ( MonadFreshId Int m
|
||||
, MonadAtomicRef m
|
||||
, Ref m ~ STRef s
|
||||
) => MonadThunk (Judgment s) (JThunkT s m) (InferT s m) where
|
||||
thunk = fmap JThunk . buildThunk
|
||||
) => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
|
||||
thunk = fmap JThunk . thunk
|
||||
thunkId (JThunk x) = thunkId x
|
||||
|
||||
force (JThunk t) f = catch (forceThunk t f) $ \(_ :: ThunkLoop) ->
|
||||
query (JThunk x) b f = query x b f
|
||||
queryM (JThunk x) b f = queryM x b f
|
||||
|
||||
force (JThunk t) f = catch (force t f) $ \(_ :: ThunkLoop) ->
|
||||
-- If we have a thunk loop, we just don't know the type.
|
||||
f =<< Judgment As.empty [] <$> fresh
|
||||
forceEff (JThunk t) f = catch (forceEffects t f) $ \(_ :: ThunkLoop) ->
|
||||
forceEff (JThunk t) f = catch (forceEff t f) $ \(_ :: ThunkLoop) ->
|
||||
-- If we have a thunk loop, we just don't know the type.
|
||||
f =<< Judgment As.empty [] <$> fresh
|
||||
|
||||
wrapValue = JThunk . valueRef
|
||||
getValue (JThunk x) = thunkValue x
|
||||
wrapValue = JThunk . wrapValue
|
||||
getValue (JThunk x) = getValue x
|
||||
|
||||
instance ( MonadFreshId Int m
|
||||
, MonadAtomicRef m
|
||||
|
|
|
|||
Loading…
Reference in a new issue