diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index 0c550f1a2..20e9d1ed3 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -221,6 +221,14 @@ makeLenses ''WithStack makeLenses ''AtomInfo makeLenses ''CellInfo +isCell :: Term a -> Bool +isCell = \case + TermCell {} -> True + _ -> False + +isAtom :: Term a -> Bool +isAtom = not . isCell + atomHint :: Lens' (Atom a) (Maybe AtomHint) atomHint = atomInfo . atomInfoHint @@ -460,6 +468,12 @@ opAddress txt p = TermCell (txt @ OpAddress #. p) opQuote :: (IsNock x) => Text -> x -> Term Natural opQuote txt p = TermCell (txt @ OpQuote #. p) +opTrace :: Term Natural -> Term Natural +opTrace val = OpHint # (nockHintAtom NockHintPuts # val) # val + +opTrace' :: Term Natural -> Term Natural -> Term Natural +opTrace' msg val = OpHint # (nockNilTagged "opTrace'" # msg) # val + {-# COMPLETE Cell #-} pattern Cell :: Term a -> Term a -> Cell a diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index f35207859..50eed30cf 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -11,27 +11,18 @@ module Juvix.Compiler.Nockma.Translation.FromTree FunctionCtx (..), FunctionId (..), closurePath, - foldTermsOrNil, - add, + foldTermsOrQuotedNil, sub, - dec, - mul, - pow2, nockNatLiteral, nockIntegralLiteral, callStdlib, - appendRights, foldTerms, pathToArg, makeList, - appendToTuple, - append, - opAddress', - replaceSubterm', runCompilerWith, emptyCompilerCtx, CompilerCtx (..), - stdlibCurry, + curryClosure, IndexTupleArgs (..), indexTuple, ) @@ -163,11 +154,8 @@ data AnomaCallablePathId = FunCode | ArgsTuple | --- - FunctionsLibrary - | ClosureTotalArgsNum - | ClosureArgsNum - | ClosureArgs - | AnomaGetOrder + ClosureRemainingArgsNum + | FunctionsLibrary | StandardLibrary deriving stock (Enum, Bounded, Eq, Show) @@ -188,6 +176,9 @@ constructorPath = pathFromEnum closurePath :: AnomaCallablePathId -> Path closurePath = pathFromEnum +anomaGetPath :: Path +anomaGetPath = [L] + data IndexTupleArgs = IndexTupleArgs { _indexTupleArgsLength :: Natural, _indexTupleArgsIndex :: Natural @@ -300,8 +291,21 @@ makeClosure = termFromParts makeConstructor :: (ConstructorPathId -> Term Natural) -> Term Natural makeConstructor = termFromParts +-- | The result is not quoted and cannot be evaluated. +rawTermFromParts :: (Bounded p, Enum p) => (p -> Term Natural) -> Term Natural +rawTermFromParts f = makeList [f pi | pi <- allElements] + +-- | The result is not quoted and cannot be evaluated. +makeRawClosure :: (AnomaCallablePathId -> Term Natural) -> Term Natural +makeRawClosure = rawTermFromParts + +-- | The provided terms cannot be evaluated. foldTermsOrNil :: [Term Natural] -> Term Natural -foldTermsOrNil = maybe (OpQuote # nockNilTagged "foldTermsOrNil") foldTerms . nonEmpty +foldTermsOrNil = maybe (nockNilTagged "foldTermsOrNil") foldTerms . nonEmpty + +-- | The provided terms can be evaluated. +foldTermsOrQuotedNil :: [Term Natural] -> Term Natural +foldTermsOrQuotedNil = maybe (OpQuote # nockNilTagged "foldTermsOrQuotedNil") foldTerms . nonEmpty foldTerms :: NonEmpty (Term Natural) -> Term Natural foldTerms = foldr1 (#) @@ -339,7 +343,7 @@ supportsMaybeNockmaRep tab ci = | otherwise -> Nothing _ -> Nothing --- | Use `Tree.toNockma` before calling this function +-- | Use `Tree.toNockma` before calling this function. The result is an unquoted subject. fromTreeTable :: (Members '[Error JuvixError, Reader CompilerOptions] r) => Tree.InfoTable -> Sem r AnomaResult fromTreeTable t = case t ^. Tree.infoMainFunction of Just mainFun -> do @@ -408,6 +412,7 @@ addressTempRef tr = do p <- tempRefPath tr return $ opAddress "tempRef" p +-- `funsLib` is being quoted in this function mainFunctionWrapper :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) mainFunctionWrapper funslib funCode = do -- 1. The Anoma system expects to receive a function of type `ScryId -> Transaction` @@ -424,8 +429,7 @@ mainFunctionWrapper funslib funCode = do anomaGet <- getFieldInSubject ArgsTuple captureAnomaGetOrder <- replaceSubject $ \case FunCode -> Just (OpQuote # funCode) - AnomaGetOrder -> Just anomaGet - FunctionsLibrary -> Just (OpQuote # funslib) + FunctionsLibrary -> Just (OpReplace # (anomaGetPath # anomaGet) # OpQuote # funslib) _ -> Nothing return $ opCall "mainFunctionWrapper" (closurePath FunCode) captureAnomaGetOrder @@ -601,23 +605,19 @@ compile = \case goPrimUnop op arg = case op of Tree.OpShow -> stringsErr "show" Tree.OpStrToInt -> stringsErr "strToInt" - Tree.OpArgsNum -> do - arg' <- compile arg - withTemp - arg' - ( \ref -> do - tmp <- addressTempRef ref - sub (getClosureField ClosureTotalArgsNum tmp) (getClosureField ClosureArgsNum tmp) - ) + Tree.OpArgsNum -> + compile arg + >>= return . getClosureField ClosureRemainingArgsNum Tree.OpIntToField -> fieldErr Tree.OpFieldToInt -> fieldErr - Tree.OpIntToUInt8 -> intToUInt8 =<< compile arg + Tree.OpIntToUInt8 -> compile arg >>= intToUInt8 Tree.OpUInt8ToInt -> compile arg goAnomaGet :: [Term Natural] -> Sem r (Term Natural) goAnomaGet key = do - anomaGet <- getFieldInSubject AnomaGetOrder - let arg = remakeList [anomaGet, foldTermsOrNil key] + funlibPath <- stackPath FunctionsLibrary + let anomaGet = opAddress "anomaGet" (funlibPath <> anomaGetPath) + let arg = remakeList [anomaGet, foldTermsOrQuotedNil key] return (OpScry # (OpQuote # nockNilTagged "OpScry-typehint") # arg) goAnomaEncode :: [Term Natural] -> Sem r (Term Natural) @@ -739,7 +739,7 @@ compile = \case goTrace arg = do withTemp arg $ \ref -> do val <- addressTempRef ref - return $ OpHint # (nockHintAtom NockHintPuts # val) # val + return $ opTrace val goBinop :: Tree.NodeBinop -> Sem r (Term Natural) goBinop Tree.NodeBinop {..} = do @@ -772,18 +772,25 @@ compile = \case fpath <- getFunctionPath fun farity <- getFunctionArity fun args <- mapM compile _nodeAllocClosureArgs - return . makeClosure $ \case - FunCode -> opAddress "allocClosureFunPath" (base <> fpath <> closurePath FunCode) - ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" farity - FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder - StandardLibrary -> OpQuote # stdlibPlaceHolder - ClosureTotalArgsNum -> nockNatLiteral farity - ClosureArgsNum -> nockIntegralLiteral (length args) - ClosureArgs -> remakeList args - AnomaGetOrder -> OpQuote # nockNilTagged "goAllocClosure-AnomaGetOrder" + let funLib = opAddress "functionsLibrary" (base <> closurePath FunctionsLibrary) + stdLib = opAddress "standardLibrary" (base <> closurePath StandardLibrary) + closure = + opReplace "putStdLib" (closurePath StandardLibrary) stdLib + . opReplace "putFunLib" (closurePath FunctionsLibrary) funLib + $ opAddress "goAllocClosure-getFunction" (base <> fpath) + newArity = farity - fromIntegral (length args) + massert (newArity > 0) + curryClosure closure args (nockNatLiteral newArity) goExtendClosure :: Tree.NodeExtendClosure -> Sem r (Term Natural) - goExtendClosure = extendClosure + goExtendClosure Tree.NodeExtendClosure {..} = do + closureFun <- compile _nodeExtendClosureFun + withTemp closureFun $ \ref -> do + args <- mapM compile _nodeExtendClosureArgs + closure <- addressTempRef ref + let remainingArgsNum = getClosureField ClosureRemainingArgsNum closure + newArity <- sub remainingArgsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) + curryClosure closure (toList args) newArity goCall :: Tree.NodeCall -> Sem r (Term Natural) goCall Tree.NodeCall {..} = @@ -797,20 +804,13 @@ compile = \case newargs <- mapM compile _nodeCallArgs callClosure ref newargs -opAddress' :: Term Natural -> Term Natural -opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x - +-- | Creates a tuple that needs to be quoted before evaluation 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 - n' <- pow2 n - mul n' (OpInc # OpQuote # path) >>= dec - testEq :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Tree.Node -> Sem r (Term Natural) testEq a b = do a' <- compile a @@ -823,48 +823,8 @@ nockNatLiteral = nockIntegralLiteral nockIntegralLiteral :: (Integral a) => a -> Term Natural nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral --- | xs must be a list. --- ys is a non-empty tuple. --- the result is a tuple. --- TODO: this function generates inefficient code -appendToTuple :: - (Member (Reader CompilerCtx) r) => - Term Natural -> - Term Natural -> - Term Natural -> - Sem r (Term Natural) -appendToTuple xs lenXs ys = append xs lenXs ys - --- TODO: what does this function do? what are the arguments? --- TODO: this function generates inefficient code -append :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Term Natural -> Sem r (Term Natural) -append xs lenXs ys = do - posOfXsNil <- appendRights emptyPath lenXs - return $ replaceSubterm' xs posOfXsNil ys - -extendClosure :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - Tree.NodeExtendClosure -> - Sem r (Term Natural) -extendClosure Tree.NodeExtendClosure {..} = do - closureFun <- compile _nodeExtendClosureFun - withTemp closureFun $ \ref -> do - args <- mapM compile _nodeExtendClosureArgs - closure <- addressTempRef ref - let argsNum = getClosureField ClosureArgsNum closure - oldArgs = getClosureField ClosureArgs closure - allArgs <- append oldArgs argsNum (remakeList args) - newArgsNum <- add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) - return . makeClosure $ \case - FunCode -> getClosureField FunCode closure - ClosureTotalArgsNum -> getClosureField ClosureTotalArgsNum closure - ClosureArgsNum -> newArgsNum - ClosureArgs -> allArgs - ArgsTuple -> getClosureField ArgsTuple closure - FunctionsLibrary -> getClosureField FunctionsLibrary closure - StandardLibrary -> getClosureField StandardLibrary closure - AnomaGetOrder -> getClosureField AnomaGetOrder closure - +-- [call L [replace [RL [seq [@ R] a]] [@ (locStdlib <> fPath)]]] ? +-- -- Calling convention for Anoma stdlib -- -- [push @@ -890,7 +850,7 @@ callStdlib fun args = do callFn = opCall "callStdlib" (closurePath FunCode) adjustArgs meta = StdlibCall - { _stdlibCallArgs = foldTermsOrNil args, + { _stdlibCallArgs = foldTermsOrQuotedNil args, _stdlibCallFunction = fun } callCell = set cellCall (Just meta) (OpPush #. (getFunCode # callFn)) @@ -923,29 +883,31 @@ nockmaBuiltinTag = \case -- | Generic constructors are encoded as [tag args], where args is a -- nil terminated list. goConstructor :: NockmaMemRep -> Tree.Tag -> [Term Natural] -> Term Natural -goConstructor mr t args = case t of - Tree.BuiltinTag b -> case nockmaBuiltinTag b of - NockmaBuiltinBool v -> nockBoolLiteral v - Tree.UserTag tag -> case mr of - NockmaMemRepConstr -> - makeConstructor $ \case - ConstructorTag -> OpQuote # (fromIntegral (tag ^. Tree.tagUserWord) :: Natural) - ConstructorArgs -> remakeList args - NockmaMemRepTuple -> foldTerms (nonEmpty' args) - NockmaMemRepList constr -> case constr of - NockmaMemRepListConstrNil - | null args -> remakeList [] - | otherwise -> impossible - NockmaMemRepListConstrCons -> case args of - [l, r] -> TCell l r - _ -> impossible - NockmaMemRepMaybe constr -> case constr of - NockmaMemRepMaybeConstrNothing - | null args -> (OpQuote # nockNilTagged "maybe-constr-nothing") - | otherwise -> impossible - NockmaMemRepMaybeConstrJust -> case args of - [x] -> TCell (OpQuote # nockNilTagged "maybe-constr-just-head") x - _ -> impossible +goConstructor mr t args = assert (all isCell args) $ + case t of + Tree.BuiltinTag b -> case nockmaBuiltinTag b of + NockmaBuiltinBool v -> nockBoolLiteral v + Tree.UserTag tag -> case mr of + NockmaMemRepConstr -> + makeConstructor $ \case + ConstructorTag -> OpQuote # (fromIntegral (tag ^. Tree.tagUserWord) :: Natural) + ConstructorArgs -> remakeList args + NockmaMemRepTuple -> + foldTerms (nonEmpty' args) + NockmaMemRepList constr -> case constr of + NockmaMemRepListConstrNil + | null args -> remakeList [] + | otherwise -> impossible + NockmaMemRepListConstrCons -> case args of + [l, r] -> TCell l r + _ -> impossible + NockmaMemRepMaybe constr -> case constr of + NockmaMemRepMaybeConstrNothing + | null args -> (OpQuote # nockNilTagged "maybe-constr-nothing") + | otherwise -> impossible + NockmaMemRepMaybeConstrJust -> case args of + [x] -> TCell (OpQuote # nockNilTagged "maybe-constr-just-head") x + _ -> impossible unsupported :: Text -> a unsupported thing = error ("The Nockma backend does not support " <> thing) @@ -959,12 +921,15 @@ fieldErr = unsupported "the field type" cairoErr :: a cairoErr = unsupported "cairo builtins" +-- | The elements will not be evaluated. makeList :: (Foldable f) => f (Term Natural) -> Term Natural makeList ts = foldTerms (toList ts `prependList` pure (nockNilTagged "makeList")) +-- | The elements of the list will be evaluated to create the list. remakeList :: (Foldable l) => l (Term Natural) -> Term Natural remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNilTagged "remakeList")) +-- | The result is unquoted. runCompilerWith :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> AnomaResult runCompilerWith _opts constrs moduleFuns mainFun = AnomaResult @@ -974,6 +939,13 @@ runCompilerWith _opts constrs moduleFuns mainFun = libFuns :: [CompilerFunction] libFuns = moduleFuns ++ (builtinFunction <$> allElements) + -- The number of "extra" functions at the front of the functions library + -- list which are not defined by the user. Currently, the only such function + -- is anomaGet (the `main` function and the functions from `libFuns` are + -- defined by the user). + libFunShift :: Natural + libFunShift = 1 + allFuns :: NonEmpty CompilerFunction allFuns = mainFun :| libFuns @@ -987,45 +959,43 @@ runCompilerWith _opts constrs moduleFuns mainFun = mainClosure :: Term Natural mainClosure = makeMainFunction (runCompilerFunction compilerCtx mainFun) + -- This term is not quoted and cannot be evaluated. funcsLib :: Term Natural funcsLib = Str.theFunctionsLibrary @ makeList compiledFuns where compiledFuns :: [Term Natural] compiledFuns = - (OpQuote # (666 :: Natural)) -- TODO we have this unused term so that indices match. Remove it and adjust as needed + (nockNilTagged "anomaGetPlaceholder") + : (nockNilTagged "mainFunctionPlaceholder") : ( makeLibraryFunction <$> [(f ^. compilerFunctionName, f ^. compilerFunctionArity, runCompilerFunction compilerCtx f) | f <- libFuns] ) + -- The result is not quoted and cannot be evaluated. makeLibraryFunction :: (Text, Natural, Term Natural) -> Term Natural makeLibraryFunction (funName, funArity, c) = ("def-" <> funName) - @ makeClosure + @ makeRawClosure ( \p -> let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p) in case p of FunCode -> ("funCode-" <> funName) @ c ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction" funArity + ClosureRemainingArgsNum -> ("closureRemainingArgsNum-" <> funName) @ nockNilHere FunctionsLibrary -> ("functionsLibrary-" <> funName) @ functionsLibraryPlaceHolder StandardLibrary -> ("stdlib-" <> funName) @ stdlibPlaceHolder - ClosureTotalArgsNum -> ("closureTotalArgsNum-" <> funName) @ nockNilHere - ClosureArgsNum -> ("closureArgsNum-" <> funName) @ nockNilHere - ClosureArgs -> ("closureArgs-" <> funName) @ nockNilHere - AnomaGetOrder -> ("anomaGetOrder-" <> funName) @ nockNilHere ) + -- The result is not quoted and cannot be evaluated directly. makeMainFunction :: Term Natural -> Term Natural - makeMainFunction c = makeClosure $ \p -> + makeMainFunction c = makeRawClosure $ \p -> let nockNilHere = nockNilTagged ("makeMainFunction-" <> show p) in case p of FunCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib c ArgsTuple -> argsTuplePlaceholder "mainFunction" (mainFun ^. compilerFunctionArity) + ClosureRemainingArgsNum -> nockNilHere FunctionsLibrary -> functionsLibraryPlaceHolder StandardLibrary -> stdlib - ClosureTotalArgsNum -> nockNilHere - ClosureArgsNum -> nockNilHere - ClosureArgs -> nockNilHere - AnomaGetOrder -> nockNilHere functionInfos :: HashMap FunctionId FunctionInfo functionInfos = hashMap (run (runStreamOfNaturals (toList <$> userFunctions))) @@ -1036,7 +1006,7 @@ runCompilerWith _opts constrs moduleFuns mainFun = return ( _compilerFunctionId, FunctionInfo - { _functionInfoPath = pathFromEnum FunctionsLibrary ++ indexStack i, + { _functionInfoPath = pathFromEnum FunctionsLibrary ++ indexStack (i + libFunShift), _functionInfoArity = _compilerFunctionArity, _functionInfoName = _compilerFunctionName } @@ -1081,7 +1051,7 @@ builtinFunction = \case -- | Call a function with the passed arguments callFunWithArgs :: forall r. - (Members '[Reader CompilerCtx] r) => + (Member (Reader CompilerCtx) r) => FunctionId -> [Term Natural] -> Sem r (Term Natural) @@ -1092,26 +1062,27 @@ callFunWithArgs fun args = do let p' = fpath ++ closurePath FunCode return (opCall ("callFun-" <> fname) p' newSubject) -callClosure :: (Members '[Reader CompilerCtx] r) => TempRef -> [Term Natural] -> Sem r (Term Natural) -callClosure ref newArgs = do +callClosure :: (Member (Reader CompilerCtx) r) => TempRef -> [Term Natural] -> Sem r (Term Natural) +callClosure ref args = do -- We never call a closure with zero arguments: if there are no arguments then -- there is no application and the closure is just returned. This differs from -- the behaviour with calls to known functions which may have zero arguments. - massert (not (null newArgs)) + massert (not (null args)) closure <- addressTempRef ref - let oldArgsNum = getClosureField ClosureArgsNum closure - oldArgs = getClosureField ClosureArgs closure - allArgs <- appendToTuple oldArgs oldArgsNum (foldTermsOrNil newArgs) - newSubject <- replaceSubject $ \case - FunCode -> Just (getClosureField FunCode closure) - ArgsTuple -> Just allArgs - FunctionsLibrary -> Nothing - StandardLibrary -> Nothing - ClosureArgs -> Nothing - ClosureTotalArgsNum -> Nothing - ClosureArgsNum -> Nothing - AnomaGetOrder -> Nothing - return (opCall "callClosure" (closurePath FunCode) newSubject) + let closure' = OpReplace # (closurePath ArgsTuple # foldTermsOrQuotedNil args) # closure + return (opCall "callClosure" (closurePath FunCode) closure') + +curryClosure :: Term Natural -> [Term Natural] -> Term Natural -> Sem r (Term Natural) +curryClosure f args newArity = do + let args' = (foldTerms (nonEmpty' $ map (\x -> (OpQuote # OpQuote) # x) args <> [OpQuote # OpAddress # closurePath ArgsTuple])) + return . makeClosure $ \case + FunCode -> (OpQuote # OpCall) # (OpQuote # closurePath FunCode) # (OpQuote # OpReplace) # ((OpQuote # closurePath ArgsTuple) # args') # (OpQuote # OpQuote) # f + ArgsTuple -> OpQuote # nockNilTagged "argsTuple" -- We assume the arguments tuple is never accessed before being replaced by the caller. + ClosureRemainingArgsNum -> newArity + -- The functions library and the standard library are always taken from the + -- closure `f`. The environment of `f` is used when evaluating the call. + FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder + StandardLibrary -> OpQuote # stdlibPlaceHolder replaceSubject :: (Member (Reader CompilerCtx) r) => (AnomaCallablePathId -> Maybe (Term Natural)) -> Sem r (Term Natural) replaceSubject = replaceSubject' "replaceSubject" @@ -1133,7 +1104,7 @@ replaceArgsWithTerm tag term = -- | Replace the arguments in the ArgsTuple stack with the passed arguments. -- Resets the temporary stack to empty. Returns the new subject. replaceArgs :: (Member (Reader CompilerCtx) r) => [Term Natural] -> Sem r (Term Natural) -replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrNil +replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrQuotedNil getFunctionInfo :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r FunctionInfo getFunctionInfo funId = asks (^?! compilerFunctionInfos . at funId . _Just) @@ -1144,15 +1115,6 @@ getFunctionPath funId = (^. functionInfoPath) <$> getFunctionInfo funId getFunctionName :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r Text getFunctionName funId = (^. functionInfoName) <$> getFunctionInfo funId -evaluated :: Term Natural -> Term Natural -evaluated t = OpApply # (opAddress "evaluated" emptyPath) # t - --- | obj[eval(relPath)] := newVal --- relPath is relative to obj -replaceSubterm' :: Term Natural -> Term Natural -> Term Natural -> Term Natural -replaceSubterm' obj relPath newVal = - evaluated $ (OpQuote # OpReplace) # ((relPath # (OpQuote # newVal)) # (OpQuote # obj)) - builtinTagToTerm :: NockmaBuiltinTag -> Term Natural builtinTagToTerm = \case NockmaBuiltinBool v -> nockBoolLiteral v @@ -1303,26 +1265,11 @@ getConstructorMemRep tag = (^. constructorInfoMemRep) <$> getConstructorInfo tag crash :: Term Natural crash = ("crash" @ OpAddress # OpAddress # OpAddress) -mul :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) -mul a b = callStdlib StdlibMul [a, b] - -pow2 :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) -pow2 x = callStdlib StdlibPow2 [x] - -add :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) -add a b = callStdlib StdlibAdd [a, b] - sub :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) sub a b = callStdlib StdlibSub [a, b] -dec :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) -dec x = callStdlib StdlibDec [x] - intToUInt8 :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) intToUInt8 i = callStdlib StdlibMod [i, nockIntegralLiteral @Natural (2 ^ uint8Size)] 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] diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index 7c4f1eeb0..8cf43dff0 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -269,8 +269,8 @@ applyFun f = anomaCallingConventionTests :: [Test] anomaCallingConventionTests = [True, False] - <**> [ anomaTestM "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) [] (eqNock [nock| 3 |]), - anomaTestM "stdlib add with arg" (add (nockNatLiteral 1) (nockNatLiteral 2)) [nockNatLiteral 1] (eqNock [nock| 3 |]), + <**> [ anomaTestM "stdlib add" (callStdlib StdlibAdd [nockNatLiteral 1, nockNatLiteral 2]) [] (eqNock [nock| 3 |]), + anomaTestM "stdlib add with arg" (callStdlib StdlibAdd [nockNatLiteral 1, nockNatLiteral 2]) [nockNatLiteral 1] (eqNock [nock| 3 |]), let args = [nockNatLiteral 3, nockNatLiteral 1] fx = FunctionCtx @@ -283,20 +283,25 @@ anomaCallingConventionTests = --- 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 |]), + --- test curry with "and" + anomaTestM "(curry and true) false == false" (applyFun <$> curryClosure (OpQuote # nockAndFun) [nockTrueLiteral] (nockNatLiteral 1)) [nockFalseLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and true) true == true" (applyFun <$> curryClosure (OpQuote # nockAndFun) [nockTrueLiteral] (nockNatLiteral 1)) [nockTrueLiteral] (eqNock [nock| true |]), + anomaTestM "(curry and false) true == false" (applyFun <$> curryClosure (OpQuote # nockAndFun) [nockFalseLiteral] (nockNatLiteral 1)) [nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and false) false == false" (applyFun <$> curryClosure (OpQuote # nockAndFun) [nockFalseLiteral] (nockNatLiteral 1)) [nockFalseLiteral] (eqNock [nock| false |]), + --- test curry with "and" in non-empty stack + anomaTestM "((push 0 (curry and)) true) false == false" ((applyFun . (\x -> OpPush # nockNatLiteral 0 # x)) <$> curryClosure (OpQuote # nockAndFun) [nockTrueLiteral] (nockNatLiteral 1)) [nockFalseLiteral] (eqNock [nock| false |]), + anomaTestM "((push 0 (curry and)) true) true == true" ((applyFun . (\x -> OpPush # nockNatLiteral 0 # x)) <$> curryClosure (OpQuote # nockAndFun) [nockTrueLiteral] (nockNatLiteral 1)) [nockTrueLiteral] (eqNock [nock| true |]), + anomaTestM "((push 0 (curry and)) false) true == false" ((applyFun . (\x -> OpPush # nockNatLiteral 0 # x)) <$> curryClosure (OpQuote # nockAndFun) [nockFalseLiteral] (nockNatLiteral 1)) [nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "((push 0 (curry and)) false) false == false" ((applyFun . (\x -> OpPush # nockNatLiteral 0 # x)) <$> curryClosure (OpQuote # nockAndFun) [nockFalseLiteral] (nockNatLiteral 1)) [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 |]) + --- test curry with "and3" + anomaTestM "(curry and3 true) false true == false" (applyFun <$> curryClosure (OpQuote # nockAnd3Fun) [nockTrueLiteral] (nockNatLiteral 2)) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and3 true) true true == true" (applyFun <$> curryClosure (OpQuote # nockAnd3Fun) [nockTrueLiteral] (nockNatLiteral 2)) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]), + anomaTestM "(curry and3 false) true true == false" (applyFun <$> curryClosure (OpQuote # nockAnd3Fun) [nockFalseLiteral] (nockNatLiteral 2)) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and3 false) false true == false" (applyFun <$> curryClosure (OpQuote # nockAnd3Fun) [nockFalseLiteral] (nockNatLiteral 2)) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]) ] serializationTests :: [Test] @@ -363,40 +368,20 @@ nockCall formula args = (OpReplace # ([R, L] # foldTerms args) # (OpQuote # form juvixCallingConventionTests :: [Test] juvixCallingConventionTests = [True, False] - <**> [ compilerTestM "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) (eqNock [nock| 3 |]), - compilerTestM "stdlib dec" (dec (nockNatLiteral 1)) (eqNock [nock| 0 |]), - compilerTestM "stdlib mul" (mul (nockNatLiteral 2) (nockNatLiteral 3)) (eqNock [nock| 6 |]), + <**> [ compilerTestM "stdlib add" (callStdlib StdlibAdd [nockNatLiteral 1, nockNatLiteral 2]) (eqNock [nock| 3 |]), + compilerTestM "stdlib dec" (callStdlib StdlibDec [nockNatLiteral 1]) (eqNock [nock| 0 |]), + compilerTestM "stdlib mul" (callStdlib StdlibMul [nockNatLiteral 2, nockNatLiteral 3]) (eqNock [nock| 6 |]), compilerTestM "stdlib sub" (sub (nockNatLiteral 2) (nockNatLiteral 1)) (eqNock [nock| 1 |]), compilerTestM "stdlib div" (callStdlib StdlibDiv [nockNatLiteral 10, nockNatLiteral 3]) (eqNock [nock| 3 |]), compilerTestM "stdlib mod" (callStdlib StdlibMod [nockNatLiteral 3, nockNatLiteral 2]) (eqNock [nock| 1 |]), compilerTestM "stdlib le" (callStdlib StdlibLe [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| true |]), compilerTestM "stdlib lt" (callStdlib StdlibLt [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| false |]), - compilerTestM "stdlib pow2" (pow2 (nockNatLiteral 3)) (eqNock [nock| 8 |]), - compilerTestM "stdlib nested" (dec =<< (dec (nockNatLiteral 20))) (eqNock [nock| 18 |]), - compilerTestM "append rights - empty" (appendRights emptyPath (nockNatLiteral 3)) (eqNock (toNock [R, R, R])), - compilerTestM "append rights" (appendRights [L, L] (nockNatLiteral 3)) (eqNock (toNock [L, L, R, R, R])), - compilerTest "opAddress" ((OpQuote # (foldTerms (toNock @Natural <$> (5 :| [6, 1])))) >># opAddress' (OpQuote # [R, R])) (eqNock (toNock @Natural 1)), - compilerTest "foldTermsOrNil (empty)" (foldTermsOrNil []) (eqNock (nockNilTagged "expected-result")), + compilerTestM "stdlib pow2" (callStdlib StdlibPow2 [nockNatLiteral 3]) (eqNock [nock| 8 |]), + compilerTestM "stdlib nested" ((\x -> callStdlib StdlibDec [x]) =<< (callStdlib StdlibDec [nockNatLiteral 20])) (eqNock [nock| 18 |]), + compilerTest "foldTermsOrQuotedNil (empty)" (foldTermsOrQuotedNil []) (eqNock (nockNilTagged "expected-result")), let l :: NonEmpty Natural = 1 :| [2] l' :: NonEmpty (Term Natural) = nockNatLiteral <$> l - in compilerTest "foldTermsOrNil (non-empty)" (foldTermsOrNil (toList l')) (eqNock (foldTerms (toNock @Natural <$> l))), - let l :: Term Natural = OpQuote # foldTerms (toNock @Natural <$> (1 :| [2, 3])) - in compilerTest "replaceSubterm'" (replaceSubterm' l (OpQuote # toNock [R]) (OpQuote # (toNock @Natural 999))) (eqNock (toNock @Natural 1 # toNock @Natural 999)), - let lst :: [Term Natural] = toNock @Natural <$> [1, 2, 3] - len = nockIntegralLiteral (length lst) - l :: Term Natural = OpQuote # makeList lst - in compilerTestM "append" (append l len l) (eqNock (makeList (lst ++ lst))), - let l :: [Natural] = [1, 2] - r :: NonEmpty Natural = 3 :| [4] - res :: Term Natural = foldTerms (toNock <$> prependList l r) - lenL :: Term Natural = nockIntegralLiteral (length l) - lstL = OpQuote # makeList (map toNock l) - tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTestM "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR) (eqNock res), - let r :: NonEmpty Natural = 3 :| [4] - res :: Term Natural = foldTerms (toNock <$> r) - tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTestM "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR) (eqNock res), + in compilerTest "foldTermsOrQuotedNil (non-empty)" (foldTermsOrQuotedNil (toList l')) (eqNock (foldTerms (toNock @Natural <$> l))), compilerTestM "stdlib cat" (callStdlib StdlibCatBytes [nockNatLiteral 2, nockNatLiteral 1]) (eqNock [nock| 258 |]), compilerTestM "fold bytes empty" (callStdlib StdlibFoldBytes [OpQuote # makeList []]) (eqNock [nock| 0 |]), compilerTestM "fold bytes [1, 0, 0] == 1" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [1, 0, 0])]) (eqNock [nock| 1 |]),