From 9ef12ef163c0f4c947c11933ce50d9d3fcd30248 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Fri, 21 Jan 2022 18:33:50 +0200 Subject: [PATCH] Expr.Types: NExprF: add NApp This commit takes-put the NApp out of NBinaryOp & places it as a proper citizen on NExprF. Addresses https://github.com/haskell-nix/hnix/issues/1041 & https://github.com/haskell-nix/hnix/issues/377. --- src/Nix/Eval.hs | 2 +- src/Nix/Exec.hs | 15 +++++++++--- src/Nix/Expr/Shorthands.hs | 10 ++++++-- src/Nix/Expr/Types.hs | 16 ++++++++++--- src/Nix/Expr/Types/Annotated.hs | 14 +++++++++-- src/Nix/Lint.hs | 42 ++++++++++++++++----------------- src/Nix/Parser.hs | 13 +++++++++- src/Nix/Pretty.hs | 4 ++-- src/Nix/Reduce.hs | 14 +++++------ src/Nix/Type/Infer.hs | 3 +-- tests/ParserTests.hs | 6 ++--- 11 files changed, 90 insertions(+), 49 deletions(-) diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index f701b3596..7a3f970e5 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 NAppOp 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..df1df712c 100644 --- a/src/Nix/Expr/Shorthands.hs +++ b/src/Nix/Expr/Shorthands.hs @@ -84,6 +84,11 @@ mkNot = mkOp NNot mkNeg :: NExpr -> NExpr mkNeg = mkOp NNeg +-- | Put a binary operator. +-- @since 0.15.0 +mkApp :: NExpr -> NExpr -> NExpr +mkApp a = Fix . NApp NAppOp a + -- | Put a binary operator. -- @since 0.15.0 mkOp2 :: NBinaryOp -> NExpr -> NExpr -> NExpr @@ -325,7 +330,7 @@ recAttrsE pairs = mkRecSet $ uncurry ($=) <$> pairs -- * Nix binary operators -(@@), ($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++) +($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++) :: NExpr -> NExpr -> NExpr -- 2021-07-10: NOTE: Probably the presedence of some operators is still needs to be tweaked. @@ -343,7 +348,8 @@ infix 9 @. infix 9 @.<|> -- | Function application (@' '@ in @f x@) -(@@) = mkOp2 NApp +(@@) :: NExpr -> NExpr -> NExpr +(@@) = mkApp infixl 8 @@ -- | List concatenation: @++@ diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index fb6e82042..17782ac4c 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -529,6 +529,14 @@ data NUnaryOp $(makeTraversals ''NUnaryOp) +-- ** + +data NAppOp = NAppOp + deriving + ( Eq, Ord, Generic + , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON + , Show, Hashable + ) -- ** data NBinaryOp @@ -549,9 +557,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 +610,10 @@ data NExprF r -- -- > NUnary NNeg x ~ - x -- > NUnary NNot x ~ ! x + | NApp NAppOp !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 +823,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..98e37ab42 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 NAppOp 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 NAppOp 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..fa8648ef5 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 NAppOp) 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] + 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] + 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 + 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 + -- 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 + NUpdate -> one $ TSet mempty - NConcat -> one $ TList y + 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 + _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope #endif diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs index a5959d278..92ca57a2d 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,15 @@ getUnaryOperator = detectPrecedence spec (NUnaryDef op name, _) -> one (op, OperatorInfo i NAssocNone name) _ -> mempty +getAppOperator :: NAppOp -> OperatorInfo +getAppOperator = detectPrecedence spec + where + spec :: Int -> (NOperatorDef, b) -> [(NAppOp, OperatorInfo)] + spec i = + \case + (NAppDef assoc name, _) -> one (NAppOp, OperatorInfo i assoc name) + _ -> mempty + getBinaryOperator :: NBinaryOp -> OperatorInfo getBinaryOperator = detectPrecedence spec where diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index 6a87953e9..d38c20ec6 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 NAppOp appOpNonAssoc :: OperatorInfo appOpNonAssoc = appOp { associativity = NAssocNone } @@ -255,7 +255,7 @@ exprFNixDoc = \case [ prettyParams args <> ":" , getDoc body ] - NBinary NApp fun arg -> + NApp NAppOp 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..27f0c81dd 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 NAppOp 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") )