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