Correctly propagate unification results to 1 level deep
This commit is contained in:
parent
2799ddbfb5
commit
144972f8a3
78
Nix/Lint.hs
78
Nix/Lint.hs
|
@ -7,6 +7,7 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Nix.Lint where
|
module Nix.Lint where
|
||||||
|
@ -99,7 +100,8 @@ unpackSymbolic :: MonadIO m
|
||||||
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
|
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
|
||||||
unpackSymbolic = liftIO . readIORef
|
unpackSymbolic = liftIO . readIORef
|
||||||
|
|
||||||
renderSymbolic :: MonadIO m => Symbolic m -> m String
|
renderSymbolic :: MonadNixLint e m
|
||||||
|
=> Symbolic m -> m String
|
||||||
renderSymbolic = unpackSymbolic >=> \case
|
renderSymbolic = unpackSymbolic >=> \case
|
||||||
NAny -> return "<any>"
|
NAny -> return "<any>"
|
||||||
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
|
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
|
||||||
|
@ -117,7 +119,12 @@ renderSymbolic = unpackSymbolic >=> \case
|
||||||
TSet (Just s) -> do
|
TSet (Just s) -> do
|
||||||
x <- traverse (renderSymbolic <=< sforce) s
|
x <- traverse (renderSymbolic <=< sforce) s
|
||||||
return $ "{" ++ show x ++ "}"
|
return $ "{" ++ show x ++ "}"
|
||||||
TFunction _p _f -> return "<function>"
|
f@(TFunction p _) -> do
|
||||||
|
(args, sym) <-
|
||||||
|
lintApp (NAbs (void p) ()) (mkSymbolic [f]) everyPossible
|
||||||
|
args' <- traverse renderSymbolic args
|
||||||
|
sym' <- renderSymbolic sym
|
||||||
|
return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
|
||||||
TPath -> return "path"
|
TPath -> return "path"
|
||||||
TBuiltin _n _f -> return "<builtin function>"
|
TBuiltin _n _f -> return "<builtin function>"
|
||||||
|
|
||||||
|
@ -178,7 +185,8 @@ merge context = go
|
||||||
-}
|
-}
|
||||||
|
|
||||||
type MonadNixLint e m =
|
type MonadNixLint e m =
|
||||||
(Scoped e (SThunk m) m, Framed e m, MonadFix m, MonadIO m)
|
(Scoped e (SThunk m) m, Framed e m, MonadFix m, MonadIO m,
|
||||||
|
MonadEval (SThunk m) (Symbolic m) m)
|
||||||
|
|
||||||
-- | unify raises an error if the result is would be 'NMany []'.
|
-- | unify raises an error if the result is would be 'NMany []'.
|
||||||
unify :: MonadNixLint e m
|
unify :: MonadNixLint e m
|
||||||
|
@ -187,8 +195,12 @@ unify context x y = do
|
||||||
x' <- liftIO $ readIORef x
|
x' <- liftIO $ readIORef x
|
||||||
y' <- liftIO $ readIORef y
|
y' <- liftIO $ readIORef y
|
||||||
case (x', y') of
|
case (x', y') of
|
||||||
(NAny, _) -> return y
|
(NAny, _) -> do
|
||||||
(_, NAny) -> return x
|
liftIO $ writeIORef x y'
|
||||||
|
return y
|
||||||
|
(_, NAny) -> do
|
||||||
|
liftIO $ writeIORef y x'
|
||||||
|
return x
|
||||||
(NMany xs, NMany ys) -> do
|
(NMany xs, NMany ys) -> do
|
||||||
m <- merge context xs ys
|
m <- merge context xs ys
|
||||||
if null m
|
if null m
|
||||||
|
@ -198,14 +210,16 @@ unify context x y = do
|
||||||
throwError $ "Cannot unify "
|
throwError $ "Cannot unify "
|
||||||
++ show x' ++ " with " ++ show y'
|
++ show x' ++ " with " ++ show y'
|
||||||
++ " in context: " ++ show context
|
++ " in context: " ++ show context
|
||||||
else
|
else do
|
||||||
|
liftIO $ writeIORef x (NMany m)
|
||||||
|
liftIO $ writeIORef y (NMany m)
|
||||||
packSymbolic (NMany m)
|
packSymbolic (NMany m)
|
||||||
|
|
||||||
lintExpr :: (MonadNixLint e m, MonadEval (SThunk m) (Symbolic m) m)
|
lintExpr :: MonadNixLint e m
|
||||||
=> NExpr -> m (Symbolic m)
|
=> NExpr -> m (Symbolic m)
|
||||||
lintExpr = cata lint
|
lintExpr = cata lint
|
||||||
|
|
||||||
lint :: forall e m. (MonadNixLint e m, MonadEval (SThunk m) (Symbolic m) m)
|
lint :: forall e m. MonadNixLint e m
|
||||||
=> NExprF (m (Symbolic m)) -> m (Symbolic m)
|
=> NExprF (m (Symbolic m)) -> m (Symbolic m)
|
||||||
|
|
||||||
lint (NSym var) = do
|
lint (NSym var) = do
|
||||||
|
@ -262,8 +276,10 @@ lint e@(NBinary op larg rarg) = do
|
||||||
NConcat -> check lsym rsym [ TList y ]
|
NConcat -> check lsym rsym [ TList y ]
|
||||||
where
|
where
|
||||||
check lsym rsym xs = do
|
check lsym rsym xs = do
|
||||||
m <- unify (void e) lsym rsym
|
m <- mkSymbolic xs
|
||||||
unify (void e) m =<< mkSymbolic xs
|
_ <- unify (void e) lsym m
|
||||||
|
_ <- unify (void e) rsym m
|
||||||
|
unify (void e) lsym rsym
|
||||||
|
|
||||||
lint (NSelect aset attr alternative) = do
|
lint (NSelect aset attr alternative) = do
|
||||||
aset' <- unpackSymbolic =<< aset
|
aset' <- unpackSymbolic =<< aset
|
||||||
|
@ -325,7 +341,7 @@ lint e@(NAssert cond body) = do
|
||||||
_ <- join $ unify (void e) <$> cond <*> mkSymbolic [TConstant [TBool]]
|
_ <- join $ unify (void e) <$> cond <*> mkSymbolic [TConstant [TBool]]
|
||||||
body
|
body
|
||||||
|
|
||||||
lint e@(NApp fun arg) = lintApp (void e) fun arg
|
lint e@(NApp fun arg) = snd <$> lintApp (void e) fun arg
|
||||||
|
|
||||||
lint (NAbs params body) = do
|
lint (NAbs params body) = do
|
||||||
scope <- currentScopes @_ @(SThunk m)
|
scope <- currentScopes @_ @(SThunk m)
|
||||||
|
@ -333,17 +349,39 @@ lint (NAbs params body) = do
|
||||||
(sthunk (pushScopes scope body))]
|
(sthunk (pushScopes scope body))]
|
||||||
|
|
||||||
infixl 1 `lintApp`
|
infixl 1 `lintApp`
|
||||||
lintApp :: forall e m. (MonadNixLint e m, MonadEval (SThunk m) (Symbolic m) m)
|
lintApp :: forall e m. MonadNixLint e m
|
||||||
=> NExprF () -> m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m)
|
=> NExprF () -> m (Symbolic m) -> m (Symbolic m)
|
||||||
|
-> m (HashMap Text (Symbolic m), Symbolic m)
|
||||||
lintApp context fun arg = fun >>= unpackSymbolic >>= \case
|
lintApp context fun arg = fun >>= unpackSymbolic >>= \case
|
||||||
NAny -> throwError "Cannot apply something not known to be a function"
|
NAny -> throwError "Cannot apply something not known to be a function"
|
||||||
NMany xs -> do
|
NMany xs -> do
|
||||||
ys <- forM xs $ \case
|
(args:_, ys) <- fmap unzip $ forM xs $ \case
|
||||||
TFunction params f -> do
|
TFunction params f -> arg >>= unpackSymbolic >>= \case
|
||||||
args <- buildArgument params =<< sthunk arg
|
NAny -> do
|
||||||
clearScopes @(SThunk m) (pushScope args (sforce =<< f))
|
pset <- case params of
|
||||||
TBuiltin _ _f -> error "NYI: lintApp builtin"
|
Param name ->
|
||||||
TSet _m -> error "NYI: lintApp Set"
|
M.singleton name <$> everyPossible
|
||||||
|
ParamSet _s _ (Just _) -> error "NYI"
|
||||||
|
ParamSet s _ Nothing ->
|
||||||
|
traverse (const everyPossible) s
|
||||||
|
pset' <- traverse (sthunk . pure) pset
|
||||||
|
arg' <- sthunk $ mkSymbolic [TSet (Just pset')]
|
||||||
|
args <- buildArgument params arg'
|
||||||
|
res <- clearScopes @(SThunk m) $
|
||||||
|
pushScope args $ sforce =<< f
|
||||||
|
return (pset, res)
|
||||||
|
|
||||||
|
NMany [TSet (Just _)] -> do
|
||||||
|
args <- buildArgument params =<< sthunk arg
|
||||||
|
res <- clearScopes @(SThunk m) $
|
||||||
|
pushScope args $ sforce =<< f
|
||||||
|
args' <- traverse sforce args
|
||||||
|
return (args', res)
|
||||||
|
|
||||||
|
NMany _ -> throwError "NYI: lintApp NMany not set"
|
||||||
|
TBuiltin _ _f -> throwError "NYI: lintApp builtin"
|
||||||
|
TSet _m -> throwError "NYI: lintApp Set"
|
||||||
_x -> throwError "Attempt to call non-function"
|
_x -> throwError "Attempt to call non-function"
|
||||||
|
|
||||||
y <- everyPossible
|
y <- everyPossible
|
||||||
foldM (unify context) y ys
|
(args,) <$> foldM (unify context) y ys
|
||||||
|
|
1
tests/files/lint.nix
Normal file
1
tests/files/lint.nix
Normal file
|
@ -0,0 +1 @@
|
||||||
|
{ x, y }: let z = x + y; in [ z (y + 2) ]
|
Loading…
Reference in a new issue