mirror of
https://github.com/anoma/juvix.git
synced 2024-09-11 16:26:33 +03:00
Fast nockma eval (#2580)
Adds annotations to cells to indicate that it is a call to the stdlib and might be evaluated faster in the Haskell evaluator. The syntax for stdlib calls is as follows: ``` [stdlib@add args@<args-term> <left-term> <right-term>] ``` where `add` is the name of the function being called, `<args-term>` is a nockma term that points to the position of the arguments, and `<left-term>` and `<right-term>` are the actual components of the cell.
This commit is contained in:
parent
91ba586336
commit
39d176e643
10
.github/workflows/ci.yml
vendored
10
.github/workflows/ci.yml
vendored
@ -45,9 +45,13 @@ jobs:
|
||||
with:
|
||||
version: 0.5.3.0
|
||||
extra-args: >-
|
||||
--ghc-opt -XDerivingStrategies --ghc-opt -XImportQualifiedPost
|
||||
--ghc-opt -XMultiParamTypeClasses --ghc-opt -XStandaloneDeriving
|
||||
--ghc-opt -XTemplateHaskell --ghc-opt -XUnicodeSyntax
|
||||
--ghc-opt -XDerivingStrategies
|
||||
--ghc-opt -XImportQualifiedPost
|
||||
--ghc-opt -XMultiParamTypeClasses
|
||||
--ghc-opt -XPatternSynonyms
|
||||
--ghc-opt -XStandaloneDeriving
|
||||
--ghc-opt -XTemplateHaskell
|
||||
--ghc-opt -XUnicodeSyntax
|
||||
|
||||
build-and-test-linux:
|
||||
runs-on: ubuntu-22.04
|
||||
|
1
Makefile
1
Makefile
@ -93,6 +93,7 @@ ormolu:
|
||||
--ghc-opt -XStandaloneDeriving \
|
||||
--ghc-opt -XUnicodeSyntax \
|
||||
--ghc-opt -XDerivingStrategies \
|
||||
--ghc-opt -XPatternSynonyms \
|
||||
--ghc-opt -XMultiParamTypeClasses \
|
||||
--ghc-opt -XTemplateHaskell \
|
||||
--ghc-opt -XImportQualifiedPost \
|
||||
|
@ -2,6 +2,7 @@ module Commands.Dev.Nockma.Eval where
|
||||
|
||||
import Commands.Base hiding (Atom)
|
||||
import Commands.Dev.Nockma.Eval.Options
|
||||
import Juvix.Compiler.Nockma.Evaluator.Options
|
||||
import Juvix.Compiler.Nockma.Pretty
|
||||
import Juvix.Compiler.Nockma.Translation.FromAsm
|
||||
import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
|
||||
@ -13,7 +14,10 @@ runCommand opts = do
|
||||
case parsedTerm of
|
||||
Left err -> exitJuvixError (JuvixError err)
|
||||
Right (TermCell c) -> do
|
||||
res <- runOutputSem @(Term Natural) (say . ppTrace) (evalCompiledNock' (c ^. cellLeft) (c ^. cellRight))
|
||||
res <-
|
||||
runReader defaultEvalOptions
|
||||
. runOutputSem @(Term Natural) (say . ppTrace)
|
||||
$ evalCompiledNock' (c ^. cellLeft) (c ^. cellRight)
|
||||
ret <- getReturn res
|
||||
putStrLn (ppPrint ret)
|
||||
Right TermAtom {} -> exitFailMsg "Expected nockma input to be a cell"
|
||||
|
@ -8,6 +8,7 @@ import Control.Exception (throwIO)
|
||||
import Control.Monad.State.Strict qualified as State
|
||||
import Data.String.Interpolate (__i)
|
||||
import Juvix.Compiler.Nockma.Evaluator (NockEvalError, evalRepl, fromReplTerm, programAssignments)
|
||||
import Juvix.Compiler.Nockma.Evaluator.Options
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Compiler.Nockma.Pretty (ppPrint)
|
||||
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
|
||||
@ -133,9 +134,10 @@ evalStatement = \case
|
||||
prog <- getProgram
|
||||
et <-
|
||||
liftIO
|
||||
$ runM
|
||||
. runError @(ErrNockNatural Natural)
|
||||
. runError @NockEvalError
|
||||
. runM
|
||||
. runReader defaultEvalOptions
|
||||
. runError @(ErrNockNatural Natural)
|
||||
. runError @NockEvalError
|
||||
$ evalRepl (putStrLn . Nockma.ppTrace) prog s t
|
||||
case et of
|
||||
Left e -> error (show e)
|
||||
|
@ -143,6 +143,7 @@ default-extensions:
|
||||
- NoFieldSelectors
|
||||
- NoImplicitPrelude
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- QuasiQuotes
|
||||
- RecordWildCards
|
||||
- TemplateHaskell
|
||||
|
@ -1,10 +1,12 @@
|
||||
module Juvix.Compiler.Nockma.Evaluator
|
||||
( module Juvix.Compiler.Nockma.Evaluator,
|
||||
module Juvix.Compiler.Nockma.Evaluator.Error,
|
||||
module Juvix.Compiler.Nockma.Evaluator.Options,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Compiler.Nockma.Evaluator.Error
|
||||
import Juvix.Compiler.Nockma.Evaluator.Options
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Compiler.Nockma.Pretty
|
||||
import Juvix.Prelude hiding (Atom, Path)
|
||||
@ -45,7 +47,7 @@ subTermT = go
|
||||
subTerm :: (Member (Error NockEvalError) r) => Term a -> Path -> Sem r (Term a)
|
||||
subTerm term pos = do
|
||||
case term ^? subTermT pos of
|
||||
Nothing -> throw @NockEvalError (error "")
|
||||
Nothing -> throw (InvalidPath "subterm")
|
||||
Just t -> return t
|
||||
|
||||
setSubTerm :: (Member (Error NockEvalError) r) => Term a -> Path -> Term a -> Sem r (Term a)
|
||||
@ -55,11 +57,25 @@ setSubTerm term pos repTerm =
|
||||
| isNothing (getFirst old) -> throw @NockEvalError (error "")
|
||||
| otherwise -> return new
|
||||
|
||||
parseCell :: forall r a. (Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Cell a -> Sem r (ParsedCell a)
|
||||
parseCell ::
|
||||
forall r a.
|
||||
(Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
|
||||
Cell a ->
|
||||
Sem r (ParsedCell a)
|
||||
parseCell c = case c ^. cellLeft of
|
||||
TermAtom a -> ParsedOperatorCell <$> parseOperatorCell a (c ^. cellRight)
|
||||
TermAtom a -> operatorOrStdlibCall a (c ^. cellRight) (c ^. cellInfo . unIrrelevant)
|
||||
TermCell l -> return (ParsedAutoConsCell (AutoConsCell l (c ^. cellRight)))
|
||||
where
|
||||
operatorOrStdlibCall :: Atom a -> Term a -> Maybe (StdlibCall a) -> Sem r (ParsedCell a)
|
||||
operatorOrStdlibCall a t mcall = do
|
||||
opCell <- parseOperatorCell a t
|
||||
return $ case mcall of
|
||||
Nothing -> ParsedOperatorCell opCell
|
||||
Just call -> ParsedStdlibCallCell (parseStdlibCall opCell call)
|
||||
|
||||
parseStdlibCall :: OperatorCell a -> StdlibCall a -> StdlibCallCell a
|
||||
parseStdlibCall op call = StdlibCallCell call op
|
||||
|
||||
parseOperatorCell :: Atom a -> Term a -> Sem r (OperatorCell a)
|
||||
parseOperatorCell a t = do
|
||||
op <- nockOp a
|
||||
@ -84,7 +100,7 @@ programAssignments mprog =
|
||||
-- | The stack provided in the replExpression has priority
|
||||
evalRepl ::
|
||||
forall r a.
|
||||
(PrettyCode a, Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
|
||||
(PrettyCode a, Integral a, Members '[Reader EvalOptions, Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
|
||||
(Term a -> Sem r ()) ->
|
||||
Maybe (Program a) ->
|
||||
Maybe (Term a) ->
|
||||
@ -105,20 +121,57 @@ evalRepl handleTrace mprog defaultStack expr = do
|
||||
namedTerms :: HashMap Text (Term a)
|
||||
namedTerms = programAssignments mprog
|
||||
|
||||
eval :: forall r a. (PrettyCode a, Members '[Output (Term a), Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Term a -> Term a -> Sem r (Term a)
|
||||
eval ::
|
||||
forall r a.
|
||||
(PrettyCode a, Integral a, Members '[Reader EvalOptions, Output (Term a), Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
|
||||
Term a ->
|
||||
Term a ->
|
||||
Sem r (Term a)
|
||||
eval stack = \case
|
||||
TermAtom a -> throw (ExpectedCell ("eval " <> ppTrace a))
|
||||
TermCell c -> do
|
||||
pc <- parseCell c
|
||||
case pc of
|
||||
TermCell c ->
|
||||
parseCell c >>= \case
|
||||
ParsedAutoConsCell a -> goAutoConsCell a
|
||||
ParsedOperatorCell o -> goOperatorCell o
|
||||
ParsedStdlibCallCell o -> do
|
||||
ignore <- asks (^. evalIgnoreStdlibCalls)
|
||||
if
|
||||
| ignore -> goOperatorCell (o ^. stdlibCallRaw)
|
||||
| otherwise -> goStdlibCall (o ^. stdlibCallCell)
|
||||
where
|
||||
goStdlibCall :: StdlibCall a -> Sem r (Term a)
|
||||
goStdlibCall StdlibCall {..} = do
|
||||
args' <- eval stack _stdlibCallArgs
|
||||
let binArith :: (a -> a -> a) -> Sem r (Term a)
|
||||
binArith f = case args' of
|
||||
TCell (TAtom l) (TAtom r) -> return (TCell (TAtom (f l r)) stack)
|
||||
_ -> error "expected a cell with two atoms"
|
||||
|
||||
unaArith :: (a -> a) -> Sem r (Term a)
|
||||
unaArith f = case args' of
|
||||
TAtom n -> return (TCell (TAtom (f n)) stack)
|
||||
_ -> error "expected an atom"
|
||||
|
||||
binCmp :: (a -> a -> Bool) -> Sem r (Term a)
|
||||
binCmp f = case args' of
|
||||
TCell (TAtom l) (TAtom r) -> return (TCell (TermAtom (nockBool (f l r))) stack)
|
||||
_ -> error "expected a cell with two atoms"
|
||||
|
||||
case _stdlibCallFunction of
|
||||
StdlibDec -> unaArith pred
|
||||
StdlibAdd -> binArith (+)
|
||||
StdlibMul -> binArith (*)
|
||||
StdlibSub -> binArith (-)
|
||||
StdlibDiv -> binArith div
|
||||
StdlibMod -> binArith mod
|
||||
StdlibLt -> binCmp (<)
|
||||
StdlibLe -> binCmp (<=)
|
||||
|
||||
goAutoConsCell :: AutoConsCell a -> Sem r (Term a)
|
||||
goAutoConsCell c = do
|
||||
_cellLeft <- eval stack (TermCell (c ^. autoConsCellLeft))
|
||||
_cellRight <- eval stack (c ^. autoConsCellRight)
|
||||
return (TermCell Cell {..})
|
||||
l' <- eval stack (TermCell (c ^. autoConsCellLeft))
|
||||
r' <- eval stack (c ^. autoConsCellRight)
|
||||
return (TermCell (Cell l' r'))
|
||||
|
||||
goOperatorCell :: OperatorCell a -> Sem r (Term a)
|
||||
goOperatorCell c = case c ^. operatorCellOp of
|
||||
@ -149,7 +202,7 @@ eval stack = \case
|
||||
|
||||
goOpTrace :: Sem r (Term a)
|
||||
goOpTrace = do
|
||||
Cell tr a <- asCell "OpTrace" (c ^. operatorCellTerm)
|
||||
Cell' tr a _ <- asCell "OpTrace" (c ^. operatorCellTerm)
|
||||
tr' <- eval stack tr
|
||||
output tr'
|
||||
eval stack a
|
||||
@ -164,13 +217,13 @@ eval stack = \case
|
||||
goOpPush = do
|
||||
cellTerm <- asCell "OpPush" (c ^. operatorCellTerm)
|
||||
l <- eval stack (cellTerm ^. cellLeft)
|
||||
let s = TermCell Cell {_cellLeft = l, _cellRight = stack}
|
||||
let s = TermCell (Cell l stack)
|
||||
eval s (cellTerm ^. cellRight)
|
||||
|
||||
goOpReplace :: Sem r (Term a)
|
||||
goOpReplace = do
|
||||
Cell rot1 t2 <- asCell "OpReplace 1" (c ^. operatorCellTerm)
|
||||
Cell ro t1 <- asCell "OpReplace 2" rot1
|
||||
Cell' rot1 t2 _ <- asCell "OpReplace 1" (c ^. operatorCellTerm)
|
||||
Cell' ro t1 _ <- asCell "OpReplace 2" rot1
|
||||
r <- asPath ro
|
||||
t1' <- eval stack t1
|
||||
t2' <- eval stack t2
|
||||
@ -187,7 +240,7 @@ eval stack = \case
|
||||
goOpIf = do
|
||||
cellTerm <- asCell "OpIf 1" (c ^. operatorCellTerm)
|
||||
let t0 = cellTerm ^. cellLeft
|
||||
Cell t1 t2 <- asCell "OpIf 2" (cellTerm ^. cellRight)
|
||||
Cell' t1 t2 _ <- asCell "OpIf 2" (cellTerm ^. cellRight)
|
||||
cond <- eval stack t0 >>= asBool
|
||||
if
|
||||
| cond -> eval stack t1
|
||||
|
12
src/Juvix/Compiler/Nockma/Evaluator/Options.hs
Normal file
12
src/Juvix/Compiler/Nockma/Evaluator/Options.hs
Normal file
@ -0,0 +1,12 @@
|
||||
module Juvix.Compiler.Nockma.Evaluator.Options where
|
||||
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
newtype EvalOptions = EvalOptions
|
||||
{ _evalIgnoreStdlibCalls :: Bool
|
||||
}
|
||||
|
||||
defaultEvalOptions :: EvalOptions
|
||||
defaultEvalOptions = EvalOptions False
|
||||
|
||||
makeLenses ''EvalOptions
|
@ -45,9 +45,17 @@ data Term a
|
||||
| TermCell (Cell a)
|
||||
deriving stock (Show, Eq, Lift)
|
||||
|
||||
data Cell a = Cell
|
||||
data StdlibCall a = StdlibCall
|
||||
{ _stdlibCallFunction :: StdlibFunction,
|
||||
_stdlibCallArgs :: Term a
|
||||
}
|
||||
|
||||
deriving stock instance (Lift a) => Lift (StdlibCall a)
|
||||
|
||||
data Cell a = Cell'
|
||||
{ _cellLeft :: Term a,
|
||||
_cellRight :: Term a
|
||||
_cellRight :: Term a,
|
||||
_cellInfo :: Irrelevant (Maybe (StdlibCall a))
|
||||
}
|
||||
deriving stock (Show, Eq, Lift)
|
||||
|
||||
@ -98,9 +106,45 @@ instance Pretty NockOp where
|
||||
OpHint -> "hint"
|
||||
OpTrace -> "trace"
|
||||
|
||||
instance Pretty StdlibFunction where
|
||||
pretty = \case
|
||||
StdlibDec -> "dec"
|
||||
StdlibAdd -> "add"
|
||||
StdlibSub -> "sub"
|
||||
StdlibMul -> "mul"
|
||||
StdlibDiv -> "div"
|
||||
StdlibMod -> "mod"
|
||||
StdlibLt -> "<"
|
||||
StdlibLe -> "<="
|
||||
|
||||
data StdlibFunction
|
||||
= StdlibDec
|
||||
| StdlibAdd
|
||||
| StdlibSub
|
||||
| StdlibMul
|
||||
| StdlibDiv
|
||||
| StdlibMod
|
||||
| StdlibLt
|
||||
| StdlibLe
|
||||
deriving stock (Show, Lift, Eq, Bounded, Enum)
|
||||
|
||||
textToStdlibFunctionMap :: HashMap Text StdlibFunction
|
||||
textToStdlibFunctionMap =
|
||||
hashMap
|
||||
[ (prettyText f, f) | f <- allElements
|
||||
]
|
||||
|
||||
parseStdlibFunction :: Text -> Maybe StdlibFunction
|
||||
parseStdlibFunction t = textToStdlibFunctionMap ^. at t
|
||||
|
||||
atomOps :: HashMap Text NockOp
|
||||
atomOps = HashMap.fromList [(prettyText op, op) | op <- allElements]
|
||||
|
||||
data StdlibCallCell a = StdlibCallCell
|
||||
{ _stdlibCallCell :: StdlibCall a,
|
||||
_stdlibCallRaw :: OperatorCell a
|
||||
}
|
||||
|
||||
data OperatorCell a = OperatorCell
|
||||
{ _operatorCellOp :: NockOp,
|
||||
_operatorCellTerm :: Term a
|
||||
@ -114,6 +158,7 @@ data AutoConsCell a = AutoConsCell
|
||||
data ParsedCell a
|
||||
= ParsedOperatorCell (OperatorCell a)
|
||||
| ParsedAutoConsCell (AutoConsCell a)
|
||||
| ParsedStdlibCallCell (StdlibCallCell a)
|
||||
|
||||
newtype EncodedPath = EncodedPath
|
||||
{ _encodedPath :: Natural
|
||||
@ -138,6 +183,8 @@ emptyPath :: Path
|
||||
emptyPath = []
|
||||
|
||||
makeLenses ''Cell
|
||||
makeLenses ''StdlibCallCell
|
||||
makeLenses ''StdlibCall
|
||||
makeLenses ''Atom
|
||||
makeLenses ''OperatorCell
|
||||
makeLenses ''AutoConsCell
|
||||
@ -223,6 +270,11 @@ class (Eq a) => NockNatural a where
|
||||
nockSucc :: Atom a -> Atom a
|
||||
nockNil :: Atom a
|
||||
|
||||
nockBool :: (NockNatural a) => Bool -> Atom a
|
||||
nockBool = \case
|
||||
True -> nockTrue
|
||||
False -> nockFalse
|
||||
|
||||
data NockNaturalNaturalError
|
||||
= NaturalInvalidPath (Atom Natural)
|
||||
| NaturalInvalidOp (Atom Natural)
|
||||
@ -264,7 +316,7 @@ instance IsNock (Cell Natural) where
|
||||
toNock = TermCell
|
||||
|
||||
instance IsNock Natural where
|
||||
toNock n = toNock (Atom n (Irrelevant Nothing))
|
||||
toNock n = TermAtom (Atom n (Irrelevant Nothing))
|
||||
|
||||
instance IsNock NockOp where
|
||||
toNock op = toNock (Atom (serializeOp op) (Irrelevant (Just AtomHintOp)))
|
||||
@ -280,13 +332,58 @@ instance IsNock Path where
|
||||
instance IsNock EncodedPath where
|
||||
toNock = toNock . decodePath'
|
||||
|
||||
infixr 5 #
|
||||
|
||||
(#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
|
||||
a # b = TermCell (Cell (toNock a) (toNock b))
|
||||
|
||||
instance Semigroup EncodedPath where
|
||||
a <> b = encodePath (decodePath' a <> decodePath' b)
|
||||
|
||||
instance Monoid EncodedPath where
|
||||
mempty = encodePath []
|
||||
|
||||
infixr 5 #.
|
||||
|
||||
(#.) :: (IsNock x, IsNock y) => x -> y -> Cell Natural
|
||||
a #. b = Cell (toNock a) (toNock b)
|
||||
|
||||
infixr 5 #
|
||||
|
||||
(#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
|
||||
a # b = TermCell (a #. b)
|
||||
|
||||
infixl 1 >>#.
|
||||
|
||||
(>>#.) :: (IsNock x, IsNock y) => x -> y -> Cell Natural
|
||||
a >>#. b = OpSequence #. a # b
|
||||
|
||||
infixl 1 >>#
|
||||
|
||||
(>>#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
|
||||
a >># b = TermCell (a >>#. b)
|
||||
|
||||
stdlibNumArgs :: StdlibFunction -> Natural
|
||||
stdlibNumArgs = \case
|
||||
StdlibDec -> 1
|
||||
StdlibAdd -> 2
|
||||
StdlibSub -> 2
|
||||
StdlibMul -> 2
|
||||
StdlibMod -> 2
|
||||
StdlibDiv -> 2
|
||||
StdlibLe -> 2
|
||||
StdlibLt -> 2
|
||||
|
||||
{-# COMPLETE Cell #-}
|
||||
|
||||
pattern Cell :: Term a -> Term a -> Cell a
|
||||
pattern Cell {_cellLeft', _cellRight'} <- Cell' _cellLeft' _cellRight' _
|
||||
where
|
||||
Cell a b = Cell' a b (Irrelevant Nothing)
|
||||
|
||||
{-# COMPLETE TCell, TAtom #-}
|
||||
|
||||
pattern TCell :: Term a -> Term a -> Term a
|
||||
pattern TCell l r <- TermCell (Cell' l r _)
|
||||
where
|
||||
TCell a b = TermCell (Cell' a b (Irrelevant Nothing))
|
||||
|
||||
pattern TAtom :: a -> Term a
|
||||
pattern TAtom a <- TermAtom (Atom a _)
|
||||
where
|
||||
TAtom a = TermAtom (Atom a (Irrelevant Nothing))
|
||||
|
@ -8,6 +8,7 @@ where
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Compiler.Nockma.Pretty.Options
|
||||
import Juvix.Data.CodeAnn
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
import Juvix.Prelude hiding (Atom, Path)
|
||||
|
||||
doc :: (PrettyCode c) => Options -> c -> Doc Ann
|
||||
@ -55,15 +56,28 @@ instance PrettyCode NockOp where
|
||||
ppCode =
|
||||
return . annotate (AnnKind KNameFunction) . pretty
|
||||
|
||||
instance PrettyCode StdlibFunction where
|
||||
ppCode = return . pretty
|
||||
|
||||
instance (PrettyCode a, NockNatural a) => PrettyCode (StdlibCall a) where
|
||||
ppCode c = do
|
||||
fun <- ppCode (c ^. stdlibCallFunction)
|
||||
args <- ppCode (c ^. stdlibCallArgs)
|
||||
return (Str.stdlibTag <> fun <+> Str.argsTag <> args)
|
||||
|
||||
instance (PrettyCode a, NockNatural a) => PrettyCode (Cell a) where
|
||||
ppCode c = do
|
||||
m <- asks (^. optPrettyMode)
|
||||
inside <- case m of
|
||||
stdlibCall <- runFail $ do
|
||||
failWhenM (asks (^. optIgnoreHints))
|
||||
failMaybe (c ^. cellInfo . unIrrelevant) >>= ppCode
|
||||
components <- case m of
|
||||
AllDelimiters -> do
|
||||
l' <- ppCode (c ^. cellLeft)
|
||||
r' <- ppCode (c ^. cellRight)
|
||||
return (l' <+> r')
|
||||
MinimizeDelimiters -> sep <$> mapM ppCode (unfoldCell c)
|
||||
let inside = stdlibCall <?+> components
|
||||
return (oneLineOrNextBrackets inside)
|
||||
|
||||
unfoldCell :: Cell a -> NonEmpty (Term a)
|
||||
|
@ -112,27 +112,6 @@ functionPath = \case
|
||||
FunctionCode -> [L]
|
||||
FunctionArgs -> [R]
|
||||
|
||||
data StdlibFunction
|
||||
= StdlibDec
|
||||
| StdlibAdd
|
||||
| StdlibSub
|
||||
| StdlibMul
|
||||
| StdlibDiv
|
||||
| StdlibMod
|
||||
| StdlibLt
|
||||
| StdlibLe
|
||||
|
||||
stdlibNumArgs :: StdlibFunction -> Natural
|
||||
stdlibNumArgs = \case
|
||||
StdlibDec -> 1
|
||||
StdlibAdd -> 2
|
||||
StdlibSub -> 2
|
||||
StdlibMul -> 2
|
||||
StdlibMod -> 2
|
||||
StdlibDiv -> 2
|
||||
StdlibLe -> 2
|
||||
StdlibLt -> 2
|
||||
|
||||
-- | The stdlib paths are obtained using scripts/nockma-stdlib-parser.sh
|
||||
stdlibPath :: StdlibFunction -> Path
|
||||
stdlibPath =
|
||||
@ -490,10 +469,7 @@ sub a b aux = do
|
||||
moveTopFromTo AuxStack ValueStack
|
||||
|
||||
seqTerms :: [Term Natural] -> Term Natural
|
||||
seqTerms = foldl' step (OpAddress # emptyPath) . reverse
|
||||
where
|
||||
step :: Term Natural -> Term Natural -> Term Natural
|
||||
step acc t = OpSequence # t # acc
|
||||
seqTerms = foldl' (flip (>>#)) (OpAddress # emptyPath) . reverse
|
||||
|
||||
makeEmptyList :: Term Natural
|
||||
makeEmptyList = makeList []
|
||||
@ -785,11 +761,19 @@ callStdlibOn' s f = do
|
||||
let fNumArgs = stdlibNumArgs f
|
||||
fPath = stdlibPath f
|
||||
decodeFn = OpCall # (fPath # (OpAddress # stackPath StandardLibrary))
|
||||
arguments = OpSequence # (OpAddress # [R]) # stdlibStackTake s fNumArgs
|
||||
preargs = stdlibStackTake s fNumArgs
|
||||
arguments = OpSequence # (OpAddress # [R]) # preargs
|
||||
extractResult = (OpAddress # [L]) # (OpAddress # [R, R])
|
||||
callFn = OpPush # (OpCall # [L] # (OpReplace # ([R, L] # arguments) # (OpAddress # [L]))) # extractResult
|
||||
meta =
|
||||
StdlibCall
|
||||
{ _stdlibCallArgs = preargs,
|
||||
_stdlibCallFunction = f
|
||||
}
|
||||
|
||||
output (OpPush # decodeFn # callFn)
|
||||
callCell = (OpPush #. (decodeFn # callFn)) {_cellInfo = Irrelevant (Just meta)}
|
||||
|
||||
output (toNock callCell)
|
||||
output (replaceTopStackN fNumArgs s)
|
||||
where
|
||||
stdlibStackTake :: StackId -> Natural -> Term Natural
|
||||
@ -1021,18 +1005,12 @@ pushNat = pushNatOnto ValueStack
|
||||
pushNatOnto :: (Member Compiler r) => StackId -> Natural -> Sem r ()
|
||||
pushNatOnto s n = pushOnto s (OpQuote # toNock n)
|
||||
|
||||
compileAndRunNock :: CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Term Natural
|
||||
compileAndRunNock opts constrs funs = run . ignoreOutput @(Term Natural) . compileAndRunNock' opts constrs funs
|
||||
|
||||
compileAndRunNock' :: (Member (Output (Term Natural)) r) => CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Sem r (Term Natural)
|
||||
compileAndRunNock' :: (Members '[Reader EvalOptions, Output (Term Natural)] r) => CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Sem r (Term Natural)
|
||||
compileAndRunNock' opts constrs funs mainfun =
|
||||
let Cell nockSubject t = runCompilerWith opts constrs funs mainfun
|
||||
in evalCompiledNock' nockSubject t
|
||||
|
||||
evalCompiledNock :: Term Natural -> Term Natural -> Term Natural
|
||||
evalCompiledNock stack = run . ignoreOutput @(Term Natural) . evalCompiledNock' stack
|
||||
|
||||
evalCompiledNock' :: (Member (Output (Term Natural)) r) => Term Natural -> Term Natural -> Sem r (Term Natural)
|
||||
evalCompiledNock' :: (Members '[Reader EvalOptions, Output (Term Natural)] r) => Term Natural -> Term Natural -> Sem r (Term Natural)
|
||||
evalCompiledNock' stack mainTerm = do
|
||||
evalT <-
|
||||
runError @(ErrNockNatural Natural)
|
||||
|
@ -4,6 +4,7 @@ import Data.HashMap.Internal.Strict qualified as HashMap
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Text qualified as Text
|
||||
import Juvix.Compiler.Nockma.Language qualified as N
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
import Juvix.Parser.Error
|
||||
import Juvix.Prelude hiding (Atom, many, some)
|
||||
import Juvix.Prelude.Parsing hiding (runParser)
|
||||
@ -43,7 +44,9 @@ runParser :: FilePath -> Text -> Either MegaparsecError (N.Term Natural)
|
||||
runParser = runParserFor term
|
||||
|
||||
spaceConsumer :: Parser ()
|
||||
spaceConsumer = L.space space1 empty empty
|
||||
spaceConsumer = L.space space1 lineComment empty
|
||||
where
|
||||
lineComment :: Parser () = L.skipLineComment "--"
|
||||
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme = L.lexeme spaceConsumer
|
||||
@ -102,14 +105,37 @@ patom =
|
||||
<|> atomBool
|
||||
<|> atomNil
|
||||
|
||||
iden :: Parser Text
|
||||
iden = lexeme (takeWhile1P (Just "<iden>") isAlphaNum)
|
||||
|
||||
cell :: Parser (N.Cell Natural)
|
||||
cell = do
|
||||
lsbracket
|
||||
c <- optional stdlibCall
|
||||
firstTerm <- term
|
||||
restTerms <- some term
|
||||
rsbracket
|
||||
return (buildCell firstTerm restTerms)
|
||||
let r = buildCell firstTerm restTerms
|
||||
return (set N.cellInfo (Irrelevant c) r)
|
||||
where
|
||||
stdlibCall :: Parser (N.StdlibCall Natural)
|
||||
stdlibCall = do
|
||||
chunk Str.stdlibTag
|
||||
f <- stdlibFun
|
||||
chunk Str.argsTag
|
||||
args <- term
|
||||
return
|
||||
N.StdlibCall
|
||||
{ _stdlibCallArgs = args,
|
||||
_stdlibCallFunction = f
|
||||
}
|
||||
|
||||
stdlibFun :: Parser N.StdlibFunction
|
||||
stdlibFun = do
|
||||
i <- iden
|
||||
let err = error ("invalid stdlib function identifier: " <> i)
|
||||
maybe err return (N.parseStdlibFunction i)
|
||||
|
||||
buildCell :: N.Term Natural -> NonEmpty (N.Term Natural) -> N.Cell Natural
|
||||
buildCell h = \case
|
||||
x :| [] -> N.Cell h x
|
||||
|
@ -45,6 +45,10 @@ failWhen :: (Member Fail r) => Bool -> Sem r ()
|
||||
failWhen c = when c fail
|
||||
{-# INLINE failWhen #-}
|
||||
|
||||
failWhenM :: (Member Fail r) => Sem r Bool -> Sem r ()
|
||||
failWhenM c = whenM c fail
|
||||
{-# INLINE failWhenM #-}
|
||||
|
||||
failUnlessM :: (Member Fail r) => Sem r Bool -> Sem r ()
|
||||
failUnlessM c = unlessM c fail
|
||||
{-# INLINE failUnlessM #-}
|
||||
|
@ -581,6 +581,12 @@ tmp = "tmp"
|
||||
instrAdd :: (IsString s) => s
|
||||
instrAdd = "add"
|
||||
|
||||
argsTag :: (IsString s) => s
|
||||
argsTag = "args@"
|
||||
|
||||
stdlibTag :: (IsString s) => s
|
||||
stdlibTag = "stdlib@"
|
||||
|
||||
instrSub :: (IsString s) => s
|
||||
instrSub = "sub"
|
||||
|
||||
|
@ -5,6 +5,7 @@ import Asm.Run.Positive qualified as Asm
|
||||
import Base
|
||||
import Juvix.Compiler.Asm
|
||||
import Juvix.Compiler.Asm.Options qualified as Asm
|
||||
import Juvix.Compiler.Nockma.Evaluator qualified as NockmaEval
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
|
||||
import Juvix.Compiler.Nockma.Translation.FromAsm
|
||||
@ -14,13 +15,19 @@ runNockmaAssertion :: Handle -> Symbol -> InfoTable -> IO ()
|
||||
runNockmaAssertion hout _main tab = do
|
||||
Nockma.Cell nockSubject nockMain <-
|
||||
runM
|
||||
( runReader
|
||||
(Asm.makeOptions TargetNockma True)
|
||||
$ runReader
|
||||
(Nockma.CompilerOptions {_compilerOptionsEnableTrace = True})
|
||||
(runErrorIO' @JuvixError (asmToNockma' tab))
|
||||
)
|
||||
res <- runM $ runOutputSem @(Term Natural) (embed . hPutStrLn hout . Nockma.ppPrint) (evalCompiledNock' nockSubject nockMain)
|
||||
. runReader
|
||||
(Asm.makeOptions TargetNockma True)
|
||||
. runReader
|
||||
(Nockma.CompilerOptions {_compilerOptionsEnableTrace = True})
|
||||
. runErrorIO' @JuvixError
|
||||
$ asmToNockma' tab
|
||||
res <-
|
||||
runM
|
||||
. runOutputSem @(Term Natural)
|
||||
(embed . hPutStrLn hout . Nockma.ppPrint)
|
||||
. runReader NockmaEval.defaultEvalOptions
|
||||
. evalCompiledNock' nockSubject
|
||||
$ nockMain
|
||||
let ret = getReturn res
|
||||
hPutStrLn hout (Nockma.ppPrint ret)
|
||||
where
|
||||
|
@ -16,6 +16,7 @@ type Check = Sem '[Reader [Term Natural], Reader (Term Natural), Embed IO]
|
||||
data Test = Test
|
||||
{ _testName :: Text,
|
||||
_testCheck :: Check (),
|
||||
_testEvalOptions :: EvalOptions,
|
||||
_testProgram :: Sem '[Compiler] ()
|
||||
}
|
||||
|
||||
@ -33,8 +34,12 @@ data FunctionName
|
||||
sym :: (Enum a) => a -> FunctionId
|
||||
sym = UserFunction . Asm.defaultSymbol . fromIntegral . fromEnum
|
||||
|
||||
debugProg :: Sem '[Compiler] () -> ([Term Natural], Term Natural)
|
||||
debugProg mkMain = run . runOutputList $ compileAndRunNock' opts exampleConstructors exampleFunctions mainFun
|
||||
debugProg :: EvalOptions -> Sem '[Compiler] () -> ([Term Natural], Term Natural)
|
||||
debugProg evalOpts mkMain =
|
||||
run
|
||||
. runReader evalOpts
|
||||
. runOutputList
|
||||
$ compileAndRunNock' opts exampleConstructors exampleFunctions mainFun
|
||||
where
|
||||
mainFun =
|
||||
CompilerFunction
|
||||
@ -122,7 +127,7 @@ allTests = testGroup "Nockma compile unit positive" (map mk tests)
|
||||
where
|
||||
mk :: Test -> TestTree
|
||||
mk Test {..} = testCase (unpack _testName) $ do
|
||||
let (traces, n) = debugProg _testProgram
|
||||
let (traces, n) = debugProg _testEvalOptions _testProgram
|
||||
runM (runReader n (runReader traces _testCheck))
|
||||
|
||||
eqSubStack :: StackId -> Path -> Term Natural -> Check ()
|
||||
@ -167,7 +172,7 @@ eqStack st = eqSubStack st []
|
||||
unfoldTerm :: Term Natural -> NonEmpty (Term Natural)
|
||||
unfoldTerm t = case t of
|
||||
TermAtom {} -> t :| []
|
||||
TermCell Cell {..} -> _cellLeft NonEmpty.<| unfoldTerm _cellRight
|
||||
TermCell (Cell l r) -> l NonEmpty.<| unfoldTerm r
|
||||
|
||||
checkStackSize :: StackId -> Natural -> Check ()
|
||||
checkStackSize st stSize = subStackPred st ([] :: Path) $ \s -> do
|
||||
@ -186,49 +191,94 @@ checkStackSize st stSize = subStackPred st ([] :: Path) $ \s -> do
|
||||
<> show n
|
||||
assertFailure (unpack msg)
|
||||
|
||||
defTest :: Text -> Check () -> Sem '[Compiler] () -> Test
|
||||
defTest _testName _testCheck _testProgram =
|
||||
Test
|
||||
{ _testEvalOptions = defaultEvalOptions,
|
||||
..
|
||||
}
|
||||
|
||||
defTestNoJets :: Text -> Check () -> Sem '[Compiler] () -> Test
|
||||
defTestNoJets _testName _testCheck _testProgram =
|
||||
Test
|
||||
{ _testEvalOptions =
|
||||
EvalOptions
|
||||
{ _evalIgnoreStdlibCalls = True
|
||||
},
|
||||
..
|
||||
}
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ Test "push" (eqStack ValueStack [nock| [1 5 nil] |]) $ do
|
||||
[ defTest "push" (eqStack ValueStack [nock| [1 5 nil] |]) $ do
|
||||
pushNat 5
|
||||
pushNat 1,
|
||||
Test "pop" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
defTest "pop" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
pushNat 1
|
||||
pushNat 33
|
||||
pop,
|
||||
Test "increment" (eqStack ValueStack [nock| [3 nil] |]) $ do
|
||||
defTest "increment" (eqStack ValueStack [nock| [3 nil] |]) $ do
|
||||
pushNat 1
|
||||
increment
|
||||
increment,
|
||||
Test "dec" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "dec" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 6
|
||||
dec,
|
||||
Test "branch true" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "branch true" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
push (nockBoolLiteral True)
|
||||
branch (pushNat 5) (pushNat 666),
|
||||
Test "branch false" (eqStack ValueStack [nock| [666 nil] |]) $ do
|
||||
defTest "branch false" (eqStack ValueStack [nock| [666 nil] |]) $ do
|
||||
push (nockBoolLiteral False)
|
||||
branch (pushNat 5) (pushNat 666),
|
||||
Test "sub" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "sub" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 3
|
||||
pushNat 8
|
||||
callStdlib StdlibSub,
|
||||
Test "mul" (eqStack ValueStack [nock| [24 nil] |]) $ do
|
||||
defTest "mul" (eqStack ValueStack [nock| [24 nil] |]) $ do
|
||||
pushNat 8
|
||||
pushNat 3
|
||||
callStdlib StdlibMul,
|
||||
Test "div" (eqStack ValueStack [nock| [3 nil] |]) $ do
|
||||
defTest "div" (eqStack ValueStack [nock| [3 nil] |]) $ do
|
||||
pushNat 5
|
||||
pushNat 15
|
||||
callStdlib StdlibDiv,
|
||||
Test "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 10
|
||||
pushNat 15
|
||||
callStdlib StdlibMod,
|
||||
Test "add" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTestNoJets "mul no jets" (eqStack ValueStack [nock| [24 nil] |]) $ do
|
||||
pushNat 8
|
||||
pushNat 3
|
||||
callStdlib StdlibMul,
|
||||
defTestNoJets "div no jets" (eqStack ValueStack [nock| [3 nil] |]) $ do
|
||||
pushNat 5
|
||||
pushNat 15
|
||||
callStdlib StdlibDiv,
|
||||
defTestNoJets "mod no jets" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 10
|
||||
pushNat 15
|
||||
callStdlib StdlibMod,
|
||||
defTest "add" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 2
|
||||
pushNat 3
|
||||
add,
|
||||
Test "pow2" (eqStack ValueStack [nock| [1 2 8 32 nil] |]) $ do
|
||||
defTest "add big" (eqStack ValueStack [nock| [55555 nil] |]) $ do
|
||||
pushNat 33333
|
||||
pushNat 22222
|
||||
add,
|
||||
defTest "mul big" (eqStack ValueStack [nock| [1111088889 nil] |]) $ do
|
||||
pushNat 33333
|
||||
pushNat 33333
|
||||
mul,
|
||||
defTest "sub big" (eqStack ValueStack [nock| [66666 nil] |]) $ do
|
||||
pushNat 33333
|
||||
pushNat 99999
|
||||
callStdlib StdlibSub,
|
||||
defTest "le big" (eqStack ValueStack [nock| [true nil] |]) $ do
|
||||
pushNat 99999
|
||||
pushNat 999
|
||||
callStdlib StdlibLe,
|
||||
defTest "pow2" (eqStack ValueStack [nock| [1 2 8 32 nil] |]) $ do
|
||||
pushNat 5
|
||||
pow2
|
||||
pushNat 3
|
||||
@ -237,38 +287,38 @@ tests =
|
||||
pow2
|
||||
pushNat 0
|
||||
pow2,
|
||||
Test "append rights" (eqStack ValueStack [nock| [95 3 nil] |]) $ do
|
||||
defTest "append rights" (eqStack ValueStack [nock| [95 3 nil] |]) $ do
|
||||
push (OpQuote # toNock ([] :: Path))
|
||||
pushNat 1
|
||||
appendRights
|
||||
push (OpQuote # toNock [L])
|
||||
pushNat 5
|
||||
appendRights,
|
||||
Test "le less" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
defTest "le less" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
pushNat 2
|
||||
pushNat 3
|
||||
callStdlib StdlibLe,
|
||||
Test "lt true" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
defTest "lt true" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
pushNat 4
|
||||
pushNat 3
|
||||
callStdlib StdlibLt,
|
||||
Test "lt eq" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
defTest "lt eq" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
pushNat 3
|
||||
pushNat 3
|
||||
callStdlib StdlibLt,
|
||||
Test "le eq" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
defTest "le eq" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
pushNat 3
|
||||
pushNat 3
|
||||
callStdlib StdlibLe,
|
||||
Test "primitive eq true" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
defTest "primitive eq true" (eqStack ValueStack [nock| [0 nil] |]) $ do
|
||||
pushNat 4
|
||||
pushNat 4
|
||||
testEq,
|
||||
Test "primitive eq false" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
defTest "primitive eq false" (eqStack ValueStack [nock| [1 nil] |]) $ do
|
||||
pushNat 4
|
||||
pushNat 1
|
||||
testEq,
|
||||
Test
|
||||
defTest
|
||||
"save"
|
||||
( do
|
||||
eqStack ValueStack [nock| [67 2 nil] |]
|
||||
@ -279,21 +329,21 @@ tests =
|
||||
pushNat 3
|
||||
save False (pushNat 77)
|
||||
save True (pushNat 67),
|
||||
Test "primitive increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "primitive increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 3
|
||||
increment
|
||||
increment,
|
||||
Test "call increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "call increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 2
|
||||
callEnum FunIncrement 1
|
||||
callEnum FunIncrement 1
|
||||
callEnum FunIncrement 1,
|
||||
Test "call increment indirectly" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
defTest "call increment indirectly" (eqStack ValueStack [nock| [5 nil] |]) $ do
|
||||
pushNat 2
|
||||
callEnum FunIncrement 1
|
||||
callEnum FunCallInc 1
|
||||
callEnum FunIncrement 1,
|
||||
Test
|
||||
defTest
|
||||
"push temp"
|
||||
( do
|
||||
eqStack ValueStack [nock| [5 6 nil] |]
|
||||
@ -304,20 +354,20 @@ tests =
|
||||
pushNatOnto TempStack 6
|
||||
pushTempRef 2 1
|
||||
pushTempRef 2 0,
|
||||
Test "push cell" (eqStack ValueStack [nock| [[1 2] nil] |]) $ do
|
||||
defTest "push cell" (eqStack ValueStack [nock| [[1 2] nil] |]) $ do
|
||||
push (OpQuote # (1 :: Natural) # (2 :: Natural)),
|
||||
Test "push unit" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
|
||||
defTest "push unit" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
|
||||
push constUnit,
|
||||
Test "alloc nullary constructor" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
|
||||
defTest "alloc nullary constructor" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
|
||||
allocConstr (constructorTag ConstructorFalse),
|
||||
Test "alloc unary constructor" (eqStack ValueStack [nock| [[2 [[55 66] nil] nil] nil]|]) $ do
|
||||
defTest "alloc unary constructor" (eqStack ValueStack [nock| [[2 [[55 66] nil] nil] nil]|]) $ do
|
||||
push (OpQuote # (55 :: Natural) # (66 :: Natural))
|
||||
allocConstr (constructorTag ConstructorWrapper),
|
||||
Test "alloc binary constructor" (eqStack ValueStack [nock| [[3 [9 7 nil] nil] nil] |]) $ do
|
||||
defTest "alloc binary constructor" (eqStack ValueStack [nock| [[3 [9 7 nil] nil] nil] |]) $ do
|
||||
pushNat 7
|
||||
pushNat 9
|
||||
allocConstr (constructorTag ConstructorPair),
|
||||
Test
|
||||
defTest
|
||||
"alloc closure"
|
||||
( do
|
||||
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 5 |]
|
||||
@ -331,7 +381,7 @@ tests =
|
||||
pushNat 9
|
||||
pushNat 10
|
||||
allocClosure (sym FunConst5) 3,
|
||||
Test
|
||||
defTest
|
||||
"alloc closure no args from value stack"
|
||||
( do
|
||||
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 3 |]
|
||||
@ -340,7 +390,7 @@ tests =
|
||||
checkStackSize ValueStack 1
|
||||
)
|
||||
$ allocClosure (sym FunAdd3) 0,
|
||||
Test
|
||||
defTest
|
||||
"extend closure"
|
||||
( do
|
||||
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 5 |]
|
||||
@ -355,7 +405,7 @@ tests =
|
||||
pushNat 10
|
||||
allocClosure (sym FunConst5) 1
|
||||
extendClosure 2,
|
||||
Test "alloc, extend and call closure" (eqStack ValueStack [nock| [6 nil] |]) $
|
||||
defTest "alloc, extend and call closure" (eqStack ValueStack [nock| [6 nil] |]) $
|
||||
do
|
||||
pushNat 1
|
||||
pushNat 2
|
||||
@ -363,13 +413,13 @@ tests =
|
||||
allocClosure (sym FunAdd3) 1
|
||||
extendClosure 1
|
||||
callHelper False Nothing 1,
|
||||
Test "call closure" (eqStack ValueStack [nock| [110 nil] |]) $
|
||||
defTest "call closure" (eqStack ValueStack [nock| [110 nil] |]) $
|
||||
do
|
||||
pushNat 100
|
||||
pushNat 110
|
||||
allocClosure (sym FunConst) 1
|
||||
callHelper False Nothing 1,
|
||||
Test
|
||||
defTest
|
||||
"compute argsNum of a closure"
|
||||
(eqStack ValueStack [nock| [2 7 nil] |])
|
||||
$ do
|
||||
@ -379,7 +429,7 @@ tests =
|
||||
pushNat 10
|
||||
allocClosure (sym FunConst5) 3
|
||||
closureArgsNum,
|
||||
Test
|
||||
defTest
|
||||
"save not tail"
|
||||
( do
|
||||
eqStack ValueStack [nock| [17 nil] |]
|
||||
@ -392,7 +442,7 @@ tests =
|
||||
addOn TempStack
|
||||
moveTopFromTo TempStack ValueStack
|
||||
pushNatOnto TempStack 9,
|
||||
Test
|
||||
defTest
|
||||
"save tail"
|
||||
( do
|
||||
eqStack ValueStack [nock| [17 nil] |]
|
||||
@ -405,7 +455,7 @@ tests =
|
||||
addOn TempStack
|
||||
moveTopFromTo TempStack ValueStack
|
||||
pushNatOnto TempStack 9,
|
||||
Test
|
||||
defTest
|
||||
"cmdCase: single branch"
|
||||
(eqStack ValueStack [nock| [777 [2 [123 nil] nil] nil] |])
|
||||
$ do
|
||||
@ -415,7 +465,7 @@ tests =
|
||||
Nothing
|
||||
[ (constructorTag ConstructorWrapper, pushNat 777)
|
||||
],
|
||||
Test
|
||||
defTest
|
||||
"cmdCase: default branch"
|
||||
(eqStack ValueStack [nock| [5 nil] |])
|
||||
$ do
|
||||
@ -425,7 +475,7 @@ tests =
|
||||
(Just (pop >> pushNat 5))
|
||||
[ (constructorTag ConstructorFalse, pushNat 777)
|
||||
],
|
||||
Test
|
||||
defTest
|
||||
"cmdCase: second branch"
|
||||
(eqStack ValueStack [nock| [5 nil] |])
|
||||
$ do
|
||||
@ -436,7 +486,7 @@ tests =
|
||||
[ (constructorTag ConstructorFalse, pushNat 0),
|
||||
(constructorTag ConstructorWrapper, pop >> pushNat 5)
|
||||
],
|
||||
Test
|
||||
defTest
|
||||
"cmdCase: case on builtin true"
|
||||
(eqStack ValueStack [nock| [5 nil] |])
|
||||
$ do
|
||||
@ -446,7 +496,7 @@ tests =
|
||||
[ (Asm.BuiltinTag Asm.TagTrue, pop >> pushNat 5),
|
||||
(Asm.BuiltinTag Asm.TagFalse, pushNat 0)
|
||||
],
|
||||
Test
|
||||
defTest
|
||||
"cmdCase: case on builtin false"
|
||||
(eqStack ValueStack [nock| [5 nil] |])
|
||||
$ do
|
||||
@ -456,7 +506,7 @@ tests =
|
||||
[ (Asm.BuiltinTag Asm.TagTrue, pushNat 0),
|
||||
(Asm.BuiltinTag Asm.TagFalse, pop >> pushNat 5)
|
||||
],
|
||||
Test
|
||||
defTest
|
||||
"push constructor field"
|
||||
(eqStack TempStack [nock| [30 nil] |])
|
||||
$ do
|
||||
@ -466,7 +516,7 @@ tests =
|
||||
pushConstructorFieldOnto TempStack Asm.StackRef 0
|
||||
pushConstructorFieldOnto TempStack Asm.StackRef 1
|
||||
addOn TempStack,
|
||||
Test
|
||||
defTest
|
||||
"trace"
|
||||
( do
|
||||
eqStack ValueStack [nock| [10 nil] |]
|
||||
|
@ -26,6 +26,7 @@ allTests = testGroup "Nockma eval unit positive" (map mk tests)
|
||||
mk Test {..} = testCase (unpack _testName) $ do
|
||||
let evalResult =
|
||||
run
|
||||
. runReader defaultEvalOptions
|
||||
. ignoreOutput @(Term Natural)
|
||||
. runError @(ErrNockNatural Natural)
|
||||
. runError @NockEvalError
|
||||
|
@ -52,5 +52,6 @@ tests :: [PosTest]
|
||||
tests =
|
||||
[ PosTest "Identity" $(mkRelDir ".") $(mkRelFile "Identity.nock"),
|
||||
PosTest "Identity Pretty" $(mkRelDir ".") $(mkRelFile "IdentityPretty.pnock"),
|
||||
PosTest "StdlibCall" $(mkRelDir ".") $(mkRelFile "StdlibCall.pnock"),
|
||||
PosTest "Stdlib" $(mkRelDir ".") $(mkRelFile "Stdlib.nock")
|
||||
]
|
||||
|
2
tests/nockma/positive/StdlibCall.pnock
Normal file
2
tests/nockma/positive/StdlibCall.pnock
Normal file
@ -0,0 +1,2 @@
|
||||
-- It only tests parsing and printing. It cannot be evaluated
|
||||
[stdlib@add args@[0 1] 123 [0 1]]
|
Loading…
Reference in New Issue
Block a user