mirror of
https://github.com/anoma/juvix.git
synced 2024-09-11 16:26:33 +03:00
parent
efb7f2abd0
commit
544bddba43
2
Makefile
2
Makefile
@ -140,7 +140,7 @@ ORMOLUMODE?=inplace
|
||||
|
||||
.PHONY: format
|
||||
format: clang-format
|
||||
${ORMOLU} ${ORMOLUFLAGS} \
|
||||
@${ORMOLU} ${ORMOLUFLAGS} \
|
||||
--ghc-opt -XStandaloneDeriving \
|
||||
--ghc-opt -XUnicodeSyntax \
|
||||
--ghc-opt -XDerivingStrategies \
|
||||
|
@ -287,6 +287,7 @@ a === b = (toExpression a ==% toExpression b) mempty
|
||||
|
||||
infix 4 ==%
|
||||
|
||||
-- TODO: make it symmetric
|
||||
(==%) :: (IsExpression a, IsExpression b) => a -> b -> HashSet Name -> Bool
|
||||
(==%) a b free =
|
||||
isRight
|
||||
|
@ -261,7 +261,7 @@ registerBuiltinFunction d = \case
|
||||
BuiltinBoolAnd -> registerAnd d
|
||||
|
||||
registerBuiltinAxiom ::
|
||||
(Members '[InfoTableBuilder, Error ScoperError, Builtins] r) =>
|
||||
(Members '[InfoTableBuilder, Error ScoperError, Builtins, NameIdGen] r) =>
|
||||
Abstract.AxiomDef ->
|
||||
BuiltinAxiom ->
|
||||
Sem r ()
|
||||
@ -272,6 +272,8 @@ registerBuiltinAxiom d = \case
|
||||
BuiltinString -> registerString d
|
||||
BuiltinStringPrint -> registerStringPrint d
|
||||
BuiltinBoolPrint -> registerBoolPrint d
|
||||
BuiltinTrace -> registerTrace d
|
||||
BuiltinFail -> registerFail d
|
||||
|
||||
goInductive ::
|
||||
(Members '[InfoTableBuilder, Builtins, Error ScoperError] r) =>
|
||||
@ -396,7 +398,7 @@ goExpression = \case
|
||||
r' <- goExpression r
|
||||
return (Abstract.Application l'' r' Explicit)
|
||||
|
||||
goLambda :: forall r. Members '[Error ScoperError, InfoTableBuilder] r => Lambda 'Scoped -> Sem r Abstract.Lambda
|
||||
goLambda :: forall r. (Members '[Error ScoperError, InfoTableBuilder] r) => Lambda 'Scoped -> Sem r Abstract.Lambda
|
||||
goLambda l = Abstract.Lambda <$> mapM goClause (l ^. lambdaClauses)
|
||||
where
|
||||
goClause :: LambdaClause 'Scoped -> Sem r Abstract.LambdaClause
|
||||
@ -504,7 +506,7 @@ goPattern p = case p of
|
||||
PatternWildcard i -> return (Abstract.PatternWildcard i)
|
||||
PatternEmpty {} -> return Abstract.PatternEmpty
|
||||
|
||||
goAxiom :: (Members '[InfoTableBuilder, Error ScoperError, Builtins] r) => AxiomDef 'Scoped -> Sem r Abstract.AxiomDef
|
||||
goAxiom :: (Members '[InfoTableBuilder, Error ScoperError, Builtins, NameIdGen] r) => AxiomDef 'Scoped -> Sem r Abstract.AxiomDef
|
||||
goAxiom a = do
|
||||
_axiomType' <- goExpression (a ^. axiomType)
|
||||
let axiom =
|
||||
|
@ -24,6 +24,8 @@ builtinAxiomName = \case
|
||||
BuiltinString -> Just string_
|
||||
BuiltinStringPrint -> Just printString
|
||||
BuiltinBoolPrint -> Just printBool
|
||||
BuiltinTrace -> Just trace_
|
||||
BuiltinFail -> Just fail_
|
||||
|
||||
builtinFunctionName :: BuiltinFunction -> Maybe Text
|
||||
builtinFunctionName = \case
|
||||
|
@ -80,6 +80,12 @@ boolor = primPrefix "or"
|
||||
booland :: Text
|
||||
booland = primPrefix "and"
|
||||
|
||||
trace_ :: Text
|
||||
trace_ = "trace"
|
||||
|
||||
fail_ :: Text
|
||||
fail_ = "fail"
|
||||
|
||||
funField :: Text
|
||||
funField = "fun"
|
||||
|
||||
|
@ -4,10 +4,12 @@ module Juvix.Compiler.Builtins
|
||||
module Juvix.Compiler.Builtins.IO,
|
||||
module Juvix.Compiler.Builtins.Bool,
|
||||
module Juvix.Compiler.Builtins.String,
|
||||
module Juvix.Compiler.Builtins.Debug,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Compiler.Builtins.Bool
|
||||
import Juvix.Compiler.Builtins.Debug
|
||||
import Juvix.Compiler.Builtins.Effect
|
||||
import Juvix.Compiler.Builtins.IO
|
||||
import Juvix.Compiler.Builtins.Nat
|
||||
|
30
src/Juvix/Compiler/Builtins/Debug.hs
Normal file
30
src/Juvix/Compiler/Builtins/Debug.hs
Normal file
@ -0,0 +1,30 @@
|
||||
module Juvix.Compiler.Builtins.Debug where
|
||||
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Juvix.Compiler.Abstract.Extra
|
||||
import Juvix.Compiler.Builtins.Effect
|
||||
import Juvix.Prelude
|
||||
|
||||
registerTrace :: (Members '[Builtins, NameIdGen] r) => AxiomDef -> Sem r ()
|
||||
registerTrace f = do
|
||||
let ftype = f ^. axiomType
|
||||
u = ExpressionUniverse (Universe {_universeLevel = Nothing, _universeLoc = error "Universe with no location"})
|
||||
a <- freshVar "a"
|
||||
b <- freshVar "b"
|
||||
let freeVars = HashSet.fromList [a, b]
|
||||
unless
|
||||
(((u <>--> u <>--> a --> b --> b) ==% ftype) freeVars)
|
||||
(error "trace must be of type {A : Type} -> {B : Type} -> A -> B -> B")
|
||||
registerBuiltin BuiltinTrace (f ^. axiomName)
|
||||
|
||||
registerFail :: (Members '[Builtins, NameIdGen] r) => AxiomDef -> Sem r ()
|
||||
registerFail f = do
|
||||
let ftype = f ^. axiomType
|
||||
u = ExpressionUniverse (Universe {_universeLevel = Nothing, _universeLoc = error "Universe with no location"})
|
||||
a <- freshVar "a"
|
||||
let freeVars = HashSet.fromList [a]
|
||||
string_ <- getBuiltinName (getLoc f) BuiltinString
|
||||
unless
|
||||
(((u <>--> string_ --> a) ==% ftype) freeVars)
|
||||
(error "fail must be of type {A : Type} -> String -> A")
|
||||
registerBuiltin BuiltinFail (f ^. axiomName)
|
@ -100,6 +100,8 @@ data BuiltinAxiom
|
||||
| BuiltinString
|
||||
| BuiltinIO
|
||||
| BuiltinIOSequence
|
||||
| BuiltinTrace
|
||||
| BuiltinFail
|
||||
deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Data)
|
||||
|
||||
instance Hashable BuiltinAxiom
|
||||
@ -112,3 +114,5 @@ instance Pretty BuiltinAxiom where
|
||||
BuiltinIO -> Str.io
|
||||
BuiltinString -> Str.string
|
||||
BuiltinIOSequence -> Str.ioSequence
|
||||
BuiltinTrace -> Str.trace_
|
||||
BuiltinFail -> Str.fail_
|
||||
|
@ -365,6 +365,8 @@ goAxiomInductive a = whenJust (a ^. Internal.axiomBuiltin) builtinInductive
|
||||
Internal.BuiltinIOSequence -> return ()
|
||||
Internal.BuiltinString -> registerInductiveAxiom
|
||||
Internal.BuiltinIO -> registerInductiveAxiom
|
||||
Internal.BuiltinTrace -> return ()
|
||||
Internal.BuiltinFail -> return ()
|
||||
|
||||
registerInductiveAxiom :: Sem r ()
|
||||
registerInductiveAxiom = do
|
||||
@ -423,6 +425,9 @@ goAxiomDef a = case a ^. Internal.axiomBuiltin >>= builtinBody of
|
||||
)
|
||||
Internal.BuiltinString -> Nothing
|
||||
Internal.BuiltinIO -> Nothing
|
||||
Internal.BuiltinTrace -> Nothing
|
||||
Internal.BuiltinFail ->
|
||||
Just (mkLambda' (mkLambda' (mkBuiltinApp' OpFail [mkVar' 0])))
|
||||
|
||||
axiomType' :: Sem r Type
|
||||
axiomType' = runReader initIndexTable (goExpression (a ^. Internal.axiomType))
|
||||
@ -652,6 +657,23 @@ goApplication a = do
|
||||
mkApps' fExpr <$> exprArgs
|
||||
|
||||
case f of
|
||||
Internal.ExpressionIden (Internal.IdenAxiom n) -> do
|
||||
axiomInfo <- HashMap.lookupDefault impossible n <$> asks (^. Internal.infoAxioms)
|
||||
case axiomInfo ^. Internal.axiomInfoBuiltin of
|
||||
Just Internal.BuiltinNatPrint -> app
|
||||
Just Internal.BuiltinStringPrint -> app
|
||||
Just Internal.BuiltinBoolPrint -> app
|
||||
Just Internal.BuiltinString -> app
|
||||
Just Internal.BuiltinIO -> app
|
||||
Just Internal.BuiltinIOSequence -> app
|
||||
Just Internal.BuiltinTrace -> do
|
||||
as <- exprArgs
|
||||
case as of
|
||||
(_ : _ : arg1 : arg2 : xs) ->
|
||||
return (mkApps' (mkBuiltinApp' OpTrace [arg1, arg2]) xs)
|
||||
_ -> error "trace must be called with 2 arguments"
|
||||
Just Internal.BuiltinFail -> app
|
||||
Nothing -> app
|
||||
Internal.ExpressionIden (Internal.IdenFunction n) -> do
|
||||
funInfo <- HashMap.lookupDefault impossible n <$> asks (^. Internal.infoFunctions)
|
||||
case funInfo ^. Internal.functionInfoDef . Internal.funDefBuiltin of
|
||||
|
@ -189,7 +189,15 @@ tests =
|
||||
posTest
|
||||
"Issue 1704 (Type synonyms)"
|
||||
$(mkRelDir "Internal")
|
||||
$(mkRelFile "Synonyms.juvix")
|
||||
$(mkRelFile "Synonyms.juvix"),
|
||||
posTest
|
||||
"Issue 1731 Trace builtin for debugging"
|
||||
$(mkRelDir "issue1731")
|
||||
$(mkRelFile "builtinTrace.juvix"),
|
||||
posTest
|
||||
"Issue 1731 Fail builtin for debugging"
|
||||
$(mkRelDir "issue1731")
|
||||
$(mkRelFile "builtinFail.juvix")
|
||||
]
|
||||
<> [ compilationTest t | t <- Compilation.tests, t ^. Compilation.name /= "Self-application"
|
||||
]
|
||||
|
@ -1,7 +1,9 @@
|
||||
-- streams without memoization
|
||||
|
||||
constr nil 0;
|
||||
constr cons 2;
|
||||
type list {
|
||||
nil : list;
|
||||
cons : any -> list -> list;
|
||||
};
|
||||
|
||||
def force := \f f nil;
|
||||
|
||||
|
@ -1,7 +1,10 @@
|
||||
-- no matching case branch
|
||||
|
||||
constr cons 2;
|
||||
type list {
|
||||
nil : list;
|
||||
cons : any -> list -> list;
|
||||
};
|
||||
|
||||
case cons 1 2 of {
|
||||
case cons 1 nil of {
|
||||
nil -> true
|
||||
}
|
||||
|
@ -1,6 +1,8 @@
|
||||
-- erroneous Church numerals
|
||||
|
||||
constr pair 2;
|
||||
type product {
|
||||
pair : any -> any -> product;
|
||||
};
|
||||
|
||||
def fst := \p case p of { pair x _ -> x };
|
||||
def snd := \p case p of { pair _ x -> x };
|
||||
|
@ -2,18 +2,16 @@
|
||||
|
||||
def g := \x trace x g;
|
||||
|
||||
def f := \x \y
|
||||
if x = 0 then
|
||||
9
|
||||
else
|
||||
trace 1 (f (x - 1) (y 0));
|
||||
def f := \x \y if x = 0 then 9 else trace 1 (f (x - 1) (y 0));
|
||||
|
||||
def h := \x trace 8 (trace x (x + x));
|
||||
|
||||
def const := \x \y x;
|
||||
|
||||
constr nil 0;
|
||||
constr cons 2;
|
||||
type list {
|
||||
nil : list;
|
||||
cons : any -> list -> list;
|
||||
};
|
||||
|
||||
trace (const 0 (trace "!" 1)) (
|
||||
trace (const 0 (cons (trace "a" 1) (trace "b" (cons (trace "c" 1) (trace "d" nil))))) (
|
||||
|
10
tests/positive/issue1731/builtinFail.juvix
Normal file
10
tests/positive/issue1731/builtinFail.juvix
Normal file
@ -0,0 +1,10 @@
|
||||
module builtinFail;
|
||||
open import Stdlib.Prelude;
|
||||
|
||||
builtin fail axiom fail : {A : Type} → String → A;
|
||||
|
||||
main : IO;
|
||||
main := printStringLn "Get"
|
||||
>> fail "Enough"
|
||||
>> printStringLn "Sleep";
|
||||
end;
|
25
tests/positive/issue1731/builtinTrace.juvix
Normal file
25
tests/positive/issue1731/builtinTrace.juvix
Normal file
@ -0,0 +1,25 @@
|
||||
module builtinTrace;
|
||||
open import Stdlib.Prelude;
|
||||
open import Stdlib.Data.Nat.Ord;
|
||||
|
||||
builtin trace axiom trace : {A : Type} → {B : Type} → A → B → B;
|
||||
|
||||
terminating
|
||||
f : Nat → Nat → Nat;
|
||||
f x y := if (x == 0) y (trace x (f (sub x 1) y));
|
||||
|
||||
{-
|
||||
f 4 0 =
|
||||
trace 4 (f 3 0)
|
||||
=> trace 4 (trace 3 (f 2 0))
|
||||
=> trace 4 (trace 3 (trace 2 (f 1 0)))
|
||||
=> trace 4 (trace 3 (trace 2 (trace 1 (f 0 0))))
|
||||
=> trace 4 (trace 3 (trace 2 (trace 1 0)))
|
||||
= 0
|
||||
|
||||
𝔸 β \X \Y . Apply (Apply trace X) Y
|
||||
|
||||
-}
|
||||
main : IO;
|
||||
main := printNatLn $ f 4 0;
|
||||
end;
|
0
tests/positive/issue1731/juvix.yaml
Normal file
0
tests/positive/issue1731/juvix.yaml
Normal file
@ -199,3 +199,48 @@ tests:
|
||||
contains: |
|
||||
suc (suc (suc zero))
|
||||
exit-status: 0
|
||||
|
||||
- name: repl-trace
|
||||
command:
|
||||
- juvix
|
||||
- repl
|
||||
args:
|
||||
- positive/issue1731/builtinTrace.juvix
|
||||
stdin: trace 2 (printNatLn 3)
|
||||
stdout:
|
||||
contains: |
|
||||
suc (suc (suc zero))
|
||||
stderr: |
|
||||
suc (suc zero)
|
||||
exit-status: 0
|
||||
|
||||
- name: repl-trace-file
|
||||
command:
|
||||
- juvix
|
||||
- repl
|
||||
args:
|
||||
- positive/issue1731/builtinTrace.juvix
|
||||
stdin: f 4 0
|
||||
stdout:
|
||||
contains: |
|
||||
zero
|
||||
stderr: |
|
||||
suc (suc (suc (suc zero)))
|
||||
suc (suc (suc zero))
|
||||
suc (suc zero)
|
||||
suc zero
|
||||
exit-status: 0
|
||||
|
||||
- name: repl-fail
|
||||
command:
|
||||
- juvix
|
||||
- repl
|
||||
args:
|
||||
- positive/issue1731/builtinFail.juvix
|
||||
stdin: main
|
||||
stdout:
|
||||
contains: builtinFail> builtinFail>
|
||||
stderr:
|
||||
contains: |
|
||||
evaluation error: failure: Enough
|
||||
exit-status: 0
|
Loading…
Reference in New Issue
Block a user