(#1042) Expr.Types: NExprF: add NApp

Implements #1041.

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

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

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 =

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

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

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

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

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)
 

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"