Merge branch 'main' into stdlib-style

src/Juvix/Compiler/Nockma/Evaluator.hs

@@ -197,15 +197,18 @@ evalProfile inistack initerm =
           ParsedOperatorCell o -> goOperatorCell o
           ParsedStdlibCallCell o -> do
             intercept' <- asks (^. evalInterceptStdlibCalls)
+            let nonInterceptCall = goOperatorCell (o ^. stdlibCallRaw)
+            -- Pass the raw call to goStdlibCall so that stdlib intercepts
+            -- can choose to use the raw call instead.
             if
-                | intercept' -> goStdlibCall (o ^. stdlibCallCell)
-                | otherwise -> goOperatorCell (o ^. stdlibCallRaw)
+                | intercept' -> goStdlibCall nonInterceptCall (o ^. stdlibCallCell)
+                | otherwise -> nonInterceptCall
       where
         loc :: Maybe Interval
         loc = term ^. termLoc
 
-        goStdlibCall :: StdlibCall a -> Sem r (Term a)
-        goStdlibCall StdlibCall {..} = do
+        goStdlibCall :: Sem r (Term a) -> StdlibCall a -> Sem r (Term a)
+        goStdlibCall nonInterceptCall StdlibCall {..} = do
           let w = EvalCrumbStdlibCallArgs (CrumbStdlibCallArgs _stdlibCallFunction)
           args' <- withCrumb w (recEval stack _stdlibCallArgs)
           let binArith :: (a -> a -> a) -> Sem r (Term a)
@@ -262,6 +265,9 @@ evalProfile inistack initerm =
             StdlibLengthBytes -> case args' of
               TermAtom a -> TermAtom <$> goLengthBytes a
               _ -> error "expected an atom"
+            -- Use the raw nock code for curry. The nock stdlib curry function is
+            -- small. There's no benefit in implementing it separately in the evaluator.
+            StdlibCurry -> nonInterceptCall
           where
             goCat :: Atom a -> Atom a -> Sem r (Term a)
             goCat arg1 arg2 = TermAtom . setAtomHint AtomHintString <$> atomConcatenateBytes arg1 arg2

src/Juvix/Compiler/Nockma/StdlibFunction.hs

@@ -27,6 +27,7 @@ stdlibPath = \case
   StdlibSignDetached -> [nock| [9 23 0 1] |]
   StdlibVerify -> [nock| [9 4 0 1] |]
   StdlibLengthList -> [nock| [9 1.406 0 31] |]
+  StdlibCurry -> [nock| [9 4 0 31] |]
   -- Obtained from the urbit dojo using:
   --
   -- =>  anoma  !=(~(met block 3))

src/Juvix/Compiler/Nockma/StdlibFunction/Base.hs

@@ -24,6 +24,7 @@ instance Pretty StdlibFunction where
     StdlibFoldBytes -> "fold-bytes"
     StdlibLengthList -> "length-list"
     StdlibLengthBytes -> "length-bytes"
+    StdlibCurry -> "curry"
 
 data StdlibFunction
   = StdlibDec
@@ -45,6 +46,7 @@ data StdlibFunction
   | StdlibFoldBytes
   | StdlibLengthList
   | StdlibLengthBytes
+  | StdlibCurry
   deriving stock (Show, Lift, Eq, Bounded, Enum, Generic)
 
 instance Hashable StdlibFunction

src/Juvix/Compiler/Nockma/Translation/FromTree.hs

@@ -31,6 +31,9 @@ module Juvix.Compiler.Nockma.Translation.FromTree
     runCompilerWith,
     emptyCompilerCtx,
     CompilerCtx (..),
+    stdlibCurry,
+    IndexTupleArgs (..),
+    indexTuple,
   )
 where
 
@@ -758,7 +761,7 @@ compile = \case
       args <- mapM compile _nodeAllocClosureArgs
       return . makeClosure $ \case
         FunCode -> opAddress "allocClosureFunPath" (base <> fpath <> closurePath FunCode)
-        ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure"
+        ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" farity
         FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder
         StandardLibrary -> OpQuote # stdlibPlaceHolder
         ClosureTotalArgsNum -> nockNatLiteral farity
@@ -784,8 +787,11 @@ compile = \case
 opAddress' :: Term Natural -> Term Natural
 opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x
 
-argsTuplePlaceholder :: Text -> Term Natural
-argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt)
+argsTuplePlaceholder :: Text -> Natural -> Term Natural
+argsTuplePlaceholder txt arity = ("argsTuplePlaceholder-" <> txt) @ foldTermsOrNil (replicate arityInt (TermAtom nockNil))
+  where
+    arityInt :: Int
+    arityInt = fromIntegral arity
 
 appendRights :: (Member (Reader CompilerCtx) r) => Path -> Term Natural -> Sem r (Term Natural)
 appendRights path n = do
@@ -975,18 +981,18 @@ runCompilerWith _opts constrs moduleFuns mainFun =
         compiledFuns =
           (OpQuote # (666 :: Natural)) -- TODO we have this unused term so that indices match. Remove it and adjust as needed
             : ( makeLibraryFunction
-                  <$> [(f ^. compilerFunctionName, runCompilerFunction compilerCtx f) | f <- libFuns]
+                  <$> [(f ^. compilerFunctionName, f ^. compilerFunctionArity, runCompilerFunction compilerCtx f) | f <- libFuns]
               )
 
-    makeLibraryFunction :: (Text, Term Natural) -> Term Natural
-    makeLibraryFunction (funName, c) =
+    makeLibraryFunction :: (Text, Natural, Term Natural) -> Term Natural
+    makeLibraryFunction (funName, funArity, c) =
       ("def-" <> funName)
         @ makeClosure
           ( \p ->
               let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p)
                in case p of
                     FunCode -> ("funCode-" <> funName) @ c
-                    ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction"
+                    ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction" funArity
                     FunctionsLibrary -> ("functionsLibrary-" <> funName) @ functionsLibraryPlaceHolder
                     StandardLibrary -> ("stdlib-" <> funName) @ stdlibPlaceHolder
                     ClosureTotalArgsNum -> ("closureTotalArgsNum-" <> funName) @ nockNilHere
@@ -1000,7 +1006,7 @@ runCompilerWith _opts constrs moduleFuns mainFun =
       let nockNilHere = nockNilTagged ("makeMainFunction-" <> show p)
        in case p of
             FunCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib c
-            ArgsTuple -> argsTuplePlaceholder "mainFunction"
+            ArgsTuple -> argsTuplePlaceholder "mainFunction" (mainFun ^. compilerFunctionArity)
             FunctionsLibrary -> functionsLibraryPlaceHolder
             StandardLibrary -> stdlib
             ClosureTotalArgsNum -> nockNilHere
@@ -1304,3 +1310,6 @@ intToUInt8 i = callStdlib StdlibMod [i, nockIntegralLiteral @Natural (2 ^ uint8S
   where
     uint8Size :: Natural
     uint8Size = 8
+
+stdlibCurry :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural)
+stdlibCurry f arg = callStdlib StdlibCurry [f, arg]

test/Nockma/Eval/Positive.hs

@@ -159,6 +159,113 @@ testWithStorage s = Test defaultEvalOptions Nothing (Storage (HashMap.fromList (
 test :: Text -> Term Natural -> Term Natural -> Check () -> Test
 test = testWithStorage []
 
+--- A Nock formula that computes logical and
+nockAnd :: Term Natural
+nockAnd =
+  OpIf
+    # (OpAddress # argPath 0)
+    # ( OpIf
+          # (OpAddress # argPath 1)
+          # nockTrueLiteral
+          # nockFalseLiteral
+      )
+    # nockFalseLiteral
+  where
+    argPath :: Natural -> Path
+    argPath idx =
+      closurePath ArgsTuple
+        ++ indexTuple
+          ( IndexTupleArgs
+              { _indexTupleArgsIndex = idx,
+                _indexTupleArgsLength = funArity
+              }
+          )
+    funArity :: Natural
+    funArity = 2
+
+--- A nock function that computes logical and
+nockAndFun :: Term Natural
+nockAndFun = nockAnd # args # env
+  where
+    arg :: Term Natural
+    arg = nockNilTagged "placeholder argument"
+
+    args :: Term Natural
+    args = arg # arg
+
+    env :: Term Natural
+    env = nockNilTagged "environment"
+
+--- A Nock formula that computes logical and of 3 arguments
+nockAnd3 :: Term Natural
+nockAnd3 =
+  OpIf
+    # (OpAddress # argPath 0)
+    # ( OpIf
+          # (OpAddress # argPath 1)
+          # ( OpIf
+                # (OpAddress # argPath 2)
+                # nockTrueLiteral
+                # nockFalseLiteral
+            )
+          # nockFalseLiteral
+      )
+    # nockFalseLiteral
+  where
+    argPath :: Natural -> Path
+    argPath idx =
+      closurePath ArgsTuple
+        ++ indexTuple
+          ( IndexTupleArgs
+              { _indexTupleArgsIndex = idx,
+                _indexTupleArgsLength = funArity
+              }
+          )
+    funArity :: Natural
+    funArity = 3
+
+--- A nock function that computes logical and for 3 arguments
+nockAnd3Fun :: Term Natural
+nockAnd3Fun = nockAnd3 # args # env
+  where
+    arg :: Term Natural
+    arg = nockNilTagged "placeholder argument"
+
+    args :: Term Natural
+    args = arg # arg # arg
+
+    env :: Term Natural
+    env = nockNilTagged "environment"
+
+-- | Wrap a function in a formula that calls the function with arguments from the subject.
+applyFun :: Term Natural -> Term Natural
+applyFun f =
+  OpPush
+    # f
+    # ( OpCall
+          # codePath
+          # ( OpReplace
+                # ( argsPath
+                      # (OpAddress # subjectPath >># (OpAddress # argsPath))
+                  )
+                # (OpAddress # fPath)
+            )
+      )
+  where
+    codePath :: Path
+    codePath = closurePath FunCode
+
+    argsPath :: Path
+    argsPath = closurePath ArgsTuple
+
+    -- Path to the function being applied after pushing
+    fPath :: Path
+    fPath = [L]
+
+    -- Path to the original subject after pushing
+    subjectPath :: Path
+    subjectPath = [R]
+
 anomaCallingConventionTests :: [Test]
 anomaCallingConventionTests =
   [True, False]
@@ -172,7 +279,24 @@ anomaCallingConventionTests =
             in run . runReader fx . runReader emptyCompilerCtx $ do
                  p0 <- pathToArg 0
                  p1 <- pathToArg 1
-                 return (anomaTestM "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |]))
+                 return (anomaTestM "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |])),
+           --- sanity check nockAnd
+           anomaTestM "(and true false) == false" (return nockAnd) [nockTrueLiteral, nockFalseLiteral] (eqNock [nock| false |]),
+           anomaTestM "(and true true) == true" (return nockAnd) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]),
+           --- test curry with and
+           anomaTestM "(curry and true) false == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockTrueLiteral) [nockFalseLiteral] (eqNock [nock| false |]),
+           anomaTestM "(curry and true) true == true" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockTrueLiteral) [nockTrueLiteral] (eqNock [nock| true |]),
+           anomaTestM "(curry and false) true == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockFalseLiteral) [nockTrueLiteral] (eqNock [nock| false |]),
+           anomaTestM "(curry and false) false == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockFalseLiteral) [nockFalseLiteral] (eqNock [nock| false |]),
+           --- sanity check nockAnd3
+           anomaTestM "(and3 true false true) == false" (return nockAnd3) [nockTrueLiteral, nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]),
+           anomaTestM "(and3 true true false) == false" (return nockAnd3) [nockTrueLiteral, nockTrueLiteral, nockFalseLiteral] (eqNock [nock| false |]),
+           anomaTestM "(and3 true true true) == true" (return nockAnd3) [nockTrueLiteral, nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]),
+           --- test curry with and3
+           anomaTestM "(curry and3 true) false true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockTrueLiteral) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]),
+           anomaTestM "(curry and3 true) true true == true" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockTrueLiteral) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]),
+           anomaTestM "(curry and3 false) true true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockFalseLiteral) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| false |]),
+           anomaTestM "(curry and3 false) false true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockFalseLiteral) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |])
          ]
 
 serializationTests :: [Test]
@@ -232,6 +356,10 @@ serializationTests =
         [nock| [[0 1] [2 3] [4 5] [6 7] [8 9] [10 11] [12 13] [14 15] [16 17] [18 19] [20 21] 0] |]
         [nock| 308.947.677.754.874.070.959.300.747.182.056.036.528.545.493.781.368.831.595.479.491.505.523.344.414.501 |]
 
+-- Call a formula with specified arguments
+nockCall :: Term Natural -> NonEmpty (Term Natural) -> Term Natural
+nockCall formula args = (OpReplace # ([R, L] # foldTerms args) # (OpQuote # formula)) >># (OpCall # [L] # (OpAddress # emptyPath))
+
 juvixCallingConventionTests :: [Test]
 juvixCallingConventionTests =
   [True, False]