Run brittany
This commit is contained in:
parent
9b046a80c7
commit
d1ada44817
22
main/Main.hs
22
main/Main.hs
|
@ -158,18 +158,16 @@ main = do
|
|||
findAttrs = go ""
|
||||
where
|
||||
go prefix s = do
|
||||
xs <-
|
||||
forM (sortOn fst (M.toList s))
|
||||
$ \(k, nv) -> case nv of
|
||||
Free v -> pure (k, Just (Free v))
|
||||
Pure (StdThunk (extract -> Thunk _ _ ref)) -> do
|
||||
let path = prefix ++ Text.unpack k
|
||||
(_, descend) = filterEntry path k
|
||||
val <- readVar @(StandardT IO) ref
|
||||
case val of
|
||||
Computed _ -> pure (k, Nothing)
|
||||
_ | descend -> (k, ) <$> forceEntry path nv
|
||||
| otherwise -> pure (k, Nothing)
|
||||
xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of
|
||||
Free v -> pure (k, Just (Free v))
|
||||
Pure (StdThunk (extract -> Thunk _ _ ref)) -> do
|
||||
let path = prefix ++ Text.unpack k
|
||||
(_, descend) = filterEntry path k
|
||||
val <- readVar @(StandardT IO) ref
|
||||
case val of
|
||||
Computed _ -> pure (k, Nothing)
|
||||
_ | descend -> (k, ) <$> forceEntry path nv
|
||||
| otherwise -> pure (k, Nothing)
|
||||
|
||||
forM_ xs $ \(k, mv) -> do
|
||||
let path = prefix ++ Text.unpack k
|
||||
|
|
|
@ -135,7 +135,7 @@ processResult
|
|||
processResult h val = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
case attr opts of
|
||||
Nothing -> h val
|
||||
Nothing -> h val
|
||||
Just (Text.splitOn "." -> keys) -> go keys val
|
||||
where
|
||||
go :: [Text.Text] -> NValue t f m -> m a
|
||||
|
|
|
@ -75,10 +75,7 @@ class FromValue a m v where
|
|||
fromValueMay :: v -> m (Maybe a)
|
||||
|
||||
type Convertible e t f m
|
||||
= ( Framed e m
|
||||
, MonadDataErrorContext t f m
|
||||
, MonadThunk t m (NValue 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
|
||||
|
@ -86,7 +83,7 @@ instance ( Convertible e t f m
|
|||
)
|
||||
=> FromValue a m (NValueNF t f m) where
|
||||
fromValueMay (Fix v) = fromValueMay v
|
||||
fromValue (Fix v) = fromValue v
|
||||
fromValue (Fix v) = fromValue v
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, MonadValue (NValue t f m) m
|
||||
|
@ -96,7 +93,7 @@ instance ( Convertible e t f m
|
|||
fromValueMay = flip demand $ \case
|
||||
Pure t -> force t fromValueMay
|
||||
Free v -> fromValueMay v
|
||||
fromValue = flip demand $ \case
|
||||
fromValue = flip demand $ \case
|
||||
Pure t -> force t fromValue
|
||||
Free v -> fromValue v
|
||||
|
||||
|
@ -106,7 +103,7 @@ instance ( Convertible e 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)
|
||||
fromValue (Deeper (Fix v)) = fromValue (Deeper v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, MonadValue (NValue t f m) m
|
||||
|
@ -116,7 +113,7 @@ instance ( Convertible e t f m
|
|||
fromValueMay (Deeper v) = demand v $ \case
|
||||
Pure t -> force t (fromValueMay . Deeper)
|
||||
Free v -> fromValueMay (Deeper v)
|
||||
fromValue (Deeper v) = demand v $ \case
|
||||
fromValue (Deeper v) = demand v $ \case
|
||||
Pure t -> force t (fromValue . Deeper)
|
||||
Free v -> fromValue (Deeper v)
|
||||
|
||||
|
@ -196,7 +193,7 @@ 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) (embedValue v)
|
||||
|
||||
instance ( Convertible e t f m
|
||||
, EmbedValue t f m r
|
||||
|
@ -204,10 +201,10 @@ instance ( Convertible e t f m
|
|||
=> FromValue ByteString m (NValue' t f m r) where
|
||||
fromValueMay = \case
|
||||
NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
|
||||
_ -> pure Nothing
|
||||
_ -> 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) (embedValue v)
|
||||
|
||||
newtype Path = Path { getPath :: FilePath }
|
||||
deriving Show
|
||||
|
@ -291,7 +288,7 @@ instance ( Convertible e t f m
|
|||
)
|
||||
=> FromValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m r)) where
|
||||
fromValueMay = \case
|
||||
Deeper (NVSet' s p) -> fmap (,p) <$> sequence <$> traverse fromValueMay s
|
||||
Deeper (NVSet' s p) -> fmap (, p) <$> sequence <$> traverse fromValueMay s
|
||||
_ -> pure Nothing
|
||||
fromValue v = fromValueMay v >>= \case
|
||||
Just b -> pure b
|
||||
|
@ -368,11 +365,7 @@ instance ( Convertible e t f m
|
|||
f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f))
|
||||
l' <- toValue (unPos l)
|
||||
c' <- toValue (unPos c)
|
||||
let pos = M.fromList
|
||||
[ ("file" :: Text, f')
|
||||
, ("line" , l')
|
||||
, ("column" , c')
|
||||
]
|
||||
let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')]
|
||||
pure $ nvSet' pos mempty
|
||||
|
||||
-- | With 'ToValue', we can always act recursively
|
||||
|
@ -420,9 +413,9 @@ instance ( MonadValue (NValue t f m) m
|
|||
[] -> return Nothing
|
||||
_ -> Just <$> toValue ts
|
||||
pure $ flip nvSet' M.empty $ M.fromList $ catMaybes
|
||||
[ (\p -> ("path", p)) <$> path
|
||||
[ (\p -> ("path", p)) <$> path
|
||||
, (\ao -> ("allOutputs", ao)) <$> allOutputs
|
||||
, (\os -> ("outputs", os)) <$> outputs
|
||||
, (\os -> ("outputs", os)) <$> outputs
|
||||
]
|
||||
|
||||
instance Convertible e t f m => ToValue () m (NExprF r) where
|
||||
|
|
|
@ -212,10 +212,7 @@ attrSetAlter (k : ks) pos m p val = case M.lookup k m of
|
|||
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
|
||||
( M.insert
|
||||
k
|
||||
( toValue @(AttrSet v, AttrSet SourcePos)
|
||||
=<< (, mempty)
|
||||
<$> sequence st'
|
||||
)
|
||||
(toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st')
|
||||
st
|
||||
, M.insert k pos sp
|
||||
)
|
||||
|
|
|
@ -88,9 +88,9 @@ import GHC.DataSize
|
|||
|
||||
type MonadCited t f m
|
||||
= ( HasCitations m (NValue t f m) t
|
||||
, HasCitations1 m (NValue t f m) f
|
||||
, MonadDataContext f m
|
||||
)
|
||||
, HasCitations1 m (NValue t f m) f
|
||||
, MonadDataContext f m
|
||||
)
|
||||
|
||||
nvConstantP
|
||||
:: MonadCited t f m => Provenance m (NValue t f m) -> NAtom -> NValue t f m
|
||||
|
@ -104,14 +104,14 @@ nvStrP
|
|||
nvStrP p ns = addProvenance p (nvStr ns)
|
||||
|
||||
nvPathP
|
||||
:: MonadCited t f m
|
||||
=> Provenance m (NValue t f m)
|
||||
-> FilePath
|
||||
-> NValue t f m
|
||||
:: MonadCited 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 m (NValue t f m) -> [NValue t f m] -> 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
|
||||
|
@ -299,10 +299,9 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
|
|||
evalAbs p k = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
pure $ nvClosureP
|
||||
(Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
|
||||
(void p)
|
||||
(\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b))
|
||||
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
|
||||
(void p)
|
||||
(\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b))
|
||||
|
||||
evalError = throwError
|
||||
|
||||
|
@ -706,18 +705,27 @@ instance ( MonadFix m
|
|||
Lazy $ ReaderT $ const $ modify (M.insert path expr)
|
||||
pure expr
|
||||
|
||||
derivationStrict = fromValue @(AttrSet (NValue t f (Lazy 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 (Lazy t f m))) @_ @(NValue t f (Lazy t f m)) s'
|
||||
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
|
||||
derivationStrict = fromValue @(AttrSet (NValue t f (Lazy 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 (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, NValue t f (Lazy t f m))
|
||||
-> Lazy t f m (Maybe (Text, NValue t f (Lazy t f m)))
|
||||
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.
|
||||
|
@ -729,10 +737,12 @@ 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 (NValue t f (Lazy t f m))
|
||||
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 (NValue t f (Lazy t f m))
|
||||
coerceNixList
|
||||
:: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m))
|
||||
coerceNixList v = do
|
||||
xs <- fromValue @[NValue t f (Lazy t f m)] v
|
||||
ys <- traverse (\x -> demand x coerceNix) xs
|
||||
|
@ -798,17 +808,18 @@ findPathBy finder l name = do
|
|||
where
|
||||
go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath)
|
||||
go p@(Just _) _ = pure p
|
||||
go Nothing l = demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do
|
||||
p <- resolvePath s
|
||||
demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
|
||||
Nothing -> tryPath path Nothing
|
||||
Just pf -> demand pf $ fromValueMay >=> \case
|
||||
Just (nsPfx :: NixString) ->
|
||||
let pfx = hackyStringIgnoreContext nsPfx
|
||||
in if not (Text.null pfx)
|
||||
then tryPath path (Just (Text.unpack pfx))
|
||||
else tryPath path Nothing
|
||||
_ -> tryPath path Nothing
|
||||
go Nothing l =
|
||||
demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do
|
||||
p <- resolvePath s
|
||||
demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
|
||||
Nothing -> tryPath path Nothing
|
||||
Just pf -> demand pf $ fromValueMay >=> \case
|
||||
Just (nsPfx :: NixString) ->
|
||||
let pfx = hackyStringIgnoreContext nsPfx
|
||||
in if not (Text.null pfx)
|
||||
then tryPath path (Just (Text.unpack pfx))
|
||||
else tryPath path Nothing
|
||||
_ -> tryPath path Nothing
|
||||
|
||||
tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' =
|
||||
finder $ p <///> joinPath ns
|
||||
|
@ -825,8 +836,12 @@ findPathBy finder l name = do
|
|||
++ " with 'path' elements, but saw: "
|
||||
++ show s
|
||||
|
||||
findPathM :: forall e t f m . MonadNix e t f m
|
||||
=> [NValue t f m] -> 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)
|
||||
|
@ -840,7 +855,7 @@ findEnvPathM name = do
|
|||
mres <- lookupVar "__nixPath"
|
||||
case mres of
|
||||
Nothing -> error "impossible"
|
||||
Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) ->
|
||||
Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) ->
|
||||
findPathBy nixFilePath l name
|
||||
where
|
||||
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
|
||||
|
|
|
@ -46,7 +46,8 @@ nvalueToJSON = \case
|
|||
<$> traverse (join . lift . flip demand (return . nvalueToJSON)) l
|
||||
NVSet m _ -> case HM.lookup "outPath" m of
|
||||
Nothing ->
|
||||
A.Object <$> traverse (join . lift . flip demand (return . nvalueToJSON)) m
|
||||
A.Object
|
||||
<$> traverse (join . lift . flip demand (return . nvalueToJSON)) m
|
||||
Just outPath -> join $ lift $ demand outPath (return . nvalueToJSON)
|
||||
NVPath p -> do
|
||||
fp <- lift $ unStorePath <$> addPath p
|
||||
|
|
|
@ -112,16 +112,23 @@ everyPossible = packSymbolic NAny
|
|||
mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m)
|
||||
mkSymbolic xs = packSymbolic (NMany xs)
|
||||
|
||||
packSymbolic :: MonadVar m
|
||||
=> NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
|
||||
packSymbolic
|
||||
:: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
|
||||
packSymbolic = fmap SV . newVar
|
||||
|
||||
unpackSymbolic :: (MonadVar m, MonadThunkId m, MonadCatch m)
|
||||
=> Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
|
||||
unpackSymbolic
|
||||
:: (MonadVar m, MonadThunkId m, MonadCatch m)
|
||||
=> Symbolic m
|
||||
-> m (NSymbolicF (NTypeF m (Symbolic m)))
|
||||
unpackSymbolic = flip demand $ readVar . getSV
|
||||
|
||||
type MonadLint e m
|
||||
= (Scoped (Symbolic m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId m)
|
||||
= ( Scoped (Symbolic m) m
|
||||
, Framed e m
|
||||
, MonadVar m
|
||||
, MonadCatch m
|
||||
, MonadThunkId m
|
||||
)
|
||||
|
||||
symerr :: forall e m a . MonadLint e m => String -> m a
|
||||
symerr = evalError @(Symbolic m) . ErrorCall
|
||||
|
@ -164,7 +171,9 @@ merge
|
|||
merge context = go
|
||||
where
|
||||
go
|
||||
:: [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
|
||||
:: [NTypeF m (Symbolic m)]
|
||||
-> [NTypeF m (Symbolic m)]
|
||||
-> m [NTypeF m (Symbolic m)]
|
||||
go [] _ = return []
|
||||
go _ [] = return []
|
||||
go (x : xs) (y : ys) = case (x, y) of
|
||||
|
|
|
@ -75,20 +75,21 @@ normalize f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
|
|||
|
||||
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>")
|
||||
. ( 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
|
||||
|
|
|
@ -339,11 +339,12 @@ valueToExpr = iterNValueNF phi
|
|||
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"
|
||||
phi _ = error "Pattern synonyms foil completeness check"
|
||||
|
||||
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
|
||||
|
||||
prettyNValueNF :: forall t f m ann. MonadDataContext f m => NValueNF t f m -> Doc ann
|
||||
prettyNValueNF
|
||||
:: forall t f m ann . MonadDataContext f m => NValueNF t f m -> Doc ann
|
||||
prettyNValueNF = prettyNix . valueToExpr
|
||||
|
||||
-- | This function is used only by the testing code.
|
||||
|
@ -371,7 +372,7 @@ printNix = iterNValueNF phi
|
|||
phi NVClosure'{} = "<<lambda>>"
|
||||
phi (NVPath' fp ) = fp
|
||||
phi (NVBuiltin' name _) = "<<builtin " ++ name ++ ">>"
|
||||
phi _ = error "Pattern synonyms foil completeness check"
|
||||
phi _ = error "Pattern synonyms foil completeness check"
|
||||
|
||||
prettyNValue
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
|
|
|
@ -159,16 +159,12 @@ renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
|
|||
|
||||
renderValueFrame
|
||||
:: forall e t f m ann
|
||||
. ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
. (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
|
||||
=> NixLevel
|
||||
-> ValueFrame t f m
|
||||
-> m [Doc ann]
|
||||
renderValueFrame level = fmap (: []) . \case
|
||||
ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI
|
||||
ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI
|
||||
ConcerningValue _v -> pure "ConcerningValue"
|
||||
Comparison _ _ -> pure "Comparing"
|
||||
Addition _ _ -> pure "Adding"
|
||||
|
@ -185,7 +181,7 @@ renderValueFrame level = fmap (: []) . \case
|
|||
v' <- renderValue level "" "" v
|
||||
pure $ "CoercionToJson " <> v'
|
||||
CoercionFromJson _j -> pure "CoercionFromJson"
|
||||
Expectation t r -> case getEitherOr r of
|
||||
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)
|
||||
|
@ -195,11 +191,7 @@ renderValueFrame level = fmap (: []) . \case
|
|||
|
||||
renderValue
|
||||
:: forall e t f m ann
|
||||
. ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
. (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
|
||||
=> NixLevel
|
||||
-> String
|
||||
-> String
|
||||
|
|
|
@ -39,11 +39,11 @@ type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
|
|||
|
||||
instance (MonadBasicThunk m, MonadCatch m)
|
||||
=> MonadThunk (NThunkF m v) m v where
|
||||
thunk = buildThunk
|
||||
thunk = buildThunk
|
||||
thunkId (Thunk n _ _) = n
|
||||
queryM = queryThunk
|
||||
force = forceThunk
|
||||
forceEff = forceEffects
|
||||
queryM = queryThunk
|
||||
force = forceThunk
|
||||
forceEff = forceEffects
|
||||
|
||||
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
|
||||
buildThunk action = do
|
||||
|
|
|
@ -78,8 +78,8 @@ instance ( MonadStdThunk (u m)
|
|||
thunk = fmap (StdThunk . StdCited) . thunk
|
||||
thunkId = thunkId . _stdCited . _stdThunk
|
||||
queryM x b f = queryM (_stdCited (_stdThunk x)) b f
|
||||
force = force . _stdCited . _stdThunk
|
||||
forceEff = forceEff . _stdCited . _stdThunk
|
||||
force = force . _stdCited . _stdThunk
|
||||
forceEff = forceEff . _stdCited . _stdThunk
|
||||
-- query x b f = query (_stdCited (_stdThunk x)) b f
|
||||
-- wrapValue = StdThunk . StdCited . wrapValue
|
||||
-- getValue = getValue . _stdCited . _stdThunk
|
||||
|
|
|
@ -403,10 +403,12 @@ instance Monad m => MonadCatch (InferT s m) where
|
|||
(fromException (toException e))
|
||||
err -> error $ "Unexpected error: " ++ show err
|
||||
|
||||
type MonadInfer m = ({- MonadThunkId m,-} MonadVar m, MonadFix m)
|
||||
type MonadInfer m
|
||||
= ({- MonadThunkId m,-}
|
||||
MonadVar m, MonadFix m)
|
||||
|
||||
instance MonadValue (Judgment s) (InferT s m) where
|
||||
defer = id
|
||||
defer = id
|
||||
demand = flip ($)
|
||||
|
||||
{-
|
||||
|
|
|
@ -95,23 +95,20 @@ 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
|
||||
:: (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)
|
||||
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
|
||||
fixToFree = Free . go where go (Fix f) = fmap (Free . go) f
|
||||
|
||||
-- | adi is Abstracting Definitional Interpreters:
|
||||
--
|
||||
|
|
|
@ -154,16 +154,17 @@ compareAttrSets f eq lm rm = runIdentity
|
|||
$ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm
|
||||
|
||||
valueEqM
|
||||
:: forall t f m. (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 (Pure x) (Pure y) = thunkEqM x y
|
||||
valueEqM (Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y)
|
||||
valueEqM x@(Free _) (Pure y) = thunkEqM ?? y =<< thunk (pure x)
|
||||
valueEqM ( Pure x) ( Pure y) = thunkEqM x y
|
||||
valueEqM ( Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y)
|
||||
valueEqM x@(Free _) ( Pure y) = thunkEqM ?? y =<< thunk (pure x)
|
||||
valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
|
||||
valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y
|
||||
where
|
||||
where
|
||||
f (Pure t) = force t $ \case
|
||||
NVStr s -> pure $ Just s
|
||||
_ -> pure Nothing
|
||||
|
|
|
@ -16,10 +16,7 @@ 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 = runWithStringContext . fmap pp . iterNValueNF phi
|
||||
where
|
||||
pp =
|
||||
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
|
||||
|
@ -36,8 +33,9 @@ toXML =
|
|||
NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false")
|
||||
NNull -> return $ Element (unqual "null") [] [] Nothing
|
||||
|
||||
NVStr' str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
|
||||
NVList' l -> sequence l
|
||||
NVStr' str ->
|
||||
mkElem "string" "value" . Text.unpack <$> extractNixString str
|
||||
NVList' l -> sequence l
|
||||
>>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing
|
||||
|
||||
NVSet' s _ -> sequence s >>= \kvs -> return $ Element
|
||||
|
@ -59,7 +57,7 @@ toXML =
|
|||
return $ Element (unqual "function") [] (paramsXML p) Nothing
|
||||
NVPath' fp -> return $ mkElem "path" "value" fp
|
||||
NVBuiltin' name _ -> return $ mkElem "function" "name" name
|
||||
_ -> error "Pattern synonyms mask coverage"
|
||||
_ -> error "Pattern synonyms mask coverage"
|
||||
|
||||
mkElem :: String -> String -> String -> Element
|
||||
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing
|
||||
|
|
Loading…
Reference in New Issue