diff --git a/ChangeLog.md b/ChangeLog.md index d6a068ddb..6acf7737e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,13 @@ # ChangeLog +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.16.0...0.17.0#files_bucket) 0.17.0 + +* Breaking: + * `Nix.Expr.Types` + * [(link)](https://github.com/haskell-nix/hnix/pull/1042/files) The central HNix type `NExprF` changed, the `NApp` was moved out of `NBinary` & now a `NExprF` constructor of its own, the type signatures were changed accordingly. + * [(link)](https://github.com/haskell-nix/hnix/pull/1038/files) project was using `megaparsec` `{,Source}Pos` and to use it shipped a lot of orphan instances. To improve the situation & performance (reports [#1026](https://github.com/haskell-nix/hnix/issues/1026), [#746](https://github.com/haskell-nix/hnix/issues/746)) project uses `N{,Source}Pos` types, related type signatures were changed accordingly. + ## [(diff)](https://github.com/haskell-nix/hnix/compare/0.15.0...0.16.0#files_bucket) 0.16.0 On update problems, please reach out to us. For support refere to: https://github.com/haskell-nix/hnix/issues/984 diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 39e6366a3..207913935 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -1717,40 +1717,37 @@ addErrorContextNix _ = pure execNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) execNix xs = - do - xs' <- traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs - -- 2018-11-19: NOTE: Still need to do something with the context here - -- See prim_exec in nix/src/libexpr/primops.cc - -- Requires the implementation of EvalState::realiseContext - exec $ ignoreContext <$> xs' + -- 2018-11-19: NOTE: Still need to do something with the context here + -- See prim_exec in nix/src/libexpr/primops.cc + -- Requires the implementation of EvalState::realiseContext + (exec . fmap ignoreContext) =<< traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs fetchurlNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) fetchurlNix = (\case - NVSet _ s -> go (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s - v@NVStr{} -> go Nothing v + NVSet _ s -> fetch (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s + v@NVStr{} -> fetch Nothing v v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v ) <=< demand where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) - go _msha = + -- 2022-01-21: NOTE: Needs to check the hash match. + fetch :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) + fetch _msha = \case NVStr ns -> either -- msha throwError toValue - =<< getURL =<< noContextAttrs ns + =<< getURL + =<< maybe + (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") + pure + (getStringNoContext ns) v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or string, got " <> show v - noContextAttrs ns = - maybe - (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") - pure - (getStringNoContext ns) - partitionNix :: forall e t f m . MonadNix e t f m @@ -1759,10 +1756,9 @@ partitionNix -> m (NValue t f m) partitionNix f nvlst = do - l <- fromValue @[NValue t f m] nvlst let match t = (, t) <$> (fromValue =<< callFunc f t) - selection <- traverse match l + selection <- traverse match =<< fromValue @[NValue t f m] nvlst let (right, wrong) = partition fst selection diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs index b85fc896b..4a3fb3b45 100644 --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -290,24 +290,27 @@ class -- ** Instances instance MonadHttp IO where - getURL url = do - let urlstr = toString url - traceM $ "fetching HTTP URL: " <> urlstr - req <- parseRequest urlstr - manager <- - if secure req - then newTlsManager - else newManager defaultManagerSettings - -- print req - response <- httpLbs (req { method = "GET" }) manager - let status = statusCode $ responseStatus response - pure $ Left $ ErrorCall $ if status /= 200 - then - "fail, got " <> show status <> " when fetching url:" <> urlstr - else - -- do - -- let bstr = responseBody response - "success in downloading but hnix-store is not yet ready; url = " <> urlstr + getURL url = + do + let urlstr = toString url + traceM $ "fetching HTTP URL: " <> urlstr + req <- parseRequest urlstr + manager <- + bool + (newManager defaultManagerSettings) + newTlsManager + (secure req) + -- print req + response <- httpLbs (req { method = "GET" }) manager + let status = statusCode $ responseStatus response + pure $ Left $ ErrorCall $ + bool + ("fail, got " <> show status <> " when fetching url = ") + -- do + -- let bstr = responseBody response + "success in downloading but hnix-store is not yet ready; url = " + (status == 200) + <> urlstr deriving instance @@ -418,13 +421,12 @@ instance MonadStore IO where -- ** Functions parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) -parseStoreResult name res = - pure $ either - (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) - pure -- result - (fst res) - where - logs = snd res +parseStoreResult name (res, logs) = + pure $ + either + (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) + pure + res addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath addTextToStore a b c d = diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index f701b3596..7e90a0d39 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -119,7 +119,7 @@ eval (NLiteralPath p ) = evalLiteralPath p eval (NEnvPath p ) = evalEnvPath p eval (NUnary op arg ) = evalUnary op =<< arg -eval (NBinary NApp fun arg) = +eval (NApp fun arg ) = do f <- fun scope <- askScopes diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 3f9dc07e8..93a30866a 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -103,6 +103,17 @@ mkNVUnaryOpWithProvenance mkNVUnaryOpWithProvenance scope span op val = addProvenance (Provenance scope $ NUnaryAnnF span op val) +mkNVAppOpWithProvenance + :: MonadCited t f m + => Scopes m (NValue t f m) + -> SrcSpan + -> Maybe (NValue t f m) + -> Maybe (NValue t f m) + -> NValue t f m + -> NValue t f m +mkNVAppOpWithProvenance scope span lval rval = + addProvenance (Provenance scope $ NAppAnnF span lval rval) + mkNVBinaryOpWithProvenance :: MonadCited t f m => Scopes m (NValue t f m) @@ -274,7 +285,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where do scope <- askScopes span <- askSpan - mkNVBinaryOpWithProvenance scope span NApp (pure f) Nothing <$> (callFunc f =<< defer x) + mkNVAppOpWithProvenance scope span (pure f) Nothing <$> (callFunc f =<< defer x) evalAbs :: Params (m (NValue t f m)) @@ -444,8 +455,6 @@ execBinaryOpForced scope span op lval rval = mkStrP . (ls <>) <$> coerceAnyToNixString callFunc DontCopyToStore rs _ -> unsupportedTypes - - NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" _other -> shouldBeAlreadyHandled where diff --git a/src/Nix/Expr/Shorthands.hs b/src/Nix/Expr/Shorthands.hs index bddf4d7bc..4959c67d1 100644 --- a/src/Nix/Expr/Shorthands.hs +++ b/src/Nix/Expr/Shorthands.hs @@ -68,7 +68,12 @@ mkSynHole = Fix . mkSynHoleF mkSelector :: Text -> NAttrPath NExpr mkSelector = one . StaticKey . coerce +-- | Put a binary operator. +-- @since +mkApp :: NExpr -> NExpr -> NExpr +mkApp a = Fix . NApp a -- | Put an unary operator. + -- @since 0.15.0 mkOp :: NUnaryOp -> NExpr -> NExpr mkOp op = Fix . NUnary op @@ -343,7 +348,7 @@ infix 9 @. infix 9 @.<|> -- | Function application (@' '@ in @f x@) -(@@) = mkOp2 NApp +(@@) = mkApp infixl 8 @@ -- | List concatenation: @++@ diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index fb6e82042..ee2733217 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -116,12 +116,10 @@ type AttrSet = HashMap VarName -- A type synonym for @HashMap VarName NSourcePos@. type PositionSet = AttrSet NSourcePos --- ** orphan instances +-- ** Additional N{,Source}Pos instances -- Placed here because TH inference depends on declaration sequence. --- Upstreaming so far was not pursued. - instance Serialise NPos where encode = Serialise.encode . unPos . coerce decode = coerce . mkPos <$> Serialise.decode @@ -529,7 +527,6 @@ data NUnaryOp $(makeTraversals ''NUnaryOp) - -- ** data NBinaryOp -- | Binary operators expressible in the nix language. @@ -549,9 +546,6 @@ data NBinaryOp | NMult -- ^ Multiplication (@*@) | NDiv -- ^ Division (@/@) | NConcat -- ^ List concatenation (@++@) - | NApp -- ^ Apply a function to an argument. - -- - -- > NBinary NApp f x ~ f x deriving ( Eq, Ord, Enum, Bounded, Generic , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON @@ -605,6 +599,10 @@ data NExprF r -- -- > NUnary NNeg x ~ - x -- > NUnary NNot x ~ ! x + | NApp !r !r + -- ^ Functional application (aka F.A., apply a function to an argument). + -- + -- > NApp f x ~ f x | NBinary !NBinaryOp !r !r -- ^ Application of a binary operator to two expressions. -- @@ -814,6 +812,7 @@ getFreeVars e = (NLiteralPath _ ) -> mempty (NEnvPath _ ) -> mempty (NUnary _ expr ) -> getFreeVars expr + (NApp left right ) -> collectFreeVars left right (NBinary _ left right ) -> collectFreeVars left right (NSelect orExpr expr path) -> Set.unions diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs index 8b739c267..829725682 100644 --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -168,7 +168,7 @@ annNHasAttr :: NExprLoc -> AnnUnit SrcSpan (NAttrPath NExprLoc) -> NExprLoc annNHasAttr e1@(Ann s1 _) (AnnUnit s2 ats) = NHasAttrAnn (s1 <> s2) e1 ats annNApp :: NExprLoc -> NExprLoc -> NExprLoc -annNApp e1@(Ann s1 _) e2@(Ann s2 _) = NBinaryAnn (s1 <> s2) NApp e1 e2 +annNApp e1@(Ann s1 _) e2@(Ann s2 _) = NAppAnn (s1 <> s2) e1 e2 annNAbs :: AnnUnit SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc annNAbs (AnnUnit s1 ps) e1@(Ann s2 _) = NAbsAnn (s1 <> s2) ps e1 @@ -187,7 +187,9 @@ nullSpan :: SrcSpan nullSpan = SrcSpan nullPos nullPos {-# inline nullSpan #-} --- | Pattern systems for matching on @NExprLocF@ constructions. +-- ** Patterns + +-- *** Patterns to match on 'NExprLocF' constructions (for 'SrcSpan'-based annotations). pattern NConstantAnnF :: SrcSpan -> NAtom -> NExprLocF r pattern NConstantAnnF ann x = AnnF ann (NConstant x) @@ -213,6 +215,9 @@ pattern NEnvPathAnnF ann x = AnnF ann (NEnvPath x) pattern NUnaryAnnF :: SrcSpan -> NUnaryOp -> r -> NExprLocF r pattern NUnaryAnnF ann op x = AnnF ann (NUnary op x) +pattern NAppAnnF :: SrcSpan -> r -> r -> NExprLocF r +pattern NAppAnnF ann x y = AnnF ann (NApp x y) + pattern NBinaryAnnF :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r pattern NBinaryAnnF ann op x y = AnnF ann (NBinary op x y) @@ -242,6 +247,8 @@ pattern NSynHoleAnnF ann x = AnnF ann (NSynHole x) {-# complete NConstantAnnF, NStrAnnF, NSymAnnF, NListAnnF, NSetAnnF, NLiteralPathAnnF, NEnvPathAnnF, NUnaryAnnF, NBinaryAnnF, NSelectAnnF, NHasAttrAnnF, NAbsAnnF, NLetAnnF, NIfAnnF, NWithAnnF, NAssertAnnF, NSynHoleAnnF #-} +-- *** Patterns to match on 'NExprLoc' constructions (for 'SrcSpan'-based annotations). + pattern NConstantAnn :: SrcSpan -> NAtom -> NExprLoc pattern NConstantAnn ann x = Ann ann (NConstant x) @@ -266,6 +273,9 @@ pattern NEnvPathAnn ann x = Ann ann (NEnvPath x) pattern NUnaryAnn :: SrcSpan -> NUnaryOp -> NExprLoc -> NExprLoc pattern NUnaryAnn ann op x = Ann ann (NUnary op x) +pattern NAppAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc +pattern NAppAnn ann x y = Ann ann (NApp x y) + pattern NBinaryAnn :: SrcSpan -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc pattern NBinaryAnn ann op x y = Ann ann (NBinary op x y) diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index f231a774d..54c8f7b81 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -391,7 +391,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where _ <- unify (void e) cond =<< mkSymbolic (one $ TConstant $ one TBool) pure body' - evalApp = (fmap snd .) . lintApp (join (NBinary NApp) mempty) + evalApp = (fmap snd .) . lintApp (join NApp mempty) evalAbs params _ = mkSymbolic (one $ TClosure $ void params) evalError = throwError @@ -408,33 +408,31 @@ lintBinaryOp op lsym rarg = rsym <- rarg y <- defer everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - _ -> check lsym rsym $ - case op of - NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - - NLt -> one $ TConstant [TInt, TBool, TNull] - NLte -> one $ TConstant [TInt, TBool, TNull] - NGt -> one $ TConstant [TInt, TBool, TNull] - NGte -> one $ TConstant [TInt, TBool, TNull] - - NAnd -> one $ TConstant $ one TBool - NOr -> one $ TConstant $ one TBool - NImpl -> one $ TConstant $ one TBool - - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> [TConstant $ one TInt, TStr, TPath] - NMinus -> one $ TConstant $ one TInt - NMult -> one $ TConstant $ one TInt - NDiv -> one $ TConstant $ one TInt - - NUpdate -> one $ TSet mempty - - NConcat -> one $ TList y -#if __GLASGOW_HASKELL__ < 900 - _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope + check lsym rsym $ + case op of + NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + + NLt -> one $ TConstant [TInt, TBool, TNull] + NLte -> one $ TConstant [TInt, TBool, TNull] + NGt -> one $ TConstant [TInt, TBool, TNull] + NGte -> one $ TConstant [TInt, TBool, TNull] + + NAnd -> one $ TConstant $ one TBool + NOr -> one $ TConstant $ one TBool + NImpl -> one $ TConstant $ one TBool + + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> [TConstant $ one TInt, TStr, TPath] + NMinus -> one $ TConstant $ one TInt + NMult -> one $ TConstant $ one TInt + NDiv -> one $ TConstant $ one TInt + + NUpdate -> one $ TSet mempty + + NConcat -> one $ TList y +#if __GLASGOW_HASKELL__ < 810 + _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope #endif @@ -467,13 +465,9 @@ lintApp context fun arg = (args, ys) <- fmap unzip $ forM xs $ \case TClosure _params -> (\case - NAny -> do - error "NYI" - - NMany [TSet (Just _)] -> do - error "NYI" - - NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" + NAny -> error "NYI" + NMany [TSet (Just _)] -> error "NYI" + NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" ) =<< unpackSymbolic =<< arg TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin" TSet _m -> throwError $ ErrorCall "NYI: lintApp Set" diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs index a5959d278..f1ccc0bdd 100644 --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -20,6 +20,7 @@ module Nix.Parser , NAssoc(..) , NOperatorDef , getUnaryOperator + , getAppOperator , getBinaryOperator , getSpecialOperator , nixExpr @@ -472,6 +473,7 @@ data NAssoc = NAssocNone | NAssocLeft | NAssocRight data NOperatorDef = NUnaryDef NUnaryOp Text + | NAppDef NAssoc Text | NBinaryDef NAssoc NBinaryOp Text | NSpecialDef NAssoc NSpecialOp Text deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) @@ -548,7 +550,7 @@ nixOperators selector = {- 2 -} one - ( NBinaryDef NAssocLeft NApp " " + ( NAppDef NAssocLeft " " , -- Thanks to Brent Yorgey for showing me this trick! InfixL $ annNApp <$ symbols mempty @@ -640,6 +642,14 @@ getUnaryOperator = detectPrecedence spec (NUnaryDef op name, _) -> one (op, OperatorInfo i NAssocNone name) _ -> mempty +getAppOperator :: OperatorInfo +getAppOperator = + OperatorInfo + { precedence = 1 -- inside the code it is 1, inside the Nix they are +1 + , associativity = NAssocLeft + , operatorName = " " + } + getBinaryOperator :: NBinaryOp -> OperatorInfo getBinaryOperator = detectPrecedence spec where diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index 6a87953e9..aa3109fd2 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -74,7 +74,7 @@ leastPrecedence = mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" appOp :: OperatorInfo -appOp = getBinaryOperator NApp +appOp = getAppOperator appOpNonAssoc :: OperatorInfo appOpNonAssoc = appOp { associativity = NAssocNone } @@ -255,7 +255,7 @@ exprFNixDoc = \case [ prettyParams args <> ":" , getDoc body ] - NBinary NApp fun arg -> + NApp fun arg -> mkNixDoc appOp (precedenceWrap appOp fun <> " " <> precedenceWrap appOpNonAssoc arg) NBinary op r1 r2 -> mkNixDoc diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index b360a5263..6eb3cdac7 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -171,13 +171,13 @@ reduce (NUnaryAnnF uann op arg) = -- -- * Reduce a lambda function by adding its name to the local -- scope and recursively reducing its body. -reduce (NBinaryAnnF bann NApp fun arg) = +reduce (NAppAnnF bann fun arg) = (\case f@(NSymAnn _ "import") -> (\case -- NEnvPathAnn pann origPath -> staticImport pann origPath NLiteralPathAnn pann origPath -> staticImport pann origPath - v -> pure $ NBinaryAnn bann NApp f v + v -> pure $ NAppAnn bann f v ) =<< arg NAbsAnn _ (Param name) body -> @@ -187,7 +187,7 @@ reduce (NBinaryAnnF bann NApp fun arg) = (coerce $ HM.singleton name x) (foldFix reduce body) - f -> NBinaryAnn bann NApp f <$> arg + f -> NAppAnn bann f <$> arg ) =<< fun -- | Reduce an integer addition to its result. @@ -391,14 +391,14 @@ pruneTree opts = NSelect alt (Just aset) attr -> pure $ NSelect (join alt) aset $ pruneKeyName <$> attr + -- If the function was never called, it means its argument was in a + -- thunk that was forced elsewhere. + NApp Nothing (Just _) -> Nothing + -- These are the only short-circuiting binary operators NBinary NAnd (Just (Ann _ larg)) _ -> pure larg NBinary NOr (Just (Ann _ larg)) _ -> pure larg - -- If the function was never called, it means its argument was in a - -- thunk that was forced elsewhere. - NBinary NApp Nothing (Just _) -> Nothing - -- The idea behind emitted a binary operator where one side may be -- invalid is that we're trying to emit what will reproduce whatever -- fail the user encountered, which means providing all aspects of diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index 795219bc9..77d07795c 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -677,9 +677,8 @@ unops u1 op = binops :: Type -> NBinaryOp -> [Constraint] binops u1 op = if - -- NApp in fact is handled separately -- Equality tells nothing about the types, because any two types are allowed. - | op `elem` [ NApp , NEq , NNEq ] -> mempty + | op `elem` [ NEq , NNEq ] -> mempty | op `elem` [ NGt , NGte , NLt , NLte ] -> inequality | op `elem` [ NAnd , NOr , NImpl ] -> gate | op == NConcat -> concatenation diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs index 6094572c9..d18220520 100644 --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -662,12 +662,10 @@ case_simpleLoc = (one $ NamedVar (one $ StaticKey "foo") - (NBinaryAnn + (NAppAnn (mkSpan (2, 7) (3, 15)) - NApp - (NBinaryAnn + (NAppAnn (mkSpan (2, 7) (3, 9)) - NApp (NSymAnn (mkSpan (2, 7) (2, 10)) "bar") (NSymAnn (mkSpan (3, 6) (3, 9 )) "baz") )