Expr.Types: NExprF: add NApp

This commit takes-put the NApp out of NBinaryOp & places it as a proper citizen
on NExprF.

Addresses haskell-nix#1041 &
haskell-nix#377.

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

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

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: @++@

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

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)
 

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
 
 

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

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

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

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

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")
             )