├── test ├── ok │ ├── ok0000_emptyFile.fram │ ├── ok0012_adt.fram │ ├── ok0001_id.fram │ ├── ok0024_letFunc.fram │ ├── ok0095_wildcardTypeParam.fram │ ├── ok0038_explicitArg.fram │ ├── ok0105_recFunWithNamedParam.fram │ ├── ok0017_wildcard.fram │ ├── ok0002_poly.fram │ ├── ok0003_local.fram │ ├── ok0004_fnArg.fram │ ├── ok0005_let.fram │ ├── ok0032_dataArg.fram │ ├── ok0077_effectResume.fram │ ├── ok0007_letArg.fram │ ├── ok0008_idHandler.fram │ ├── ok0078_unitMethods.fram │ ├── ok0006_fnArg.fram │ ├── ok0013_emptyADT.fram │ ├── ok0096_fixTypeAnnot.fram │ ├── ok0027_explicitApp.fram │ ├── ok0031_explicitArg.fram │ ├── ok0127_polymorphicParam.fram │ ├── ok0050_typeArgRename.fram │ ├── ok0126_explicitTypeParam.fram │ ├── ok0016_trivialMatch.fram │ ├── ok0021_simpleMatch.fram │ ├── ok0023_letPattern.fram │ ├── ok0076_ifExpr.fram │ ├── ok0035_schemes.fram │ ├── ok0036_schemeAnnot.fram │ ├── ok0048_explicitTypeInst.fram │ ├── ok0133_uvarAlias.fram │ ├── ok0014_arrows.fram │ ├── ok0028_patArg.fram │ ├── ok0073_extern.fram │ ├── ok0088_abstractData.fram │ ├── ok0120_polyNamedPatternCheck.fram │ ├── ok0125_unpackModule.fram │ ├── ok0010_implicit.fram │ ├── ok0069_effectCtorArg.fram │ ├── ok0009_purityRestriction.fram │ ├── ok0026_funSugar.fram │ ├── ok0085_letChecked.fram │ ├── ok0138_polyReinst.fram │ ├── ok0042_existentialTypes.fram │ ├── ok0049_expilicitInstOrder.fram │ ├── ok0103_genericRecords.fram │ ├── ok0145_positiveAdt.fram │ ├── ok0025_letFuncImplicit.fram │ ├── ok0059_effectArg.fram │ ├── ok0068_shadowCtors.fram │ ├── ok0034_schemes.fram │ ├── ok0047_namedParam.fram │ ├── ok0053_firstClassHandler.fram │ ├── ok0079_impureMethod.fram │ ├── ok0101_implicitParamsRecord.fram │ ├── ok0102_simpleRecord.fram │ ├── ok0134_uvarAlias2.fram │ ├── ok0011_implicit.fram │ ├── ok0099_nestedEffArrows.fram │ ├── ok0121_adtsInModules.fram │ ├── ok0018_namePattern.fram │ ├── ok0040_polymorphicFields.fram │ ├── ok0089_pubPat.fram │ ├── ok0129_recursiveADTValues.fram │ ├── ok0064_typeAnnot.fram │ ├── ok0019_simplePattern.fram │ ├── ok0044_implicitCtorArgs.fram │ ├── ok0110_publicModulePattern.fram │ ├── ok0046_mutualDataRec.fram │ ├── ok0080_moduleDef.fram │ ├── ok0130_effectfulArrow.fram │ ├── ok0135_specialImplicits.fram │ ├── ok0039_polymorphicImplicit.fram │ ├── ok0052_emptyMatch.fram │ ├── ok0113_pureMatchingNonrecUVar.fram │ ├── ok0119_patternOpen.fram │ ├── ok0132_typeAlias.fram │ ├── ok0143_sectionShadow.fram │ ├── ok0071_numbers.fram │ ├── ok0104_chars.fram │ ├── ok0131_methodOnMethodFn.fram │ ├── ok0147_handlePure.fram │ ├── ok0015_ctor.fram │ ├── ok0029_handle.fram │ ├── ok0054_firstClassHandler.fram │ ├── ok0061_returnFinallyMatch.fram │ ├── ok0109_fieldPattern.fram │ ├── ok0066_method.fram │ ├── ok0112_pureRecord.fram │ ├── ok0020_patternMatch.fram │ ├── ok0137_parameterMethod.fram │ ├── ok0142_section.fram │ ├── ok0084_operators.fram │ ├── ok0022_deepMatch.fram │ ├── ok0072_strings.fram │ ├── ok0058_unitState.fram │ ├── ok0106_recursiveMethod.fram │ ├── ok0045_recursiveData.fram │ ├── ok0081_nestedModule.fram │ ├── ok0097_recursion.fram │ ├── ok0118_parameter.fram │ ├── ok0116_pureRecordAccessor.fram │ ├── ok0067_pureMethod.fram │ ├── ok0087_opratorOverloading.fram │ ├── ok0114_pureTail.fram │ ├── ok0100_polymorphicRecursion.fram │ ├── ok0124_explicitMethodInst.fram │ ├── ok0107_polymorphicRecursion.fram │ ├── ok0033_higherKinds.fram │ ├── ok0083_pubPatternMatch.fram │ ├── ok0146_attributes.fram │ ├── ok0141_explicitEffectfulFunctionInstantiation.fram │ ├── ok0140_explicitFunctionInstantiation.fram │ ├── ok0128_recursiveADTValues.fram │ ├── ok0074_implicitWithType.fram │ ├── ok0115_purePatternMatching.fram │ ├── ok0098_mutualRecursion.fram │ ├── ok0094_unaryIf.fram │ ├── ok0055_complexHandlers.fram │ ├── ok0051_existentialTypePattern.fram │ ├── ok0090_lists.fram │ ├── ok0136_stringInterpolation.fram │ ├── ok0060_returnFinally.fram │ ├── ok0082_moduleDataDef.fram │ ├── ok0070_effectMethodArg.fram │ ├── ok0092_multipleNamedMethodParams.fram │ ├── ok0075_effectsFromImplicits.fram │ ├── ok0056_complexHandlers.fram │ ├── ok0057_dataArgLabels.fram │ ├── ok0122_reexportedMethods.fram │ ├── ok0111_optionalParams.fram │ ├── ok0123_explicitMethodInst.fram │ ├── ok0144_sizedMethodResolve.fram │ ├── ok0139_nestedHandlers.fram │ ├── ok0086_optionState.fram │ ├── ok0030_bt.fram │ ├── ok0091_namedParamMethod.fram │ ├── ok0148_equivEffect.fram │ ├── ok0041_existentialTypes.fram │ ├── ok0108_modulePattern.fram │ ├── ok0117_comments.fram │ └── ok0093_specialBinops.fram ├── err │ ├── lexer_0001_illegalOp1.fram │ ├── lexer_0000_illegalOp0.fram │ ├── parser_0001_illegalBinopCtor.fram │ ├── parser_0000_illegalBinopPattern.fram │ ├── lexer_0002_eofInComment.fram │ ├── lexer_0003_lexerDirective.fram │ ├── tc_0006_unapplicableKind.fram │ ├── tc_0000_implicitLoop.fram │ ├── tc_0005_specialBinops.fram │ ├── tc_0009_polymorphicOptionalArg.fram │ ├── tc_0019_effectArrow.fram │ ├── tc_0001_escapingType.fram │ ├── tc_0002_escapingType.fram │ ├── tc_0018_nonProductiveRecDef.fram │ ├── tc_0017_unsolvedMethodConstr.fram │ ├── tc_0016_adtVisibility.fram │ ├── tc_0015_multipleMethodInst.fram │ ├── tc_0010_impureNonPositiveRecord.fram │ ├── tc_0012_impureExprInPureMatch.fram │ ├── tc_0011_nonPositiveUVar.fram │ ├── tc_0013_ambiguousMethodInst.fram │ └── tc_0014_moduleInstAfterMethod.fram ├── stdlib │ ├── stdlib0000_Int64.fram │ ├── stdlib0001_Option.fram │ ├── stdlib0005_ToString.fram │ ├── stdlib0006_Prelude.fram │ └── String.fram └── test_suite ├── examples ├── Modules │ ├── C.fram │ ├── B │ │ ├── A.fram │ │ └── C │ │ │ └── D.fram │ ├── A.fram │ └── Main.fram └── Tick.fram ├── .gitignore ├── src ├── Utils │ ├── dune │ ├── Eq.ml │ ├── SyntaxNode.ml │ ├── UID.ml │ ├── SExpr.mli │ ├── UID.mli │ ├── Var.ml │ ├── BRef.mli │ ├── Var.mli │ ├── BiDirectional.ml │ ├── Scope.ml │ ├── Scope.mli │ └── PPTree.mli ├── IncrSAT │ ├── dune │ ├── PropVar.mli │ ├── Solver.mli │ ├── PropVar.ml │ └── Formula.mli ├── Lang │ ├── UnifCommon │ │ ├── dune │ │ ├── Names.ml │ │ ├── BuiltinType.ml │ │ ├── TVar.ml │ │ ├── Kind.mli │ │ └── TVar.mli │ ├── CorePriv │ │ ├── dune │ │ ├── Kind.ml │ │ ├── Subst.mli │ │ ├── ConstrSet.mli │ │ ├── ConstrSet.ml │ │ ├── BuiltinType.ml │ │ ├── Effect.ml │ │ └── Syntax.ml │ ├── UnifPriv │ │ ├── dune │ │ ├── ProofExpr.mli │ │ ├── Effect.ml │ │ ├── ProofExpr.ml │ │ ├── TyAlias.mli │ │ ├── Pretty.mli │ │ ├── TyAlias.ml │ │ ├── Ren.mli │ │ ├── TypeWhnf.ml │ │ ├── Name.ml │ │ ├── Pretty.ml │ │ └── Subst.mli │ ├── dune │ ├── ConEPriv │ │ ├── dune │ │ ├── TVar.ml │ │ ├── SExprPrinter.mli │ │ ├── CtorDecl.ml │ │ ├── CEffect.mli │ │ ├── CEffect.ml │ │ ├── Pretty.mli │ │ ├── Subst.mli │ │ ├── TVar.mli │ │ ├── Syntax.ml │ │ └── TypeBase.mli │ ├── Core.ml │ └── ConE.ml ├── ToCore │ ├── dune │ ├── Main.mli │ ├── DataType.mli │ ├── Type.mli │ ├── Env.mli │ └── Env.ml ├── Eval │ ├── dune │ ├── Eval.mli │ ├── Env.ml │ ├── Env.mli │ ├── External.ml │ ├── ExternalRef.ml │ ├── ExternalUtils.ml │ ├── Value.ml │ ├── ExternalInt.ml │ ├── ExternalInt64.ml │ └── ExternalOs.ml ├── InterpLib │ ├── dune │ ├── InternalError.ml │ ├── InternalError.mli │ ├── TextRangePrinting.mli │ ├── Error.mli │ └── Error.ml ├── TypeInference │ ├── dune │ ├── Main.mli │ ├── ConstrSolve.mli │ ├── Inst.mli │ ├── ParamCycleDetect.ml │ ├── Constr.ml │ ├── ReplUtils.mli │ ├── Expr.mli │ ├── ParamCycleDetect.mli │ ├── Def.mli │ ├── BuiltinTypes.mli │ ├── Main.ml │ ├── Constr.mli │ ├── BuiltinTypes.ml │ ├── Uniqueness.mli │ ├── NameUtils.mli │ ├── RecDefs.mli │ ├── ConstrSolve.ml │ ├── ExprUtils.mli │ ├── MatchClause.mli │ ├── Common.ml │ ├── DataType.mli │ ├── Name.mli │ ├── ExprUtils.ml │ └── Type.mli ├── EffectInference │ ├── dune │ ├── ConstrSet.ml │ ├── Main.ml │ ├── Main.mli │ ├── DataType.mli │ ├── ProofExpr.mli │ ├── ConstrSet.mli │ ├── Type.mli │ ├── Constr.mli │ ├── Expr.mli │ ├── Error.mli │ ├── ConstrSimplify.mli │ ├── Constr.ml │ ├── PatternMatch.mli │ ├── Subtyping.mli │ ├── Common.ml │ └── Pattern.mli ├── DblParser │ ├── dune │ ├── Lexer.mli │ ├── Attributes.mli │ ├── File.mli │ ├── Main.mli │ ├── Import.mli │ ├── File.ml │ └── Error.mli ├── Lsp │ ├── dune │ ├── Connection.mli │ └── JsonRpc.mli ├── dune ├── Pipeline.mli ├── Pipeline.ml └── DblConfig.ml ├── lib ├── Base │ ├── Types.fram │ ├── Bool.fram │ ├── Char.fram │ ├── Result.fram │ ├── Assert.fram │ ├── String.fram │ ├── Operators.fram │ └── Option.fram └── String.fram ├── dune-project ├── dune ├── .github └── workflows │ └── Test.yml └── LICENSE /test/ok/ok0000_emptyFile.fram: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/ok/ok0012_adt.fram: -------------------------------------------------------------------------------- 1 | data T = I 2 | -------------------------------------------------------------------------------- /test/ok/ok0001_id.fram: -------------------------------------------------------------------------------- 1 | let id = fn x => x 2 | -------------------------------------------------------------------------------- /test/ok/ok0024_letFunc.fram: -------------------------------------------------------------------------------- 1 | let id x = x 2 | -------------------------------------------------------------------------------- /examples/Modules/C.fram: -------------------------------------------------------------------------------- 1 | pub let mod_C_value = 0 2 | -------------------------------------------------------------------------------- /test/err/lexer_0001_illegalOp1.fram: -------------------------------------------------------------------------------- 1 | let (a ~ b) = c -------------------------------------------------------------------------------- /test/ok/ok0095_wildcardTypeParam.fram: -------------------------------------------------------------------------------- 1 | data T _ = A -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | 3 | dbl.opam 4 | .ocamlformat 5 | -------------------------------------------------------------------------------- /test/err/lexer_0000_illegalOp0.fram: -------------------------------------------------------------------------------- 1 | let (a ? b) = c 2 | -------------------------------------------------------------------------------- /test/err/parser_0001_illegalBinopCtor.fram: -------------------------------------------------------------------------------- 1 | data T = (;) 2 | -------------------------------------------------------------------------------- /test/ok/ok0038_explicitArg.fram: -------------------------------------------------------------------------------- 1 | let id {type X} (x : X) = x 2 | -------------------------------------------------------------------------------- /test/ok/ok0105_recFunWithNamedParam.fram: -------------------------------------------------------------------------------- 1 | let rec f {x} = x 2 | -------------------------------------------------------------------------------- /examples/Modules/B/A.fram: -------------------------------------------------------------------------------- 1 | pub let id x = x 2 | pub let bar = 13 3 | -------------------------------------------------------------------------------- /test/err/parser_0000_illegalBinopPattern.fram: -------------------------------------------------------------------------------- 1 | let (a && b) = c 2 | -------------------------------------------------------------------------------- /test/ok/ok0017_wildcard.fram: -------------------------------------------------------------------------------- 1 | let _ = match () with _ => () end 2 | -------------------------------------------------------------------------------- /examples/Modules/A.fram: -------------------------------------------------------------------------------- 1 | import B/C/D 2 | 3 | pub let foo = D.id 42 4 | -------------------------------------------------------------------------------- /src/Utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name utils) 3 | (wrapped false)) 4 | -------------------------------------------------------------------------------- /test/ok/ok0002_poly.fram: -------------------------------------------------------------------------------- 1 | let id = fn x => x 2 | let x = id id (id ()) 3 | -------------------------------------------------------------------------------- /src/IncrSAT/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incrSAT) 3 | (libraries utils)) 4 | -------------------------------------------------------------------------------- /test/err/lexer_0002_eofInComment.fram: -------------------------------------------------------------------------------- 1 | # @stderr:!!#} 2 | {#!! 3 | {# #} 4 | -------------------------------------------------------------------------------- /test/ok/ok0003_local.fram: -------------------------------------------------------------------------------- 1 | let x = 2 | let id = fn x => x in 3 | id () 4 | -------------------------------------------------------------------------------- /test/ok/ok0004_fnArg.fram: -------------------------------------------------------------------------------- 1 | let id = fn x => x 2 | let x = id (fn y => y) () 3 | -------------------------------------------------------------------------------- /test/ok/ok0005_let.fram: -------------------------------------------------------------------------------- 1 | let x = 2 | let y = (fn z => z) () in 3 | y 4 | -------------------------------------------------------------------------------- /test/ok/ok0032_dataArg.fram: -------------------------------------------------------------------------------- 1 | data Option X = 2 | | None 3 | | Some of X 4 | -------------------------------------------------------------------------------- /test/ok/ok0077_effectResume.fram: -------------------------------------------------------------------------------- 1 | let h = handler effect x => resume x end 2 | -------------------------------------------------------------------------------- /test/err/lexer_0003_lexerDirective.fram: -------------------------------------------------------------------------------- 1 | #@ 123 foo 2 | in 3 | # @stderr:foo:123 4 | -------------------------------------------------------------------------------- /test/ok/ok0007_letArg.fram: -------------------------------------------------------------------------------- 1 | let x = (fn x => ()) (let f = fn x => x in f ()) 2 | -------------------------------------------------------------------------------- /test/ok/ok0008_idHandler.fram: -------------------------------------------------------------------------------- 1 | let _ = handle id = effect x / r => r x in id () 2 | -------------------------------------------------------------------------------- /test/ok/ok0078_unitMethods.fram: -------------------------------------------------------------------------------- 1 | method unit () = () 2 | 3 | let _ = ().unit 4 | -------------------------------------------------------------------------------- /src/Lang/UnifCommon/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name unifCommon) 3 | (libraries utils)) 4 | -------------------------------------------------------------------------------- /src/ToCore/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name toCore) 3 | (libraries interpLib lang utils)) 4 | -------------------------------------------------------------------------------- /test/err/tc_0006_unapplicableKind.fram: -------------------------------------------------------------------------------- 1 | data rec Fix (F: type) = Fix of F (Fix F) 2 | -------------------------------------------------------------------------------- /test/ok/ok0006_fnArg.fram: -------------------------------------------------------------------------------- 1 | let f = fn g => fn x => g x 2 | let x = f (fn x => x) () 3 | -------------------------------------------------------------------------------- /test/ok/ok0013_emptyADT.fram: -------------------------------------------------------------------------------- 1 | data E = 2 | 3 | data M = 4 | | None 5 | | Some of E 6 | -------------------------------------------------------------------------------- /test/ok/ok0096_fixTypeAnnot.fram: -------------------------------------------------------------------------------- 1 | data rec Fix (F : type -> type) = Fix of F (Fix F) 2 | -------------------------------------------------------------------------------- /src/Eval/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eval) 3 | (libraries interpLib lang unix dblConfig)) 4 | -------------------------------------------------------------------------------- /src/InterpLib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name interpLib) 3 | (libraries utils dblConfig str)) 4 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name corePriv) 3 | (libraries utils interpLib)) 4 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name unifPriv) 3 | (libraries utils unifCommon)) 4 | -------------------------------------------------------------------------------- /test/ok/ok0027_explicitApp.fram: -------------------------------------------------------------------------------- 1 | parameter ~n 2 | let foo = ~n 3 | let _ = foo { ~n = () } 4 | -------------------------------------------------------------------------------- /test/ok/ok0031_explicitArg.fram: -------------------------------------------------------------------------------- 1 | let ~f {~x} = ~x 2 | let f {~f=g} = g 3 | let h ~x = f () 4 | -------------------------------------------------------------------------------- /test/ok/ok0127_polymorphicParam.fram: -------------------------------------------------------------------------------- 1 | parameter ~id : {T} -> T -> T 2 | 3 | let id = ~id 4 | -------------------------------------------------------------------------------- /src/Lang/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lang) 3 | (libraries unifPriv conEPriv corePriv utils)) 4 | -------------------------------------------------------------------------------- /test/ok/ok0050_typeArgRename.fram: -------------------------------------------------------------------------------- 1 | let id {X=Y} (x : Y) = x 2 | 3 | let id2 {Z} = id {X=Z} 4 | -------------------------------------------------------------------------------- /test/ok/ok0126_explicitTypeParam.fram: -------------------------------------------------------------------------------- 1 | parameter x 2 | 3 | let foo {T} (f : _ ->[_] T) = f x 4 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conEPriv) 3 | (libraries utils incrSAT unifCommon)) 4 | -------------------------------------------------------------------------------- /src/TypeInference/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typeInference) 3 | (libraries interpLib lang utils)) 4 | -------------------------------------------------------------------------------- /test/ok/ok0016_trivialMatch.fram: -------------------------------------------------------------------------------- 1 | let _ = 2 | match fn x => x with 3 | | f => f 4 | end () 5 | -------------------------------------------------------------------------------- /test/ok/ok0021_simpleMatch.fram: -------------------------------------------------------------------------------- 1 | data A = A 2 | data B = B 3 | 4 | let _ = match A with A => B end 5 | -------------------------------------------------------------------------------- /test/ok/ok0023_letPattern.fram: -------------------------------------------------------------------------------- 1 | data T = X | Y 2 | data P = P of T, T 3 | 4 | let P x y = P X Y 5 | -------------------------------------------------------------------------------- /test/ok/ok0076_ifExpr.fram: -------------------------------------------------------------------------------- 1 | data Bool = True | False 2 | 3 | let not x = if x then False else True 4 | -------------------------------------------------------------------------------- /test/ok/ok0035_schemes.fram: -------------------------------------------------------------------------------- 1 | data T X = T of (({type Y} -> Y) -> X) 2 | 3 | let foo = T (fn em => em) 4 | -------------------------------------------------------------------------------- /test/ok/ok0036_schemeAnnot.fram: -------------------------------------------------------------------------------- 1 | let foo (id : {type X} -> X -> X) = id id 2 | let _ = foo (fn x => x) () 3 | -------------------------------------------------------------------------------- /test/ok/ok0048_explicitTypeInst.fram: -------------------------------------------------------------------------------- 1 | let id {X} (x : X) = x 2 | 3 | let id2 {X} = id {X=X->X} (id {X}) 4 | -------------------------------------------------------------------------------- /test/ok/ok0133_uvarAlias.fram: -------------------------------------------------------------------------------- 1 | let f x = 2 | type T = _ 3 | let id (y : T) = y 4 | in 5 | id x 6 | -------------------------------------------------------------------------------- /test/ok/ok0014_arrows.fram: -------------------------------------------------------------------------------- 1 | data X = I 2 | 3 | data T = 4 | | Pure of (X -> X) 5 | | Impure of (X ->[] X) 6 | -------------------------------------------------------------------------------- /test/ok/ok0028_patArg.fram: -------------------------------------------------------------------------------- 1 | data Bool = True | False 2 | data P = P of Bool, Bool 3 | 4 | let fst (P x _) = x 5 | -------------------------------------------------------------------------------- /test/ok/ok0073_extern.fram: -------------------------------------------------------------------------------- 1 | let addInt = extern dbl_addInt : Int -> Int -> Int 2 | 3 | let _ = addInt 13 42 4 | -------------------------------------------------------------------------------- /test/ok/ok0088_abstractData.fram: -------------------------------------------------------------------------------- 1 | module M 2 | abstr data T = C | D 3 | end 4 | 5 | let f (x : M.T) = x 6 | -------------------------------------------------------------------------------- /test/ok/ok0120_polyNamedPatternCheck.fram: -------------------------------------------------------------------------------- 1 | data T = T of {id : {X} -> X -> X} 2 | let foo (T {id}) = id id 42 3 | -------------------------------------------------------------------------------- /test/ok/ok0125_unpackModule.fram: -------------------------------------------------------------------------------- 1 | data T = T of { U } 2 | let mk = T { U = Unit } 3 | let T { module U } = mk 4 | -------------------------------------------------------------------------------- /src/EffectInference/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name effectInference) 3 | (libraries incrSAT interpLib lang utils)) 4 | -------------------------------------------------------------------------------- /test/err/tc_0000_implicitLoop.fram: -------------------------------------------------------------------------------- 1 | parameter ~n 2 | let ~n = ~n 3 | let _ = ~n 4 | 5 | # @stderr: infinite loop 6 | -------------------------------------------------------------------------------- /test/ok/ok0010_implicit.fram: -------------------------------------------------------------------------------- 1 | parameter ~a 2 | 3 | let foo = ~a 4 | 5 | let _ = 6 | let ~a = () in 7 | foo 8 | -------------------------------------------------------------------------------- /test/ok/ok0069_effectCtorArg.fram: -------------------------------------------------------------------------------- 1 | data T (E : effect) = C of (Unit ->[E] Unit) 2 | 3 | let f {E} (C g : T E) = g 4 | -------------------------------------------------------------------------------- /test/ok/ok0009_purityRestriction.fram: -------------------------------------------------------------------------------- 1 | let id = 2 | let id2 = fn x => x in 3 | id2 id2 4 | 5 | let _ = id id () 6 | -------------------------------------------------------------------------------- /test/ok/ok0026_funSugar.fram: -------------------------------------------------------------------------------- 1 | let foo f x = f x x 2 | let bar g = foo (fn x y => g y x) () 3 | let _ = bar (fn x y => x) 4 | -------------------------------------------------------------------------------- /test/ok/ok0085_letChecked.fram: -------------------------------------------------------------------------------- 1 | let f x = 2 | let y = 3 | match x with 4 | | _ => x 5 | end 6 | in y 7 | -------------------------------------------------------------------------------- /test/ok/ok0138_polyReinst.fram: -------------------------------------------------------------------------------- 1 | let foo (x : {X, x : X} -> Int) = 42 2 | let bar {X, x : X} = 42 3 | let _ = foo bar 4 | -------------------------------------------------------------------------------- /test/stdlib/stdlib0000_Int64.fram: -------------------------------------------------------------------------------- 1 | 2 | let zero = Int64.one + Int64.one.neg 3 | 4 | let _ = (zero == 0L) 5 | 6 | 7 | -------------------------------------------------------------------------------- /test/err/tc_0005_specialBinops.fram: -------------------------------------------------------------------------------- 1 | let _ = "" && True 2 | let _ = "" && "" || "" 3 | let _ = True || 5 4 | let _ = ""; 5 5 | -------------------------------------------------------------------------------- /test/ok/ok0042_existentialTypes.fram: -------------------------------------------------------------------------------- 1 | data Ex = Ex of {type X}, X 2 | 3 | let foo (f : {type A} -> A -> A) (Ex x) = Ex (f x) 4 | -------------------------------------------------------------------------------- /test/ok/ok0049_expilicitInstOrder.fram: -------------------------------------------------------------------------------- 1 | data Pair X Y = Pair of X, Y 2 | 3 | let swap {A,B} (Pair x y) = Pair {Y=A,X=B} y x 4 | -------------------------------------------------------------------------------- /test/ok/ok0103_genericRecords.fram: -------------------------------------------------------------------------------- 1 | data Vec T = { x : T, y : T } 2 | 3 | let swap (v : Vec _) = Vec { x = v.y, y = v.x } 4 | -------------------------------------------------------------------------------- /test/ok/ok0145_positiveAdt.fram: -------------------------------------------------------------------------------- 1 | data rec T = C of ((T -> Unit) -> Unit) 2 | let foo (C f) = f (fn (C g) => g (fn _ => ())) 3 | -------------------------------------------------------------------------------- /examples/Modules/B/C/D.fram: -------------------------------------------------------------------------------- 1 | {# This import resolves to the absolute path `/Main/B/A`. #} 2 | import A 3 | 4 | pub let id = A.id 5 | -------------------------------------------------------------------------------- /test/ok/ok0025_letFuncImplicit.fram: -------------------------------------------------------------------------------- 1 | parameter ~f 2 | 3 | let foo x = ~f x 4 | 5 | let ~f x = x 6 | 7 | let _ = 8 | foo () 9 | -------------------------------------------------------------------------------- /test/ok/ok0059_effectArg.fram: -------------------------------------------------------------------------------- 1 | let id {E : effect} x = x 2 | 3 | let id2 {E = X} = id {E = X} 4 | 5 | let hId = handler id2 end 6 | -------------------------------------------------------------------------------- /test/ok/ok0068_shadowCtors.fram: -------------------------------------------------------------------------------- 1 | data T = C 2 | data S = C 3 | 4 | let f (x : T) = 5 | match x with 6 | | C => C 7 | end 8 | -------------------------------------------------------------------------------- /test/ok/ok0034_schemes.fram: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | data A = A of (({~x : Bool} -> Bool) ->[] Bool) 3 | 4 | let foo (A g) = g ~x 5 | -------------------------------------------------------------------------------- /test/ok/ok0047_namedParam.fram: -------------------------------------------------------------------------------- 1 | data Vec X = Vec of { x : X, y : X } 2 | 3 | let get_x (Vec { x }) = x 4 | let get_y (Vec { y }) = y 5 | -------------------------------------------------------------------------------- /test/ok/ok0053_firstClassHandler.fram: -------------------------------------------------------------------------------- 1 | let hId = handler effect x / r => r x end 2 | 3 | handle id with hId 4 | 5 | let _ = id () 6 | -------------------------------------------------------------------------------- /test/ok/ok0079_impureMethod.fram: -------------------------------------------------------------------------------- 1 | data rec U = I of (U -> U) 2 | 3 | method foo (I f) = f (I f) 4 | 5 | let baz (I _) (x : U) = x.foo 6 | -------------------------------------------------------------------------------- /test/ok/ok0101_implicitParamsRecord.fram: -------------------------------------------------------------------------------- 1 | data Vec _ = { x : Unit, y : Unit } 2 | 3 | let swap (v : Vec _) = Vec { x = v.y, y = v.x } 4 | -------------------------------------------------------------------------------- /test/ok/ok0102_simpleRecord.fram: -------------------------------------------------------------------------------- 1 | data A = B | C 2 | 3 | data T = { x : A, y : A } 4 | 5 | let swap (v : T) = T { x = v.y, y = v.x } 6 | -------------------------------------------------------------------------------- /test/ok/ok0134_uvarAlias2.fram: -------------------------------------------------------------------------------- 1 | let f x = 2 | type T = _ 3 | type U = T 4 | let (a : T) = x in 5 | let (b : U) = a in 6 | b 7 | -------------------------------------------------------------------------------- /test/err/tc_0009_polymorphicOptionalArg.fram: -------------------------------------------------------------------------------- 1 | let foo {?x:{x:Int} -> Int} = x 2 | 3 | # @stderr: Optional parameters cannot be polymorphic 4 | -------------------------------------------------------------------------------- /test/err/tc_0019_effectArrow.fram: -------------------------------------------------------------------------------- 1 | data T (E : type -> effect) = T of (Unit ->[E Unit] Unit) 2 | # @stderr:1:13-26: fatal error: Effect kind 3 | -------------------------------------------------------------------------------- /test/ok/ok0011_implicit.fram: -------------------------------------------------------------------------------- 1 | parameter ~id 2 | 3 | let id = fn x => ~id (~id x) 4 | 5 | let _ = 6 | let ~id = fn y => y in 7 | id () 8 | -------------------------------------------------------------------------------- /test/ok/ok0099_nestedEffArrows.fram: -------------------------------------------------------------------------------- 1 | let foo (f : Unit ->[] Unit ->[] Unit) = f () () 2 | let foo (f : Unit ->[] ({X} -> X) -> Unit) = () 3 | -------------------------------------------------------------------------------- /test/ok/ok0121_adtsInModules.fram: -------------------------------------------------------------------------------- 1 | module M 2 | pub module N 3 | pub data T = C 4 | end 5 | end 6 | 7 | let f (C : M.N.T) = M.N.C 8 | -------------------------------------------------------------------------------- /test/err/tc_0001_escapingType.fram: -------------------------------------------------------------------------------- 1 | data T = Ex of {type X}, X 2 | 3 | let get (Ex x) = x 4 | # @stderr: Type variable 5 | # @stderr: escapes 6 | -------------------------------------------------------------------------------- /test/ok/ok0018_namePattern.fram: -------------------------------------------------------------------------------- 1 | parameter ~n 2 | 3 | let foo = fn x => ~n 4 | 5 | let _ = 6 | match () with 7 | | ~n => foo () 8 | end 9 | -------------------------------------------------------------------------------- /test/ok/ok0040_polymorphicFields.fram: -------------------------------------------------------------------------------- 1 | data I = I of ({type X} -> X -> X) 2 | 3 | let foo (I id) = id () 4 | 5 | let bar = foo (I (fn x => x)) 6 | -------------------------------------------------------------------------------- /test/ok/ok0089_pubPat.fram: -------------------------------------------------------------------------------- 1 | module M 2 | data Pair X Y = Pair of X, Y 3 | 4 | let Pair (pub x) y = Pair 42 0 5 | end 6 | 7 | let x = M.x 8 | -------------------------------------------------------------------------------- /test/ok/ok0129_recursiveADTValues.fram: -------------------------------------------------------------------------------- 1 | data Loop = Loop of (Unit ->[] Unit) 2 | 3 | let rec loop = Loop (fn () => let (Loop loop) = loop in loop ()) 4 | -------------------------------------------------------------------------------- /test/err/tc_0002_escapingType.fram: -------------------------------------------------------------------------------- 1 | data T X = Ex of {type Y}, (Y -> X) 2 | 3 | let foo (Ex f) x = f x 4 | # @stderr: Type variable 5 | # @stderr: escapes 6 | -------------------------------------------------------------------------------- /test/ok/ok0064_typeAnnot.fram: -------------------------------------------------------------------------------- 1 | data T = A 2 | 3 | let foo f = 4 | (f : ({type A} -> A -> A) -> T) (fn x => x) 5 | 6 | let _ = foo (fn id => id id A) 7 | -------------------------------------------------------------------------------- /test/err/tc_0018_nonProductiveRecDef.fram: -------------------------------------------------------------------------------- 1 | data rec T = C of T 2 | 3 | let rec x = C x 4 | 5 | # @stderr:3:1-15: error: Non-productive recursive definition 6 | -------------------------------------------------------------------------------- /test/ok/ok0019_simplePattern.fram: -------------------------------------------------------------------------------- 1 | data Col = R | G | B 2 | 3 | let rot = fn c => 4 | match c with 5 | | R => G 6 | | G => B 7 | | B => R 8 | end 9 | -------------------------------------------------------------------------------- /test/ok/ok0044_implicitCtorArgs.fram: -------------------------------------------------------------------------------- 1 | data Vec X Y = Vec of { ~x : X, ~y : Y } 2 | 3 | data Box X = Box of X 4 | 5 | let foo (Vec { ~x, ~y = Box v }) = ~x v 6 | -------------------------------------------------------------------------------- /test/ok/ok0110_publicModulePattern.fram: -------------------------------------------------------------------------------- 1 | module M 2 | data T = C of { x : Int } 3 | pub let C { module N } = C { x = 42 } 4 | end 5 | 6 | let x = M.N.x 7 | -------------------------------------------------------------------------------- /test/ok/ok0046_mutualDataRec.fram: -------------------------------------------------------------------------------- 1 | rec 2 | data Tree X = Node of X, TreeList X 3 | data TreeList X = 4 | | Nil 5 | | Cons of Tree X, TreeList X 6 | end 7 | -------------------------------------------------------------------------------- /test/ok/ok0080_moduleDef.fram: -------------------------------------------------------------------------------- 1 | module X 2 | let f x = x 3 | pub let id = f 4 | pub let x = 42 5 | end 6 | 7 | open X 8 | 9 | let z = id x 10 | -------------------------------------------------------------------------------- /test/ok/ok0130_effectfulArrow.fram: -------------------------------------------------------------------------------- 1 | 2 | data Eff E = { op : Int ->[E] Int } 3 | 4 | let foo (f : _ ->> _) = f 42 5 | 6 | let t {~e : Eff _} () = foo (~e.op) 7 | 8 | -------------------------------------------------------------------------------- /test/ok/ok0135_specialImplicits.fram: -------------------------------------------------------------------------------- 1 | let f {~__line__ : Int} () = ~__line__ 2 | let g {~__file__ : String} () = ~__file__ 3 | 4 | let _ = f () 5 | let _ = g () 6 | -------------------------------------------------------------------------------- /test/err/tc_0017_unsolvedMethodConstr.fram: -------------------------------------------------------------------------------- 1 | let foo {T, method bar : T -> Unit} = () 2 | 3 | let _ = foo 4 | 5 | # @stderr:3:9-11: error: Cannot resolve a method bar 6 | -------------------------------------------------------------------------------- /test/ok/ok0039_polymorphicImplicit.fram: -------------------------------------------------------------------------------- 1 | let foo {~id : {type X} -> X -> X} = ~id () 2 | 3 | let _ = foo {~id = fn x => x} 4 | 5 | let ~id x = x 6 | 7 | let _ = foo 8 | -------------------------------------------------------------------------------- /test/ok/ok0052_emptyMatch.fram: -------------------------------------------------------------------------------- 1 | data Empty = 2 | 3 | let ofEmpty (x : Empty) = 4 | match x with end 5 | 6 | data rec T = C of T 7 | 8 | let foo x = C (ofEmpty x) 9 | -------------------------------------------------------------------------------- /test/ok/ok0113_pureMatchingNonrecUVar.fram: -------------------------------------------------------------------------------- 1 | data T = C of _ 2 | let get (C x) = x 3 | 4 | let checkPure (f : _ -> _) = () 5 | 6 | let _ = checkPure get 7 | let _ = C () 8 | -------------------------------------------------------------------------------- /test/ok/ok0119_patternOpen.fram: -------------------------------------------------------------------------------- 1 | data T X = C of {x : X, y : X} 2 | 3 | let f (C {open, y = z}) = 4 | let x = C {x, y} 5 | let y = C {x = y, y = z} in 6 | C {open} 7 | -------------------------------------------------------------------------------- /test/ok/ok0132_typeAlias.fram: -------------------------------------------------------------------------------- 1 | type T = Int 2 | let id (x : T) = x 3 | let _ = id 42 4 | 5 | data U X = C of X 6 | let a = C 42 7 | let g (x : U T) = x 8 | let _ = g a 9 | -------------------------------------------------------------------------------- /test/ok/ok0143_sectionShadow.fram: -------------------------------------------------------------------------------- 1 | parameter ~x : Int 2 | 3 | section 4 | parameter ~x : Bool 5 | 6 | let y = ~x : Bool 7 | end 8 | 9 | let z = ~x : Int 10 | -------------------------------------------------------------------------------- /test/ok/ok0071_numbers.fram: -------------------------------------------------------------------------------- 1 | let _ = 0 2 | let _ = 0x123 3 | let _ = 0B10 4 | let _ = 42 5 | let _ = 0o555 6 | 7 | let foo (x : Int) = x 8 | 9 | let _ = foo 13 10 | -------------------------------------------------------------------------------- /test/ok/ok0104_chars.fram: -------------------------------------------------------------------------------- 1 | let _ = 'a' 2 | let _ = ''' 3 | let _ = '\n' 4 | let _ = '\t' 5 | let _ = '\\' 6 | 7 | let foo (x : Char) = x 8 | 9 | let _ = foo '1' 10 | -------------------------------------------------------------------------------- /src/DblParser/dune: -------------------------------------------------------------------------------- 1 | (ocamlyacc (modules YaccParser)) 2 | (ocamllex (modules Lexer)) 3 | 4 | (library 5 | (name dblParser) 6 | (libraries str interpLib lang utils dblConfig)) 7 | -------------------------------------------------------------------------------- /test/ok/ok0131_methodOnMethodFn.fram: -------------------------------------------------------------------------------- 1 | parameter T 2 | parameter U 3 | let (- .) {method neg : T ->[] U} (x : T) = x.neg 4 | method neg (self : Int) = self 5 | let baz = (-42).neg 6 | -------------------------------------------------------------------------------- /test/ok/ok0147_handlePure.fram: -------------------------------------------------------------------------------- 1 | data T (E : effect) = X 2 | 3 | let h = handler X end 4 | 5 | let foo (bar : {E, ~n : T E} -> Unit ->[] Unit) = 6 | handle ~n with h in bar () 7 | -------------------------------------------------------------------------------- /test/err/tc_0016_adtVisibility.fram: -------------------------------------------------------------------------------- 1 | module M 2 | pub module N 3 | pub data T = C of Int 4 | end 5 | end 6 | 7 | let foo (M.C x : M.N.T) = x 8 | 9 | # @stderr:7: 10 | -------------------------------------------------------------------------------- /test/ok/ok0015_ctor.fram: -------------------------------------------------------------------------------- 1 | data A = 2 | | A 3 | 4 | data B = 5 | | B of A 6 | 7 | data C = 8 | | C of (A -> B), A 9 | 10 | data D = 11 | | D of (A ->[] C) 12 | 13 | let _ = D (C B) 14 | -------------------------------------------------------------------------------- /test/ok/ok0029_handle.fram: -------------------------------------------------------------------------------- 1 | let f p = p 2 | 3 | parameter ~f 4 | 5 | let test f = 6 | f (~f ()) 7 | 8 | let tauto _ = 9 | handle x = effect x / r => () 10 | in test {~f=x} f 11 | -------------------------------------------------------------------------------- /test/err/tc_0015_multipleMethodInst.fram: -------------------------------------------------------------------------------- 1 | let foo {A, method m : A -> A} = 42 2 | 3 | let _ = foo {method m = fn x => x, method m = fn x => x} 4 | 5 | # @stderr: Method m is provided more than once 6 | -------------------------------------------------------------------------------- /test/ok/ok0054_firstClassHandler.fram: -------------------------------------------------------------------------------- 1 | let runH {A} h (f : {E} -> (A ->[E] A) ->[E] _) = 2 | handle x with h in 3 | f x 4 | 5 | let _ = runH (handler effect x / r => r () end) (fn op => op ()) 6 | -------------------------------------------------------------------------------- /test/ok/ok0061_returnFinallyMatch.fram: -------------------------------------------------------------------------------- 1 | data T = A | B 2 | 3 | let _ = 4 | handle x = A 5 | return A => B 6 | return B => A 7 | finally A => B 8 | finally B => A 9 | in 10 | x 11 | -------------------------------------------------------------------------------- /test/ok/ok0109_fieldPattern.fram: -------------------------------------------------------------------------------- 1 | data T = C of { S, x : Int } 2 | 3 | module M 4 | pub let C { S, x } = C { S = Unit, x = 42 } 5 | end 6 | 7 | let y = M.x 8 | 9 | let f (x : M.S) = x 10 | -------------------------------------------------------------------------------- /test/err/tc_0010_impureNonPositiveRecord.fram: -------------------------------------------------------------------------------- 1 | data rec T = { foo : T -> T } 2 | 3 | let checkPure (f : _ -> _) = () 4 | 5 | let _ = checkPure (fn (x : T) => x.foo) 6 | 7 | # @stderr::5:20-38: error: 8 | -------------------------------------------------------------------------------- /test/ok/ok0066_method.fram: -------------------------------------------------------------------------------- 1 | data Vec T = Vec of { x : T, y : T } 2 | 3 | method x self = let Vec { x } = self in x 4 | method y (Vec { y }) = y 5 | 6 | let swap (v : Vec _) = Vec { x = v.y, y = v.x } 7 | -------------------------------------------------------------------------------- /test/ok/ok0112_pureRecord.fram: -------------------------------------------------------------------------------- 1 | data Vec X = { x : X, y : X } 2 | 3 | let checkPure (f : _ -> _) = () 4 | 5 | let _ = checkPure (fn (v : Vec Unit) => v.x) 6 | let _ = checkPure (fn (v : Vec Unit) => v.y) 7 | -------------------------------------------------------------------------------- /test/ok/ok0020_patternMatch.fram: -------------------------------------------------------------------------------- 1 | data A = C1 | C2 2 | 3 | data B = X | Y of A 4 | 5 | let foo = fn x => 6 | match x with 7 | | X => C1 8 | | Y x => x 9 | end 10 | 11 | let _ = foo (Y C2) 12 | -------------------------------------------------------------------------------- /test/ok/ok0137_parameterMethod.fram: -------------------------------------------------------------------------------- 1 | parameter T 2 | parameter method foo : T -> T 3 | 4 | let bar (x : T) = x.foo 5 | 6 | parameter U 7 | parameter method foo : U -> U 8 | 9 | let baz (x : U) = bar x 10 | -------------------------------------------------------------------------------- /test/ok/ok0142_section.fram: -------------------------------------------------------------------------------- 1 | section 2 | parameter x 3 | parameter y 4 | 5 | let f g = g x y : Unit 6 | let h g = g y x : Int 7 | end 8 | 9 | let _ = f {x=(), y=()} 10 | let _ = h {x=42, y=13} 11 | -------------------------------------------------------------------------------- /test/err/tc_0012_impureExprInPureMatch.fram: -------------------------------------------------------------------------------- 1 | let foo (f : Unit ->[] Unit) = 2 | match f () with x => x end 3 | 4 | let checkPure (f : _ -> _) = () 5 | 6 | let _ = checkPure foo 7 | 8 | # @stderr::6:19-21: error: 9 | -------------------------------------------------------------------------------- /test/ok/ok0084_operators.fram: -------------------------------------------------------------------------------- 1 | let (+) = (extern dbl_addInt : Int -> Int -> Int) 2 | let (-) = (extern dbl_subInt : Int -> Int -> Int) 3 | let (- .) = (fn x => 0 - x) 4 | let x = 5 + 3 5 | let y = 5 - 3 6 | let z = -5 7 | -------------------------------------------------------------------------------- /test/err/tc_0011_nonPositiveUVar.fram: -------------------------------------------------------------------------------- 1 | data rec T = C of _ 2 | 3 | let checkPure (f : _ -> _) = () 4 | 5 | let _ = checkPure (fn (C x) => x) 6 | 7 | let _ = C (fn (C x) => C x) 8 | 9 | # @stderr::5:20-32: error: 10 | -------------------------------------------------------------------------------- /test/ok/ok0022_deepMatch.fram: -------------------------------------------------------------------------------- 1 | data A = A | T 2 | data P = P of A, A 3 | 4 | let foo = fn p => 5 | match p with 6 | | P x T => x 7 | | P T y => y 8 | | _ => A 9 | end 10 | 11 | let _ = foo (P T A) 12 | -------------------------------------------------------------------------------- /test/ok/ok0072_strings.fram: -------------------------------------------------------------------------------- 1 | let _ = "" 2 | let _ = "'" 3 | let _ = "\\" 4 | let _ = "\"" 5 | let _ = "\n" 6 | let _ = "\x13\X42" 7 | let _ = "\0\n\b\t\r\v\a\f" 8 | 9 | let foo (x : String) = x 10 | 11 | let _ = foo "42" 12 | -------------------------------------------------------------------------------- /test/err/tc_0013_ambiguousMethodInst.fram: -------------------------------------------------------------------------------- 1 | let foo {A, B, method m : A -> A, method m : B -> B} (x : A) = x.m 2 | 3 | let _ = foo {method m = fn x => x} 4 | # @stderr::3:14-33: error: 5 | # @stderr:There are more than one method named m 6 | -------------------------------------------------------------------------------- /test/ok/ok0058_unitState.fram: -------------------------------------------------------------------------------- 1 | data Unit = I 2 | 3 | data State E X = State of 4 | { get : Unit ->[E] X 5 | , put : X ->[E] Unit 6 | } 7 | 8 | let id x = x 9 | 10 | let unitStateCap = State {E = [], get = id, put = id} 11 | -------------------------------------------------------------------------------- /test/ok/ok0106_recursiveMethod.fram: -------------------------------------------------------------------------------- 1 | rec 2 | data List X = [] | (::) of X, List X 3 | 4 | method map (self : List _) f = 5 | match self with 6 | | [] => [] 7 | | x :: xs => x :: xs.map f 8 | end 9 | end 10 | -------------------------------------------------------------------------------- /src/DblParser/Lexer.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Lexer *) 6 | 7 | val reset : unit -> unit 8 | 9 | val token : Lexing.lexbuf -> YaccParser.token 10 | -------------------------------------------------------------------------------- /src/Eval/Eval.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Evaluator *) 6 | 7 | exception Runtime_error 8 | 9 | val eval_program : Lang.Untyped.program -> unit 10 | -------------------------------------------------------------------------------- /src/Lsp/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name framls) 3 | (public_name framls) 4 | (optional) 5 | (libraries 6 | yojson 7 | uri 8 | dblParser 9 | interpLib 10 | typeInference 11 | toCore 12 | effectInference)) 13 | -------------------------------------------------------------------------------- /test/ok/ok0045_recursiveData.fram: -------------------------------------------------------------------------------- 1 | data rec List X = 2 | | Nil 3 | | Cons of X, List X 4 | 5 | let tl xs = 6 | match xs with 7 | | Nil => Nil 8 | | Cons _ xs => xs 9 | end 10 | 11 | let _ = tl (Cons () (Cons () (Cons () Nil))) 12 | -------------------------------------------------------------------------------- /test/ok/ok0081_nestedModule.fram: -------------------------------------------------------------------------------- 1 | module Z 2 | pub let id x = x 3 | end 4 | 5 | module X 6 | let x = 42 7 | 8 | pub module Y 9 | pub open Z 10 | pub let x = id x 11 | end 12 | end 13 | 14 | open X.Y 15 | 16 | let y = id x 17 | -------------------------------------------------------------------------------- /test/ok/ok0097_recursion.fram: -------------------------------------------------------------------------------- 1 | data rec List A = [] | (::) of A, List A 2 | 3 | let rec map f xs = 4 | match xs with 5 | | [] => [] 6 | | x :: xs => f x :: map f xs 7 | end 8 | 9 | let _ = map (fn _ => ()) (map (fn _ => "a") [1,2,3]) 10 | -------------------------------------------------------------------------------- /test/ok/ok0118_parameter.fram: -------------------------------------------------------------------------------- 1 | parameter X 2 | parameter Y : type -> type 3 | parameter type Z 4 | parameter E : effect 5 | parameter x 6 | parameter y : Y Z 7 | parameter ?opt 8 | parameter ~named : X ->[E] Z 9 | parameter method m : X -> X ->[] Z 10 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/Kind.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on kinds *) 6 | 7 | open TypeBase 8 | 9 | let equal = kind_equal 10 | 11 | type ex = Ex : 'k kind -> ex 12 | -------------------------------------------------------------------------------- /src/Utils/Eq.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Equality of types, encoded using GADT. *) 6 | 7 | type (_, _) t = 8 | | Equal : ('a, 'a) t 9 | | NotEqual : ('a, 'b) t 10 | -------------------------------------------------------------------------------- /test/ok/ok0116_pureRecordAccessor.fram: -------------------------------------------------------------------------------- 1 | rec 2 | data A = A | B 3 | data Vec X = { x : X, y : X } 4 | end 5 | 6 | let checkPure (f : _ -> _) = () 7 | 8 | let _ = checkPure (fn (c : Vec Unit) => c.x) 9 | let _ = checkPure (fn (c : Vec Unit) => c.y) 10 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/ProofExpr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on proof expressions. *) 6 | 7 | open Syntax 8 | 9 | val subst : Subst.t -> proof_expr -> proof_expr 10 | -------------------------------------------------------------------------------- /test/ok/ok0067_pureMethod.fram: -------------------------------------------------------------------------------- 1 | data T = A 2 | data U = B 3 | 4 | method id (_ : T) = A 5 | 6 | data Pair X Y = Pair of X, Y 7 | 8 | method snd (Pair _ x) = x 9 | 10 | let poly = Pair (A).id (fn x => x) 11 | 12 | let bar = Pair (poly.snd A) (poly.snd B) 13 | -------------------------------------------------------------------------------- /test/ok/ok0087_opratorOverloading.fram: -------------------------------------------------------------------------------- 1 | method add = (extern dbl_addInt : Int -> Int -> Int) 2 | method add = (extern dbl_strCat : String -> String -> String) 3 | 4 | let (+) {T, type U, method add : T -> U} (x : T) = x.add 5 | 6 | let _ = 2 + 2 7 | let _ = "a" + "b" 8 | -------------------------------------------------------------------------------- /src/ToCore/Main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module of a translation from ConE to Core *) 6 | 7 | (** Translate program *) 8 | val tr_program : Lang.ConE.program -> Lang.Core.program 9 | -------------------------------------------------------------------------------- /test/ok/ok0114_pureTail.fram: -------------------------------------------------------------------------------- 1 | data rec List X = [] | (::) of X, List X 2 | 3 | let tail xs = 4 | match xs with 5 | | [] => [] 6 | | _ :: xs => xs 7 | end 8 | 9 | let checkPure (f : _ -> _) = () 10 | 11 | let _ = checkPure (tail : List Unit -> List Unit) 12 | -------------------------------------------------------------------------------- /test/err/tc_0014_moduleInstAfterMethod.fram: -------------------------------------------------------------------------------- 1 | module M 2 | method m (self : Int) = self 3 | end 4 | 5 | let foo {A, method m : A -> A} = 42 6 | 7 | let _ = foo {method m = fn x => x, module M} 8 | 9 | # @stderr: Cannot instantiate with a module after explicit method instantiation 10 | -------------------------------------------------------------------------------- /test/ok/ok0100_polymorphicRecursion.fram: -------------------------------------------------------------------------------- 1 | data Sqr A = (,) of A, A 2 | data rec Tree A = Leaf | Node of Tree (Sqr A) 3 | 4 | let rec map {A,B,E} (f : A ->[E] B) (t : Tree A) = 5 | match t with 6 | | Leaf => Leaf 7 | | Node t => Node (map (fn (x, y) => (f x, f y)) t) 8 | end : Tree B 9 | -------------------------------------------------------------------------------- /test/ok/ok0124_explicitMethodInst.fram: -------------------------------------------------------------------------------- 1 | data A = A 2 | data B = B 3 | 4 | module M 5 | pub method m {~n : A} (_ : A) = A 6 | pub let ~n = B 7 | end 8 | 9 | let ~n = A 10 | 11 | method m (_ : A) = B 12 | 13 | let foo {method m : A -> A} = () 14 | 15 | let _ = foo {module M} 16 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/TVar.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type variables *) 6 | 7 | include UnifCommon.TVar 8 | 9 | let fresh_eff ~scope = fresh ~scope UnifCommon.Kind.k_effect 10 | 11 | let clone_unif = clone 12 | -------------------------------------------------------------------------------- /test/ok/ok0107_polymorphicRecursion.fram: -------------------------------------------------------------------------------- 1 | data Sqr A = (,) of A, A 2 | data rec Tree A = Leaf | Node of Tree (Sqr A) 3 | 4 | method rec map {A,B} (self : Tree A) (f : A ->[_] B) = 5 | match self with 6 | | Leaf => Leaf 7 | | Node t => Node (t.map (fn (x, y) => (f x, f y))) 8 | end : Tree B 9 | -------------------------------------------------------------------------------- /test/ok/ok0033_higherKinds.fram: -------------------------------------------------------------------------------- 1 | data Option X = 2 | | None 3 | | Some of X 4 | 5 | data Pair X Y = Pair of X, Y 6 | 7 | data ST S M X = ST of (S ->[] M (Pair S X)) 8 | 9 | let run s0 (ST m) = 10 | match m s0 with 11 | | None => None 12 | | Some (Pair _ x) => Some x 13 | end 14 | -------------------------------------------------------------------------------- /src/TypeInference/Main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module of a type inference *) 6 | 7 | (** Infer types in a program and translate it to the Unif language *) 8 | val tr_program : Lang.Surface.program -> Lang.Unif.program 9 | -------------------------------------------------------------------------------- /test/ok/ok0083_pubPatternMatch.fram: -------------------------------------------------------------------------------- 1 | data P = P of Int, Int 2 | data R = R of { x : Int } 3 | 4 | module M 5 | pub let P x ~n = P 42 0 6 | pub let R { x = y } = R { x = 42 } 7 | end 8 | 9 | let x = M.x 10 | let y = M.y 11 | 12 | let foo {~n} () = ~n 13 | 14 | open M 15 | 16 | let z = foo () 17 | -------------------------------------------------------------------------------- /test/ok/ok0146_attributes.fram: -------------------------------------------------------------------------------- 1 | 2 | # no attributes 3 | let x = 10 4 | 5 | # pub 6 | pub let y = 10 7 | 8 | # empty attributes + pub 9 | @{} 10 | pub let z = 20 11 | 12 | # test ignores this statement 13 | @{test} 14 | pub let w = 20 + "sdadad" 15 | 16 | @{test a1 a2, test a3 a4 } 17 | let u = 30 18 | -------------------------------------------------------------------------------- /lib/Base/Types.fram: -------------------------------------------------------------------------------- 1 | {# This file is part of DBL, released under MIT license. 2 | # See LICENSE for details. 3 | #} 4 | 5 | pub data rec List A = [] | (::) of A, List A 6 | 7 | pub data Pair X Y = (,) of X, Y 8 | 9 | pub data Either X Y = Left of X | Right of Y 10 | 11 | pub data Result A E = Ok of A | Err of E 12 | -------------------------------------------------------------------------------- /test/ok/ok0141_explicitEffectfulFunctionInstantiation.fram: -------------------------------------------------------------------------------- 1 | data BT E = 2 | { flip : Unit ->[E] Bool 3 | , fail : {type X} -> Unit ->[E] X 4 | } 5 | 6 | let fun1 {E} (s : BT E) = 7 | s.fail () 8 | 9 | let _ = handle ~bt = BT 10 | { effect flip () / r = r True; r False 11 | , effect fail () = () 12 | } in fun1 ~bt 13 | -------------------------------------------------------------------------------- /test/stdlib/stdlib0001_Option.fram: -------------------------------------------------------------------------------- 1 | let _ = 2 | assert ((None).unwrapOr 0 == 0); 3 | assert ((Some 42).unwrapOr 0 == 42); 4 | assert ((Some 42).unwrap == 42); 5 | let ~onError () = 0 in 6 | assert ((None).unwrapErr == 0); 7 | assert ((Some 42).unwrapErr == 42); 8 | assert (Some 42 >.map (fn x => 1 + x) >.unwrapErr == 43) 9 | -------------------------------------------------------------------------------- /test/ok/ok0140_explicitFunctionInstantiation.fram: -------------------------------------------------------------------------------- 1 | data Triples X Y Z = Triple of X, Y, Z 2 | 3 | let _ = 4 | let f {type X, type Y, foo : X -> Y -> Triples X Y Y, bar : X ->[] X} x y = 5 | foo (bar x) y 6 | in 7 | match f {foo x y = (Triple x y y), bar (x : Unit) = x} () () with 8 | | Triple _ _ _ => () 9 | end 10 | -------------------------------------------------------------------------------- /test/ok/ok0128_recursiveADTValues.fram: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | data rec Nat = Z | S of Nat 3 | data Pair A B = (,) of A, B 4 | 5 | let fst (x, _) = x 6 | let snd (_, y) = y 7 | 8 | let rec p = 9 | ( (fn n => match n with Z => False | S n => fst p n end) 10 | , (fn n => match n with Z => True | S n => snd p n end) 11 | ) 12 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/Effect.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on effects *) 6 | 7 | open TypeBase 8 | 9 | let join eff1 eff2 = 10 | match eff1 with 11 | | Pure -> eff2 12 | | Impure -> Impure 13 | 14 | let joins effs = List.fold_left join Pure effs 15 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dblConfig) 3 | (modules dblConfig) 4 | (libraries unix dune-glob)) 5 | 6 | (executable 7 | (name dbl) 8 | (modes byte exe) 9 | (public_name dbl) 10 | (libraries interpLib dblParser typeInference effectInference toCore eval 11 | unix dune-glob) 12 | (modules dbl pipeline conETypeErase coreTypeErase)) 13 | -------------------------------------------------------------------------------- /test/ok/ok0074_implicitWithType.fram: -------------------------------------------------------------------------------- 1 | data State E X = State of 2 | { get : Unit ->[E] X 3 | , put : X ->[E] Unit 4 | } 5 | 6 | method get {E} (State { get } : State E _) = get 7 | method put {E} (State { put } : State E _) = put 8 | 9 | parameter State_Eff 10 | parameter ~st : State State_Eff _ 11 | 12 | let update f = ~st.put (f (~st.get ())) 13 | -------------------------------------------------------------------------------- /src/ToCore/DataType.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of datatype definitions from ConE to Core *) 6 | open Common 7 | 8 | (** Translate a list of mutually recursive datatype definitions *) 9 | val tr_data_defs : Env.t -> S.data_def list -> Env.t * T.data_def list 10 | -------------------------------------------------------------------------------- /test/ok/ok0115_purePatternMatching.fram: -------------------------------------------------------------------------------- 1 | rec 2 | data Trie X = Node of X, TrieList X 3 | data TrieList X = [] | (::) of Trie X, TrieList X 4 | end 5 | 6 | let get t = 7 | match t with 8 | | Node _ (_ :: _ :: Node _ (_ :: Node x _ :: _) :: _) => x 9 | | _ => () 10 | end 11 | 12 | let checkPure (f : _ -> _) = () 13 | 14 | let _ = checkPure get 15 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/Subst.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type substitutions *) 6 | 7 | open TypeBase 8 | 9 | type t 10 | 11 | val empty : t 12 | 13 | val singleton : 'k tvar -> 'k typ -> t 14 | 15 | val add : t -> 'k tvar -> 'k typ -> t 16 | 17 | val in_type : t -> 'k typ -> 'k typ 18 | -------------------------------------------------------------------------------- /test/ok/ok0098_mutualRecursion.fram: -------------------------------------------------------------------------------- 1 | data rec Nat = Z | S of Nat 2 | data Bool = False | True 3 | 4 | rec 5 | let odd n = 6 | match n with 7 | | Z => False 8 | | S n => even n 9 | end 10 | 11 | let even n = 12 | match n with 13 | | Z => True 14 | | S n => odd n 15 | end 16 | end 17 | 18 | let _ = even (S (S (S (S (S Z))))) 19 | -------------------------------------------------------------------------------- /test/ok/ok0094_unaryIf.fram: -------------------------------------------------------------------------------- 1 | let printStrLn = extern dbl_printStrLn : String ->[IO] Unit 2 | let printStr = extern dbl_printStr : String ->[IO] Unit 3 | 4 | data Bool = False | True 5 | 6 | let _ = 7 | if (printStr "Succ"; False) then 8 | if True 9 | then printStr "FAIL" 10 | else printStr "FAIL"; 11 | printStrLn "ess!" 12 | 13 | # @stdout:Success! 14 | -------------------------------------------------------------------------------- /test/ok/ok0055_complexHandlers.fram: -------------------------------------------------------------------------------- 1 | data Unit = I 2 | 3 | data State E X = State of 4 | { get : Unit ->[E] X 5 | , put : X ->[E] Unit 6 | } 7 | 8 | let hState s = 9 | handler 10 | State 11 | { get = effect I / r => fn s => r s s 12 | , put = effect s / r => fn _ => r I s 13 | } 14 | return x => fn _ => x 15 | finally f => f s 16 | end 17 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.11) 2 | (name dbl) 3 | 4 | (generate_opam_files true) 5 | 6 | (source (github fram-lang/dbl)) 7 | (license MIT) 8 | 9 | (package 10 | (name dbl) 11 | (synopsis "Interpreter of Fram: a language with algebraic effects and powerful named parameters") 12 | (description "") 13 | (depends 14 | (dune (>= 3.11)) 15 | (dune-glob (>= 3.7.0)))) 16 | -------------------------------------------------------------------------------- /src/TypeInference/ConstrSolve.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Constraint solving. *) 6 | 7 | (** Solve only those constraints that concern concrete types. *) 8 | val solve_partial : Constr.t list -> Constr.t list 9 | 10 | (** Try to solve all constraints *) 11 | val solve_all : Constr.t list -> unit 12 | -------------------------------------------------------------------------------- /src/Utils/SyntaxNode.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Node of the abstract syntax tree *) 6 | 7 | type 'a node = { 8 | pos : Position.t; 9 | data : 'a 10 | } 11 | 12 | module Export = struct 13 | type nonrec 'a node = 'a node = { 14 | pos : Position.t; 15 | data : 'a 16 | } 17 | end 18 | -------------------------------------------------------------------------------- /test/ok/ok0051_existentialTypePattern.fram: -------------------------------------------------------------------------------- 1 | data Pair X Y = Pair of X, Y 2 | 3 | data Stream X = Stream of {St}, St, (St ->[] Pair X St) 4 | 5 | let fst (Pair x _) = x 6 | let snd (Pair _ y) = y 7 | 8 | let head (Stream {St} (st : St) f) = fst (f st) 9 | 10 | let suffixes {X=Z} (Stream {St=X} st f) = 11 | Stream {St=X,X=Stream Z} st (fn st => Pair (Stream st f) (snd (f st))) 12 | -------------------------------------------------------------------------------- /test/ok/ok0090_lists.fram: -------------------------------------------------------------------------------- 1 | data rec List X = [] | (::) of X, List X 2 | 3 | let tl xs = 4 | match xs with 5 | | [] => [] 6 | | _ :: xs => xs 7 | end 8 | 9 | let swap_if_two xs = 10 | match xs with 11 | | [x,y] => [y,x] 12 | | _ => xs 13 | end 14 | 15 | let dup_hd xs = 16 | match xs with 17 | | [] => [] 18 | | (::) x xs => x :: x :: xs 19 | end 20 | -------------------------------------------------------------------------------- /test/ok/ok0136_stringInterpolation.fram: -------------------------------------------------------------------------------- 1 | data rec List A = [] | (::) of A, List A 2 | 3 | data UnitFmt = UnitFmt of { ?unit : String } 4 | 5 | method toString {?prec : Int, ?fmt : UnitFmt} () = 6 | match fmt with 7 | | Some (UnitFmt {unit=Some name}) => name 8 | | _ => "()" 9 | end 10 | 11 | let _ = "unformatted \{ () }" 12 | let _ = "formatted \{ () | UnitFmt {unit="UNIT"}}" 13 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/SExprPrinter.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translating ConE to S-expressions *) 6 | 7 | open TypeBase 8 | open Syntax 9 | 10 | val tr_type : typ -> SExpr.t 11 | 12 | val tr_scheme : scheme -> SExpr.t 13 | 14 | val tr_constr : constr -> SExpr.t 15 | 16 | val tr_program : program -> SExpr.t 17 | -------------------------------------------------------------------------------- /src/Utils/UID.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Unique identifier *) 6 | 7 | type t = int 8 | 9 | let compare = Int.compare 10 | 11 | let next_fresh = ref 0 12 | let fresh () = 13 | let x = !next_fresh in 14 | next_fresh := x + 1; 15 | x 16 | 17 | let to_string x = Printf.sprintf "#%x" x 18 | 19 | module Map = Map.Make(Int) 20 | -------------------------------------------------------------------------------- /test/ok/ok0060_returnFinally.fram: -------------------------------------------------------------------------------- 1 | data Unit = I 2 | 3 | data State E X = State of 4 | { get : Unit ->[E] X 5 | , put : X ->[E] Unit 6 | } 7 | 8 | let hState (comp : {E} -> State E _ ->[E,_] _) initSt = 9 | handle st = State 10 | { get = effect I / r => fn s => r s s 11 | , put = effect s / r => fn _ => r I s 12 | } 13 | return x => fn _ => x 14 | finally f => f initSt 15 | in 16 | comp st 17 | -------------------------------------------------------------------------------- /test/ok/ok0082_moduleDataDef.fram: -------------------------------------------------------------------------------- 1 | module X 2 | pub data T = C 3 | pub data rec N = Z | S of N 4 | pub data P = P of T, T 5 | pub data R = R of { l : T } 6 | 7 | pub let id x = x 8 | end 9 | 10 | let f1 (C : X.T) = () 11 | let f2 X.C = () 12 | 13 | let X.C = X.id X.C 14 | let X.P x y = X.P X.C X.C 15 | 16 | let r = X.R { l = X.C } 17 | 18 | open X 19 | 20 | let g C = C 21 | 22 | let s (n : N) = S n 23 | -------------------------------------------------------------------------------- /src/DblParser/Attributes.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Attribute handlers. *) 6 | 7 | (** Resolves attributes for given definition list. *) 8 | val tr_attrs : 9 | Raw.attribute list -> Lang.Surface.def list -> Lang.Surface.def list 10 | 11 | (** Makes pattern public. *) 12 | val make_vis_pattern : Lang.Surface.pattern -> Lang.Surface.pattern 13 | -------------------------------------------------------------------------------- /src/DblParser/File.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Parse a single file with no handling of imports *) 6 | 7 | type fname = string 8 | type def_list = Lang.Surface.def list Lang.Surface.node 9 | 10 | (** Parse a single source file into a list of imports and definitions. *) 11 | val parse_defs : ?pos:Position.t -> fname -> Raw.import list * def_list 12 | -------------------------------------------------------------------------------- /src/DblParser/Main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module of the parser *) 6 | 7 | (** File name *) 8 | type fname = string 9 | 10 | (** Parse single source file *) 11 | val parse_file : 12 | ?pos:Position.t -> use_prelude:bool -> fname -> Lang.Surface.program 13 | 14 | (** REPL program *) 15 | val repl : use_prelude:bool -> Lang.Surface.program 16 | -------------------------------------------------------------------------------- /test/ok/ok0070_effectMethodArg.fram: -------------------------------------------------------------------------------- 1 | data State (E : effect) X = State of 2 | { get : Unit ->[E] X 3 | , put : X ->[E] Unit 4 | } 5 | 6 | method get {E} (State { get } : State E _) = get 7 | method put {E} (State { put } : State E _) = put 8 | 9 | method update {E} (self : State E _) f = 10 | self.put (f (self.get ())) 11 | 12 | method updateTwice {E} (self : State E _) f = 13 | let _ = self.update f in 14 | self.update f 15 | -------------------------------------------------------------------------------- /test/ok/ok0092_multipleNamedMethodParams.fram: -------------------------------------------------------------------------------- 1 | data Pair A B = (,) of A, B 2 | 3 | let (+) = (extern dbl_strCat : String -> String -> String) 4 | 5 | method toString = (extern dbl_intToString : Int -> String) 6 | 7 | method toString {A, B} 8 | {method toString : A ->[] String} 9 | {method toString : B ->[] String} 10 | ((x : A), (y : B)) = 11 | "(" + x.toString + "," + y.toString + ")" 12 | 13 | let _ = (13, 42).toString 14 | -------------------------------------------------------------------------------- /src/Utils/SExpr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** S-expressions *) 6 | 7 | (** Type of S-expressions *) 8 | type t = 9 | | Sym of string 10 | | Num of int 11 | | List of t list 12 | 13 | (** Pretty-print S-expression to stdout *) 14 | val pretty_stdout : t -> unit 15 | 16 | (** Pretty-print S-expression to stdout *) 17 | val pretty_stderr : t -> unit 18 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags -w +9))) 4 | 5 | ; This is needed to make the language server optional 6 | ; Now, running `dune build` is equivalent to `dune build @install` instead of `dune build @all` 7 | ; If something doesn't build as expected, this might be the reason 8 | (alias 9 | (name default) 10 | (deps 11 | (alias install))) 12 | 13 | (install 14 | (section lib) 15 | (files (glob_files_rec (lib/*.fram with_prefix stdlib)))) 16 | -------------------------------------------------------------------------------- /test/ok/ok0075_effectsFromImplicits.fram: -------------------------------------------------------------------------------- 1 | data StateSig E X = State of 2 | { get : Unit ->[E] X 3 | , put : X ->[E] Unit 4 | } 5 | 6 | method get {State} (State { get } : StateSig State _) = get 7 | method put {State} (State { put } : StateSig State _) = put 8 | 9 | parameter State 10 | parameter ~st : StateSig State _ 11 | 12 | let update f = 13 | ~st.put (f (~st.get ())) 14 | 15 | let updateTwice f = 16 | let _ = update f in 17 | update f 18 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/ProofExpr.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on proof expressions. *) 6 | 7 | open Syntax 8 | 9 | let subst sub (e : proof_expr) = 10 | match e with 11 | | PE_Unit -> PE_Unit 12 | | PE_Bool -> PE_Bool 13 | | PE_Option tp -> PE_Option (Subst.in_type sub tp) 14 | | PE_Var(x, tps) -> PE_Var(x, List.map (Subst.in_type sub) tps) 15 | -------------------------------------------------------------------------------- /src/EffectInference/ConstrSet.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Mutable sets of constraints *) 6 | 7 | type t = Constr.t list BRef.t 8 | 9 | let create () = BRef.create [] 10 | 11 | let add cset c = BRef.set cset (c :: BRef.get cset) 12 | 13 | let add_list cset cs = BRef.set cset (cs @ BRef.get cset) 14 | 15 | let to_list cset = BRef.get cset 16 | 17 | let clear cset = BRef.set cset [] 18 | -------------------------------------------------------------------------------- /src/EffectInference/Main.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** The main module of the effect inference *) 6 | 7 | open Common 8 | 9 | let tr_program ~solve_all p = 10 | let env = Env.initial ~solve_all () in 11 | let (e, Checked) = 12 | Expr.check_type env p 13 | (T.Type.t_var T.BuiltinType.tv_unit) 14 | (Check T.CEffect.prog_effect) in 15 | ConstrSolver.final_solve env; 16 | e 17 | -------------------------------------------------------------------------------- /test/ok/ok0056_complexHandlers.fram: -------------------------------------------------------------------------------- 1 | data Unit = I 2 | 3 | data State E X = State of 4 | { get : Unit ->[E] X 5 | , put : X ->[E] Unit 6 | , update : (X ->[E] X) ->[E] Unit 7 | } 8 | 9 | let hState s = 10 | handler 11 | let get I = effect / r => fn s => r s s 12 | let put s = effect / r => fn s => r I s 13 | let update f = put (f (get I)) 14 | in 15 | State { get, put, update } 16 | return x => fn _ => x 17 | finally f => f s 18 | end 19 | -------------------------------------------------------------------------------- /src/EffectInference/Main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** The main module of the effect inference *) 6 | 7 | (** The main function of the translation. The [solve_all] flag indicates the 8 | behavior of the constraint solving: when set all constraints are solved. 9 | Otherwise, it only checks if constraints are solvable. *) 10 | val tr_program : solve_all:bool -> Lang.Unif.program -> Lang.ConE.program 11 | -------------------------------------------------------------------------------- /src/Utils/UID.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Unique identifier *) 6 | 7 | type t = private int 8 | 9 | (** Comparator *) 10 | val compare : t -> t -> int 11 | 12 | (** Generate fresh identifier *) 13 | val fresh : unit -> t 14 | 15 | (** Return a string that uniquely identify the UID *) 16 | val to_string : t -> string 17 | 18 | (** Finite maps from UIDs *) 19 | module Map : Map.S with type key = t 20 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/ConstrSet.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Set of constraints *) 6 | 7 | open TypeBase 8 | 9 | type t 10 | 11 | (** Empty set of constraints *) 12 | val empty : t 13 | 14 | (** Add a list of constraints to the set *) 15 | val add_list : t -> constr list -> t 16 | 17 | (** Get the list of upper bounds for a given effect variable *) 18 | val upper_bounds : t -> keffect tvar -> effct list 19 | -------------------------------------------------------------------------------- /test/ok/ok0057_dataArgLabels.fram: -------------------------------------------------------------------------------- 1 | data Unit = I 2 | 3 | data State E (type T) = State of 4 | { get : Unit ->[E] T 5 | , put : T ->[E] Unit 6 | , update : {F} -> (T ->[E,F] T) ->[E,F] Unit 7 | } 8 | 9 | let hState s = 10 | handler 11 | let get I = effect / r => fn s => r s s 12 | let put s = effect / r => fn s => r I s 13 | let update f = put (f (get I)) 14 | in 15 | State { get, put, update } 16 | return x => fn _ => x 17 | finally f => f s 18 | end 19 | -------------------------------------------------------------------------------- /test/ok/ok0122_reexportedMethods.fram: -------------------------------------------------------------------------------- 1 | data A = A 2 | data B = B 3 | data C = C 4 | 5 | method m (_ : A) = A 6 | method m (_ : B) = A 7 | 8 | module M 9 | let _ = (A).m : A 10 | pub method m (_ : A) = B 11 | pub method m (_ : B) = B 12 | module N 13 | let _ = (A).m : B 14 | pub method m (_ : A) = C 15 | let _ = (A).m : C 16 | end 17 | let _ = (A).m : C 18 | pub module O 19 | pub method m (_ : B) = C 20 | end 21 | end 22 | let _ = (A).m : B 23 | let _ = (B).m : C 24 | -------------------------------------------------------------------------------- /src/Lang/Core.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Core Language. *) 6 | 7 | include CorePriv.TypeBase 8 | include CorePriv.Syntax 9 | 10 | module Kind = CorePriv.Kind 11 | module Type = CorePriv.Type 12 | module Effect = CorePriv.Effect 13 | module BuiltinType = CorePriv.BuiltinType 14 | 15 | let to_sexpr = CorePriv.SExprPrinter.tr_program 16 | let check_well_typed = CorePriv.WellTypedInvariant.check_program 17 | -------------------------------------------------------------------------------- /.github/workflows/Test.yml: -------------------------------------------------------------------------------- 1 | name: Run tests 2 | 3 | on: 4 | push: 5 | pull_request: 6 | 7 | jobs: 8 | test: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v4 12 | - uses: ocaml/setup-ocaml@v3 13 | with: 14 | ocaml-compiler: 5.3.0 15 | - run: opam install dune yojson uri dune-glob 16 | - run: opam exec -- dune build 17 | - run: opam exec -- dune install 18 | - run: eval $(opam env) && ./test.sh dbl ./test/test_suite 19 | 20 | -------------------------------------------------------------------------------- /src/EffectInference/DataType.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of datatype definitions. *) 6 | 7 | open Common 8 | 9 | (** Translate datatype definitions and add them to the environment. Returns the 10 | updated environment, the translated datatype definitions, and the list of type 11 | variables that were introduced. *) 12 | val tr_data_defs : 13 | Env.t -> S.data_def list -> Env.t * T.data_def list * T.tvar list 14 | -------------------------------------------------------------------------------- /src/TypeInference/Inst.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type-checking of explicit instantiations *) 6 | 7 | open Common 8 | open BiDirectional 9 | open TypeCheckFix 10 | 11 | (** Instantiate polymorphic expression of given scheme by providing the 12 | explicit instantiation. *) 13 | val instantiate_poly_expr : tcfix:tcfix -> 14 | pos:Position.t -> 'st Env.t -> T.poly_expr -> T.scheme -> S.inst list -> 15 | infer expr_result 16 | -------------------------------------------------------------------------------- /src/TypeInference/ParamCycleDetect.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Detection of cycles in named parameter resolution. *) 6 | 7 | type t = int Var.Map.t 8 | 9 | let empty = Var.Map.empty 10 | 11 | let add_var pcyc ?(size=0) x = 12 | match Var.Map.find_opt x pcyc with 13 | | None -> Some (Var.Map.add x size pcyc) 14 | | Some old_size when size < old_size -> 15 | Some (Var.Map.add x size pcyc) 16 | | Some _ -> 17 | None 18 | -------------------------------------------------------------------------------- /test/ok/ok0111_optionalParams.fram: -------------------------------------------------------------------------------- 1 | pub method add = (extern dbl_addInt : Int -> Int -> Int) 2 | pub let (+) {T, type U, method add : T -> U} (x : T) = x.add 3 | 4 | let f {?x} = x 5 | let a = f 6 | let b = f {x=2} 7 | 8 | let g {?x : Int} () = 9 | match x with 10 | | Some n => n + 2 11 | | None => 42 12 | end 13 | let c = g () 14 | let d = g {x=2} () 15 | let e = g {?x = Some 2} () 16 | 17 | let h {?x} () = 18 | match x with 19 | | Some n => n 20 | | None => None 21 | end 22 | 23 | let a = h {x=Some 2} 24 | -------------------------------------------------------------------------------- /test/ok/ok0123_explicitMethodInst.fram: -------------------------------------------------------------------------------- 1 | data A = A 2 | data B = B 3 | data C = C 4 | data D = D 5 | 6 | let foo 7 | { method m : A -> A 8 | , method m : B -> B 9 | , method m : C -> C 10 | , method mm : D -> D 11 | } = () 12 | 13 | module M 14 | pub method m (_ : A) = A 15 | end 16 | 17 | module N 18 | pub method m (_ : A) = B 19 | pub method m (_ : B) = B 20 | end 21 | 22 | method m (_ : A) = C 23 | method m (_ : B) = C 24 | method m (_ : C) = C 25 | 26 | let _ = foo {module N, module M, method mm = fn x => x} 27 | -------------------------------------------------------------------------------- /test/ok/ok0144_sizedMethodResolve.fram: -------------------------------------------------------------------------------- 1 | data B X = B of X 2 | data P X Y = P of X, Y 3 | 4 | data rec Shape = 5 | | SU 6 | | SB of Shape 7 | | SP of Shape, Shape 8 | 9 | method shape () = SU 10 | method shape {X, method shape : X -> Shape} (B (x : X)) = 11 | SB x.shape 12 | method shape 13 | { X, Y 14 | , method shape : X -> Shape 15 | , method shape : Y -> Shape 16 | } (P (x : X) (y : Y)) = 17 | SP x.shape y.shape 18 | 19 | let _ = 20 | (P (P (P (B (B ())) (B (P () ()))) (B (P () (B (P () ()))))) ()).shape 21 | -------------------------------------------------------------------------------- /src/Lsp/Connection.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Base HTTP-like protocol *) 6 | 7 | (** An exception indicating a problem with the connection, 8 | e.g. unexpected EOF or invalid headers *) 9 | exception Connection_error of string 10 | 11 | (** Receive a message from the client *) 12 | val receive_string : in_channel -> string 13 | 14 | (** Send a message with the specified content to the client *) 15 | val send_string : out_channel -> string -> unit 16 | -------------------------------------------------------------------------------- /src/EffectInference/ProofExpr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of ADT-shape proof expressions. *) 6 | 7 | open Common 8 | 9 | (** Translate a proof expression to a computationally irrelevant expression. 10 | Returns the translated expression, the type of the ADT, the list of its 11 | constructors, and the effect of pattern-matching on this ADT. *) 12 | val tr_proof_expr : 13 | Env.t -> S.proof_expr -> T.expr * T.typ * T.ctor_decl list * T.ceffect 14 | -------------------------------------------------------------------------------- /src/TypeInference/Constr.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Constraints generated during type inference *) 6 | 7 | open Common 8 | 9 | type t = 10 | | ResolveMethod : { 11 | hole : T.poly_fun option BRef.t; 12 | pcyc : ParamCycleDetect.t; 13 | pos : Position.t; 14 | env : 'st Env.t; 15 | method_env : 'st Env.t; 16 | self_tp : T.typ; 17 | mname : S.method_name; 18 | sch : T.scheme; 19 | } -> t 20 | -------------------------------------------------------------------------------- /test/ok/ok0139_nestedHandlers.fram: -------------------------------------------------------------------------------- 1 | let printStrLn = extern dbl_printStrLn : String ->[IO] Unit 2 | let addInt = extern dbl_addInt : Int -> Int -> Int 3 | method toString = (extern dbl_intToString : Int -> String) 4 | 5 | data Reader E X = { 6 | ask : Unit ->[E] X 7 | } 8 | 9 | let hReader init = 10 | handler Reader 11 | { ask = effect () / r => r init 12 | } 13 | end 14 | 15 | let (res : Int) = 16 | handle r1 with hReader 1 in 17 | handle r2 with hReader 5 in 18 | addInt (r1.ask ()) (r2.ask ()) 19 | 20 | let _ = printStrLn res.toString 21 | # @stdout:6 22 | 23 | -------------------------------------------------------------------------------- /src/EffectInference/ConstrSet.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Mutable sets of constraints *) 6 | 7 | type t 8 | 9 | (** Create a new empty set *) 10 | val create : unit -> t 11 | 12 | (** Add a constraint to the set *) 13 | val add : t -> Constr.t -> unit 14 | 15 | (** Add a list of constraints to the set *) 16 | val add_list : t -> Constr.t list -> unit 17 | 18 | (** Convert the set to a list *) 19 | val to_list : t -> Constr.t list 20 | 21 | (** Clear the set of constraints *) 22 | val clear : t -> unit 23 | -------------------------------------------------------------------------------- /src/EffectInference/Type.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of types and related constructs. *) 6 | 7 | open Common 8 | 9 | (** Translate a type *) 10 | val tr_type : Env.t -> S.typ -> T.typ 11 | 12 | (** Translate a type expression *) 13 | val tr_type_expr : Env.t -> S.type_expr -> T.typ 14 | 15 | (** Translate a scheme expression *) 16 | val tr_scheme_expr : Env.t -> S.scheme_expr -> T.scheme 17 | 18 | (** Translate a named scheme expression *) 19 | val tr_named_scheme_expr : Env.t -> S.named_scheme_expr -> T.named_scheme 20 | -------------------------------------------------------------------------------- /src/TypeInference/ReplUtils.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Utility functions related to the REPL. *) 6 | 7 | open Common 8 | open BiDirectional 9 | open TypeCheckFix 10 | 11 | (** Build an expression that evaluates to the function converting a value 12 | of given type to its string representation. It tries to use [show] 13 | method if available; otherwise, it falls back to default conversion, 14 | relying on an external function. *) 15 | val show_expr : tcfix:tcfix -> pos:Position.t -> 16 | 'st Env.t -> T.typ -> infer expr_result 17 | -------------------------------------------------------------------------------- /src/Utils/Var.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Generic variable representation. *) 6 | 7 | module Ordered = struct 8 | type t = { 9 | uid : UID.t; 10 | name : string 11 | } 12 | 13 | let compare x y = UID.compare x.uid y.uid 14 | end 15 | include Ordered 16 | 17 | let fresh ?(name="x") () = 18 | { uid = UID.fresh () 19 | ; name = name 20 | } 21 | 22 | let unique_name x = 23 | x.name ^ UID.to_string x.uid 24 | 25 | let equal x y = x == y 26 | 27 | module Set = Set.Make(Ordered) 28 | module Map = Map.Make(Ordered) 29 | -------------------------------------------------------------------------------- /src/ToCore/Type.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of types *) 6 | 7 | open Common 8 | 9 | (** Translate a computation effect *) 10 | val tr_ceffect : Env.t -> S.ceffect -> T.effct 11 | 12 | (** Translate a type *) 13 | val tr_type : Env.t -> S.typ -> T.Type.ex 14 | 15 | (** Translate a type of type kind *) 16 | val tr_ttype : Env.t -> S.typ -> T.ttype 17 | 18 | (** Translate a type scheme *) 19 | val tr_scheme : Env.t -> S.scheme -> T.ttype 20 | 21 | (** Translate a constraint *) 22 | val tr_constr : Env.t -> S.constr -> T.constr 23 | -------------------------------------------------------------------------------- /src/EffectInference/Constr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Effect constraints *) 6 | 7 | open Common 8 | 9 | (** Constraints *) 10 | type t = 11 | | CSubeffect of origin * T.effct * T.effct 12 | (** Subeffect constraint. *) 13 | 14 | (** Collect all generalizable variables that do not belong to the given 15 | (outer) scope and add them to the given set. *) 16 | val collect_gvars : 17 | outer_scope:Scope.t -> t list -> T.GVar.Set.t -> T.GVar.Set.t 18 | 19 | (** Pretty-print constraint as S-expression *) 20 | val to_sexpr : t -> SExpr.t 21 | -------------------------------------------------------------------------------- /src/EffectInference/Expr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of expressions *) 6 | 7 | open Common 8 | 9 | (** Infer type of the expression. Effect-checking is in the bidirectional 10 | style. *) 11 | val infer_type : 12 | Env.t -> S.expr -> (T.ceffect, 'ed) request -> 13 | T.expr * T.typ * (T.ceffect, 'ed) response 14 | 15 | (** Check the type of the expression. Effect-checking is in the bidirectional 16 | style. *) 17 | val check_type : 18 | Env.t -> S.expr -> T.typ -> (T.ceffect, 'ed) request -> 19 | T.expr * (T.ceffect, 'ed) response 20 | -------------------------------------------------------------------------------- /test/ok/ok0086_optionState.fram: -------------------------------------------------------------------------------- 1 | data State E X = State of 2 | { get : Unit ->[E] X 3 | , put : X ->[E] Unit 4 | } 5 | 6 | parameter E_st 7 | parameter ~st : State E_st _ 8 | 9 | let get x = 10 | let (State { get }) = ~st in 11 | get x 12 | 13 | let put x = 14 | let (State { put }) = ~st in 15 | put x 16 | 17 | handle ~st = 18 | let get = effect x / r => fn s => r s s 19 | let put = effect s / r => fn _ => r () s 20 | in State { get, put } 21 | return x => fn _ => x 22 | finally c => c None 23 | 24 | let putSome f = 25 | put (Some f) 26 | 27 | let _ = 28 | match get () with 29 | | None => () 30 | | Some f => f () 31 | end 32 | -------------------------------------------------------------------------------- /src/Lsp/JsonRpc.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main loop. Get a message, handle it, send response. *) 6 | 7 | open Message 8 | 9 | (** Send a notification to the client *) 10 | val send_notification : State.t -> server_notification -> unit 11 | 12 | (** Main loop of the server. The fuction expects: 13 | - the initial state 14 | - a handler for requests 15 | - a handler for notifications *) 16 | val run : 17 | State.t -> 18 | (State.t -> request -> State.t * (server_result, response_error) result) -> 19 | (State.t -> client_notification -> State.t) -> 20 | 'bottom 21 | 22 | -------------------------------------------------------------------------------- /src/EffectInference/Error.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Reporting errors related to effect-inference *) 6 | 7 | open Common 8 | 9 | (** Abstract representation of errors *) 10 | type t 11 | 12 | (** Report fatal error and abort the compilation *) 13 | val fatal : t -> 'a 14 | 15 | (** Report a warning. *) 16 | val warn : t -> unit 17 | 18 | val escaping_effect_var : origin:origin -> T.tvar -> t 19 | 20 | val non_exhaustive_match : pos:Position.t -> PatternContext.ctx -> t 21 | 22 | val unused_pattern : pos:Position.t -> t 23 | 24 | val unsolved_unification_variable : pos:Position.t -> t 25 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/CtorDecl.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on constructor declarations *) 6 | 7 | open TypeBase 8 | 9 | let collect_gvars ~outer_scope ctor gvs = 10 | let { ctor_name = _; ctor_targs = _; ctor_named; ctor_arg_schemes } = ctor 11 | in 12 | let gvs = 13 | List.fold_left 14 | (fun gvs (_, sch) -> Type.collect_scheme_gvars ~outer_scope sch gvs) 15 | gvs 16 | ctor_named 17 | in 18 | List.fold_left 19 | (fun gvs sch -> Type.collect_scheme_gvars ~outer_scope sch gvs) 20 | gvs 21 | ctor_arg_schemes 22 | 23 | let subst = Subst.in_ctor_decl 24 | -------------------------------------------------------------------------------- /src/EffectInference/ConstrSimplify.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Constraint simplification before generalization *) 6 | 7 | open Common 8 | 9 | (** Simplify the set of constraints. The [outer_scope] is an outer scope of 10 | the place of the generalization. Variables in [pgvs] are those that appear 11 | on non-negative positions, and therefore cannot be promoted to supereffects. 12 | Dually, [ngvs] appears on non-positive positions, so cannot be downgraded 13 | to subeffects. *) 14 | val simplify : 15 | outer_scope:Scope.t -> pgvs:T.GVar.Set.t -> ngvs:T.GVar.Set.t -> 16 | Constr.t list -> Constr.t list 17 | -------------------------------------------------------------------------------- /src/Lang/UnifCommon/Names.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Names of types and values. *) 6 | 7 | (** Name of a named type parameter *) 8 | type tname = 9 | | TNAnon 10 | (** Anonymous parameter *) 11 | 12 | | TNVar of string 13 | (** Regular named type parameter *) 14 | 15 | (** Name of a named parameter *) 16 | type name = 17 | | NVar of string 18 | (** Regular named parameter *) 19 | 20 | | NOptionalVar of string 21 | (** Optional named parameter *) 22 | 23 | | NImplicit of string 24 | (** Implicit parameter *) 25 | 26 | | NMethod of string 27 | (** Name of methods **) 28 | -------------------------------------------------------------------------------- /test/stdlib/stdlib0005_ToString.fram: -------------------------------------------------------------------------------- 1 | # Bool 2 | let _ = 3 | assert ((True).toString == "True"); 4 | assert ((False).toString == "False") 5 | 6 | # String 7 | let _ = 8 | assert ("abc".toString == "abc"); 9 | assert ("".toString == ""); 10 | assert ("\n".toString == "\n") 11 | 12 | # Char 13 | let _ = 14 | assert (' '.toString == " "); 15 | assert ('a'.toString == "a"); 16 | assert ('\n'.toString == "\n") 17 | 18 | # Int 19 | let _ = 20 | assert (10.toString == "10"); 21 | assert (0.toString == "0"); 22 | assert ((-1).toString == "-1") 23 | 24 | # Int64 25 | let _ = 26 | assert (10L.toString == "10"); 27 | assert (0L.toString == "0"); 28 | assert ((-1L).toString == "-1") 29 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/CEffect.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Computation effects with distinguished purity *) 6 | 7 | type t = 8 | | Pure 9 | | Impure of Effct.t 10 | 11 | (** Expected effect of the whole program *) 12 | val prog_effect : t 13 | 14 | (** Join two computation effects. *) 15 | val join : t -> t -> t 16 | 17 | (** Collect all generalizable variables that do not belong to the given 18 | (outer) scope and add them to the given set. *) 19 | val collect_gvars : 20 | outer_scope:Scope.t -> t -> Effct.GVar.Set.t -> Effct.GVar.Set.t 21 | 22 | (** Pretty-print effect as S-expression *) 23 | val to_sexpr : t -> SExpr.t 24 | -------------------------------------------------------------------------------- /src/TypeInference/Expr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type-inference for expressions and related syntactic categories *) 6 | 7 | open Common 8 | open BiDirectional 9 | open TypeCheckFix 10 | 11 | (** Infer the type of an expression. When the expression is applied to some 12 | arguments, the [?app_type] parameter, if provided, specifies the type of 13 | the application. *) 14 | val infer_expr_type : tcfix:tcfix -> ?app_type:T.typ -> 15 | 'st Env.t -> S.expr -> infer expr_result 16 | 17 | (** Check the type of an expression. *) 18 | val check_expr_type : tcfix:tcfix -> 19 | 'st Env.t -> S.expr -> T.typ -> check expr_result 20 | -------------------------------------------------------------------------------- /test/ok/ok0030_bt.fram: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | let not b = 4 | match b with 5 | | True => False 6 | | False => True 7 | end 8 | 9 | let band b1 b2 = 10 | match b1 with 11 | | True => b2 12 | | False => False 13 | end 14 | 15 | let bor b1 b2 = not (band (not b1) (not b2)) 16 | 17 | let iff b1 b2 = 18 | match b1 with 19 | | True => b2 20 | | False => not b2 21 | end 22 | 23 | let form p q r = 24 | iff (band p (bor q r)) (bor (band p q) (band p r)) 25 | 26 | parameter ~flip 27 | 28 | let test f = 29 | f (~flip ()) (~flip ()) (~flip ()) 30 | 31 | let tauto _ = 32 | handle ~flip = effect x / r => band (r True) (r False) 33 | in test form 34 | 35 | let _ = tauto () 36 | -------------------------------------------------------------------------------- /lib/Base/Bool.fram: -------------------------------------------------------------------------------- 1 | {# This file is part of DBL, released under MIT license. 2 | # See LICENSE for details. 3 | #} 4 | 5 | import open Types 6 | 7 | pub method toString {?fmt : Unit} self = if self then "True" else "False" 8 | 9 | pub method neg self = 10 | if self then False else True 11 | 12 | pub method equal self (oth : Bool) = 13 | if self then oth else oth.neg 14 | 15 | pub method neq self (oth : Bool) = 16 | if self then oth.neg else oth 17 | 18 | pub method gt self (oth : Bool) = 19 | self && oth.neg 20 | 21 | pub method lt (self : Bool) oth = 22 | self.neg && oth 23 | 24 | pub method ge self (oth : Bool) = 25 | self || oth.neg 26 | 27 | pub method le (self : Bool) oth = 28 | self.neg || oth 29 | -------------------------------------------------------------------------------- /src/Pipeline.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Pipeline of the compiler *) 6 | 7 | (** Dump internal ConE representation if this flag is set. *) 8 | val dump_cone : bool ref 9 | 10 | (** Dump internal Core representation if this flag is set. *) 11 | val dump_core : bool ref 12 | 13 | (** Include the prelude only if this flag is set. *) 14 | val use_prelude : bool ref 15 | 16 | (** Include the standard library only if this flag is set. *) 17 | val use_stdlib : bool ref 18 | 19 | (** Run in REPL mode *) 20 | val run_repl : unit -> unit 21 | 22 | (** Run single file as a program. It takes file path as a parameter. *) 23 | val run_file : string -> unit 24 | -------------------------------------------------------------------------------- /src/EffectInference/Constr.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Effect constraints *) 6 | 7 | open Common 8 | 9 | type t = 10 | | CSubeffect of origin * T.effct * T.effct 11 | 12 | let to_sexpr (CSubeffect(_, eff1, eff2)) = 13 | SExpr.List [T.Effct.to_sexpr eff1; Sym "<:"; T.Effct.to_sexpr eff2] 14 | 15 | let collect_constr_gvars ~outer_scope c gvs = 16 | match c with 17 | | CSubeffect(_, eff1, eff2) -> 18 | gvs 19 | |> T.Effct.collect_gvars ~outer_scope eff1 20 | |> T.Effct.collect_gvars ~outer_scope eff2 21 | 22 | let collect_gvars ~outer_scope cs gvs = 23 | List.fold_left (fun gvs c -> collect_constr_gvars ~outer_scope c gvs) gvs cs 24 | -------------------------------------------------------------------------------- /src/Eval/Env.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | open Value 6 | 7 | type value_box = value option ref 8 | 9 | type t = value_box Var.Map.t 10 | 11 | let empty = Var.Map.empty 12 | 13 | let extend env x v = 14 | Var.Map.add x (ref (Some v)) env 15 | 16 | let extend_box env x = 17 | let box = ref None in 18 | (Var.Map.add x box env, box) 19 | 20 | let update_box box v = 21 | match !box with 22 | | None -> box := Some v 23 | | Some _ -> failwith "Runtime error: recursive value updated twice" 24 | 25 | let lookup env x = 26 | match !(Var.Map.find x env) with 27 | | Some v -> v 28 | | None -> failwith "Runtime error: non-productive recursive definition" 29 | -------------------------------------------------------------------------------- /src/Utils/BRef.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Backtrackable references *) 6 | 7 | type 'a t 8 | 9 | (** Create backtrackable reference. *) 10 | val create : 'a -> 'a t 11 | 12 | (** Check physical equality. *) 13 | val equal : 'a t -> 'a t -> bool 14 | 15 | (** Get current value. *) 16 | val get : 'a t -> 'a 17 | 18 | (** Set a new current value. If `set` is used inside a bracket, 19 | the old value will be saved for potential backtracking 20 | unless it was set within the same bracket. *) 21 | val set : 'a t -> 'a -> unit 22 | 23 | (** Run computation and commit changes on success and 24 | backtrack on failure. *) 25 | val bracket : (unit -> 'a) -> 'a 26 | -------------------------------------------------------------------------------- /test/ok/ok0091_namedParamMethod.fram: -------------------------------------------------------------------------------- 1 | data rec List A = Nil | Cons of A, List A 2 | 3 | let fix {type A, type B, type E} f = 4 | data rec Fix = Fix of (Fix -> A ->[E] B) 5 | let fi ix x = let Fix fi = ix in f (fi ix) x in 6 | fi (Fix fi) 7 | 8 | let fold_left f acc xs = fix (fn fold acc xs => 9 | match xs with 10 | | Nil => acc 11 | | Cons x xs => fold (f acc x) xs 12 | end) acc xs 13 | 14 | method toString = (extern dbl_intToString : Int -> String) 15 | method add = (extern dbl_strCat : String -> String -> String) 16 | 17 | method toString {A, method toString : A ->[] String} (self : (List A)) = 18 | fold_left (fn (acc : String) (x : A) => acc.add x.toString) "" 19 | 20 | 21 | let x = Cons 1 (Cons 2 Nil) 22 | let _ = x.toString 23 | -------------------------------------------------------------------------------- /src/ToCore/Env.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Environment of the translation *) 6 | 7 | open Common 8 | 9 | type t 10 | 11 | (** Initial environment *) 12 | val initial : t 13 | 14 | (** Extend the environment with type variable. *) 15 | val add_tvar : t -> S.tvar -> t * T.TVar.ex 16 | 17 | (** Extend environment with multiple type variables. *) 18 | val add_tvars : t -> S.tvar list -> t * T.TVar.ex list 19 | 20 | (** Extend the environment with a list of named type variables. *) 21 | val add_named_tvars : t -> S.named_tvar list -> t * T.TVar.ex list 22 | 23 | (** Lookup for a type variable. It must be present in the environment *) 24 | val lookup_tvar : t -> S.tvar -> T.TVar.ex 25 | -------------------------------------------------------------------------------- /src/TypeInference/ParamCycleDetect.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Detection of cycles in named parameter resolution. *) 6 | 7 | (** Data structure used to detect cycles. *) 8 | type t 9 | 10 | (** Empty cycle detection structure. *) 11 | val empty : t 12 | 13 | (** Check for cyclic dependencies in named parameters, and update the state 14 | of the cycle detector. Returns [None] if a cycle is detected, or 15 | [Some new_state] otherwise. The [size] parameter is used to allow multiple 16 | usages of the same parameter, as long as the consecutive usages have 17 | decreasing sizes. If the size is not provided, it defaults to 0. *) 18 | val add_var : t -> ?size:int -> Var.t -> t option 19 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/CEffect.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Computation effects with distinguished purity *) 6 | 7 | type t = 8 | | Pure 9 | | Impure of Effct.t 10 | 11 | let prog_effect = Impure (Effct.var UnifCommon.BuiltinType.tv_io) 12 | 13 | let join eff1 eff2 = 14 | match eff1, eff2 with 15 | | Pure, _ -> eff2 16 | | _, Pure -> eff1 17 | | Impure eff1, Impure eff2 -> Impure (Effct.join eff1 eff2) 18 | 19 | let collect_gvars ~outer_scope eff gvs = 20 | match eff with 21 | | Pure -> gvs 22 | | Impure eff -> Effct.collect_gvars ~outer_scope eff gvs 23 | 24 | let to_sexpr eff = 25 | match eff with 26 | | Pure -> SExpr.Sym "pure" 27 | | Impure eff -> Effct.to_sexpr eff 28 | -------------------------------------------------------------------------------- /test/ok/ok0148_equivEffect.fram: -------------------------------------------------------------------------------- 1 | data Box E = Box of (Unit ->[E] Unit) 2 | let f (g : Box _ -> Box _) x = g (g x) 3 | let f g = f (f g) 4 | let f g = f (f g) 5 | let f g = f (f g) 6 | let f g = f (f g) 7 | let f g = f (f g) 8 | let f g = f (f g) 9 | let f g = f (f g) 10 | let f g = f (f g) 11 | let f g = f (f g) 12 | let f g = f (f g) 13 | let f g = f (f g) 14 | let f g = f (f g) 15 | let f g = f (f g) 16 | let f g = f (f g) 17 | let f g = f (f g) 18 | let f g = f (f g) 19 | let f g = f (f g) 20 | let f g = f (f g) 21 | let f g = f (f g) 22 | let f g = f (f g) 23 | let f g = f (f g) 24 | let f g = f (f g) 25 | let f g = f (f g) 26 | let f g = f (f g) 27 | let f g = f (f g) 28 | let f g = f (f g) 29 | let f g = f (f g) 30 | let f g = f (f g) 31 | let f g = f (f g) 32 | let f g = f (f g) 33 | -------------------------------------------------------------------------------- /src/IncrSAT/PropVar.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Propositional variables *) 6 | 7 | type t 8 | 9 | (** Value of a variable *) 10 | type value = 11 | | True 12 | | False 13 | | SameAs of t 14 | 15 | (** Create a fresh variable *) 16 | val fresh : unit -> t 17 | 18 | (** Get the value of the variable. *) 19 | val value : t -> value 20 | 21 | (** Set the value of the variable to some boolean value. *) 22 | val set_bool : t -> bool -> unit 23 | 24 | (** Pretty-print variable as S-expression *) 25 | val to_sexpr : t -> SExpr.t 26 | 27 | (** Finite sets of propositional variables *) 28 | module Set : Set.S with type elt = t 29 | 30 | (** Finite maps from propositional variables *) 31 | module Map : Map.S with type key = t 32 | -------------------------------------------------------------------------------- /test/ok/ok0041_existentialTypes.fram: -------------------------------------------------------------------------------- 1 | data Option X = 2 | | None 3 | | Some of X 4 | 5 | let option_map f opt = 6 | match opt with 7 | | None => None 8 | | Some x => Some (f x) 9 | end 10 | 11 | data Pair X Y = 12 | | Pair of X, Y 13 | 14 | data Stream X = 15 | | Stream of {type S}, S, (S ->[] Option (Pair X S)) 16 | 17 | let nil = Stream () (fn _ => None) 18 | 19 | let cons x (Stream s f) = 20 | let view st = 21 | match st with 22 | | None => Some (Pair x (Some s)) 23 | | Some s => option_map (fn (Pair x st) => Pair x (Some st)) (f s) 24 | end 25 | in 26 | Stream None view 27 | 28 | let repeat x = Stream () (fn _ => Some (Pair x ())) 29 | 30 | let view (Stream s f) = 31 | match f s with 32 | | None => None 33 | | Some (Pair x s) => Some (Pair x (Stream s f)) 34 | end 35 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/TyAlias.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type aliases *) 6 | 7 | type t 8 | 9 | (** Create fresh type alias. Optionally, a unique identifier used by the 10 | pretty-printer can be provided. If omitted, it will be the same as the 11 | freshly generated unique identifier of the alias. *) 12 | val fresh : ?pp_uid:PPTree.uid -> scope:Scope.t -> unit -> t 13 | 14 | (** Check type aliases for equality *) 15 | val equal : t -> t -> bool 16 | 17 | (** Get the unique identifier for pretty-printing *) 18 | val pp_uid : t -> PPTree.uid 19 | 20 | (** Check if an alias can be used in a given scope *) 21 | val in_scope : t -> Scope.t -> bool 22 | 23 | (** Finite map from type aliases *) 24 | module Map : Map.S with type key = t 25 | -------------------------------------------------------------------------------- /test/stdlib/stdlib0006_Prelude.fram: -------------------------------------------------------------------------------- 1 | # min 2 | let _ = 3 | assert (min 10 20 == 10); 4 | assert (min 20 10 == 10); 5 | assert (min 10 10 == 10); 6 | assert (min "abc" "def" == "abc") 7 | 8 | # max 9 | let _ = 10 | assert (max 10 20 == 20); 11 | assert (max 20 10 == 20); 12 | assert (max 20 20 == 20); 13 | assert (max "abc" "def" == "def") 14 | 15 | # strListCat 16 | let _ = 17 | assert (strListCat ["a", "b", "c"] == "abc"); 18 | assert (strListCat ["do", "re", "mi"] == "doremi"); 19 | assert (strListCat [] == "") 20 | 21 | # replicate 22 | let _ = 23 | assert (replicate "ab" 0 == ""); 24 | assert (replicate "ab" 1 == "ab"); 25 | assert (replicate "ab" 2 == "abab"); 26 | assert (replicate "ab" 3 == "ababab"); 27 | assert (replicate "ab" 5 == "ababababab"); 28 | assert (replicate "" 20 == "") 29 | -------------------------------------------------------------------------------- /src/Eval/Env.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Environment of the interpreter *) 6 | 7 | open Value 8 | 9 | type t 10 | 11 | (** A box containing a value. The box might be empty in case of a recursive 12 | definition. *) 13 | type value_box 14 | 15 | (** Empty environment *) 16 | val empty : t 17 | 18 | (** Extend the environment with a new binding *) 19 | val extend : t -> Var.t -> value -> t 20 | 21 | (** Extend the environment with an empty binding *) 22 | val extend_box : t -> Var.t -> t * value_box 23 | 24 | (** Update a contents of a box. It is an error to call this function on a 25 | non-empty box. *) 26 | val update_box : value_box -> value -> unit 27 | 28 | (** Lookup a variable in the environment *) 29 | val lookup : t -> Var.t -> value 30 | -------------------------------------------------------------------------------- /test/ok/ok0108_modulePattern.fram: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | data Ord = Lt | Eq | Gt 4 | 5 | data rec List A = [] | (::) of A, List A 6 | 7 | data Set Elem = Set of 8 | { T 9 | , empty : T 10 | , method add : T -> Elem ->[] T 11 | , method mem : T -> Elem ->[] Bool 12 | } 13 | 14 | let add xs x = x :: xs 15 | 16 | let rec mem compare xs x = 17 | match xs with 18 | | [] => False 19 | | y :: xs => 20 | match compare x y with 21 | | Eq => True 22 | | _ => mem compare xs x 23 | end 24 | end 25 | 26 | let make {Elem} (compare : Elem -> Elem ->[] Ord) = 27 | Set { T = List Elem, empty = [], method add = add, method mem = mem compare } 28 | 29 | let compare (_ : Unit) (_ : Unit) = Eq 30 | 31 | let Set { module UnitSet } = make compare 32 | 33 | let m = UnitSet.empty.add () 34 | 35 | let f () = m.mem () 36 | -------------------------------------------------------------------------------- /src/IncrSAT/Solver.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Simple incremental SAT-solver *) 6 | 7 | type 'a t 8 | 9 | (** Create a new solver *) 10 | val create : unit -> 'a t 11 | 12 | (** Add formula implication with attached value. *) 13 | val add_imply : 'a t -> 'a -> Formula.t -> Formula.t -> unit 14 | 15 | (** Result of a solver *) 16 | type 'a solve_result = 17 | | Ok 18 | | Error of 'a 19 | 20 | (** Partially solve collected clauses, trying to quickly fail if the clause 21 | set is not satisfiable *) 22 | val solve_partial : 'a t -> 'a solve_result 23 | 24 | (** Solve all the collected clauses *) 25 | val solve_all : 'a t -> 'a solve_result 26 | 27 | (** Pretty print all clauses of the SAT-solver as S-expressions. *) 28 | val clauses_to_sexpr : 'a t -> SExpr.t list 29 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/Pretty.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Pretty-printing of kinds and types *) 6 | 7 | open TypeBase 8 | 9 | (** Context of pretty-printing *) 10 | type ctx 11 | 12 | (** Create an empty context. *) 13 | val empty_context : unit -> ctx 14 | 15 | (** Pretty-print kind *) 16 | val pp_kind : ctx -> kind -> string 17 | 18 | (** Pretty-print type variable *) 19 | val pp_tvar : ctx -> PPTree.t -> tvar -> string 20 | 21 | (** Pretty-print type *) 22 | val pp_type : ctx -> PPTree.t -> typ -> string 23 | 24 | (** Pretty-print type scheme *) 25 | val pp_scheme : ctx -> PPTree.t -> scheme -> string 26 | 27 | (** Pretty-print additional information about printing context, e.g., 28 | locations of binders of anonymous types. *) 29 | val additional_info : ctx -> string 30 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/TyAlias.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type aliases *) 6 | 7 | module Ordered = struct 8 | type t = 9 | { uid : UID.t; 10 | pp_uid : PPTree.uid; 11 | scope : Scope.t 12 | } 13 | 14 | let compare x y = UID.compare x.uid y.uid 15 | end 16 | include Ordered 17 | 18 | let fresh ?pp_uid ~scope () = 19 | assert (not (Scope.equal scope Scope.root)); 20 | let uid = UID.fresh () in 21 | { uid = uid; 22 | pp_uid = 23 | begin match pp_uid with 24 | | Some pp_uid -> pp_uid 25 | | None -> PP_UID uid 26 | end; 27 | scope = scope 28 | } 29 | 30 | let equal a b = a == b 31 | 32 | let pp_uid a = a.pp_uid 33 | 34 | let in_scope a scope = Scope.mem a.scope scope 35 | 36 | module Map = Map.Make(Ordered) 37 | -------------------------------------------------------------------------------- /src/InterpLib/InternalError.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module for reporting internal errors errors *) 6 | 7 | let verbose = ref false 8 | 9 | let sexpr_info name s = 10 | match s with 11 | | None -> () 12 | | Some s -> 13 | Printf.eprintf "%s\n" name; 14 | SExpr.pretty_stderr s 15 | 16 | let report ~reason ?sloc ?requested ?provided ?var ?in_type ?in_effect () = 17 | if !verbose then begin 18 | Printf.eprintf "Internal error: %s\n" reason; 19 | sexpr_info "at:" sloc; 20 | sexpr_info "requested:" requested; 21 | sexpr_info "provided:" provided; 22 | sexpr_info "var:" var; 23 | sexpr_info "type:" in_type; 24 | sexpr_info "effect:" in_effect 25 | end; 26 | failwith (Printf.sprintf "Internal error: %s" reason) 27 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/Pretty.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Pretty-printing of types *) 6 | 7 | open TypeBase 8 | 9 | (** Context of pretty-printing *) 10 | type ctx 11 | 12 | (** Create an empty context. *) 13 | val empty_context : unit -> ctx 14 | 15 | (** Pretty-print a type variable *) 16 | val pp_tvar : ctx -> PPTree.t -> tvar -> string 17 | 18 | (** Pretty-print an effect *) 19 | val pp_effect : ctx -> PPTree.t -> effct -> string 20 | 21 | (** Pretty-print a type *) 22 | val pp_type : ctx -> PPTree.t -> typ -> string 23 | 24 | (** Pretty-print a type scheme *) 25 | val pp_scheme : ctx -> PPTree.t -> scheme -> string 26 | 27 | (** Pretty-print additional information about printing context, e.g., 28 | the locations of binders of anonymous types. *) 29 | val additional_info : ctx -> string 30 | -------------------------------------------------------------------------------- /src/TypeInference/Def.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type-inference for definitions *) 6 | 7 | open Common 8 | open BiDirectional 9 | open TypeCheckFix 10 | 11 | (** Check the type of a single definition. It uses bidirectional type 12 | checking and passes the extended environment to the body-generating 13 | continuation. *) 14 | val check_def : tcfix:tcfix -> 15 | ('st, sec) opn Env.t -> S.def -> (T.typ, 'dir) request -> 16 | 'st def_cont -> 'dir expr_result 17 | 18 | (** Check the type of a block of definitions. It uses bidirectional type 19 | checking and passes the extended environment to the body-generating 20 | continuation. *) 21 | val check_defs : tcfix:tcfix -> 22 | ('st, sec) opn Env.t -> S.def list -> (T.typ, 'dir) request -> 23 | 'st def_cont -> 'dir expr_result 24 | -------------------------------------------------------------------------------- /test/test_suite: -------------------------------------------------------------------------------- 1 | function simple_run_tests { 2 | for file in test/ok/*.fram 3 | do 4 | simple_test $file 5 | done 6 | } 7 | 8 | run_with_flags simple_run_tests "-no-prelude -no-stdlib" 9 | 10 | function simple_examples { 11 | simple_test examples/Tick.fram 12 | simple_test examples/LWT_lexical.fram 13 | simple_test examples/Prolog.fram 14 | simple_test examples/Pythagorean.fram 15 | simple_test examples/Modules/Main.fram 16 | } 17 | 18 | run_with_flags simple_examples "" 19 | 20 | function simple_stdlib_tests { 21 | for file in test/stdlib/*.fram 22 | do 23 | simple_test $file 24 | done 25 | } 26 | 27 | run_with_flags simple_stdlib_tests "" 28 | 29 | function simple_error_tests { 30 | for file in test/err/*.fram 31 | do 32 | exit_code_test 1 $file 33 | done 34 | } 35 | 36 | run_with_flags simple_error_tests "-no-prelude -no-stdlib -no-error-context" 37 | -------------------------------------------------------------------------------- /lib/Base/Char.fram: -------------------------------------------------------------------------------- 1 | {# This file is part of DBL, released under MIT license. 2 | # See LICENSE for details. 3 | #} 4 | 5 | import open /Base/Types 6 | 7 | pub method code = (extern dbl_chrCode : Char -> Int) 8 | 9 | pub method equal = (extern dbl_eqInt : Char -> Char -> Bool) 10 | pub method neq = (extern dbl_neqInt : Char -> Char -> Bool) 11 | pub method gt = (extern dbl_gtInt : Char -> Char -> Bool) 12 | pub method lt = (extern dbl_ltInt : Char -> Char -> Bool) 13 | pub method ge = (extern dbl_geInt : Char -> Char -> Bool) 14 | pub method le = (extern dbl_leInt : Char -> Char -> Bool) 15 | 16 | {## Escapes a character for inclusion in a string literal. 17 | 18 | Additional quotes are not added around the result. ##} 19 | pub method escape = (extern dbl_chrEscape : Char -> String) 20 | 21 | pub method toString {?fmt : Unit} (self : Char) = 22 | (extern dbl_chrToString : Char -> String) self 23 | -------------------------------------------------------------------------------- /src/Utils/Var.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Generic variable representation. 6 | 7 | Variables are identified by their unique identifier, but they also contain 8 | name provided by the user. Names are used for pretty-printing and they 9 | don't need to be unique. *) 10 | 11 | type t = private { 12 | uid : UID.t; (** Unique identifier *) 13 | name : string (** Name *) 14 | } 15 | 16 | (** Create fresh variable *) 17 | val fresh : ?name:string -> unit -> t 18 | 19 | (** Return name of the variable, that is guaranteed to be unique, i.e., for 20 | different variables, [unique_name] return different names *) 21 | val unique_name : t -> string 22 | 23 | (** Equality of variables *) 24 | val equal : t -> t -> bool 25 | 26 | (** Finite sets of variables *) 27 | module Set : Set.S with type elt = t 28 | 29 | (** Finite maps from variables *) 30 | module Map : Map.S with type key = t 31 | -------------------------------------------------------------------------------- /src/TypeInference/BuiltinTypes.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on built-in types. *) 6 | 7 | open Common 8 | 9 | (** Built [Option] type with given type argument and transform it to a 10 | monomorphic scheme. *) 11 | val mk_option_scheme : T.typ -> T.scheme 12 | 13 | (** Built [Option] type with given type expression argument and transform it 14 | to a monomorphic scheme expression. *) 15 | val mk_option_scheme_expr : T.type_expr -> T.scheme_expr 16 | 17 | (** Treat given scheme as an [Option] type and extract the type argument. *) 18 | val scheme_to_option_arg : T.scheme -> T.typ 19 | 20 | (** Create a [None] constructor *) 21 | val mk_none : pos:Position.t -> pp:PPTree.t -> T.typ -> T.expr 22 | 23 | (** Wrap a polymorphic function (of a monomorphic scheme) with [Some] 24 | constructor. *) 25 | val mk_some_poly : pos:Position.t -> pp:PPTree.t -> 26 | T.typ -> T.poly_fun -> T.expr 27 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/ConstrSet.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Set of constraints *) 6 | 7 | open TypeBase 8 | 9 | (** Effect constraints are represented as maps from effect variables to list 10 | of their upper bounds. *) 11 | type t = effct list TVar.Map.t 12 | 13 | let empty = TVar.Map.empty 14 | 15 | let upper_bounds cset x = 16 | match TVar.Map.find_opt x cset with 17 | | None -> [] 18 | | Some effs -> effs 19 | 20 | let rec add_simplify cset (eff1 : effct) eff2 = 21 | match eff1 with 22 | | TEffPure -> cset 23 | | TEffJoin(effa, effb) -> 24 | let cset = add_simplify cset effa eff2 in 25 | add_simplify cset effb eff2 26 | | TVar x -> 27 | TVar.Map.add x (eff2 :: upper_bounds cset x) cset 28 | | TApp _ -> 29 | failwith "Internal error: TApp in effect" 30 | 31 | let add cset (eff1, eff2) = 32 | add_simplify cset eff1 eff2 33 | 34 | let add_list cset cs = 35 | List.fold_left add cset cs 36 | -------------------------------------------------------------------------------- /src/EffectInference/PatternMatch.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Translation of deep pattern-matching *) 6 | 7 | open Common 8 | 9 | (** Clause of a pattern-matching. *) 10 | type clause = { 11 | cl_pos : Position.t; 12 | (** Position of the clause *) 13 | 14 | cl_pat : Pattern.t; 15 | (** Pattern of the clause *) 16 | 17 | cl_body : T.expr; 18 | (** Body of the clause. This expression is a function that should be 19 | applied to [cl_tvars], [cl_vars], and the unit value. *) 20 | 21 | cl_tvars : T.tvar list; 22 | (** Type variables bound by the pattern *) 23 | 24 | cl_vars : T.var list 25 | (** Regular variables bound by the pattern *) 26 | } 27 | 28 | (** Translate a pattern-matching, assuming that the the result of the 29 | translation has type [tp] and effect [eff]. *) 30 | val tr_match : 31 | pos:Position.t -> T.expr -> 32 | tp:T.typ -> eff:T.ceffect -> clause list -> T.expr 33 | -------------------------------------------------------------------------------- /src/TypeInference/Main.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module of a type inference *) 6 | 7 | open Common 8 | open TypeCheckFix 9 | 10 | (** Module of mutually recursive functions of the type-checker. 11 | See [TypeCheckFix] for more details. *) 12 | module rec TCFix : TCFix = struct 13 | let infer_expr_type ?app_type env e = 14 | Expr.infer_expr_type ~tcfix:(module TCFix) ?app_type env e 15 | 16 | let check_expr_type env e tp = 17 | Expr.check_expr_type ~tcfix:(module TCFix) env e tp 18 | 19 | let check_def env def tp_req cont = 20 | Def.check_def ~tcfix:(module TCFix) env def tp_req cont 21 | 22 | let check_defs env defs tp_req cont = 23 | Def.check_defs ~tcfix:(module TCFix) env defs tp_req cont 24 | end 25 | 26 | let tr_program p = 27 | let er = TCFix.check_expr_type Env.initial p T.Type.t_unit in 28 | ConstrSolve.solve_all er.er_constr; 29 | InterpLib.Error.assert_no_error (); 30 | er.er_expr 31 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/Subst.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Substitutions *) 6 | 7 | open TypeBase 8 | 9 | type t 10 | 11 | (** Empty substitution *) 12 | val empty : t 13 | 14 | (** Add a renaming to the substitution. *) 15 | val rename : t -> tvar -> tvar -> t 16 | 17 | (** Add a type to the substitution. *) 18 | val add : t -> tvar -> typ -> t 19 | 20 | (** Create a new substitution that maps given type variables to the 21 | corresponding types. Both list must have equal lengths. *) 22 | val for_named_tvars : named_tvar list -> typ list -> t 23 | 24 | (** Apply the substitution to an effect *) 25 | val in_effect : t -> effct -> effct 26 | 27 | (** Apply the substitution to a type *) 28 | val in_type : t -> typ -> typ 29 | 30 | (** Apply the substitution to a type scheme *) 31 | val in_scheme : t -> scheme -> scheme 32 | 33 | (** Apply the substitution to a constructor declaration *) 34 | val in_ctor_decl : t -> ctor_decl -> ctor_decl 35 | -------------------------------------------------------------------------------- /src/Eval/External.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | open Value 6 | open ExternalUtils 7 | 8 | let extern_map = 9 | let extern_map = 10 | [ "dbl_runtimeError", str_fun (fun fname -> 11 | int_fun (fun line -> 12 | str_fun (fun msg -> 13 | runtime_error_with_postion fname line msg))); 14 | "dbl_magic", pure_fun Fun.id; 15 | "dbl_defaultShow", pure_fun (fun v -> VStr (Value.to_string v)); 16 | "dbl_exit", int_fun exit; 17 | "dbl_abstrType", unit_fun (fun () -> v_abstr); 18 | ] |> List.to_seq |> Hashtbl.of_seq 19 | and lib_externs = 20 | [ ExternalInt.extern_int_seq; 21 | ExternalStr.extern_str_seq; 22 | ExternalInt64.extern_int64_seq; 23 | ExternalRef.extern_ref_seq; 24 | ExternalOs.extern_os_seq; 25 | ] |> List.to_seq |> Seq.concat in 26 | Hashtbl.add_seq extern_map lib_externs; 27 | extern_map 28 | -------------------------------------------------------------------------------- /lib/Base/Result.fram: -------------------------------------------------------------------------------- 1 | {# This file is part of DBL, released under MIT license. 2 | # See LICENSE for details. 3 | #} 4 | 5 | import open /Base/Types 6 | import open /Base/Assert 7 | 8 | {## For `Ok x` returns `x`, otherwise the provided argument is returned. ##} 9 | pub method unwrapOr self default = 10 | match self with 11 | | Err _ => default 12 | | Ok x => x 13 | end 14 | 15 | {## For `Ok x` returns `x`, otherwise the function `~onError` is called and 16 | its result returned. ##} 17 | pub method unwrapErr {~onError} self = 18 | match self with 19 | | Err _ => ~onError () 20 | | Ok x => x 21 | end 22 | 23 | {## This method should only be called on `Ok x` values, in which case it 24 | returns `x`. When applied to `Err e` the entire program crashes irrecoverably 25 | with a runtime error. The resulting error message can be optionally specified 26 | with `?msg`. ##} 27 | pub method unwrap {?msg} self = 28 | match self with 29 | | Err _ => runtimeError (msg.unwrapOr "Called `unwrap` on `Err`") 30 | | Ok x => x 31 | end 32 | -------------------------------------------------------------------------------- /src/IncrSAT/PropVar.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Propositional variables *) 6 | 7 | type t = 8 | { uid : UID.t; 9 | value : value option BRef.t 10 | } 11 | 12 | and value = 13 | | True 14 | | False 15 | | SameAs of t 16 | 17 | let fresh () = 18 | { uid = UID.fresh (); 19 | value = BRef.create None 20 | } 21 | 22 | let rec value x = 23 | match BRef.get x.value with 24 | | None -> SameAs x 25 | | Some ((True | False) as v) -> v 26 | | Some (SameAs y) -> 27 | let v = value y in 28 | BRef.set x.value (Some v); 29 | v 30 | 31 | let set_bool x b = 32 | match BRef.get x.value with 33 | | None -> 34 | BRef.set x.value (Some (if b then True else False)) 35 | | Some _ -> 36 | assert false 37 | 38 | let to_sexpr x = SExpr.Sym (UID.to_string x.uid) 39 | 40 | module Ordered = struct 41 | type nonrec t = t 42 | let compare x y = UID.compare x.uid y.uid 43 | end 44 | 45 | module Set = Set.Make(Ordered) 46 | module Map = Map.Make(Ordered) 47 | -------------------------------------------------------------------------------- /src/TypeInference/Constr.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Constraints generated during type inference *) 6 | 7 | open Common 8 | 9 | type t = 10 | | ResolveMethod : { (** Unknown implictly provided method *) 11 | hole : T.poly_fun option BRef.t; 12 | (** Hole to be filled with method implementation *) 13 | 14 | pcyc : ParamCycleDetect.t; 15 | (** Parameter cycle detector state *) 16 | 17 | pos : Position.t; 18 | (** Position of the place where parameter resoultion is requested *) 19 | 20 | env : 'st Env.t; 21 | (** Environment in which resolution is requested *) 22 | 23 | method_env : 'st Env.t; 24 | (** Environment in which the method should be searched *) 25 | 26 | self_tp : T.typ; 27 | (** Type of the method's owner *) 28 | 29 | mname : S.method_name; 30 | (** Name of the method to be resolved *) 31 | 32 | sch : T.scheme; 33 | (** Scheme of the method to be resolved *) 34 | } -> t 35 | -------------------------------------------------------------------------------- /src/Eval/ExternalRef.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | open ExternalUtils 6 | open Value 7 | 8 | let ref_fun f = VFn (fun v cont -> 9 | match v with 10 | | VRef r -> cont (f r) 11 | | _ -> runtime_error "Not a reference") 12 | 13 | let array_fun f = VFn (fun v cont -> 14 | match v with 15 | | VArray a -> cont (f a) 16 | | _ -> runtime_error "Not an array") 17 | 18 | let extern_ref_seq = 19 | [ "dbl_ref", pure_fun (fun x -> VRef (ref x)); 20 | "dbl_refGet", ref_fun (!); 21 | "dbl_refSet", ref_fun (fun r -> pure_fun (fun v -> r := v; v_unit)); 22 | "dbl_mkArray", int_fun (fun n -> VArray(Array.make n v_unit)); 23 | "dbl_arrayGet", array_fun (fun a -> int_fun (fun n -> a.(n))); 24 | "dbl_arraySet", array_fun (fun a -> int_fun (fun n -> pure_fun (fun v -> 25 | a.(n) <- v; v_unit))); 26 | "dbl_maxArrayLength", VNum Sys.max_array_length; 27 | "dbl_arrayLength", array_fun (fun a -> VNum (Array.length a)); 28 | ] |> List.to_seq 29 | 30 | -------------------------------------------------------------------------------- /src/ToCore/Env.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Environment of the translation *) 6 | 7 | open Common 8 | 9 | type t = 10 | { tvar_map : T.TVar.ex S.TVar.Map.t 11 | } 12 | 13 | let initial = 14 | { tvar_map = 15 | S.BuiltinType.all 16 | |> List.map (fun (name, x) -> (x, List.assoc name T.BuiltinType.all)) 17 | |> List.to_seq |> S.TVar.Map.of_seq; 18 | } 19 | 20 | let add_tvar env x = 21 | let (Ex k) = tr_kind (S.TVar.kind x) in 22 | let y = T.TVar.Ex (T.TVar.fresh k) in 23 | { tvar_map = S.TVar.Map.add x y env.tvar_map 24 | }, y 25 | 26 | let add_tvars env xs = 27 | List.fold_left_map add_tvar env xs 28 | 29 | let add_named_tvar env (_, x) = 30 | add_tvar env x 31 | 32 | let add_named_tvars env xs = 33 | List.fold_left_map add_named_tvar env xs 34 | 35 | let lookup_tvar env x = 36 | try S.TVar.Map.find x env.tvar_map with 37 | | Not_found -> 38 | InterpLib.InternalError.report 39 | ~reason:"unbound type variable" 40 | ~provided:(S.TVar.to_sexpr x) 41 | () 42 | -------------------------------------------------------------------------------- /src/TypeInference/BuiltinTypes.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on built-in types. *) 6 | 7 | open Common 8 | 9 | let mk_option tp = 10 | T.Type.t_app (T.Type.t_var T.BuiltinType.tv_option) tp 11 | 12 | let mk_option_type_expr tp = 13 | { tp with T.data = T.TE_Option tp } 14 | 15 | let mk_option_scheme tp = 16 | T.Scheme.of_type (mk_option tp) 17 | 18 | let mk_option_scheme_expr tp = 19 | T.SchemeExpr.of_type_expr (mk_option_type_expr tp) 20 | 21 | let scheme_to_option_arg (sch : T.scheme) = 22 | assert (T.Scheme.is_monomorphic sch); 23 | match T.Type.whnf sch.sch_body with 24 | | Whnf_Neutral(_, [arg]) -> arg 25 | | _ -> assert false 26 | 27 | let mk_none ~pos ~pp tp = 28 | let make data = { T.pos = pos; T.pp = pp; T.data = data } in 29 | make (T.EInst(make (T.ECtor([], PE_Option tp, 0)), [], [])) 30 | 31 | let mk_some_poly ~pos ~pp tp e = 32 | let make data = { T.pos = pos; T.pp = pp; T.data = data } in 33 | make (T.EAppPoly( 34 | make (T.EInst(make (T.ECtor([], PE_Option tp, 1)), [], [])), 35 | e)) 36 | -------------------------------------------------------------------------------- /test/ok/ok0117_comments.fram: -------------------------------------------------------------------------------- 1 | # This is a single-line comment. 2 | {# This is a block comment. #} 3 | {# Block comments 4 | may span multiple lines. 5 | #} 6 | let id x = x # A single-line comment may appear at the end of a line. 7 | 8 | let n {# A block comment may span a part of a single line. #} = 42 9 | {#aaa 10 | Comments cannot be nested, 11 | {# but the programmer may choose the comment delimiters. #} 12 | aaa#} 13 | 14 | {#!a! Comment names may contain operators. !a!#} 15 | 16 | {#abc 17 | This comment is ended by `abc` immediately followed by `#}`, 18 | even if the closing sequence is preceded by other characters. 19 | zzabc#} 20 | 21 | let {# 22 | # This is not a single-line comment, 23 | # because comments are not nested. 24 | # This comment can be ended #} here = 13 25 | 26 | ## This is a documentation comment. 27 | let foo x = x 28 | 29 | {## This is another documentation comment. ##} 30 | let bar = foo 31 | 32 | {### 33 | Documentation comments can contain some code 34 | ``` 35 | {## with another documentation comment (with a different name). ##} 36 | let some_code = 42 37 | ``` 38 | ###} 39 | let baz = bar 40 | -------------------------------------------------------------------------------- /lib/Base/Assert.fram: -------------------------------------------------------------------------------- 1 | {# This file is part of DBL, released under MIT license. 2 | # See LICENSE for details. 3 | #} 4 | 5 | import open Types 6 | 7 | {## Abort the program with given message. 8 | 9 | Note that this function is pure. In correct programs, this function should 10 | never be called at runtime, but it can be used to appease the type-checker. 11 | Use this function only in impossible match clauses or in case of gross 12 | violation of function preconditions (e.g., division by zero). 13 | 14 | Handles position in code implicitely. ##} 15 | pub let runtimeError {type T, ~__file__, ~__line__} = 16 | (extern dbl_runtimeError : String -> Int -> String ->[] T) ~__file__ ~__line__ 17 | 18 | {## Explicitly assert that this case is impossible. ##} 19 | pub let impossible {?msg : String, ~__file__, ~__line__} () = 20 | runtimeError 21 | match msg with 22 | | None => "Assertion failed" 23 | | Some msg => msg 24 | end 25 | 26 | {## Assert that given condition should always hold. ##} 27 | pub let assert {?msg, ~__file__, ~__line__} b = 28 | if b then () 29 | else 30 | impossible {?msg} () 31 | -------------------------------------------------------------------------------- /src/Lang/CorePriv/BuiltinType.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Built-in type variable *) 6 | 7 | open TypeBase 8 | 9 | (** Int type *) 10 | let tv_int = TVar.fresh KType 11 | 12 | (** Int64 type *) 13 | let tv_int64 = TVar.fresh KType 14 | 15 | (** String type *) 16 | let tv_string = TVar.fresh KType 17 | 18 | (** Unit type *) 19 | let tv_unit = TVar.fresh KType 20 | 21 | (** Bool_type *) 22 | let tv_bool = TVar.fresh KType 23 | 24 | (** Option type *) 25 | let tv_option = TVar.fresh (KArrow(KType, KType)) 26 | 27 | (** IO effect *) 28 | let tv_io = TVar.fresh KEffect 29 | 30 | (** Possible non-termination effect *) 31 | let tv_nterm = TVar.fresh KEffect 32 | 33 | (** List of all built-in types together with their names *) 34 | let all = 35 | [ "Int", TVar.Ex tv_int; 36 | "Int64", TVar.Ex tv_int64; 37 | "String", TVar.Ex tv_string; 38 | "Char", TVar.Ex tv_int; 39 | "Unit", TVar.Ex tv_unit; 40 | "Bool", TVar.Ex tv_bool; 41 | "Option", TVar.Ex tv_option; 42 | "IO", TVar.Ex tv_io; 43 | "#NTerm", TVar.Ex tv_nterm ] 44 | -------------------------------------------------------------------------------- /src/TypeInference/Uniqueness.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Checking uniqueness of various mutual definitions *) 6 | 7 | open Common 8 | 9 | (** Ensure that each constructor in given ADT has a unique name *) 10 | val check_ctor_uniqueness : S.ctor_decl list -> unit 11 | 12 | (** Ensure that checked named type parameters are unique *) 13 | val check_unif_named_type_args : (Position.t * T.tname * T.tvar) list -> unit 14 | 15 | (** Ensure that checked named parameters are unique *) 16 | val check_names : pp:PPTree.t -> (Position.t * Name.t) list -> unit 17 | 18 | (** Ensure that type names introduced by the first parameter are unique and 19 | do not collide with the second parameter *) 20 | val check_generalized_types : 21 | pos:Position.t -> T.named_tvar list -> T.named_tvar list -> unit 22 | 23 | (** Ensure that names introduced by the first parameter are unique and do not 24 | collide with the second parameter. *) 25 | val check_generalized_names : pos:Position.t -> pp:PPTree.t -> 26 | (Name.t * T.var * T.scheme_expr) list -> (Name.t * T.scheme) list -> unit 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023-2024 University of Wrocław 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/Ren.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Variable renaming. *) 6 | 7 | open TypeBase 8 | open Syntax 9 | 10 | type t 11 | 12 | (** Empty renaming *) 13 | val empty : scope:Scope.t -> t 14 | 15 | (** Extend renaming with a renaming of a type variable *) 16 | val add_tvar : t -> tvar -> tvar -> t 17 | 18 | (** Extend renaming with a renaming of a regular variable *) 19 | val add_var : t -> var -> var -> t 20 | 21 | (** Rename type variable binder *) 22 | val rename_tvar : t -> tvar -> tvar 23 | 24 | (** Rename named type variable binder *) 25 | val rename_named_tvar : t -> named_tvar -> named_tvar 26 | 27 | (** Rename named type variable binders *) 28 | val rename_named_tvars : t -> named_tvar list -> named_tvar list 29 | 30 | (** Rename type *) 31 | val rename_type : t -> typ -> typ 32 | 33 | (** Rename type scheme *) 34 | val rename_scheme : t -> scheme -> scheme 35 | 36 | (** Rename type scheme expression *) 37 | val rename_scheme_expr : t -> scheme_expr -> scheme_expr 38 | 39 | (** Rename variables in pattern *) 40 | val rename_pattern : t -> pattern -> pattern 41 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/TypeWhnf.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Weak head normal form of a type *) 6 | 7 | open TypeBase 8 | 9 | type neutral_head = 10 | | NH_UVar of uvar 11 | | NH_Var of tvar 12 | 13 | type whnf = 14 | | Whnf_Effect 15 | | Whnf_Neutral of neutral_head * typ list 16 | (* Arguments are in reversed order! *) 17 | | Whnf_Arrow of scheme * typ * effct 18 | | Whnf_Handler of tvar * typ * typ * typ 19 | | Whnf_Label of typ 20 | 21 | let rec whnf tp = 22 | match view tp with 23 | | TEffect -> Whnf_Effect 24 | | TUVar u -> Whnf_Neutral(NH_UVar u, []) 25 | | TVar x -> Whnf_Neutral(NH_Var x, []) 26 | | TArrow(sch, tp, eff) -> Whnf_Arrow(sch, tp, eff) 27 | | THandler(a, tp, itp, otp) -> 28 | Whnf_Handler(a, tp, itp, otp) 29 | | TLabel tp0 -> Whnf_Label tp0 30 | | TApp(tp1, tp2) -> 31 | begin match whnf tp1 with 32 | | Whnf_Neutral(h, args) -> Whnf_Neutral(h, tp2 :: args) 33 | 34 | | Whnf_Effect | Whnf_Arrow _ | Whnf_Handler _ | Whnf_Label _ -> 35 | failwith "Internal kind error" 36 | end 37 | | TAlias(_, tp) -> whnf tp 38 | -------------------------------------------------------------------------------- /src/InterpLib/InternalError.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Main module for reporting internal errors errors *) 6 | 7 | (** Flag that indicate that internal error should be more verbose *) 8 | val verbose : bool ref 9 | 10 | (** Report an internal error. The meaning of the parameters is the following. 11 | - [reason]: short readable reason of the error, e.g., type mismatch; 12 | - [sloc]: s-expression with the location of the error, e.g., the invalid 13 | expression; 14 | - [requested]: requested metadata of the erroneous entity, e.g., its 15 | requested type; 16 | - [provided]: provided metadata of the erroneous entity, e.g., its actual 17 | type. 18 | - [var]: variable associated with the error (e.g., escaping variable) 19 | - [in_type]: type of an erroneous entity. 20 | - [in_effect]: effect of an erroneous entity. *) 21 | val report : 22 | reason: string -> 23 | ?sloc: SExpr.t -> 24 | ?requested: SExpr.t -> 25 | ?provided: SExpr.t -> 26 | ?var: SExpr.t -> 27 | ?in_type: SExpr.t -> 28 | ?in_effect: SExpr.t -> 29 | unit -> 'a 30 | -------------------------------------------------------------------------------- /src/DblParser/Import.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Find and parse imported modules *) 6 | 7 | (** Type used to maintain the set of previously imported modules between 8 | calls to functions in this module. *) 9 | type import_set 10 | 11 | (** Empty set of imported modules. *) 12 | val import_set_empty : import_set 13 | 14 | (** Parse one import and its dependencies, and return the list of definitions 15 | required by the importer. *) 16 | val import_one : import_set -> Raw.import -> import_set * Lang.Surface.def list 17 | 18 | (** Parse a list of imports and their dependencies and return the list of 19 | definitions required by the importer. *) 20 | val import_many : 21 | import_set -> Raw.import list -> import_set * Lang.Surface.def list 22 | 23 | (** Parse the prelude and any dependencies and return the set of imported 24 | modules and list of definitions. *) 25 | val import_prelude : unit -> import_set * Lang.Surface.def list 26 | 27 | (** Parse imports and prepend them to a complete program. *) 28 | val prepend_imports : 29 | use_prelude:bool -> Raw.import list -> Lang.Surface.program -> 30 | Lang.Surface.program 31 | -------------------------------------------------------------------------------- /src/Utils/BiDirectional.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** GADTs for bidirectional type checking. *) 6 | 7 | (** Direction of type inference. We never use values of these types. They 8 | are only used for indexing [request] and [response] GADTs. *) 9 | type infer = Dummy_Infer 10 | type check = Dummy_Check 11 | 12 | (** Request of the bidirectional type checking. It is indexed by a direction. 13 | *) 14 | type ('a, _) request = 15 | | Infer : ('a, infer) request 16 | (** Type inference mode *) 17 | 18 | | Check : 'a -> ('a, check) request 19 | (** Type checking mode *) 20 | 21 | (** Response of the bidirectional type checking. It is indexed by a direction. 22 | *) 23 | type ('a, _) response = 24 | | Infered : 'a -> ('a, infer) response 25 | (** The result of type inference mode *) 26 | 27 | | Checked : ('a, check) response 28 | (** The result of type checking mode *) 29 | 30 | (** Extract result type, from request and response *) 31 | let bidir_result (type dir) 32 | (req : (_, dir) request) (resp : (_, dir) response) = 33 | match req, resp with 34 | | Infer, Infered tp -> tp 35 | | Check tp, Checked -> tp 36 | -------------------------------------------------------------------------------- /src/Lang/UnifCommon/BuiltinType.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Built-in type variable *) 6 | 7 | (** Int type *) 8 | let tv_int = TVar.fresh ~scope:Scope.initial Kind.k_type 9 | 10 | (** Int64 type *) 11 | let tv_int64 = TVar.fresh ~scope:Scope.initial Kind.k_type 12 | 13 | (** String type *) 14 | let tv_string = TVar.fresh ~scope:Scope.initial Kind.k_type 15 | 16 | (** Char type *) 17 | let tv_char = TVar.fresh ~scope:Scope.initial Kind.k_type 18 | 19 | (** Unit type *) 20 | let tv_unit = TVar.fresh ~scope:Scope.initial Kind.k_type 21 | 22 | (** Bool type *) 23 | let tv_bool = TVar.fresh ~scope:Scope.initial Kind.k_type 24 | 25 | (** Option type *) 26 | let tv_option = TVar.fresh ~scope:Scope.initial 27 | (Kind.k_noneff_arrow Kind.k_type Kind.k_type) 28 | 29 | (** IO effect *) 30 | let tv_io = TVar.fresh ~scope:Scope.initial Kind.k_effect 31 | 32 | (** List of all built-in types together with their names *) 33 | let all = 34 | [ "Int", tv_int; 35 | "Int64", tv_int64; 36 | "String", tv_string; 37 | "Char", tv_char; 38 | "Unit", tv_unit; 39 | "Bool", tv_bool; 40 | "Option", tv_option; 41 | "IO", tv_io ] 42 | -------------------------------------------------------------------------------- /src/TypeInference/NameUtils.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on internal representation of names. *) 6 | 7 | open Common 8 | 9 | (** Translate a self type to [method_owner]. [None] means that the type 10 | is an unification variable, potentially applied to some type arguments. *) 11 | val method_owner_of_self : T.typ -> Name.method_owner option 12 | 13 | (** Extract the method owner (self) of given method scheme *) 14 | val method_owner_of_scheme : 15 | pos:Position.t -> pp:PPTree.t -> T.scheme -> Name.method_owner 16 | 17 | (** Translate a name to an internal representation. *) 18 | val tr_name : pos:Position.t -> pp:PPTree.t -> T.name -> T.scheme -> Name.t 19 | 20 | (** Translate an identifier to an internal representation. *) 21 | val tr_ident : pos:Position.t -> pp:PPTree.t -> S.ident -> T.scheme -> Name.t 22 | 23 | (** Translate a scheme to an internal representation. *) 24 | val tr_scheme : pos:Position.t -> pp:PPTree.t -> T.scheme -> Name.scheme 25 | 26 | (** Apply renaming to a name *) 27 | val rename : T.Ren.t -> Name.t -> Name.t 28 | 29 | (** Apply renaming to a named pattern *) 30 | val rename_pattern : T.Ren.t -> Name.pattern -> Name.pattern 31 | -------------------------------------------------------------------------------- /examples/Modules/Main.fram: -------------------------------------------------------------------------------- 1 | {## This example serves to showcase the files-as-modules feature. 2 | 3 | The module hierarchy is as follows. 4 | ``` 5 | / 6 | ├─ Main 7 | │ ├─ Main (this file) 8 | │ ├─ A (imports B/C/D, resolving to /Main/B/C/D) 9 | │ ├─ B 10 | │ │  ├─ A 11 | │ │  └─ C 12 | │ │  └─ D (imports A, resolving to /Main/B/A) 13 | │ └─ C 14 | ├─ List 15 | ⋮ 16 | ``` 17 | Modules under `/Main/` are local to this example and follow its directory 18 | structure. Additionaly, the module `/List` from the standard library is 19 | imported. 20 | 21 | Relative imports refer to the module which is the closest to the importing 22 | module, working upwards through the hierarchy. In this example the module 23 | `/Main/B/C/D` imports the relative path `A`, and the nearest matching 24 | module is `/Main/B/A`. ##} 25 | 26 | import List 27 | 28 | import A 29 | import B/C/D as X 30 | import /Main/B/C/D as Y {# The same import, but as an absolute path. #} 31 | import B/A as A2 32 | 33 | {# Rather than binding a module name, import the module's contents #} 34 | import open C 35 | 36 | let _ = 37 | List.iter (fn x => printInt x; printStr "\n") 38 | [ X.id A.foo, Y.id A2.bar, mod_C_value ] 39 | -------------------------------------------------------------------------------- /src/TypeInference/RecDefs.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type-inference for recursive definitions *) 6 | 7 | open Common 8 | open TypeCheckFix 9 | 10 | (** The result of checking a block of mutually-recursive definitions. *) 11 | type 'st rec_result = 12 | { rec_env : ('st, sec) opn Env.t; 13 | (** The environment after checking the definitions. *) 14 | 15 | rec_dds : T.data_def list; 16 | (** The data definitions in the block. *) 17 | 18 | rec_targs : T.named_tvar list; 19 | (** Type parameters common to all definitions. *) 20 | 21 | rec_named : (T.name * T.var * T.scheme_expr) list; 22 | (** Named parameters common to all definitions. *) 23 | 24 | rec_fds : T.rec_def list; 25 | (** The recursive definitions in the block. *) 26 | 27 | rec_eff : T.effct; 28 | (** The effect of the definitions. It might be impure, because of 29 | generating fresh labels. *) 30 | 31 | rec_constr : Constr.t list 32 | (** The constraints that were generated. *) 33 | } 34 | 35 | (** Check a block of mutually-recursive definitions. *) 36 | val check_rec_defs : tcfix:tcfix -> pos:Position.t -> 37 | ('st, sec) opn Env.t -> S.def list -> 'st rec_result 38 | -------------------------------------------------------------------------------- /src/Lang/ConEPriv/TVar.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type variables *) 6 | 7 | type t = UnifCommon.TVar.t 8 | 9 | (** Kind of a type variable *) 10 | val kind : t -> UnifCommon.Kind.t 11 | 12 | (** Create a fresh type variable of the effect kind. *) 13 | val fresh_eff : scope:Scope.t -> t 14 | 15 | (** Fresh type variable, that uses the metadata (ppuid, kind) from the given 16 | Unif type variable *) 17 | val clone_unif : scope:Scope.t -> UnifCommon.TVar.t -> t 18 | 19 | (** Fresh type variable that uses the metadata from the given type variable *) 20 | val clone : scope:Scope.t -> t -> t 21 | 22 | (** Comparator for type variables *) 23 | val compare : t -> t -> int 24 | 25 | (** Check equality of type variables *) 26 | val equal : t -> t -> bool 27 | 28 | (** Check if a type variable can be used in a given scope *) 29 | val in_scope : t -> Scope.t -> bool 30 | 31 | (** Get the unique identifier for pretty-printing *) 32 | val pp_uid : t -> PPTree.uid 33 | 34 | (** Finite sets of type variables *) 35 | module Set : Set.S with type elt = t 36 | 37 | (** Finite map from type variables *) 38 | module Map : Map.S with type key = t 39 | 40 | (** Pretty-print a type variable as an S-expression *) 41 | val to_sexpr : t -> SExpr.t 42 | -------------------------------------------------------------------------------- /src/Lang/UnifPriv/Name.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Operations on names *) 6 | 7 | open TypeBase 8 | 9 | module Ordered = struct 10 | type t = TypeBase.name 11 | 12 | let compare n1 n2 = 13 | match n1, n2 with 14 | | NVar x1, NVar x2 -> String.compare x1 x2 15 | | NVar _, _ -> -1 16 | | _, NVar _ -> 1 17 | 18 | | NOptionalVar x1, NOptionalVar x2 -> String.compare x1 x2 19 | | NOptionalVar _, _ -> -1 20 | | _, NOptionalVar _ -> 1 21 | 22 | | NMethod n1, NMethod n2 -> String.compare n1 n2 23 | | NMethod _, _ -> -1 24 | | _, NMethod _ -> 1 25 | 26 | | NImplicit n1, NImplicit n2 -> String.compare n1 n2 27 | end 28 | 29 | let equal n1 n2 = 30 | match n1, n2 with 31 | | NVar x1, NVar x2 -> x1 = x2 32 | | NVar _, _ -> false 33 | 34 | | NOptionalVar x1, NOptionalVar x2 -> x1 = x2 35 | | NOptionalVar _, _ -> false 36 | 37 | | NMethod n1, NMethod n2 -> n1 = n2 38 | | NMethod _, _ -> false 39 | 40 | | NImplicit n1, NImplicit n2 -> n1 = n2 41 | | NImplicit _, _ -> false 42 | 43 | let assoc n xs = 44 | List.find_map (fun (m, v) -> if equal n m then Some v else None) xs 45 | 46 | module Set = Set.Make(Ordered) 47 | module Map = Map.Make(Ordered) 48 | -------------------------------------------------------------------------------- /src/IncrSAT/Formula.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Positive formulas *) 6 | 7 | type t 8 | 9 | (** Always true formula *) 10 | val top : t 11 | 12 | (* Always false formula *) 13 | val bot : t 14 | 15 | (** Propositional variable as a formula *) 16 | val var : PropVar.t -> t 17 | 18 | (** Formula build from a single fresh propositional variable *) 19 | val fresh_var : unit -> t 20 | 21 | (** Conjunction of two formuals *) 22 | val conj : t -> t -> t 23 | 24 | (** Disjunction of two formulas *) 25 | val disj : t -> t -> t 26 | 27 | (** Check if formula is trivially true *) 28 | val is_true : t -> bool 29 | 30 | (** Check if formula is trivially false *) 31 | val is_false : t -> bool 32 | 33 | (** Check if one formula trivially implies the other *) 34 | val implies : t -> t -> bool 35 | 36 | (** Set some propositional variables in order to fix its value. Return the 37 | value of the formula *) 38 | val fix : t -> bool 39 | 40 | (** Convert implication to CNF, i.e., conjunction of disjunctions of litarals. 41 | The boolean flag at each literal describes polarity: [false] means that 42 | variable is negated. *) 43 | val imp_to_cnf : t -> t -> (PropVar.t * bool) list list 44 | 45 | (** Pretty-print formula as S-expression *) 46 | val to_sexpr : t -> SExpr.t 47 | -------------------------------------------------------------------------------- /src/Lang/UnifCommon/TVar.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Type variables *) 6 | 7 | module Ordered = struct 8 | type t = { 9 | uid : UID.t; 10 | method_ns : UID.t; 11 | pp_uid : PPTree.uid; 12 | kind : Kind.t; 13 | scope : Scope.t 14 | } 15 | 16 | let compare x y = UID.compare x.uid y.uid 17 | end 18 | include Ordered 19 | 20 | let kind x = x.kind 21 | 22 | let fresh ?method_ns ?pp_uid ~scope kind = 23 | assert (not (Scope.equal scope Scope.root)); 24 | let uid = UID.fresh () in 25 | { uid = uid; 26 | method_ns = Option.value method_ns ~default:uid; 27 | pp_uid = Option.value pp_uid ~default:(PPTree.PP_UID uid); 28 | kind = kind; 29 | scope = scope 30 | } 31 | 32 | let clone ~scope x = 33 | let uid = UID.fresh () in 34 | { x with uid; method_ns = uid; scope = scope } 35 | 36 | let equal x y = x == y 37 | 38 | let uid x = x.uid 39 | 40 | let method_ns x = x.method_ns 41 | 42 | let pp_uid x = x.pp_uid 43 | 44 | let scope x = x.scope 45 | 46 | let in_scope x scope = Scope.mem x.scope scope 47 | 48 | module Set = Set.Make(Ordered) 49 | module Map = Map.Make(Ordered) 50 | 51 | let to_sexpr x = 52 | SExpr.List [ 53 | SExpr.Sym (UID.to_string x.uid); 54 | Scope.to_sexpr x.scope 55 | ] 56 | -------------------------------------------------------------------------------- /src/Eval/ExternalUtils.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | open Value 6 | 7 | 8 | exception Runtime_error 9 | 10 | (** External functions *) 11 | (* ========================================================================= *) 12 | 13 | let runtime_error msg = 14 | Printf.eprintf "Runtime error: %s\n%!" msg; 15 | raise Runtime_error 16 | 17 | let runtime_error_with_postion file line msg = 18 | Printf.eprintf "runtime error at %s:%d:\n%s!\n" file line msg; 19 | raise Runtime_error 20 | 21 | let pure_fun f = VFn (fun v cont -> cont (f v)) 22 | 23 | let unit_fun f = VFn (fun v cont -> cont (f ())) 24 | 25 | let int_fun f = VFn (fun v cont -> 26 | match v with 27 | | VNum n -> cont (f n) 28 | | _ -> runtime_error "Not an integer") 29 | 30 | let v_unit = VCtor(0, []) 31 | 32 | (** Empty constructor with some abstract types *) 33 | let v_abstr = VCtor(0, []) 34 | 35 | let of_bool b = 36 | VCtor((if b then 1 else 0), []) 37 | 38 | let rec of_list = function 39 | | [] -> VCtor(0, []) 40 | | x :: xs -> VCtor(1, [x; of_list xs]) 41 | 42 | let of_option opt = 43 | match opt with 44 | | Some x -> VCtor(1, [x]) 45 | | None -> VCtor(0, []) 46 | 47 | let str_fun f = VFn (fun v cont -> 48 | match v with 49 | | VStr s -> cont (f s) 50 | | _ -> runtime_error "Not a string") 51 | 52 | 53 | -------------------------------------------------------------------------------- /src/EffectInference/Subtyping.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Collecting constraints arising from subtyping. *) 6 | 7 | open Common 8 | 9 | (** Ensure that one computation effect is a subeffect of another *) 10 | val subceffect : origin:origin -> Env.t -> T.ceffect -> T.ceffect -> unit 11 | 12 | (** Ensure that one type is less then another *) 13 | val subtype : origin:origin -> Env.t -> T.typ -> T.typ -> unit 14 | 15 | (** Ensure that one type scheme is less then another *) 16 | val subscheme : origin:origin -> Env.t -> T.scheme -> T.scheme -> unit 17 | 18 | (** Create a type with the same shape as the given one, but with all effects 19 | replaced with fresh generalizable variables at the outer scope (the scope of 20 | [outer_env]). The type might be later used with [subtype] function to ensure 21 | that type variables of the effect kind don't escape their scopes. *) 22 | val type_shape : outer_env:Env.t -> T.typ -> T.typ 23 | 24 | (** Decompose a type into components of an arrow type *) 25 | val as_arrow : T.typ -> T.scheme * T.typ * T.ceffect 26 | 27 | (** Decompose a type into components of a label type *) 28 | val as_label : T.typ -> T.effct * T.typ * T.effct 29 | 30 | (** Decompose a type into components of a handler type *) 31 | val as_handler : T.typ -> T.tvar * T.typ * T.typ * T.effct * T.typ * T.effct 32 | -------------------------------------------------------------------------------- /src/DblParser/File.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Parse a single file with no handling of imports *) 6 | 7 | type fname = string 8 | type def_list = Lang.Surface.def list Lang.Surface.node 9 | 10 | let with_in_channel ?pos fname func = 11 | match open_in fname with 12 | | chan -> 13 | begin match func chan with 14 | | result -> close_in_noerr chan; result 15 | | exception Sys_error msg -> 16 | close_in_noerr chan; 17 | Error.fatal (Error.cannot_read_file ?pos ~fname msg) 18 | | exception ex -> 19 | close_in_noerr chan; 20 | raise ex 21 | end 22 | | exception Sys_error msg -> 23 | Error.fatal (Error.cannot_open_file ?pos ~fname msg) 24 | 25 | let parse_defs ?pos fname = 26 | let imports, prog = 27 | with_in_channel ?pos fname (fun chan -> 28 | let lexbuf = Lexing.from_channel chan in 29 | lexbuf.Lexing.lex_curr_p <- 30 | { lexbuf.Lexing.lex_curr_p with 31 | Lexing.pos_fname = fname 32 | }; 33 | Lexer.reset (); 34 | try YaccParser.file Lexer.token lexbuf with 35 | | Parsing.Parse_error -> 36 | Error.fatal (Error.unexpected_token 37 | (Position.of_pp 38 | lexbuf.Lexing.lex_start_p 39 | lexbuf.Lexing.lex_curr_p) 40 | (Lexing.lexeme lexbuf))) 41 | in 42 | (imports, Desugar.tr_program prog) 43 | -------------------------------------------------------------------------------- /src/Eval/Value.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of DBL, released under MIT license. 2 | * See LICENSE for details. 3 | *) 4 | 5 | (** Value of the evaluator *) 6 | type value = 7 | | VNum of int 8 | (** Number *) 9 | 10 | | VNum64 of int64 11 | (** 64 bit number *) 12 | 13 | | VStr of string 14 | (** String *) 15 | 16 | | VFn of (value -> value comp) 17 | (** Function *) 18 | 19 | | VCtor of int * value list 20 | (** Constructor of ADT *) 21 | 22 | | VLabel of UID.t 23 | (** Runtime label of control operator *) 24 | 25 | | VRef of value ref 26 | (** Mutable reference *) 27 | 28 | | VArray of value array 29 | (** Mutable arrays *) 30 | 31 | (** CPS Computations *) 32 | and 'v comp = ('v -> ans) -> ans 33 | 34 | (** Stack frame (related to control operators) *) 35 | and frame = 36 | { f_label : UID.t 37 | ; f_vals : value list 38 | ; f_ret : (value -> value comp) 39 | ; f_cont : (value -> ans) 40 | } 41 | 42 | (** Answer type: depends on stack *) 43 | and ans = frame list -> unit 44 | 45 | let to_string (v : value) = 46 | match v with 47 | | VNum n -> string_of_int n 48 | | VNum64 n -> Int64.to_string n 49 | | VStr s -> Printf.sprintf "\"%s\"" (String.escaped s) 50 | | VFn _ -> "" 51 | | VCtor _ -> "" 52 | | VLabel _ -> "