From 1017b108c25877cef73b4b5a412edb3712ce5575 Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Tue, 24 Oct 2023 20:25:58 +0100 Subject: [PATCH 1/4] Destroy everything --- Makefile | 99 -- backends/.dockerignore | 2 - backends/.gitignore | 42 - backends/LICENSE | 30 - backends/backends.cabal | 106 -- backends/src/Language/Mimsa/Backend.hs | 3 - .../Language/Mimsa/Backend/BackendError.hs | 35 - .../Mimsa/Backend/Javascript/Printer.hs | 152 -- backends/src/Language/Mimsa/Backend/Output.hs | 351 ----- backends/src/Language/Mimsa/Backend/Shared.hs | 62 - backends/src/Language/Mimsa/Backend/Types.hs | 20 - .../Mimsa/Backend/Typescript/DataType.hs | 98 -- .../Mimsa/Backend/Typescript/FromDataType.hs | 30 - .../Mimsa/Backend/Typescript/FromExpr.hs | 283 ---- .../Mimsa/Backend/Typescript/FromType.hs | 85 -- .../Mimsa/Backend/Typescript/Monad.hs | 202 --- .../Mimsa/Backend/Typescript/Patterns.hs | 181 --- .../Mimsa/Backend/Typescript/Printer.hs | 223 --- .../Mimsa/Backend/Typescript/Types.hs | 145 -- .../static/backend/es-modules-js/stdlib.mjs | 15 - backends/static/backend/typescript/stdlib.ts | 18 - backends/test/Spec.hs | 14 - backends/test/Test/Backend/ESModulesJS.hs | 278 ---- backends/test/Test/Backend/Typescript.hs | 318 ---- backends/test/Test/Codegen/Shared.hs | 249 --- backends/test/Test/Utils/Helpers.hs | 50 - ...51e87140a9c47df381d7f7a5a20a7a62f7e3a.json | 1 - ...99d3f65d1a5725b76bb1c4825da0d303bad2e.json | 1 - ...868a14960ab8a88c160c99155de48495a9719.json | 1 - ...b57d56146f1741754d625cc773126bab2bcec.json | 1 - ...a4159586f7127b844c456e4654b5594619708.json | 1 - ...0b40f678b4836693a1203eda44cfddaf61b51.json | 1 - ...e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json | 1 - ...215efcbab99ec33a5b53fd3f707595996281c.json | 1 - ...b1216053a4b4ad4e0be6514244b86f7af98b7.json | 1 - ...0446c146bd901b5873a29f7e2833ac329ac65.json | 1 - ...83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json | 1 - ...fd6686130250213b06c8b0e8578afec138b09.json | 1 - ...5314a91e8ee1f9a5d94092d5336801301f5c7.json | 1 - ...cb89fbb9835d356d23214678c5cdec521cfd1.json | 1 - ...eae4177b99b3dda036dc436e8cb4a5c0721f5.json | 1 - ...fc9dbf88aae1668c1935644c9a9c0a155369b.json | 1 - ...ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json | 1 - ...8a218cf0ddd6ac2dd428fd38059d9adfc1705.json | 1 - ...b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json | 1 - ...12e1c345f8e7ef087ebfa3d12688b1107d131.json | 1 - ...2a044674f184dae7712178aada1bc7a58f45c.json | 1 - ...7dd76b06341c29f2f421af30267ca6f889ab4.json | 1 - ...11933d4b49f185dcb0d781cdb3d20dac1dd1b.json | 1 - ...2d186f310fc073bbb109b9d0050e507df1aea.json | 1 - backends/test/modules/1.mimsa | 20 - backends/test/modules/10.mimsa | 10 - backends/test/modules/2.mimsa | 4 - backends/test/modules/3.mimsa | 3 - backends/test/modules/4.mimsa | 3 - backends/test/modules/5.mimsa | 1 - backends/test/modules/6.mimsa | 1 - backends/test/modules/7.mimsa | 1 - backends/test/modules/8.mimsa | 7 - backends/test/modules/9.mimsa | 1 - builder/CHANGELOG.md | 5 - builder/LICENSE | 30 - builder/builder.cabal | 116 -- builder/src/Builder.hs | 3 - builder/src/Builder/Polymorphic.hs | 99 -- builder/test/Spec.hs | 12 - builder/test/Test/Builder/BuilderSpec.hs | 102 -- cabal.project | 9 - compiler/.dockerignore | 2 - compiler/.gitignore | 42 - compiler/LICENSE | 30 - compiler/mimsa.cabal | 279 ---- .../src/Language/Mimsa/Actions/Compile.hs | 221 --- .../Language/Mimsa/Actions/Helpers/Build.hs | 107 -- .../Helpers/GetDepsForStoreExpression.hs | 40 - .../Mimsa/Actions/Helpers/LookupExpression.hs | 29 - .../Actions/Helpers/NumberStoreExpression.hs | 25 - .../Language/Mimsa/Actions/Helpers/Parse.hs | 25 - .../src/Language/Mimsa/Actions/Interpret.hs | 104 -- .../Language/Mimsa/Actions/Modules/Bind.hs | 69 - .../Language/Mimsa/Actions/Modules/Check.hs | 50 - .../Mimsa/Actions/Modules/Evaluate.hs | 75 - .../Language/Mimsa/Actions/Modules/Imports.hs | 63 - .../Mimsa/Actions/Modules/RunTests.hs | 53 - .../Actions/Modules/ToStoreExpressions.hs | 52 - .../Mimsa/Actions/Modules/Typecheck.hs | 66 - compiler/src/Language/Mimsa/Actions/Monad.hs | 159 -- .../src/Language/Mimsa/Actions/Optimise.hs | 131 -- compiler/src/Language/Mimsa/Actions/Types.hs | 67 - .../Language/Mimsa/Backend/Wasm/Compile.hs | 167 -- .../src/Language/Mimsa/Interpreter/App.hs | 38 - compiler/src/Language/Mimsa/Interpreter/If.hs | 28 - .../src/Language/Mimsa/Interpreter/Infix.hs | 125 -- .../Language/Mimsa/Interpreter/Interpret.hs | 94 -- .../src/Language/Mimsa/Interpreter/Let.hs | 56 - .../src/Language/Mimsa/Interpreter/Monad.hs | 123 -- .../Mimsa/Interpreter/PatternMatch.hs | 136 -- .../Mimsa/Interpreter/RecordAccess.hs | 53 - .../Language/Mimsa/Interpreter/SimpleExpr.hs | 52 - .../src/Language/Mimsa/Interpreter/Types.hs | 39 - compiler/src/Language/Mimsa/Logging.hs | 17 - compiler/src/Language/Mimsa/Modules/Check.hs | 66 - .../Language/Mimsa/Modules/Dependencies.hs | 255 ---- .../src/Language/Mimsa/Modules/FromParts.hs | 211 --- .../src/Language/Mimsa/Modules/HashModule.hs | 24 - compiler/src/Language/Mimsa/Modules/Monad.hs | 131 -- compiler/src/Language/Mimsa/Modules/Parse.hs | 25 - .../src/Language/Mimsa/Modules/Prelude.hs | 58 - compiler/src/Language/Mimsa/Modules/Pretty.hs | 46 - .../Language/Mimsa/Modules/ToStoreExprs.hs | 410 ----- .../src/Language/Mimsa/Modules/Typecheck.hs | 423 ------ compiler/src/Language/Mimsa/Modules/Uses.hs | 146 -- compiler/src/Language/Mimsa/Project.hs | 6 - .../src/Language/Mimsa/Project/Helpers.hs | 136 -- .../src/Language/Mimsa/Project/SourceSpan.hs | 35 - compiler/src/Language/Mimsa/Project/Stdlib.hs | 80 - .../src/Language/Mimsa/Project/TypeSearch.hs | 95 -- compiler/src/Language/Mimsa/Store.hs | 10 - .../src/Language/Mimsa/Store/ExtractTypes.hs | 24 - compiler/src/Language/Mimsa/Store/Hashing.hs | 24 - compiler/src/Language/Mimsa/Store/Helpers.hs | 24 - .../src/Language/Mimsa/Store/Persistence.hs | 89 -- .../Language/Mimsa/Store/ResolveDataTypes.hs | 34 - .../src/Language/Mimsa/Store/ResolvedDeps.hs | 128 -- compiler/src/Language/Mimsa/Store/Storage.hs | 260 ---- compiler/src/Language/Mimsa/Tests/Generate.hs | 147 -- compiler/src/Language/Mimsa/Tests/Helpers.hs | 45 - compiler/src/Language/Mimsa/Tests/UnitTest.hs | 16 - .../Language/Mimsa/Transform/BetaReduce.hs | 26 - .../src/Language/Mimsa/Transform/EtaReduce.hs | 18 - .../Language/Mimsa/Transform/FindUnused.hs | 117 -- .../src/Language/Mimsa/Transform/FindUses.hs | 45 - .../Language/Mimsa/Transform/FlattenLets.hs | 30 - .../src/Language/Mimsa/Transform/FloatDown.hs | 22 - .../src/Language/Mimsa/Transform/FloatUp.hs | 21 - .../src/Language/Mimsa/Transform/Inliner.hs | 134 -- .../src/Language/Mimsa/Transform/Shared.hs | 20 - .../Mimsa/Transform/SimplifyPatterns.hs | 85 -- .../src/Language/Mimsa/Transform/TrimDeps.hs | 24 - compiler/src/Language/Mimsa/Typechecker.hs | 6 - .../Language/Mimsa/Typechecker/BuiltIns.hs | 23 - .../Language/Mimsa/Typechecker/CreateEnv.hs | 79 - .../Language/Mimsa/Typechecker/DataTypes.hs | 198 --- .../Mimsa/Typechecker/DisplayError.hs | 37 - .../Language/Mimsa/Typechecker/Elaborate.hs | 827 ---------- .../Language/Mimsa/Typechecker/Environment.hs | 34 - .../Mimsa/Typechecker/Exhaustiveness.hs | 299 ---- .../Language/Mimsa/Typechecker/FlattenRow.hs | 15 - .../Language/Mimsa/Typechecker/Generalise.hs | 33 - .../Mimsa/Typechecker/NormaliseTypes.hs | 32 - .../Language/Mimsa/Typechecker/NumberVars.hs | 303 ---- .../Language/Mimsa/Typechecker/OutputTypes.hs | 99 -- .../Mimsa/Typechecker/ScopeTypeVar.hs | 63 - .../src/Language/Mimsa/Typechecker/Solve.hs | 48 - .../src/Language/Mimsa/Typechecker/TcMonad.hs | 126 -- .../Language/Mimsa/Typechecker/Typecheck.hs | 67 - .../Language/Mimsa/Typechecker/TypedHoles.hs | 41 - .../src/Language/Mimsa/Typechecker/Unify.hs | 180 --- compiler/src/Language/Mimsa/Types/Error.hs | 87 -- .../Mimsa/Types/Error/CodegenError.hs | 44 - .../Mimsa/Types/Error/InterpreterError.hs | 80 - .../Language/Mimsa/Types/Error/ModuleError.hs | 74 - .../Mimsa/Types/Error/PatternMatchError.hs | 101 -- .../Mimsa/Types/Error/ProjectError.hs | 28 - .../Mimsa/Types/Error/ResolverError.hs | 25 - .../Language/Mimsa/Types/Error/StoreError.hs | 76 - .../Language/Mimsa/Types/Error/TypeError.hs | 438 ------ .../Language/Mimsa/Types/Interpreter/Stack.hs | 45 - compiler/src/Language/Mimsa/Types/Project.hs | 18 - .../Language/Mimsa/Types/Project/Project.hs | 35 - .../Mimsa/Types/Project/ProjectHash.hs | 31 - .../Mimsa/Types/Project/SaveProject.hs | 35 - .../Mimsa/Types/Project/SourceItem.hs | 21 - .../Mimsa/Types/Project/SourceSpan.hs | 18 - .../src/Language/Mimsa/Types/Project/Usage.hs | 27 - .../Language/Mimsa/Types/Project/Versioned.hs | 11 - .../Mimsa/Types/Project/VersionedMap.hs | 36 - compiler/src/Language/Mimsa/Types/Store.hs | 16 - .../Language/Mimsa/Types/Store/Bindings.hs | 28 - .../Language/Mimsa/Types/Store/ExprHash.hs | 32 - .../Mimsa/Types/Store/ResolvedDeps.hs | 30 - .../Language/Mimsa/Types/Store/RootPath.hs | 10 - .../src/Language/Mimsa/Types/Store/Store.hs | 30 - .../Mimsa/Types/Store/StoreExpression.hs | 62 - .../Mimsa/Types/Store/TypeBindings.hs | 30 - compiler/src/Language/Mimsa/Types/Tests.hs | 143 -- .../src/Language/Mimsa/Types/Typechecker.hs | 14 - .../Mimsa/Types/Typechecker/Constraint.hs | 14 - .../Mimsa/Types/Typechecker/Environment.hs | 58 - .../Mimsa/Types/Typechecker/FoundPath.hs | 27 - .../Mimsa/Types/Typechecker/Scheme.hs | 17 - .../Mimsa/Types/Typechecker/Substitutions.hs | 62 - .../Types/Typechecker/TypeConstructor.hs | 25 - .../Mimsa/Types/Typechecker/UniVar.hs | 16 - .../Mimsa/Types/Typechecker/Unique.hs | 22 - compiler/static/modules/Array.mimsa | 23 - compiler/static/modules/Either.mimsa | 5 - compiler/static/modules/Maybe.mimsa | 11 - compiler/static/modules/Monoid.mimsa | 37 - compiler/static/modules/NonEmptyArray.mimsa | 6 - compiler/static/modules/Parser.mimsa | 59 - compiler/static/modules/Prelude.mimsa | 40 - compiler/static/modules/Reader.mimsa | 21 - compiler/static/modules/State.mimsa | 28 - compiler/static/modules/String.mimsa | 18 - compiler/static/modules/These.mimsa | 2 - compiler/static/modules/Tree.mimsa | 16 - compiler/static/test/failing-test.ts | 8 - compiler/static/test/test.js | 1 - compiler/static/test/test.ts | 5 - compiler/test/Spec.hs | 82 - compiler/test/Test/Actions/BindModule.hs | 81 - compiler/test/Test/Actions/Build.hs | 102 -- compiler/test/Test/Actions/Compile.hs | 41 - compiler/test/Test/Actions/Evaluate.hs | 28 - .../test/Test/Backend/ESModulesJSEndToEnd.hs | 297 ---- compiler/test/Test/Backend/RunNode.hs | 104 -- .../test/Test/Backend/TypescriptEndToEnd.hs | 286 ---- compiler/test/Test/Backend/Wasm.hs | 117 -- compiler/test/Test/Codegen/Shared.hs | 249 --- compiler/test/Test/Data/Prelude.hs | 50 - compiler/test/Test/Data/Project.hs | 24 - compiler/test/Test/Modules/Check.hs | 528 ------- compiler/test/Test/Modules/Repl.hs | 1352 ----------------- compiler/test/Test/Modules/Test.hs | 66 - compiler/test/Test/Modules/ToStoreExprs.hs | 104 -- compiler/test/Test/Modules/Uses.hs | 74 - compiler/test/Test/Project/NormaliseType.hs | 69 - compiler/test/Test/Project/SourceSpan.hs | 42 - compiler/test/Test/Project/Stdlib.hs | 47 - compiler/test/Test/RenderErrors.hs | 87 -- compiler/test/Test/Serialisation.hs | 28 - compiler/test/Test/Tests/Properties.hs | 111 -- compiler/test/Test/Transform/BetaReduce.hs | 37 - compiler/test/Test/Transform/EtaReduce.hs | 40 - compiler/test/Test/Transform/FindUnused.hs | 79 - compiler/test/Test/Transform/FindUses.hs | 27 - compiler/test/Test/Transform/FlattenLets.hs | 45 - compiler/test/Test/Transform/FloatDown.hs | 28 - compiler/test/Test/Transform/FloatUp.hs | 32 - compiler/test/Test/Transform/Inliner.hs | 73 - .../test/Test/Transform/SimplifyPatterns.hs | 30 - compiler/test/Test/Typechecker/DataTypes.hs | 97 -- compiler/test/Test/Typechecker/Elaborate.hs | 194 --- .../test/Test/Typechecker/Exhaustiveness.hs | 441 ------ compiler/test/Test/Typechecker/NumberVars.hs | 197 --- .../test/Test/Typechecker/ScopeTypeVar.hs | 76 - .../test/Test/Typechecker/Substitutions.hs | 26 - compiler/test/Test/Typechecker/Typecheck.hs | 1304 ---------------- compiler/test/Test/Typechecker/Unify.hs | 233 --- compiler/test/Test/Utils/Compilation.hs | 175 --- compiler/test/Test/Utils/Helpers.hs | 132 -- compiler/test/Test/Utils/Serialisation.hs | 128 -- ...51e87140a9c47df381d7f7a5a20a7a62f7e3a.json | 1 - ...99d3f65d1a5725b76bb1c4825da0d303bad2e.json | 1 - ...868a14960ab8a88c160c99155de48495a9719.json | 1 - ...b57d56146f1741754d625cc773126bab2bcec.json | 1 - ...a4159586f7127b844c456e4654b5594619708.json | 1 - ...0b40f678b4836693a1203eda44cfddaf61b51.json | 1 - ...e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json | 1 - ...215efcbab99ec33a5b53fd3f707595996281c.json | 1 - ...b1216053a4b4ad4e0be6514244b86f7af98b7.json | 1 - ...0446c146bd901b5873a29f7e2833ac329ac65.json | 1 - ...83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json | 1 - ...fd6686130250213b06c8b0e8578afec138b09.json | 1 - ...5314a91e8ee1f9a5d94092d5336801301f5c7.json | 1 - ...cb89fbb9835d356d23214678c5cdec521cfd1.json | 1 - ...eae4177b99b3dda036dc436e8cb4a5c0721f5.json | 1 - ...fc9dbf88aae1668c1935644c9a9c0a155369b.json | 1 - ...ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json | 1 - ...8a218cf0ddd6ac2dd428fd38059d9adfc1705.json | 1 - ...b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json | 1 - ...12e1c345f8e7ef087ebfa3d12688b1107d131.json | 1 - ...2a044674f184dae7712178aada1bc7a58f45c.json | 1 - ...7dd76b06341c29f2f421af30267ca6f889ab4.json | 1 - ...11933d4b49f185dcb0d781cdb3d20dac1dd1b.json | 1 - ...2d186f310fc073bbb109b9d0050e507df1aea.json | 1 - compiler/test/modules/1.mimsa | 20 - compiler/test/modules/10.mimsa | 10 - compiler/test/modules/2.mimsa | 4 - compiler/test/modules/3.mimsa | 3 - compiler/test/modules/4.mimsa | 3 - compiler/test/modules/5.mimsa | 1 - compiler/test/modules/6.mimsa | 1 - compiler/test/modules/7.mimsa | 1 - compiler/test/modules/8.mimsa | 7 - compiler/test/modules/9.mimsa | 1 - core/.gitignore | 18 - core/LICENSE | 30 - core/core.cabal | 126 -- core/src/Language/Mimsa/Core.hs | 22 - core/src/Language/Mimsa/Core/ExprUtils.hs | 254 ---- core/src/Language/Mimsa/Core/Parser.hs | 18 - .../src/Language/Mimsa/Core/Parser/Helpers.hs | 128 -- .../Language/Mimsa/Core/Parser/Identifier.hs | 25 - .../Language/Mimsa/Core/Parser/Identifiers.hs | 130 -- .../Language/Mimsa/Core/Parser/Language.hs | 401 ----- core/src/Language/Mimsa/Core/Parser/Lexeme.hs | 14 - .../src/Language/Mimsa/Core/Parser/Literal.hs | 82 - core/src/Language/Mimsa/Core/Parser/Module.hs | 148 -- .../Language/Mimsa/Core/Parser/MonoType.hs | 201 --- .../src/Language/Mimsa/Core/Parser/Pattern.hs | 217 --- .../Language/Mimsa/Core/Parser/TypeDecl.hs | 68 - core/src/Language/Mimsa/Core/Parser/Types.hs | 60 - core/src/Language/Mimsa/Core/Printer.hs | 88 -- core/src/Language/Mimsa/Core/TypeUtils.hs | 86 -- core/src/Language/Mimsa/Core/Types/AST.hs | 26 - .../Mimsa/Core/Types/AST/Annotation.hs | 33 - .../Language/Mimsa/Core/Types/AST/DataType.hs | 84 - .../src/Language/Mimsa/Core/Types/AST/Expr.hs | 400 ----- .../Mimsa/Core/Types/AST/Identifier.hs | 26 - .../Language/Mimsa/Core/Types/AST/InfixOp.hs | 52 - .../Language/Mimsa/Core/Types/AST/Literal.hs | 45 - .../Language/Mimsa/Core/Types/AST/Operator.hs | 43 - .../Language/Mimsa/Core/Types/AST/Pattern.hs | 135 -- .../Language/Mimsa/Core/Types/AST/Spread.hs | 46 - .../Mimsa/Core/Types/AST/StringPart.hs | 34 - .../Mimsa/Core/Types/AST/StringType.hs | 49 - .../Language/Mimsa/Core/Types/Identifiers.hs | 16 - .../Mimsa/Core/Types/Identifiers/Name.hs | 69 - .../Mimsa/Core/Types/Identifiers/TestName.hs | 26 - .../Mimsa/Core/Types/Identifiers/TyCon.hs | 71 - .../Mimsa/Core/Types/Identifiers/TyVar.hs | 68 - .../Core/Types/Identifiers/TypeIdentifier.hs | 66 - .../Mimsa/Core/Types/Identifiers/TypeName.hs | 77 - core/src/Language/Mimsa/Core/Types/Module.hs | 14 - .../Mimsa/Core/Types/Module/DefIdentifier.hs | 35 - .../Mimsa/Core/Types/Module/Entity.hs | 51 - .../Mimsa/Core/Types/Module/Module.hs | 183 --- .../Mimsa/Core/Types/Module/ModuleHash.hs | 31 - .../Mimsa/Core/Types/Module/ModuleName.hs | 68 - core/src/Language/Mimsa/Core/Types/Type.hs | 6 - .../Mimsa/Core/Types/Type/MonoType.hs | 198 --- core/src/Language/Mimsa/Core/Utils.hs | 33 - core/test/CoreTest/Parser/DataTypes.hs | 233 --- core/test/CoreTest/Parser/MonoTypeParser.hs | 301 ---- core/test/CoreTest/Parser/Pattern.hs | 100 -- core/test/CoreTest/Parser/Syntax.hs | 875 ----------- core/test/CoreTest/Prettier.hs | 157 -- core/test/CoreTest/Utils/Helpers.hs | 130 -- core/test/Spec.hs | 20 - flake.nix | 6 +- repl/.dockerignore | 2 - repl/.gitignore | 18 - repl/LICENSE | 30 - repl/repl.cabal | 82 - repl/repl/Check/Main.hs | 60 - repl/repl/Compile/Main.hs | 47 - repl/repl/Eval/Main.hs | 57 - repl/repl/Init/Main.hs | 41 - repl/repl/Main.hs | 114 -- repl/repl/Repl/Actions.hs | 63 - repl/repl/Repl/Actions/BindModule.hs | 38 - repl/repl/Repl/Actions/Bindings.hs | 41 - repl/repl/Repl/Actions/Compile.hs | 35 - repl/repl/Repl/Actions/Evaluate.hs | 39 - repl/repl/Repl/Actions/ListModules.hs | 40 - repl/repl/Repl/Helpers.hs | 70 - repl/repl/Repl/Main.hs | 86 -- repl/repl/Repl/Parser.hs | 78 - repl/repl/Repl/Persistence.hs | 80 - repl/repl/Repl/ReplM.hs | 106 -- repl/repl/Repl/Types.hs | 28 - repl/repl/Shared/LoadProject.hs | 21 - smol-backend/.gitignore | 2 - smol-backend/CHANGELOG.md | 5 - smol-backend/smol-backend.cabal | 110 -- smol-backend/src/Smol/Backend.hs | 6 - .../src/Smol/Backend/Compile/RunLLVM.hs | 76 - .../src/Smol/Backend/IR/FromExpr/DataTypes.hs | 174 --- .../src/Smol/Backend/IR/FromExpr/Expr.hs | 641 -------- .../src/Smol/Backend/IR/FromExpr/Helpers.hs | 101 -- .../src/Smol/Backend/IR/FromExpr/Pattern.hs | 114 -- .../src/Smol/Backend/IR/FromExpr/Type.hs | 87 -- .../src/Smol/Backend/IR/FromExpr/Types.hs | 21 - smol-backend/src/Smol/Backend/IR/IRExpr.hs | 140 -- .../src/Smol/Backend/IR/ToLLVM/Helpers.hs | 385 ----- .../src/Smol/Backend/IR/ToLLVM/Patterns.hs | 115 -- .../src/Smol/Backend/IR/ToLLVM/ToLLVM.hs | 241 --- .../src/Smol/Backend/Types/GetPath.hs | 18 - .../Smol/Backend/Types/PatternPredicate.hs | 16 - smol-backend/static/runtime.c | 35 - smol-backend/test/Main.hs | 16 - smol-backend/test/Test/BuiltInTypes.hs | 97 -- smol-backend/test/Test/Helpers.hs | 133 -- smol-backend/test/Test/IR/CompileSpec.hs | 45 - smol-backend/test/Test/IR/DataTypesSpec.hs | 83 - smol-backend/test/Test/IR/FromExprSpec.hs | 353 ----- smol-backend/test/Test/IR/IRSpec.hs | 259 ---- smol-backend/test/Test/IR/PatternSpec.hs | 79 - smol-backend/test/Test/IR/RawSamples.hs | 414 ----- smol-backend/test/Test/IR/Samples.hs | 492 ------ smol-core/.gitignore | 2 - smol-core/CHANGELOG.md | 5 - smol-core/smol-core.cabal | 191 --- smol-core/src/Smol/Core.hs | 18 - smol-core/src/Smol/Core/ExprUtils.hs | 274 ---- smol-core/src/Smol/Core/Helpers.hs | 119 -- smol-core/src/Smol/Core/Interpreter.hs | 6 - smol-core/src/Smol/Core/Interpreter/App.hs | 35 - .../src/Smol/Core/Interpreter/FindUses.hs | 57 - smol-core/src/Smol/Core/Interpreter/If.hs | 27 - smol-core/src/Smol/Core/Interpreter/Infix.hs | 48 - .../src/Smol/Core/Interpreter/Interpret.hs | 91 -- smol-core/src/Smol/Core/Interpreter/Let.hs | 55 - smol-core/src/Smol/Core/Interpreter/Monad.hs | 95 -- .../src/Smol/Core/Interpreter/PatternMatch.hs | 90 -- .../src/Smol/Core/Interpreter/RecordAccess.hs | 31 - smol-core/src/Smol/Core/Interpreter/Types.hs | 39 - .../Interpreter/Types/InterpreterError.hs | 76 - .../src/Smol/Core/Interpreter/Types/Stack.hs | 39 - smol-core/src/Smol/Core/Modules/Check.hs | 98 -- .../src/Smol/Core/Modules/Dependencies.hs | 274 ---- smol-core/src/Smol/Core/Modules/FromParts.hs | 141 -- smol-core/src/Smol/Core/Modules/Helpers.hs | 30 - smol-core/src/Smol/Core/Modules/Interpret.hs | 55 - smol-core/src/Smol/Core/Modules/Monad.hs | 60 - .../src/Smol/Core/Modules/ResolveDeps.hs | 381 ----- smol-core/src/Smol/Core/Modules/RunTests.hs | 17 - smol-core/src/Smol/Core/Modules/Typecheck.hs | 355 ----- smol-core/src/Smol/Core/Modules/Types.hs | 20 - .../Smol/Core/Modules/Types/DefIdentifier.hs | 46 - .../src/Smol/Core/Modules/Types/DepType.hs | 33 - .../src/Smol/Core/Modules/Types/Entity.hs | 53 - .../src/Smol/Core/Modules/Types/Module.hs | 148 -- .../Smol/Core/Modules/Types/ModuleError.hs | 86 -- .../src/Smol/Core/Modules/Types/ModuleItem.hs | 162 -- .../src/Smol/Core/Modules/Types/ModuleName.hs | 66 - smol-core/src/Smol/Core/Modules/Types/Test.hs | 64 - .../src/Smol/Core/Modules/Types/TestName.hs | 21 - .../Core/Modules/Types/TopLevelExpression.hs | 90 -- smol-core/src/Smol/Core/Modules/Uses.hs | 131 -- smol-core/src/Smol/Core/Parser.hs | 62 - smol-core/src/Smol/Core/Parser/DataType.hs | 56 - smol-core/src/Smol/Core/Parser/Expr.hs | 312 ---- smol-core/src/Smol/Core/Parser/Identifiers.hs | 197 --- smol-core/src/Smol/Core/Parser/Module.hs | 130 -- smol-core/src/Smol/Core/Parser/Op.hs | 55 - smol-core/src/Smol/Core/Parser/Pattern.hs | 192 --- smol-core/src/Smol/Core/Parser/Primitives.hs | 103 -- smol-core/src/Smol/Core/Parser/Shared.hs | 89 -- smol-core/src/Smol/Core/Parser/Type.hs | 263 ---- smol-core/src/Smol/Core/Parser/Typeclass.hs | 21 - smol-core/src/Smol/Core/Printer.hs | 85 -- smol-core/src/Smol/Core/SourceSpan.hs | 34 - smol-core/src/Smol/Core/Transform.hs | 14 - .../src/Smol/Core/Transform/BetaReduce.hs | 25 - .../src/Smol/Core/Transform/EtaReduce.hs | 44 - .../src/Smol/Core/Transform/FlattenLets.hs | 20 - .../src/Smol/Core/Transform/FloatDown.hs | 45 - smol-core/src/Smol/Core/TypeUtils.hs | 56 - smol-core/src/Smol/Core/Typecheck.hs | 20 - .../src/Smol/Core/Typecheck/Annotations.hs | 54 - .../src/Smol/Core/Typecheck/Elaborate.hs | 405 ----- smol-core/src/Smol/Core/Typecheck/Errors.hs | 89 -- .../src/Smol/Core/Typecheck/Exhaustiveness.hs | 290 ---- smol-core/src/Smol/Core/Typecheck/FreeVars.hs | 50 - .../src/Smol/Core/Typecheck/FromParsedExpr.hs | 21 - smol-core/src/Smol/Core/Typecheck/Pattern.hs | 142 -- smol-core/src/Smol/Core/Typecheck/Shared.hs | 322 ---- smol-core/src/Smol/Core/Typecheck/Simplify.hs | 55 - .../src/Smol/Core/Typecheck/Substitute.hs | 52 - smol-core/src/Smol/Core/Typecheck/Subtype.hs | 236 --- .../src/Smol/Core/Typecheck/Typecheck.hs | 25 - .../src/Smol/Core/Typecheck/Typeclass.hs | 12 - .../Core/Typecheck/Typeclass/Deduplicate.hs | 80 - .../Smol/Core/Typecheck/Typeclass/Helpers.hs | 296 ---- .../Core/Typecheck/Typeclass/KindChecker.hs | 183 --- .../Typeclass/ToDictionaryPassing.hs | 360 ----- .../Typeclass/ToDictionaryPassing/Types.hs | 42 - .../Core/Typecheck/Typeclass/Typecheck.hs | 103 -- .../Smol/Core/Typecheck/Typeclass/Types.hs | 12 - .../Typecheck/Typeclass/Types/Constraint.hs | 100 -- .../Typecheck/Typeclass/Types/Instance.hs | 78 - .../Core/Typecheck/Typeclass/Types/Kind.hs | 46 - .../Typecheck/Typeclass/Types/Typeclass.hs | 68 - .../Typeclass/Types/TypeclassError.hs | 19 - .../Typeclass/Types/TypeclassName.hs | 66 - smol-core/src/Smol/Core/Typecheck/Types.hs | 23 - .../Smol/Core/Typecheck/Types/Substitution.hs | 59 - .../src/Smol/Core/Typecheck/Types/TCError.hs | 34 - .../src/Smol/Core/Typecheck/Types/TCState.hs | 31 - .../src/Smol/Core/Typecheck/Types/TCWrite.hs | 44 - smol-core/src/Smol/Core/Types.hs | 32 - smol-core/src/Smol/Core/Types/Annotated.hs | 7 - smol-core/src/Smol/Core/Types/Annotation.hs | 18 - smol-core/src/Smol/Core/Types/Constructor.hs | 56 - smol-core/src/Smol/Core/Types/DataType.hs | 117 -- smol-core/src/Smol/Core/Types/Expr.hs | 408 ----- smol-core/src/Smol/Core/Types/Identifier.hs | 56 - smol-core/src/Smol/Core/Types/Op.hs | 21 - smol-core/src/Smol/Core/Types/ParseDep.hs | 35 - smol-core/src/Smol/Core/Types/Pattern.hs | 136 -- .../src/Smol/Core/Types/PatternMatchError.hs | 91 -- smol-core/src/Smol/Core/Types/Prim.hs | 34 - smol-core/src/Smol/Core/Types/ResolvedDep.hs | 40 - smol-core/src/Smol/Core/Types/SourceSpan.hs | 14 - smol-core/src/Smol/Core/Types/Spread.hs | 57 - smol-core/src/Smol/Core/Types/Type.hs | 205 --- smol-core/src/Smol/Core/Types/TypeName.hs | 31 - smol-core/test/Main.hs | 38 - smol-core/test/Test/BuiltInTypes.hs | 122 -- smol-core/test/Test/Helpers.hs | 338 ----- .../test/Test/Interpreter/InterpreterSpec.hs | 98 -- smol-core/test/Test/Modules/CheckSpec.hs | 49 - smol-core/test/Test/Modules/FromPartsSpec.hs | 40 - .../test/Test/Modules/InterpreterSpec.hs | 169 --- .../test/Test/Modules/ResolveDepsSpec.hs | 169 --- smol-core/test/Test/Modules/RunTestsSpec.hs | 57 - smol-core/test/Test/Modules/TypecheckSpec.hs | 71 - smol-core/test/Test/ParserSpec.hs | 224 --- smol-core/test/Test/TransformSpec.hs | 100 -- .../test/Test/Typecheck/ExhaustivenessSpec.hs | 447 ------ .../test/Test/Typecheck/NestingMonadSpec.hs | 34 - smol-core/test/Test/Typecheck/PatternSpec.hs | 61 - smol-core/test/Test/Typecheck/SubtypeSpec.hs | 204 --- .../Test/Typecheck/ToDictionaryPassingSpec.hs | 221 --- .../test/Test/Typecheck/TypeclassSpec.hs | 301 ---- smol-core/test/Test/TypecheckSpec.hs | 800 ---------- smol-core/test/static/Either.smol | 13 - smol-core/test/static/Eq.smol | 45 - smol-core/test/static/Expr.smol | 17 - smol-core/test/static/Functor.smol | 45 - smol-core/test/static/Maybe.smol | 19 - smol-core/test/static/Monoid.smol | 19 - smol-core/test/static/Prelude.smol | 32 - smol-core/test/static/Reader.smol | 16 - smol-core/test/static/Semigroup.smol | 21 - smol-core/test/static/Show.smol | 43 - smol-core/test/static/State.smol | 41 - smol-core/test/static/These.smol | 2 - smol-core/test/static/Tree.smol | 19 - smol-repl/.gitignore | 2 - smol-repl/CHANGELOG.md | 5 - smol-repl/app/Main.hs | 6 - smol-repl/smol-repl.cabal | 69 - smol-repl/src/Repl.hs | 57 - smol-repl/src/Smol/Check.hs | 41 - smol-repl/src/Smol/Repl.hs | 48 - .../src/Smol/Repl/Helpers/Diagnostics.hs | 49 - .../src/Smol/Repl/Helpers/ShowTestResults.hs | 17 - swagger.config.json | 1 - 542 files changed, 1 insertion(+), 47476 deletions(-) delete mode 100644 backends/.dockerignore delete mode 100644 backends/.gitignore delete mode 100644 backends/LICENSE delete mode 100644 backends/backends.cabal delete mode 100644 backends/src/Language/Mimsa/Backend.hs delete mode 100644 backends/src/Language/Mimsa/Backend/BackendError.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Javascript/Printer.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Output.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Shared.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Types.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/DataType.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/FromDataType.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/FromExpr.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/FromType.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/Monad.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/Patterns.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/Printer.hs delete mode 100644 backends/src/Language/Mimsa/Backend/Typescript/Types.hs delete mode 100644 backends/static/backend/es-modules-js/stdlib.mjs delete mode 100644 backends/static/backend/typescript/stdlib.ts delete mode 100644 backends/test/Spec.hs delete mode 100644 backends/test/Test/Backend/ESModulesJS.hs delete mode 100644 backends/test/Test/Backend/Typescript.hs delete mode 100644 backends/test/Test/Codegen/Shared.hs delete mode 100644 backends/test/Test/Utils/Helpers.hs delete mode 100644 backends/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json delete mode 100644 backends/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json delete mode 100644 backends/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json delete mode 100644 backends/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json delete mode 100644 backends/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json delete mode 100644 backends/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json delete mode 100644 backends/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json delete mode 100644 backends/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json delete mode 100644 backends/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json delete mode 100644 backends/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json delete mode 100644 backends/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json delete mode 100644 backends/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json delete mode 100644 backends/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json delete mode 100644 backends/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json delete mode 100644 backends/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json delete mode 100644 backends/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json delete mode 100644 backends/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json delete mode 100644 backends/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json delete mode 100644 backends/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json delete mode 100644 backends/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json delete mode 100644 backends/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json delete mode 100644 backends/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json delete mode 100644 backends/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json delete mode 100644 backends/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json delete mode 100644 backends/test/modules/1.mimsa delete mode 100644 backends/test/modules/10.mimsa delete mode 100644 backends/test/modules/2.mimsa delete mode 100644 backends/test/modules/3.mimsa delete mode 100644 backends/test/modules/4.mimsa delete mode 100644 backends/test/modules/5.mimsa delete mode 100644 backends/test/modules/6.mimsa delete mode 100644 backends/test/modules/7.mimsa delete mode 100644 backends/test/modules/8.mimsa delete mode 100644 backends/test/modules/9.mimsa delete mode 100644 builder/CHANGELOG.md delete mode 100644 builder/LICENSE delete mode 100644 builder/builder.cabal delete mode 100644 builder/src/Builder.hs delete mode 100644 builder/src/Builder/Polymorphic.hs delete mode 100644 builder/test/Spec.hs delete mode 100644 builder/test/Test/Builder/BuilderSpec.hs delete mode 100644 compiler/.dockerignore delete mode 100644 compiler/.gitignore delete mode 100644 compiler/LICENSE delete mode 100644 compiler/mimsa.cabal delete mode 100644 compiler/src/Language/Mimsa/Actions/Compile.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Helpers/Build.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Helpers/GetDepsForStoreExpression.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Helpers/LookupExpression.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Helpers/NumberStoreExpression.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Helpers/Parse.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Interpret.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/Bind.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/Check.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/Evaluate.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/Imports.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/RunTests.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/ToStoreExpressions.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Modules/Typecheck.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Monad.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Optimise.hs delete mode 100644 compiler/src/Language/Mimsa/Actions/Types.hs delete mode 100644 compiler/src/Language/Mimsa/Backend/Wasm/Compile.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/App.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/If.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/Infix.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/Interpret.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/Let.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/Monad.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/PatternMatch.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/RecordAccess.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/SimpleExpr.hs delete mode 100644 compiler/src/Language/Mimsa/Interpreter/Types.hs delete mode 100644 compiler/src/Language/Mimsa/Logging.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Check.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Dependencies.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/FromParts.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/HashModule.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Monad.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Parse.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Prelude.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Pretty.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/ToStoreExprs.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Typecheck.hs delete mode 100644 compiler/src/Language/Mimsa/Modules/Uses.hs delete mode 100644 compiler/src/Language/Mimsa/Project.hs delete mode 100644 compiler/src/Language/Mimsa/Project/Helpers.hs delete mode 100644 compiler/src/Language/Mimsa/Project/SourceSpan.hs delete mode 100644 compiler/src/Language/Mimsa/Project/Stdlib.hs delete mode 100644 compiler/src/Language/Mimsa/Project/TypeSearch.hs delete mode 100644 compiler/src/Language/Mimsa/Store.hs delete mode 100644 compiler/src/Language/Mimsa/Store/ExtractTypes.hs delete mode 100644 compiler/src/Language/Mimsa/Store/Hashing.hs delete mode 100644 compiler/src/Language/Mimsa/Store/Helpers.hs delete mode 100644 compiler/src/Language/Mimsa/Store/Persistence.hs delete mode 100644 compiler/src/Language/Mimsa/Store/ResolveDataTypes.hs delete mode 100644 compiler/src/Language/Mimsa/Store/ResolvedDeps.hs delete mode 100644 compiler/src/Language/Mimsa/Store/Storage.hs delete mode 100644 compiler/src/Language/Mimsa/Tests/Generate.hs delete mode 100644 compiler/src/Language/Mimsa/Tests/Helpers.hs delete mode 100644 compiler/src/Language/Mimsa/Tests/UnitTest.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/BetaReduce.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/EtaReduce.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/FindUnused.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/FindUses.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/FlattenLets.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/FloatDown.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/FloatUp.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/Inliner.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/Shared.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/SimplifyPatterns.hs delete mode 100644 compiler/src/Language/Mimsa/Transform/TrimDeps.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/BuiltIns.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/CreateEnv.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/DataTypes.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/DisplayError.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Elaborate.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Environment.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Exhaustiveness.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/FlattenRow.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Generalise.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/NormaliseTypes.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/NumberVars.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/OutputTypes.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/ScopeTypeVar.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Solve.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/TcMonad.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Typecheck.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/TypedHoles.hs delete mode 100644 compiler/src/Language/Mimsa/Typechecker/Unify.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/CodegenError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/InterpreterError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/ModuleError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/PatternMatchError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/ProjectError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/ResolverError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/StoreError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Error/TypeError.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Interpreter/Stack.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/Project.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/ProjectHash.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/SaveProject.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/SourceItem.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/SourceSpan.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/Usage.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/Versioned.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Project/VersionedMap.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/Bindings.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/ExprHash.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/ResolvedDeps.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/RootPath.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/Store.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/StoreExpression.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Store/TypeBindings.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Tests.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/Constraint.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/Environment.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/FoundPath.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/Scheme.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/Substitutions.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/TypeConstructor.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/UniVar.hs delete mode 100644 compiler/src/Language/Mimsa/Types/Typechecker/Unique.hs delete mode 100644 compiler/static/modules/Array.mimsa delete mode 100644 compiler/static/modules/Either.mimsa delete mode 100644 compiler/static/modules/Maybe.mimsa delete mode 100644 compiler/static/modules/Monoid.mimsa delete mode 100644 compiler/static/modules/NonEmptyArray.mimsa delete mode 100644 compiler/static/modules/Parser.mimsa delete mode 100644 compiler/static/modules/Prelude.mimsa delete mode 100644 compiler/static/modules/Reader.mimsa delete mode 100644 compiler/static/modules/State.mimsa delete mode 100644 compiler/static/modules/String.mimsa delete mode 100644 compiler/static/modules/These.mimsa delete mode 100644 compiler/static/modules/Tree.mimsa delete mode 100644 compiler/static/test/failing-test.ts delete mode 100644 compiler/static/test/test.js delete mode 100644 compiler/static/test/test.ts delete mode 100644 compiler/test/Spec.hs delete mode 100644 compiler/test/Test/Actions/BindModule.hs delete mode 100644 compiler/test/Test/Actions/Build.hs delete mode 100644 compiler/test/Test/Actions/Compile.hs delete mode 100644 compiler/test/Test/Actions/Evaluate.hs delete mode 100644 compiler/test/Test/Backend/ESModulesJSEndToEnd.hs delete mode 100644 compiler/test/Test/Backend/RunNode.hs delete mode 100644 compiler/test/Test/Backend/TypescriptEndToEnd.hs delete mode 100644 compiler/test/Test/Backend/Wasm.hs delete mode 100644 compiler/test/Test/Codegen/Shared.hs delete mode 100644 compiler/test/Test/Data/Prelude.hs delete mode 100644 compiler/test/Test/Data/Project.hs delete mode 100644 compiler/test/Test/Modules/Check.hs delete mode 100644 compiler/test/Test/Modules/Repl.hs delete mode 100644 compiler/test/Test/Modules/Test.hs delete mode 100644 compiler/test/Test/Modules/ToStoreExprs.hs delete mode 100644 compiler/test/Test/Modules/Uses.hs delete mode 100644 compiler/test/Test/Project/NormaliseType.hs delete mode 100644 compiler/test/Test/Project/SourceSpan.hs delete mode 100644 compiler/test/Test/Project/Stdlib.hs delete mode 100644 compiler/test/Test/RenderErrors.hs delete mode 100644 compiler/test/Test/Serialisation.hs delete mode 100644 compiler/test/Test/Tests/Properties.hs delete mode 100644 compiler/test/Test/Transform/BetaReduce.hs delete mode 100644 compiler/test/Test/Transform/EtaReduce.hs delete mode 100644 compiler/test/Test/Transform/FindUnused.hs delete mode 100644 compiler/test/Test/Transform/FindUses.hs delete mode 100644 compiler/test/Test/Transform/FlattenLets.hs delete mode 100644 compiler/test/Test/Transform/FloatDown.hs delete mode 100644 compiler/test/Test/Transform/FloatUp.hs delete mode 100644 compiler/test/Test/Transform/Inliner.hs delete mode 100644 compiler/test/Test/Transform/SimplifyPatterns.hs delete mode 100644 compiler/test/Test/Typechecker/DataTypes.hs delete mode 100644 compiler/test/Test/Typechecker/Elaborate.hs delete mode 100644 compiler/test/Test/Typechecker/Exhaustiveness.hs delete mode 100644 compiler/test/Test/Typechecker/NumberVars.hs delete mode 100644 compiler/test/Test/Typechecker/ScopeTypeVar.hs delete mode 100644 compiler/test/Test/Typechecker/Substitutions.hs delete mode 100644 compiler/test/Test/Typechecker/Typecheck.hs delete mode 100644 compiler/test/Test/Typechecker/Unify.hs delete mode 100644 compiler/test/Test/Utils/Compilation.hs delete mode 100644 compiler/test/Test/Utils/Helpers.hs delete mode 100644 compiler/test/Test/Utils/Serialisation.hs delete mode 100644 compiler/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json delete mode 100644 compiler/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json delete mode 100644 compiler/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json delete mode 100644 compiler/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json delete mode 100644 compiler/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json delete mode 100644 compiler/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json delete mode 100644 compiler/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json delete mode 100644 compiler/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json delete mode 100644 compiler/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json delete mode 100644 compiler/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json delete mode 100644 compiler/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json delete mode 100644 compiler/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json delete mode 100644 compiler/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json delete mode 100644 compiler/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json delete mode 100644 compiler/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json delete mode 100644 compiler/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json delete mode 100644 compiler/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json delete mode 100644 compiler/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json delete mode 100644 compiler/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json delete mode 100644 compiler/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json delete mode 100644 compiler/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json delete mode 100644 compiler/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json delete mode 100644 compiler/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json delete mode 100644 compiler/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json delete mode 100644 compiler/test/modules/1.mimsa delete mode 100644 compiler/test/modules/10.mimsa delete mode 100644 compiler/test/modules/2.mimsa delete mode 100644 compiler/test/modules/3.mimsa delete mode 100644 compiler/test/modules/4.mimsa delete mode 100644 compiler/test/modules/5.mimsa delete mode 100644 compiler/test/modules/6.mimsa delete mode 100644 compiler/test/modules/7.mimsa delete mode 100644 compiler/test/modules/8.mimsa delete mode 100644 compiler/test/modules/9.mimsa delete mode 100644 core/.gitignore delete mode 100644 core/LICENSE delete mode 100644 core/core.cabal delete mode 100644 core/src/Language/Mimsa/Core.hs delete mode 100644 core/src/Language/Mimsa/Core/ExprUtils.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Helpers.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Identifier.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Identifiers.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Language.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Lexeme.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Literal.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Module.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/MonoType.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Pattern.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/TypeDecl.hs delete mode 100644 core/src/Language/Mimsa/Core/Parser/Types.hs delete mode 100644 core/src/Language/Mimsa/Core/Printer.hs delete mode 100644 core/src/Language/Mimsa/Core/TypeUtils.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Annotation.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/DataType.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Expr.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Identifier.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/InfixOp.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Literal.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Operator.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Pattern.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/Spread.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/StringPart.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/AST/StringType.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/Name.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/TestName.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/TyCon.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/TyVar.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/TypeIdentifier.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Identifiers/TypeName.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module/DefIdentifier.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module/Entity.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module/Module.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module/ModuleHash.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Module/ModuleName.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Type.hs delete mode 100644 core/src/Language/Mimsa/Core/Types/Type/MonoType.hs delete mode 100644 core/src/Language/Mimsa/Core/Utils.hs delete mode 100644 core/test/CoreTest/Parser/DataTypes.hs delete mode 100644 core/test/CoreTest/Parser/MonoTypeParser.hs delete mode 100644 core/test/CoreTest/Parser/Pattern.hs delete mode 100644 core/test/CoreTest/Parser/Syntax.hs delete mode 100644 core/test/CoreTest/Prettier.hs delete mode 100644 core/test/CoreTest/Utils/Helpers.hs delete mode 100644 core/test/Spec.hs delete mode 100644 repl/.dockerignore delete mode 100644 repl/.gitignore delete mode 100644 repl/LICENSE delete mode 100644 repl/repl.cabal delete mode 100644 repl/repl/Check/Main.hs delete mode 100644 repl/repl/Compile/Main.hs delete mode 100644 repl/repl/Eval/Main.hs delete mode 100644 repl/repl/Init/Main.hs delete mode 100644 repl/repl/Main.hs delete mode 100644 repl/repl/Repl/Actions.hs delete mode 100644 repl/repl/Repl/Actions/BindModule.hs delete mode 100644 repl/repl/Repl/Actions/Bindings.hs delete mode 100644 repl/repl/Repl/Actions/Compile.hs delete mode 100644 repl/repl/Repl/Actions/Evaluate.hs delete mode 100644 repl/repl/Repl/Actions/ListModules.hs delete mode 100644 repl/repl/Repl/Helpers.hs delete mode 100644 repl/repl/Repl/Main.hs delete mode 100644 repl/repl/Repl/Parser.hs delete mode 100644 repl/repl/Repl/Persistence.hs delete mode 100644 repl/repl/Repl/ReplM.hs delete mode 100644 repl/repl/Repl/Types.hs delete mode 100644 repl/repl/Shared/LoadProject.hs delete mode 100644 smol-backend/.gitignore delete mode 100644 smol-backend/CHANGELOG.md delete mode 100644 smol-backend/smol-backend.cabal delete mode 100644 smol-backend/src/Smol/Backend.hs delete mode 100644 smol-backend/src/Smol/Backend/Compile/RunLLVM.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/DataTypes.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/Expr.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/Helpers.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/Pattern.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/Type.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/FromExpr/Types.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/IRExpr.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/ToLLVM/Patterns.hs delete mode 100644 smol-backend/src/Smol/Backend/IR/ToLLVM/ToLLVM.hs delete mode 100644 smol-backend/src/Smol/Backend/Types/GetPath.hs delete mode 100644 smol-backend/src/Smol/Backend/Types/PatternPredicate.hs delete mode 100644 smol-backend/static/runtime.c delete mode 100644 smol-backend/test/Main.hs delete mode 100644 smol-backend/test/Test/BuiltInTypes.hs delete mode 100644 smol-backend/test/Test/Helpers.hs delete mode 100644 smol-backend/test/Test/IR/CompileSpec.hs delete mode 100644 smol-backend/test/Test/IR/DataTypesSpec.hs delete mode 100644 smol-backend/test/Test/IR/FromExprSpec.hs delete mode 100644 smol-backend/test/Test/IR/IRSpec.hs delete mode 100644 smol-backend/test/Test/IR/PatternSpec.hs delete mode 100644 smol-backend/test/Test/IR/RawSamples.hs delete mode 100644 smol-backend/test/Test/IR/Samples.hs delete mode 100644 smol-core/.gitignore delete mode 100644 smol-core/CHANGELOG.md delete mode 100644 smol-core/smol-core.cabal delete mode 100644 smol-core/src/Smol/Core.hs delete mode 100644 smol-core/src/Smol/Core/ExprUtils.hs delete mode 100644 smol-core/src/Smol/Core/Helpers.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/App.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/FindUses.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/If.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Infix.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Interpret.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Let.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Monad.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/PatternMatch.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/RecordAccess.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Types.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Types/InterpreterError.hs delete mode 100644 smol-core/src/Smol/Core/Interpreter/Types/Stack.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Check.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Dependencies.hs delete mode 100644 smol-core/src/Smol/Core/Modules/FromParts.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Helpers.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Interpret.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Monad.hs delete mode 100644 smol-core/src/Smol/Core/Modules/ResolveDeps.hs delete mode 100644 smol-core/src/Smol/Core/Modules/RunTests.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Typecheck.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/DefIdentifier.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/DepType.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/Entity.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/Module.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/ModuleError.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/ModuleItem.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/ModuleName.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/Test.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/TestName.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Types/TopLevelExpression.hs delete mode 100644 smol-core/src/Smol/Core/Modules/Uses.hs delete mode 100644 smol-core/src/Smol/Core/Parser.hs delete mode 100644 smol-core/src/Smol/Core/Parser/DataType.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Expr.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Identifiers.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Module.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Op.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Pattern.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Primitives.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Shared.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Type.hs delete mode 100644 smol-core/src/Smol/Core/Parser/Typeclass.hs delete mode 100644 smol-core/src/Smol/Core/Printer.hs delete mode 100644 smol-core/src/Smol/Core/SourceSpan.hs delete mode 100644 smol-core/src/Smol/Core/Transform.hs delete mode 100644 smol-core/src/Smol/Core/Transform/BetaReduce.hs delete mode 100644 smol-core/src/Smol/Core/Transform/EtaReduce.hs delete mode 100644 smol-core/src/Smol/Core/Transform/FlattenLets.hs delete mode 100644 smol-core/src/Smol/Core/Transform/FloatDown.hs delete mode 100644 smol-core/src/Smol/Core/TypeUtils.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Annotations.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Elaborate.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Errors.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Exhaustiveness.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/FreeVars.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/FromParsedExpr.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Pattern.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Shared.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Simplify.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Substitute.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Subtype.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typecheck.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Deduplicate.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Helpers.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/KindChecker.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing/Types.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Typecheck.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Constraint.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Instance.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Kind.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Typeclass.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassError.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassName.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Types.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Types/Substitution.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Types/TCError.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Types/TCState.hs delete mode 100644 smol-core/src/Smol/Core/Typecheck/Types/TCWrite.hs delete mode 100644 smol-core/src/Smol/Core/Types.hs delete mode 100644 smol-core/src/Smol/Core/Types/Annotated.hs delete mode 100644 smol-core/src/Smol/Core/Types/Annotation.hs delete mode 100644 smol-core/src/Smol/Core/Types/Constructor.hs delete mode 100644 smol-core/src/Smol/Core/Types/DataType.hs delete mode 100644 smol-core/src/Smol/Core/Types/Expr.hs delete mode 100644 smol-core/src/Smol/Core/Types/Identifier.hs delete mode 100644 smol-core/src/Smol/Core/Types/Op.hs delete mode 100644 smol-core/src/Smol/Core/Types/ParseDep.hs delete mode 100644 smol-core/src/Smol/Core/Types/Pattern.hs delete mode 100644 smol-core/src/Smol/Core/Types/PatternMatchError.hs delete mode 100644 smol-core/src/Smol/Core/Types/Prim.hs delete mode 100644 smol-core/src/Smol/Core/Types/ResolvedDep.hs delete mode 100644 smol-core/src/Smol/Core/Types/SourceSpan.hs delete mode 100644 smol-core/src/Smol/Core/Types/Spread.hs delete mode 100644 smol-core/src/Smol/Core/Types/Type.hs delete mode 100644 smol-core/src/Smol/Core/Types/TypeName.hs delete mode 100644 smol-core/test/Main.hs delete mode 100644 smol-core/test/Test/BuiltInTypes.hs delete mode 100644 smol-core/test/Test/Helpers.hs delete mode 100644 smol-core/test/Test/Interpreter/InterpreterSpec.hs delete mode 100644 smol-core/test/Test/Modules/CheckSpec.hs delete mode 100644 smol-core/test/Test/Modules/FromPartsSpec.hs delete mode 100644 smol-core/test/Test/Modules/InterpreterSpec.hs delete mode 100644 smol-core/test/Test/Modules/ResolveDepsSpec.hs delete mode 100644 smol-core/test/Test/Modules/RunTestsSpec.hs delete mode 100644 smol-core/test/Test/Modules/TypecheckSpec.hs delete mode 100644 smol-core/test/Test/ParserSpec.hs delete mode 100644 smol-core/test/Test/TransformSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/ExhaustivenessSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/NestingMonadSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/PatternSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/SubtypeSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/ToDictionaryPassingSpec.hs delete mode 100644 smol-core/test/Test/Typecheck/TypeclassSpec.hs delete mode 100644 smol-core/test/Test/TypecheckSpec.hs delete mode 100644 smol-core/test/static/Either.smol delete mode 100644 smol-core/test/static/Eq.smol delete mode 100644 smol-core/test/static/Expr.smol delete mode 100644 smol-core/test/static/Functor.smol delete mode 100644 smol-core/test/static/Maybe.smol delete mode 100644 smol-core/test/static/Monoid.smol delete mode 100644 smol-core/test/static/Prelude.smol delete mode 100644 smol-core/test/static/Reader.smol delete mode 100644 smol-core/test/static/Semigroup.smol delete mode 100644 smol-core/test/static/Show.smol delete mode 100644 smol-core/test/static/State.smol delete mode 100644 smol-core/test/static/These.smol delete mode 100644 smol-core/test/static/Tree.smol delete mode 100644 smol-repl/.gitignore delete mode 100644 smol-repl/CHANGELOG.md delete mode 100644 smol-repl/app/Main.hs delete mode 100644 smol-repl/smol-repl.cabal delete mode 100644 smol-repl/src/Repl.hs delete mode 100644 smol-repl/src/Smol/Check.hs delete mode 100644 smol-repl/src/Smol/Repl.hs delete mode 100644 smol-repl/src/Smol/Repl/Helpers/Diagnostics.hs delete mode 100644 smol-repl/src/Smol/Repl/Helpers/ShowTestResults.hs delete mode 100644 swagger.config.json diff --git a/Makefile b/Makefile index 46df5f18..a800d807 100644 --- a/Makefile +++ b/Makefile @@ -1,52 +1,6 @@ HS_FILES = $(shell git ls-files '*.hs' | grep -v 'vendored/') CABAL_FILES = $(shell git ls-files '*.cabal' | grep -v 'vendored/') -.PHONY: ghcid -ghcid: - ghcid -c "cabal repl mimsa" -l=hlint - -.PHONY: ghcid-core -ghcid-core: - ghcid -c "cabal repl core" -l=hlint - -.PHONY: ghcid-core-test -ghcid-core-test: - ghcid -c "cabal repl core:test:core-test" -l=hlint - -.PHONY: ghcid-test -ghcid-test: - ghcid -c "cabal repl mimsa:test:mimsa-test" -l=hlint - -.PHONY: ghcid-repl -ghcid-repl: - ghcid -c "cabal repl repl:exe:mimsa-repl" -l=hlint - -.PHONY: ghcid-backends -ghcid-backends: - ghcid -c "cabal repl backends:lib:backends" -l=hlint - -.PHONY: ghcid-backends-test -ghcid-backends-test: - ghcid -c "cabal repl backends:test:backends-tests" --test "main" - -# EXCITING NEW WORLD - -.PHONY: ghcid-smol -ghcid-smol: - ghcid -c "cabal repl smol-core" - -.PHONY: ghcid-smol-test -ghcid-smol-test: - ghcid -c "cabal repl smol-core:test:smol-core-tests" --test "main" - -.PHONY: ghcid-smol-backend-test -ghcid-smol-backend-test: - ghcid -c "cabal repl smol-backend:test:smol-backend-tests" --test "main" - -.PHONY: ghcid-smol-repl -ghcid-smol-repl: - ghcid -c "cabal repl smol-repl" - .PHONY: update update: cabal update @@ -55,43 +9,6 @@ update: build: cabal build all -j4 -.PHONY: install -install: - cabal install repl:exe:mimsa-repl --overwrite-policy=always - -.PHONY: smol-repl -smol-repl: - cabal run smol-repl:exe:smol-repl -- repl - -CHECK_FILE = "file.smol" -.PHONY: smol-check -smol-check: - watchexec -w $(CHECK_FILE) cabal run smol-repl:exe:smol-repl -- check $(CHECK_FILE) - -.PHONY: run-server -run-server: - cabal run server:exe:mimsa-server - -.PHONY: docker-server -docker-server: - docker build docker/Dockerfile.server - -.PHONY: test -test: - cabal run mimsa:test:mimsa-test - -.PHONY: test-smol -test-smol: - cabal run smol-core:test:smol-core-tests - -.PHONY: test-smol-backend -test-smol-backend: - cabal run smol-backend:test:smol-backend-tests - -.PHONY: test-core -test-core: - cabal run core:test:core-test - .PHONY: test-llvm-calc test-llvm-calc: cabal run llvm-calc:tests @@ -108,26 +25,10 @@ test-llvm-calc3: test-llvm-calc4: cabal run llvm-calc4:tests -.PHONY: build-smol-repl -build-smol-repl: - cabal build smol-repl - -.PHONY: test-backends -test-backends: - cabal run backends:test:backends-tests - -.PHONY: test-watch -test-watch: - ghcid -c "cabal repl mimsa:test:mimsa-test" -l=hlint --test="main" - .PHONY: freeze freeze: cabal freeze --enable-tests --enable-benchmarks -.PHONY: bench -bench: - cabal bench benchmarks:benchmarks - .PHONY: format format: @ormolu --mode inplace $(HS_FILES) && echo "Ormolu success!" diff --git a/backends/.dockerignore b/backends/.dockerignore deleted file mode 100644 index d7e4614b..00000000 --- a/backends/.dockerignore +++ /dev/null @@ -1,2 +0,0 @@ -.stack-work -dist-newstyle diff --git a/backends/.gitignore b/backends/.gitignore deleted file mode 100644 index e6a31718..00000000 --- a/backends/.gitignore +++ /dev/null @@ -1,42 +0,0 @@ -.direnv/ - -.stack-work/ -*~ -store/*.json -result -result/ - -output/ - -*.hie -swagger.json - -compiler/ - -# files generated during tests - -# typescript tests -test/golden/Typescript/*.ts -test/golden/Typescript-result/*.json -test/golden/CompileTSProject/ -test/golden/CompileTSProject-result/ -test/golden/CompileTSModuleProject/ -test/golden/CompileTSModuleProject-result/ -test/golden/CompileTSProjectWhole/ -test/golden/CompileTSProjectWhole-result/ - -# esmodules compilation tests -test/golden/ESModulesJS-result/*.json -test/golden/ESModulesJS/ -test/golden/CompileJSProject/ -test/golden/CompileJSProject-result/ -test/golden/CompileJSModuleProject/ -test/golden/CompileJSModuleProject-result/ -test/golden/CompileJSProjectWhole/ -test/golden/CompileJSProjectWhole-result/ - -# .prof files generated for profiling -*.prof - -# cabal shit -dist-newstyle diff --git a/backends/LICENSE b/backends/LICENSE deleted file mode 100644 index e637cdee..00000000 --- a/backends/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/backends/backends.cabal b/backends/backends.cabal deleted file mode 100644 index 1042ba6c..00000000 --- a/backends/backends.cabal +++ /dev/null @@ -1,106 +0,0 @@ -cabal-version: 2.2 -name: backends -version: 0.1.0.0 -description: - Please see the README on GitHub at - -homepage: https://github.com/danieljharvey/mimsa#readme -bug-reports: https://github.com/danieljharvey/mimsa/issues -author: Daniel J Harvey -maintainer: danieljamesharvey@gmail.com -copyright: 2021 Daniel J Harvey -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: - static/backend/es-modules-js/stdlib.mjs - static/backend/typescript/stdlib.ts - -source-repository head - type: git - location: https://github.com/danieljharvey/mimsa - -common common-all - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - -library - import: common-all - exposed-modules: - Language.Mimsa.Backend - Language.Mimsa.Backend.BackendError - Language.Mimsa.Backend.Javascript.Printer - Language.Mimsa.Backend.Output - Language.Mimsa.Backend.Shared - Language.Mimsa.Backend.Types - Language.Mimsa.Backend.Typescript.DataType - Language.Mimsa.Backend.Typescript.FromDataType - Language.Mimsa.Backend.Typescript.FromExpr - Language.Mimsa.Backend.Typescript.FromType - Language.Mimsa.Backend.Typescript.Monad - Language.Mimsa.Backend.Typescript.Patterns - Language.Mimsa.Backend.Typescript.Printer - Language.Mimsa.Backend.Typescript.Types - - hs-source-dirs: src - default-extensions: Strict - build-depends: - , aeson - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , cryptonite - , diagnose - , directory - , exceptions - , file-embed - , hashable - , megaparsec - , memory - , monad-logger - , mtl - , openapi3 - , parallel - , parser-combinators - , prettyprinter - , QuickCheck - , text - , transformers - - default-language: Haskell2010 - -test-suite backends-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.Backend.ESModulesJS - Test.Backend.Typescript - Test.Codegen.Shared - Test.Utils.Helpers - - hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - , aeson - , backends - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , exceptions - , file-embed - , hspec - , mtl - , prettyprinter - , text - , transformers - - default-language: Haskell2010 diff --git a/backends/src/Language/Mimsa/Backend.hs b/backends/src/Language/Mimsa/Backend.hs deleted file mode 100644 index 0845489a..00000000 --- a/backends/src/Language/Mimsa/Backend.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Language.Mimsa.Backend where - --- what do we export then? diff --git a/backends/src/Language/Mimsa/Backend/BackendError.hs b/backends/src/Language/Mimsa/Backend/BackendError.hs deleted file mode 100644 index 8213e9be..00000000 --- a/backends/src/Language/Mimsa/Backend/BackendError.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Backend.BackendError where - -import Language.Mimsa.Backend.Typescript.Printer -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core -import Prettyprinter - -data BackendError ann - = CustomOperatorNotFound InfixOp - | OutputingTypedHole Name - | ExpectedExprGotBody TSExpr [TSStatement] - | ExpectedFunctionType TSType - | PatternMatchIsEmpty - | NoConstructorInTypeApp - deriving stock (Eq, Ord, Show, Functor) - -instance Printer (BackendError ann) where - prettyDoc (CustomOperatorNotFound op) = - "Could not find operator for output:" <+> prettyDoc op - prettyDoc PatternMatchIsEmpty = "Pattern match is empty" - prettyDoc (OutputingTypedHole n) = - "Trying to output a typed hold, which should not pass typechecking: " <> prettyDoc n - prettyDoc (ExpectedExprGotBody exp' exps) = - "Expected no extra exprs for :" - <> pretty (printExpr exp') - <> ", but found: " - <> pretty (printStatement <$> exps) - prettyDoc (ExpectedFunctionType tsType) = - "Expected function type but got " <> pretty (printType tsType) - prettyDoc NoConstructorInTypeApp = - "No constructor found in type application." diff --git a/backends/src/Language/Mimsa/Backend/Javascript/Printer.hs b/backends/src/Language/Mimsa/Backend/Javascript/Printer.hs deleted file mode 100644 index f76c1c08..00000000 --- a/backends/src/Language/Mimsa/Backend/Javascript/Printer.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Mimsa.Backend.Javascript.Printer - ( printModule, - printLiteral, - printExpr, - printStatement, - printDataType, - ) -where - -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Backend.Typescript.DataType -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -printDataType :: TSDataType -> Text -printDataType dt = - mconcat $ - (<>) "export " . printStatement - <$> createConstructorFunctions dt - -printLiteral :: TSLiteral -> Text -printLiteral (TSBool True) = "true" -printLiteral (TSBool False) = "false" -printLiteral (TSInt i) = prettyPrint i -printLiteral (TSString str) = "`" <> str <> "`" - -printLetBody :: TSLetBody -> Text -printLetBody (TSLetBody (TSBody [] body)) = printExpr body -printLetBody (TSLetBody (TSBody bindings body)) = - "{ " - <> mconcat (printStatement <$> bindings) - <> returnExpr body - <> " }; " - -returnExpr :: TSExpr -> Text -returnExpr tsExpr@TSError {} = printExpr tsExpr <> ";" -returnExpr other = "return " <> printExpr other <> ";" - -printStatement :: TSStatement -> Text -printStatement (TSAssignment lhsExpr _ expr) = - "const " - <> printExpr lhsExpr - <> " = " - <> printLetBody expr - <> "; " -printStatement (TSConditional predicate allBody@(TSLetBody (TSBody [] _))) = - "if (" - <> printExpr predicate - <> ") { return " - <> printLetBody allBody - <> "; }; " -printStatement (TSConditional predicate body) = - "if (" - <> printExpr predicate - <> ") " - <> printLetBody body - -printFunctionBody :: TSFunctionBody -> Text -printFunctionBody (TSFunctionBody (TSBody [] body)) = case body of - TSRecord {} -> "(" <> printExpr body <> ")" - TSData {} -> "(" <> printExpr body <> ")" - _ -> printExpr body -printFunctionBody (TSFunctionBody (TSBody bindings body)) = - "{ " - <> mconcat (printStatement <$> bindings) - <> returnExpr body - <> " }" - -printOp :: TSOp -> Text -printOp TSEquals = "===" -printOp TSAdd = "+" -printOp TSSubtract = "-" -printOp TSGreaterThan = ">" -printOp TSGreaterThanOrEqualTo = ">=" -printOp TSLessThan = "<" -printOp TSLessThanOrEqualTo = "<=" -printOp TSAnd = "&&" -printOp TSStringConcat = "+" - -protected :: Set Text -protected = S.fromList ["const", "var", "default", "delete"] - -printTSName :: TSName -> Text -printTSName (TSName t) = if S.member t protected then t <> "_" else t - -printExpr :: TSExpr -> Text -printExpr (TSLit lit) = printLiteral lit -printExpr (TSFunction name _ _ _ expr) = - "(" - <> printTSName name - <> ")" - <> " => " - <> printFunctionBody expr -printExpr (TSVar var) = printTSName var -printExpr (TSApp func val) = - printExpr func <> "(" <> printExpr val <> ")" -printExpr (TSArray as) = - "[" - <> T.intercalate - "," - (printArrayItem <$> as) - <> "]" - where - printArrayItem (TSArrayItem a) = printExpr a - printArrayItem (TSArraySpread var) = "..." <> printExpr var -printExpr (TSTuple as) = printExpr (TSArray (TSArrayItem <$> as)) -printExpr (TSArrayAccess a expr) = - printExpr expr <> "[" <> prettyPrint a <> "]" -printExpr (TSInfix op a b) = - printExpr a - <> " " - <> printOp op - <> " " - <> printExpr b -printExpr (TSRecord as) = - let outputRecordItem (name, val) = - printTSName name <> ": " <> printExpr val - items = outputRecordItem <$> M.toList as - in "{ " - <> T.intercalate - ", " - items - <> " }" -printExpr (TSRecordAccess name expr) = - printExpr expr <> "." <> printTSName name -printExpr (TSTernary cond thenE elseE) = - printExpr cond - <> " ? " - <> printExpr thenE - <> " : " - <> printExpr elseE -printExpr (TSData constructor args) = - let prettyArgs = T.intercalate "," (printExpr <$> args) - in "{ type: \"" <> prettyPrint constructor <> "\", vars: [" <> prettyArgs <> "] }" -printExpr (TSError msg) = - "throw new Error(\"" <> msg <> "\")" -printExpr TSUnderscore = "_" - -printModule :: TSModule -> Text -printModule (TSModule dataTypes (TSBody assignments export)) = - T.intercalate "\n" (printDataType <$> dataTypes) - <> T.intercalate "\n" (printStatement <$> assignments) - <> "export const main = " - <> printExpr export diff --git a/backends/src/Language/Mimsa/Backend/Output.hs b/backends/src/Language/Mimsa/Backend/Output.hs deleted file mode 100644 index cb15ae20..00000000 --- a/backends/src/Language/Mimsa/Backend/Output.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Backend.Output - ( renderDataTypeWithDeps, - renderExprWithDeps, - outputIndexFile, - indexFilename, - indexImport, - projectIndexFilename, - moduleFilename, - moduleImport, - ) -where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Coerce -import Data.List (intersperse) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Backend.Javascript.Printer as JS -import Language.Mimsa.Backend.Shared -import Language.Mimsa.Backend.Types -import qualified Language.Mimsa.Backend.Typescript.FromDataType as TS -import qualified Language.Mimsa.Backend.Typescript.FromExpr as TS -import qualified Language.Mimsa.Backend.Typescript.Monad as TS -import Language.Mimsa.Backend.Typescript.Printer -import qualified Language.Mimsa.Backend.Typescript.Printer as TS -import Language.Mimsa.Backend.Typescript.Types -import qualified Language.Mimsa.Backend.Typescript.Types as TS -import Language.Mimsa.Core - --- | Numbers each infix operator, and names them `_infix0`, `_infix1` etc --- these are then used to create both imports and the mapping from infix --- operator to the variable to use in the TS code -nameInfixes :: Map InfixOp hash -> (Map Name hash, Map InfixOp TSName) -nameInfixes infixes = - let numbered = addNumbersToMap infixes - infixName i = Name $ "_infix" <> T.pack (show i) - tsInfixName i = TSName $ "_infix" <> T.pack (show i) - toNameToHash = M.fromList . fmap (first infixName) . M.elems - toInfixToName = tsInfixName . fst <$> numbered - in (toNameToHash numbered, toInfixToName) - --- | Need to also include any types mentioned but perhaps not explicitly used -renderExprWithDeps :: - (Printer hash) => - Backend -> - Map (Maybe ModuleName, TyCon) DataType -> - Map TypeName hash -> - Map InfixOp hash -> - Map (Maybe ModuleName, Name) hash -> - Map (Maybe ModuleName, TypeName) hash -> - Expr Name MonoType -> - BackendM MonoType Text -renderExprWithDeps be dataTypes typeBindings infixes bindings types expr = do - let (infixHashes, infixNames) = - nameInfixes infixes - - deps = - renderImport' be - <$> M.toList bindings - - typeDeps = - renderTypeImport' be - <$> M.toList typeBindings - - infixDeps = - renderInfixImport be - <$> M.toList infixHashes - - mt = getAnnotation expr - -- we import types where they are used transitively, so we don't need - -- them if they are imported explicitly - requiredTypeImports = - M.filterWithKey (\(_, tn) _ -> S.notMember tn (M.keysSet typeBindings)) types - - directTypeDeps = renderDirectTypeImport be <$> M.toList requiredTypeImports - - (func, stdlibFuncs) <- - renderExpression be dataTypes infixNames expr - - let stdlib = stdlibImport be stdlibFuncs - typeComment = renderTypeSignature' mt - - pure $ - mconcat - ( intersperse - (renderNewline' be) - [ mconcat deps, - mconcat typeDeps, - mconcat infixDeps, - mconcat directTypeDeps, - stdlib, - typeComment, - func - ] - ) - -renderDataTypeWithDeps :: - (Printer hash) => - Backend -> - Map (Maybe ModuleName, TyCon) DataType -> - DataType -> - Map (Maybe ModuleName, TypeName) hash -> - BackendM MonoType Text -renderDataTypeWithDeps be dataTypes dt types = do - let directTypeDeps = renderDirectTypeImport be <$> M.toList types - - prettyDataType <- renderDataType be dataTypes dt - - pure $ - mconcat - ( intersperse - (renderNewline' be) - [ mconcat directTypeDeps, - prettyDataType - ] - ) - --- | given the fns used in a store expression --- return an import -stdlibImport :: Backend -> [TS.TSImport] -> Text -stdlibImport _ [] = "" -stdlibImport backend names = - let filteredNames = case backend of - Typescript -> prettyPrint <$> names - ESModulesJS -> - prettyPrint - <$> filter - ( \case - TS.TSImportValue _ -> True - _ -> False - ) - names - in "import { " - <> T.intercalate ", " filteredNames - <> " } from \"./" - <> stdlibFilename backend - <> "\";\n" - -renderExpression :: - Backend -> - Map (Maybe ModuleName, TyCon) DataType -> - Map InfixOp TSName -> - Expr Name MonoType -> - BackendM MonoType (Text, [TS.TSImport]) -renderExpression be dataTypes infixes expr = do - let readerState = - TS.TSReaderState - (makeTypeDepMap dataTypes) - infixes - startState = TS.TSCodegenState mempty mempty mempty - in case TS.fromExpr readerState startState expr of - Right (ts, stdlibFuncs) -> case be of - Typescript -> pure (TS.printModule ts, stdlibFuncs) - ESModulesJS -> pure (JS.printModule ts, stdlibFuncs) - Left e -> throwError e - -renderDataType :: - Backend -> - Map (Maybe ModuleName, TyCon) DataType -> - DataType -> - BackendM MonoType Text -renderDataType be dataTypes dt = do - let readerState = - TS.TSReaderState - (makeTypeDepMap dataTypes) - mempty - startState = TS.TSCodegenState mempty mempty mempty - in case TS.fromDataType readerState startState dt of - Right tsDt -> case be of - Typescript -> pure $ TS.printDataType tsDt - ESModulesJS -> pure $ JS.printDataType tsDt - Left e -> throwError e - --- map of `Just` -> `Maybe`, `Nothing` -> `Maybe`.. -makeTypeDepMap :: - Map (Maybe ModuleName, TyCon) DataType -> - Map TyCon TypeName -makeTypeDepMap rtd = - (\(DataType typeName _ _) -> typeName) <$> first snd rtd - -renderImport' :: (Printer hash) => Backend -> ((a, Name), hash) -> Text -renderImport' Typescript ((_, name), hash') = - "import { main as " - <> printTSName (coerce name) - <> " } from \"./" - <> storeExprFilename Typescript hash' - <> "\";\n" -renderImport' ESModulesJS ((_, name), hash') = - "import { main as " - <> printTSName (coerce name) - <> " } from \"./" - <> storeExprFilename ESModulesJS hash' - <> "\";\n" - -renderInfixImport :: (Printer hash) => Backend -> (Name, hash) -> Text -renderInfixImport Typescript (name, hash') = - "import { main as " - <> printTSName (coerce name) - <> " } from \"./" - <> storeExprFilename Typescript hash' - <> "\";\n" -renderInfixImport ESModulesJS (name, hash') = - "import { main as " - <> printTSName (coerce name) - <> " } from \"./" - <> storeExprFilename ESModulesJS hash' - <> "\";\n" - -renderTypeImport' :: (Printer hash) => Backend -> (TypeName, hash) -> Text -renderTypeImport' Typescript (typeName, hash') = - "import * as " - <> coerce typeName - <> " from \"./" - <> storeExprFilename Typescript hash' - <> "\";\n" -renderTypeImport' ESModulesJS (typeName, hash') = - "import * as " - <> coerce typeName - <> " from \"./" - <> storeExprFilename ESModulesJS hash' - <> "\";\n" - --- | 10x-ing hard right now, could be rekt -renderDirectTypeImport :: (Printer hash) => Backend -> ((Maybe ModuleName, TypeName), hash) -> Text -renderDirectTypeImport Typescript ((_, typeName), hash') = - "import type { " - <> coerce typeName - <> " } from \"./" - <> storeExprFilename Typescript hash' - <> "\";\n" -renderDirectTypeImport ESModulesJS _ = mempty - -renderTypeSignature' :: MonoType -> Text -renderTypeSignature' mt = - "/* \n" <> prettyPrint mt <> "\n */" - -renderNewline' :: Backend -> Text -renderNewline' _ = "\n" - -outputIndexFile :: - (Printer hash) => - Backend -> - Map Name hash -> - Map ModuleName ModuleHash -> - Map TypeName hash -> - Text -outputIndexFile be exportMap exportModuleMap exportTypeMap = - let exportExpression (name, exprHash) = case be of - ESModulesJS -> - "export { main as " - <> printTSName (coerce name) - <> " } from './" - <> storeExprFilename be exprHash - <> fileExtension be - <> "';" - Typescript -> - "export { main as " - <> printTSName (coerce name) - <> " } from './" - <> storeExprFilename be exprHash - <> "';" - - exportModule (modName, modHash) = case be of - ESModulesJS -> - "export * as " - <> printTSName (coerce modName) - <> " from './" - <> moduleImport be modHash - <> "';" - Typescript -> - "export * as " - <> printTSName (coerce modName) - <> " from './" - <> moduleImport be modHash - <> "';" - - exportType (_typeName, exprHash) = case be of - ESModulesJS -> - "export * from './" - <> storeExprFilename be exprHash - <> fileExtension be - <> "';" - Typescript -> - "export * from './" - <> storeExprFilename be exprHash - <> "';" - - allExports = - (exportExpression <$> M.toList exportMap) - <> (exportModule <$> M.toList exportModuleMap) - <> (exportType <$> M.toList exportTypeMap) - in T.intercalate "\n" allExports - --- | file name of index file (no extension for ts) -indexImport :: (Printer hash) => Backend -> hash -> Text -indexImport be hash' = - case be of - ESModulesJS -> - "index-" - <> prettyPrint hash' - <> ".mjs" - Typescript -> - "index-" - <> prettyPrint hash' - --- | filename of index file (including extension always) -indexFilename :: (Printer hash) => Backend -> hash -> Text -indexFilename be hash' = - case be of - ESModulesJS -> - "index-" - <> prettyPrint hash' - <> ".mjs" - Typescript -> - "index-" - <> prettyPrint hash' - <> ".ts" - -projectIndexFilename :: Backend -> Text -projectIndexFilename be = - case be of - ESModulesJS -> - "index.mjs" - Typescript -> - "index.ts" - --- | filename for a module (without extension for TS) -moduleImport :: Backend -> ModuleHash -> Text -moduleImport be modHash = - case be of - ESModulesJS -> - "module-" <> prettyPrint modHash <> ".mjs" - Typescript -> - "module-" <> prettyPrint modHash - --- | filename of module, always including extension -moduleFilename :: Backend -> ModuleHash -> Text -moduleFilename be modHash = - case be of - ESModulesJS -> - moduleImport be modHash - Typescript -> - moduleImport be modHash <> ".ts" diff --git a/backends/src/Language/Mimsa/Backend/Shared.hs b/backends/src/Language/Mimsa/Backend/Shared.hs deleted file mode 100644 index ec346edf..00000000 --- a/backends/src/Language/Mimsa/Backend/Shared.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Backend.Shared - ( symlinkedOutputPath, - zipFileOutputPath, - indexOutputFilename, - storeExprFilename, - fileExtension, - stdlibFilename, - outputStdlib, - ) -where - -import Data.FileEmbed -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core - --- these are saved in a file that is included in compilation -typescriptStandardLibrary :: Text -typescriptStandardLibrary = - T.decodeUtf8 $(makeRelativeToProject "static/backend/typescript/stdlib.ts" >>= embedFile) - --- these are saved in a file that is included in compilation -esModulesJSStandardLibrary :: Text -esModulesJSStandardLibrary = - T.decodeUtf8 $(makeRelativeToProject "static/backend/es-modules-js/stdlib.mjs" >>= embedFile) - -outputStdlib :: Backend -> Text -outputStdlib Typescript = typescriptStandardLibrary -outputStdlib ESModulesJS = esModulesJSStandardLibrary - -indexOutputFilename :: (Printer hash) => Backend -> hash -> Text -indexOutputFilename ESModulesJS exprHash = - "index-" <> prettyPrint exprHash <> ".mjs" -indexOutputFilename Typescript exprHash = - "index-" <> prettyPrint exprHash <> ".ts" - -symlinkedOutputPath :: Backend -> FilePath -symlinkedOutputPath ESModulesJS = - "output/ejs" -symlinkedOutputPath Typescript = - "output/ts" - -zipFileOutputPath :: Backend -> FilePath -zipFileOutputPath _ = "./output/zip" - -fileExtension :: Backend -> Text -fileExtension Typescript = ".ts" -fileExtension _ = "" - -storeExprFilename :: (Printer hash) => Backend -> hash -> Text -storeExprFilename ESModulesJS hash' = - "ejs-" <> prettyPrint hash' <> ".mjs" -storeExprFilename Typescript hash' = - "ts-" <> prettyPrint hash' - -stdlibFilename :: Backend -> Text -stdlibFilename Typescript = "ts-stdlib" -stdlibFilename ESModulesJS = "ejs-stdlib.mjs" diff --git a/backends/src/Language/Mimsa/Backend/Types.hs b/backends/src/Language/Mimsa/Backend/Types.hs deleted file mode 100644 index 1c9daa2f..00000000 --- a/backends/src/Language/Mimsa/Backend/Types.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Backend.Types - ( BackendM, - Backend (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import GHC.Generics -import Language.Mimsa.Backend.BackendError - -type BackendM ann = Either (BackendError ann) - -data Backend = ESModulesJS | Typescript - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.FromJSON, ToSchema) diff --git a/backends/src/Language/Mimsa/Backend/Typescript/DataType.hs b/backends/src/Language/Mimsa/Backend/Typescript/DataType.hs deleted file mode 100644 index f650c1ce..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/DataType.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Backend.Typescript.DataType (createConstructorFunctions) where - -import Data.Coerce (coerce) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -typeNameToTSName :: Int -> TSType -> TSName -typeNameToTSName _ (TSTypeVar a) = coerce (T.toLower a) -typeNameToTSName _ (TSType _ name _) = coerce (T.toLower name) -typeNameToTSName i _ = coerce $ "u" <> prettyPrint i - -genericsForType :: TSType -> Set TSGeneric -genericsForType (TSTypeVar a) = S.singleton (TSGeneric a) -genericsForType (TSType _ _ as) = mconcat (genericsForType <$> as) -genericsForType (TSTypeFun _ f a) = genericsForType f <> genericsForType a -genericsForType (TSTypeArray a) = genericsForType a -genericsForType (TSTypeTuple as) = mconcat (genericsForType <$> as) -genericsForType (TSTypeRecord as) = mconcat (genericsForType <$> M.elems as) -genericsForType (TSTypeAnd a b) = genericsForType a <> genericsForType b - --- | Creates the return type of a constructor -returnType :: [Text] -> TypeName -> [TSType] -> TSType -returnType dtArgs typeName consArgs = - TSType Nothing (coerce typeName) fixedConsArgs - where - allConsArgs = mconcat (genericsForType <$> consArgs) - fixedConsArgs = - ( \arg -> - if S.member (TSGeneric arg) allConsArgs - then TSTypeVar arg - else TSType Nothing "never" mempty - ) - <$> dtArgs - -createConstructorFunctions :: TSDataType -> [TSStatement] -createConstructorFunctions (TSDataType typeName dtArgs constructors) = - createConstructorFunction typeName dtArgs <$> constructors - --- | because we build constructors inside -> out, we can't look at the generics --- we've used, so instead, we take the whole thing and remove them where --- needed -removeRepeatedGenerics :: TSExpr -> TSExpr -removeRepeatedGenerics = removeSeen mempty - where - notUsedAlready alreadySeen = - S.filter (\a -> not (S.member a alreadySeen)) - removeSeen seen (TSFunction a gen b c (TSFunctionBody (TSBody d rest))) = - let newSeen = seen <> gen - in TSFunction - a - (notUsedAlready seen gen) - b - c - (TSFunctionBody (TSBody d (removeSeen newSeen rest))) - removeSeen _ other = other - --- turn Just constructor into a function like \a -> Just a -createConstructorFunction :: - TypeName -> - [Text] -> - TSConstructor -> - TSStatement -createConstructorFunction typeName dtArgs (TSConstructor tyCon []) = - TSAssignment - (TSVar (coerce tyCon)) - (Just (returnType dtArgs typeName mempty)) - (TSLetBody (TSBody [] (TSData (prettyPrint tyCon) mempty))) -createConstructorFunction typeName dtArgs (TSConstructor tyCon tsArgs) = - let numberList = zip [1 ..] tsArgs - args = (\(i, tn) -> TSVar (typeNameToTSName i tn)) <$> numberList - tsData = TSData (prettyPrint tyCon) args - foldFn (i, tsType) expr' = - let variable = typeNameToTSName i tsType - generics = genericsForType tsType - isFinal = i == length numberList - returnType' = - if isFinal - then Just (returnType dtArgs typeName tsArgs) - else Nothing - in TSFunction - variable - generics - tsType - returnType' - (TSFunctionBody (TSBody mempty expr')) - constructorFn = - foldr foldFn tsData numberList - in TSAssignment - (TSVar (coerce tyCon)) - Nothing - (TSLetBody (TSBody [] (removeRepeatedGenerics constructorFn))) diff --git a/backends/src/Language/Mimsa/Backend/Typescript/FromDataType.hs b/backends/src/Language/Mimsa/Backend/Typescript/FromDataType.hs deleted file mode 100644 index 01337575..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/FromDataType.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Language.Mimsa.Backend.Typescript.FromDataType (fromDataType) where - -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Backend.BackendError -import Language.Mimsa.Backend.Typescript.FromType -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -fromDataType :: - TSReaderState -> - TSCodegenState -> - DataType -> - Either (BackendError MonoType) TSDataType -fromDataType readerState startState dt = do - (result, _, _) <- runTypescriptM readerState startState (toTSDataType dt) - pure result - -toTSDataType :: DataType -> TypescriptM TSDataType -toTSDataType (DataType name gens cons) = do - let toTSCons (tyCon, con) = do - tsTypes' <- traverse toTSType con - pure $ TSConstructor tyCon (fst <$> tsTypes') - tsTypes <- traverse toTSCons (M.toList cons) - pure $ - TSDataType - name - (T.toTitle . prettyPrint <$> gens) - tsTypes diff --git a/backends/src/Language/Mimsa/Backend/Typescript/FromExpr.hs b/backends/src/Language/Mimsa/Backend/Typescript/FromExpr.hs deleted file mode 100644 index 0ae28b34..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/FromExpr.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Backend.Typescript.FromExpr (fromExpr) where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Backend.BackendError -import Language.Mimsa.Backend.Typescript.FromType -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Patterns -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -bimapMap :: (Ord j) => (k -> j) -> (a -> b) -> Map k a -> Map j b -bimapMap f g = M.fromList . fmap (bimap f g) . M.toList - -toLiteral :: Literal -> TSLiteral -toLiteral lit = case lit of - (MyInt i) -> TSInt i - (MyBool b) -> TSBool b - (MyString (StringType s)) -> TSString s - -toArraySpread :: Spread Name ann -> TSSpread -toArraySpread (SpreadValue _ a) = TSSpreadValue (coerce a) -toArraySpread (SpreadWildcard _) = TSSpreadWildcard -toArraySpread NoSpread = TSNoSpread - -toStringPart :: StringPart Name ann -> TSStringPart -toStringPart (StrValue _ a) = TSStringVar (coerce a) -toStringPart (StrWildcard _) = TSStringWildcard - -toPattern :: Pattern Name ann -> TSPattern -toPattern (PVar _ a) = - TSPatternVar (coerce a) -toPattern (PTuple _ a as) = - TSPatternTuple (toPattern <$> [a] <> NE.toList as) -toPattern (PWildcard _) = - TSPatternWildcard -toPattern (PConstructor _ _ name vars) = - TSPatternConstructor name (toPattern <$> vars) -toPattern (PRecord _ pMap) = - TSPatternRecord (bimapMap coerce toPattern pMap) -toPattern (PArray _ as spread) = - TSPatternArray (toPattern <$> as) (toArraySpread spread) -toPattern (PLit _ lit) = - TSPatternLit (toLiteral lit) -toPattern (PString _ sHead sTail) = - TSPatternString (toStringPart sHead) (toStringPart sTail) - -toInfix :: - Operator -> - Expr Name MonoType -> - Expr Name MonoType -> - TypescriptM TSExpr -toInfix operator a b = do - tsA <- toTSExpr a - tsB <- toTSExpr b - case operator of - Equals -> do - addImport - (TSImportValue "equals_") - pure $ - TSApp (TSApp (TSVar "equals_") tsA) tsB - Add -> - pure $ TSInfix TSAdd tsA tsB - Subtract -> - pure $ TSInfix TSSubtract tsA tsB - GreaterThan -> - pure $ TSInfix TSGreaterThan tsA tsB - GreaterThanOrEqualTo -> - pure $ TSInfix TSGreaterThanOrEqualTo tsA tsB - LessThan -> - pure $ TSInfix TSLessThan tsA tsB - LessThanOrEqualTo -> - pure $ TSInfix TSLessThanOrEqualTo tsA tsB - StringConcat -> - pure $ TSInfix TSStringConcat tsA tsB - ArrayConcat -> - pure $ TSArray [TSArraySpread tsA, TSArraySpread tsB] - (Custom op) -> do - expr <- findInfix op - pure (TSApp (TSApp expr tsA) tsB) - --- | make TS body, but throw if we get any additional lines --- a temporary measure so we can see how often these happen (because they don't --- make sense often) -toTSExpr :: Expr Name MonoType -> TypescriptM TSExpr -toTSExpr expr' = - toTSBody expr' >>= \case - (TSBody [] expr) -> pure expr - (TSBody as a) -> throwError (ExpectedExprGotBody a as) - -fromExpr :: - TSReaderState -> - TSCodegenState -> - Expr Name MonoType -> - Either (BackendError MonoType) (TSModule, [TSImport]) -fromExpr readerState startState expr = do - (result, dataTypes, imports) <- runTypescriptM readerState startState (toTSBody expr) - pure (TSModule dataTypes result, imports) - -identifierName :: Identifier Name ann -> Name -identifierName ident = case ident of - Identifier _ n -> n - -toLet :: Identifier Name MonoType -> Expr Name MonoType -> Expr Name MonoType -> TypescriptM TSBody -toLet ident letExpr letBody = do - newLetExpr <- toTSBody letExpr - let newBinding = - TSAssignment - (TSVar (coerce (identifierName ident))) - Nothing - (TSLetBody newLetExpr) - (TSBody bindings' newExpr) <- toTSBody letBody - pure (TSBody ([newBinding] <> bindings') newExpr) - -toLetPattern :: - Pattern Name MonoType -> - Expr Name MonoType -> - Expr Name MonoType -> - TypescriptM TSBody -toLetPattern pat letExpr letBody = do - newLetExpr <- toTSBody letExpr - let (tsPatExpr, statements) = getDestructureExpr TSUnderscore (toPattern pat) - let newBinding = - TSAssignment - tsPatExpr - Nothing - (TSLetBody newLetExpr) - (TSBody bindings' newExpr) <- toTSBody letBody - pure (TSBody ([newBinding] <> bindings' <> statements) newExpr) - -toLambda :: - MonoType -> - Identifier Name MonoType -> - Expr Name MonoType -> - TypescriptM TSBody -toLambda fnType ident body = do - (mtFn, generics') <- toTSType' True fnType - mtArg <- case mtFn of - (TSTypeFun _ a _) -> pure a - e -> throwError (ExpectedFunctionType e) - -- get diff between generics we've not used yet - newGenerics <- unusedGenerics generics' - -- continue.... - tsBody <- toTSBody body - pure $ - TSBody - [] - ( TSFunction - (coerce (identifierName ident)) - newGenerics - mtArg - Nothing - ( TSFunctionBody tsBody - ) - ) - -toPatternStatement :: - (Pattern Name MonoType, Expr Name MonoType) -> - TypescriptM TSStatement -toPatternStatement (pat, patExpr) = do - let (tsExpr, statements) = - getDestructureExpr (TSVar "value") (toPattern pat) - (TSBody parts tsPatExpr) <- toTSBody patExpr - let items = - if tsExpr /= TSUnderscore - then - TSAssignment - tsExpr - Nothing - ( TSLetBody - ( TSBody [] (TSVar "value") - ) - ) - : parts - else parts - pure $ - TSConditional - (conditions $ toPattern pat) - (TSLetBody (TSBody (statements <> items) tsPatExpr)) - -getMatchReturnType :: [(a, Expr Name MonoType)] -> TypescriptM TSType -getMatchReturnType as = case as of - ((_pat, expr) : _) -> fst <$> toTSType (getAnnotation expr) - _ -> throwError PatternMatchIsEmpty - -toPatternMatch :: - Expr Name MonoType -> - [(Pattern Name MonoType, Expr Name MonoType)] -> - TypescriptM TSBody -toPatternMatch matchExpr patterns = do - matches <- traverse toPatternStatement patterns - (TSBody tsStatements tsA) <- toTSBody matchExpr - (tyMatchExpr, matchGenerics) <- toTSType (getAnnotation matchExpr) - newGenerics <- unusedGenerics matchGenerics - returnType <- getMatchReturnType patterns - let assignment = - TSAssignment - (TSVar "match") - Nothing - ( TSLetBody - ( TSBody - [] - ( TSFunction - "value" - newGenerics - tyMatchExpr - (Just returnType) - ( TSFunctionBody - ( TSBody - matches - (TSError "Pattern match error") - ) - ) - ) - ) - ) - - pure $ - TSBody - (tsStatements <> [assignment]) - (TSApp (TSVar "match") tsA) - -toTSBody :: Expr Name MonoType -> TypescriptM TSBody -toTSBody expr' = - case expr' of - (MyLiteral _ lit) -> - pure $ TSBody mempty (TSLit (toLiteral lit)) - (MyAnnotation _ _ expr) -> toTSBody expr - (MyLet _ ident letExpr letBody) -> - toLet ident letExpr letBody - (MyLetPattern _ pat letExpr letBody) -> - toLetPattern pat letExpr letBody - (MyTuple _ a as) -> do - tsA <- toTSExpr a - tsAs <- traverse toTSExpr as - pure (TSBody mempty (TSTuple $ [tsA] <> NE.toList tsAs)) - (MyVar _ _ a) -> - pure (TSBody mempty (TSVar (coerce a))) - (MyLambda fnType bind body) -> - toLambda fnType bind body - (MyPatternMatch _mtPatternMatch matchExpr patterns) -> - toPatternMatch matchExpr patterns - (MyApp _mtApp func val) -> do - (TSBody as tsFunc) <- toTSBody func - (TSBody bs tsVal) <- toTSBody val - pure $ TSBody (as <> bs) (TSApp tsFunc tsVal) - (MyConstructor _ _ tyCon) -> do - namespace <- findTypeName tyCon - pure $ - TSBody [] $ case namespace of - Just typeName -> - TSRecordAccess (coerce tyCon) (TSVar (coerce typeName)) - _ -> TSVar (coerce tyCon) - (MyIf _mtIf predExpr thenExpr elseExpr) -> do - (TSBody as tsPred) <- toTSBody predExpr - (TSBody bs tsThen) <- toTSBody thenExpr - (TSBody cs tsElse) <- toTSBody elseExpr - pure $ TSBody (as <> bs <> cs) (TSTernary tsPred tsThen tsElse) - (MyRecord _ as) -> do - tsExprs <- traverse toTSBody as - let bodies = (\(TSBody a b) -> (a, b)) <$> tsExprs - statements = mconcat (fst <$> M.elems bodies) - pure $ TSBody statements (TSRecord (bimapMap coerce snd bodies)) - (MyRecordAccess _ recExpr name) -> do - (TSBody as tsExpr) <- toTSBody recExpr - pure $ TSBody as (TSRecordAccess (coerce name) tsExpr) - (MyTupleAccess _ tupExpr index) -> do - (TSBody as tsExpr) <- toTSBody tupExpr - pure $ TSBody as (TSArrayAccess (fromIntegral (index - 1)) tsExpr) -- TupleAccess starts at 1, not 0 - (MyInfix _ op a b) -> do - TSBody [] <$> toInfix op a b - (MyArray _ as) -> do - tsAs <- (fmap . fmap) TSArrayItem (traverse toTSExpr as) - pure $ TSBody [] (TSArray tsAs) - (MyTypedHole _ name) -> - throwError (OutputingTypedHole name) diff --git a/backends/src/Language/Mimsa/Backend/Typescript/FromType.hs b/backends/src/Language/Mimsa/Backend/Typescript/FromType.hs deleted file mode 100644 index 02f069f7..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/FromType.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Backend.Typescript.FromType (toTSType, toTSType') where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import Language.Mimsa.Backend.BackendError -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -consToTSType :: Type ann -> TypescriptM (TSType, Set TSGeneric) -consToTSType mt = - case varsFromDataType mt of - Just (_modName, TypeName n, vars) -> do - imported <- typeNameIsImport (TypeName n) - let namespace = - if imported - then Just n - else Nothing - tsTypes <- traverse toTSType vars - let (types, generics) = unzip tsTypes - pure (TSType namespace n types, mconcat generics) - Nothing -> - throwError NoConstructorInTypeApp - -toTSTypeRecord :: Map Name (Type ann) -> TypescriptM (TSType, Set TSGeneric) -toTSTypeRecord as = do - tsAll <- traverse toTSType as - let generics = snd . snd <$> M.toList tsAll - tsItems = M.fromList . fmap (bimap coerce fst) . M.toList $ tsAll - pure (TSTypeRecord tsItems, mconcat generics) - -toTSTypeTuple :: [Type ann] -> TypescriptM (TSType, Set TSGeneric) -toTSTypeTuple as = do - tsAll <- traverse toTSType as - let generics = snd <$> tsAll - tsItems = fst <$> tsAll - pure (TSTypeTuple tsItems, mconcat generics) - -toTSType :: Type ann -> TypescriptM (TSType, Set TSGeneric) -toTSType = toTSType' False - --- | returns the type and any generics used in the expression -toTSType' :: Bool -> Type ann -> TypescriptM (TSType, Set TSGeneric) -toTSType' _ (MTPrim _ MTString) = pure (TSType Nothing "string" [], mempty) -toTSType' _ (MTPrim _ MTInt) = pure (TSType Nothing "number" [], mempty) -toTSType' _ (MTPrim _ MTBool) = pure (TSType Nothing "boolean" [], mempty) -toTSType' _ (MTVar _ a) = - let newVar = case a of - TVUnificationVar i' -> T.toTitle (T.pack (printTypeNum (i' + 1))) - TVName a' -> T.toTitle (coerce a') - TVScopedVar i' _ -> T.toTitle (T.pack (printTypeNum (i' + 1))) - in pure (TSTypeVar newVar, S.singleton (TSGeneric newVar)) -toTSType' _ mt@MTTypeApp {} = - consToTSType mt -toTSType' topLevel (MTFunction _ a b) = do - (tsA, genA) <- toTSType' False a - (tsB, genB) <- toTSType' False b - let generics = - if topLevel - then genA -- we don't want to include generics from later args in curried functions - else genA <> genB -- but we do want later args of higher-order functions - pure (TSTypeFun "arg" tsA tsB, generics) -toTSType' _ (MTArray _ as) = do - (tsAs, genAs) <- toTSType as - pure (TSTypeArray tsAs, genAs) -toTSType' _ (MTTuple _ a as) = do - toTSTypeTuple ([a] <> NE.toList as) -toTSType' _ mt@MTConstructor {} = - consToTSType mt -toTSType' _ (MTRecord _ as Nothing) = - toTSTypeRecord as -toTSType' _ (MTRecord _ as (Just rest)) = do - (tsItems, generics) <- toTSTypeRecord as - (tsRest, genRest) <- toTSType rest - pure (TSTypeAnd tsItems tsRest, generics <> genRest) -toTSType' b (MTGlobals _ _ _ expr) = toTSType' b expr diff --git a/backends/src/Language/Mimsa/Backend/Typescript/Monad.hs b/backends/src/Language/Mimsa/Backend/Typescript/Monad.hs deleted file mode 100644 index 735b256b..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/Monad.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Backend.Typescript.Monad - ( TypescriptM, - TSCodegenState (..), - TSStateStack, - TSReaderState (..), - runTypescriptM, - getState, - addInfix, - findInfix, - findTypeName, - typeNameIsImport, - unusedGenerics, - addGenerics, - addDataType, - addImport, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Writer.CPS (runWriterT) -import Control.Monad.Writer.CPS -import Data.Either -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Backend.BackendError -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -type TypescriptM = - ExceptT - (BackendError MonoType) - (WriterT [TSWriterItem] (ReaderT TSReaderState (State TSStateStack))) - -data TSReaderState = TSReaderState - { tsConstructorTypes :: Map TyCon TypeName, -- Just -> Maybe, Nothing -> Maybe etc - tsInfixNames :: Map InfixOp TSName -- infix operators from imports - } - -type TSWriterItem = - Either TSDataType TSImport - --- | we keep the datatypes in both the writer and the state --- because we want both a sum of all datatypes, and a stack where they are --- brought into and out of scope -data TSCodegenState = TSCodegenState - { csGenerics :: Set TSGeneric, - csDataTypes :: [DataType], - csInfix :: Map InfixOp TSExpr - } - deriving stock (Eq, Ord, Show) - -type TSStateStack = NE.NonEmpty TSCodegenState - --- | Modify the current stack entry (ie, head of NE list) -modifyState :: - (MonadState TSStateStack m) => - (TSCodegenState -> TSCodegenState) -> - m () -modifyState f = - modify - ( \stack -> - let newHead = f (NE.head stack) - in newHead :| NE.tail stack - ) - --- | get current state entry -getState :: - (MonadState TSStateStack m) => - m TSCodegenState -getState = gets NE.head - --- | add new generics to state -addGenerics :: - (MonadState TSStateStack m) => - Set TSGeneric -> - m () -addGenerics generics = - modifyState - ( \codegenState -> - codegenState - { csGenerics = - csGenerics codegenState <> generics - } - ) - --- given some generics, return the ones we haven't already seen, then add them --- to state -unusedGenerics :: - (MonadState TSStateStack m) => - Set TSGeneric -> - m (Set TSGeneric) -unusedGenerics new = do - old <- getState - let unused = S.difference new (csGenerics old) - addGenerics new - pure unused - --- | add a datatype to both the Writer and current stack -addDataType :: - ( MonadState TSStateStack m, - MonadWriter [TSWriterItem] m - ) => - DataType -> - TSDataType -> - m () -addDataType dt tsDt = do - tell [Left tsDt] - modifyState - ( \codegenState -> - codegenState - { csDataTypes = csDataTypes codegenState <> [dt] - } - ) - --- | add a datatype to both the Writer and current stack -addImport :: - ( MonadWriter [TSWriterItem] m - ) => - TSImport -> - m () -addImport tsImport = - tell [Right tsImport] - --- | define an infix operator, binding it to some 2-arity function -addInfix :: (MonadState TSStateStack m) => InfixOp -> TSExpr -> m () -addInfix op expr = - modifyState - ( \codegenState -> - codegenState - { csInfix = - csInfix codegenState - <> M.singleton op expr - } - ) - --- | is this type in our reader context (and thus is it an import, and should --- be use it with a namespace, ie, Maybe.Maybe? -typeNameIsImport :: (MonadReader TSReaderState m) => TypeName -> m Bool -typeNameIsImport typeName = do - consType <- asks tsConstructorTypes - let typeNames = S.fromList (M.elems consType) - pure (S.member typeName typeNames) - --- | what the absolute fuck why must we do this -strFind :: (Printer k) => k -> Map k a -> Maybe a -strFind key = - listToMaybe . M.elems . M.filterWithKey (\k1 _ -> prettyPrint k1 == prettyPrint key) - --- given 'Just', (hopefully) return 'Maybe' -findTypeName :: (MonadReader TSReaderState m) => TyCon -> m (Maybe TypeName) -findTypeName tyCon = do - consTypes <- asks tsConstructorTypes - case strFind tyCon consTypes of - Just typeName -> pure (Just typeName) - Nothing -> pure Nothing - --- | lookup an infix op firstly in scope then in imports --- later when we bin off scoped infix defintions we'll only --- look in the reader state -findInfix :: - ( MonadReader TSReaderState m, - MonadState TSStateStack m, - MonadError (BackendError MonoType) m - ) => - InfixOp -> - m TSExpr -findInfix op = do - tsState <- getState - case M.lookup op (csInfix tsState) of - Just expr -> pure expr - Nothing -> do - infixMap <- asks tsInfixNames - case M.lookup op infixMap of - Just name -> pure (TSVar name) - Nothing -> throwError (CustomOperatorNotFound op) - -runTypescriptM :: - TSReaderState -> - TSCodegenState -> - TypescriptM a -> - Either (BackendError MonoType) (a, [TSDataType], [TSImport]) -runTypescriptM readerState startState computation = - case evalState - ( runReaderT - (runWriterT (runExceptT computation)) - readerState - ) - (NE.singleton startState) of - (Right a, writerOutput) -> - let (dts, imports) = partitionEithers writerOutput - in pure (a, dts, imports) - (Left e, _) -> throwError e diff --git a/backends/src/Language/Mimsa/Backend/Typescript/Patterns.hs b/backends/src/Language/Mimsa/Backend/Typescript/Patterns.hs deleted file mode 100644 index d1914929..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/Patterns.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Mimsa.Backend.Typescript.Patterns - ( conditions, - getDestructureExpr, - destructure, - ) -where - -import Data.Foldable (foldl') -import qualified Data.Map.Strict as M -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -isUseful :: TSExpr -> Bool -isUseful TSUnderscore = False -isUseful _ = True - --- | matchExpr is the thing we're match against, useful when constructing --- string destructurings -getDestructureExpr :: TSExpr -> TSPattern -> (TSExpr, [TSStatement]) -getDestructureExpr _ (TSPatternVar n) = (TSVar n, mempty) -getDestructureExpr _ TSPatternWildcard = (TSUnderscore, mempty) -getDestructureExpr matchExpr (TSPatternTuple as) = - let withIndex i = getDestructureExpr (TSArrayAccess (i - 1) matchExpr) - (tsAs, assignAs) = unzip (mapWithIndex withIndex as) - in ( if or (isUseful <$> tsAs) - then TSArray (TSArrayItem <$> tsAs) - else TSUnderscore, - mconcat assignAs - ) -getDestructureExpr matchExpr (TSPatternRecord as) = - let outputRecordItem (name, val) = - let (tsA, assignA) = getDestructureExpr (TSRecordAccess name matchExpr) val - in if isUseful tsA - then (M.singleton name tsA, assignA) - else (mempty, assignA) - (items, assignAs) = mconcat $ outputRecordItem <$> M.toList as - in ( if null items then TSUnderscore else TSRecord items, - assignAs - ) -getDestructureExpr matchExpr (TSPatternConstructor _ vars) = - let withIndex i = - getDestructureExpr - ( TSArrayAccess - (i - 1) - (TSRecordAccess "vars" matchExpr) - ) - (as, assignAs) = unzip (mapWithIndex withIndex vars) - in ( if or (isUseful <$> as) - then - TSRecord - ( M.singleton - "vars" - ( TSArray (TSArrayItem <$> as) - ) - ) - else TSUnderscore, - mconcat assignAs - ) -getDestructureExpr matchExpr (TSPatternArray as spread) = - let (spreadRequired, tsSpread) = case spread of - TSSpreadValue a -> (True, [TSArraySpread (TSVar a)]) - _ -> (False, []) - withIndex i = getDestructureExpr (TSArrayAccess (i - 1) matchExpr) - (tsAs, assignAs) = unzip (mapWithIndex withIndex as) - in ( if spreadRequired || or (isUseful <$> tsAs) - then TSArray ((TSArrayItem <$> tsAs) <> tsSpread) - else TSUnderscore, - mconcat assignAs - ) -getDestructureExpr _ (TSPatternLit _) = (TSUnderscore, mempty) -getDestructureExpr matchExpr (TSPatternString tsHead tsTail) = - let aValue = case tsHead of - TSStringVar vA -> - [ TSAssignment - (TSVar vA) - Nothing - ( TSLetBody - ( TSBody - mempty - ( TSApp - (TSRecordAccess "charAt" matchExpr) - (TSLit (TSInt 0)) - ) - ) - ) - ] - _ -> mempty - asValue = case tsTail of - TSStringVar vAs -> - [ TSAssignment - (TSVar vAs) - Nothing - ( TSLetBody - ( TSBody - mempty - ( TSApp - ( TSRecordAccess "slice" matchExpr - ) - (TSLit (TSInt 1)) - ) - ) - ) - ] - _ -> mempty - in (TSUnderscore, aValue <> asValue) - -destructure :: TSPattern -> [TSStatement] -destructure tsPat = - let (patExpr, statements) = getDestructureExpr (TSVar "value") tsPat - tsMainConst = - if isUseful patExpr - then - [ TSAssignment - patExpr - Nothing - ( TSLetBody - ( TSBody - mempty - (TSVar "value") - ) - ) - ] - else mempty - in tsMainConst <> statements - -conditions :: TSPattern -> TSExpr -conditions pat = - let parts = toMatchExpression (TSVar "value") pat - in case parts of - [] -> TSLit (TSBool True) - (a : as) -> foldl' (TSInfix TSAnd) a as - --- | turn a pattern map into a match expression for this pattern -toMatchExpression :: TSExpr -> TSPattern -> [TSExpr] -toMatchExpression _ TSPatternWildcard = - mempty -toMatchExpression _ (TSPatternVar _) = - mempty -toMatchExpression name (TSPatternTuple as) = - let subPattern i = - toMatchExpression (TSArrayAccess (i - 1) name) - in mconcat (mapWithIndex subPattern as) -toMatchExpression name (TSPatternLit lit) = - [TSInfix TSEquals name (TSLit lit)] -toMatchExpression name (TSPatternRecord items) = - let subPattern (k, v) = toMatchExpression (TSRecordAccess k name) v - in mconcat (subPattern <$> M.toList items) -toMatchExpression name (TSPatternConstructor tyCon args) = - let tyConGuard = TSInfix TSEquals (TSRecordAccess "type" name) (TSLit (TSString (prettyPrint tyCon))) - subPattern i = toMatchExpression (TSArrayAccess (i - 1) (TSRecordAccess "vars" name)) - in [tyConGuard] <> mconcat (mapWithIndex subPattern args) -toMatchExpression name (TSPatternArray as spread) = - let lengthGuard = case spread of - TSNoSpread -> - TSInfix - TSEquals - (TSRecordAccess "length" name) - (TSLit (TSInt (length as))) - TSSpreadWildcard -> - TSInfix - TSGreaterThanOrEqualTo - (TSRecordAccess "length" name) - (TSLit (TSInt (length as))) - (TSSpreadValue _) -> - TSInfix - TSGreaterThanOrEqualTo - (TSRecordAccess "length" name) - (TSLit (TSInt (length as))) - subPattern i = - toMatchExpression (TSArrayAccess (i - 1) name) - in [lengthGuard] <> mconcat (mapWithIndex subPattern as) -toMatchExpression name (TSPatternString _a _as) = - [ TSInfix - TSGreaterThanOrEqualTo - (TSRecordAccess "length" name) - (TSLit (TSInt 1)) - ] diff --git a/backends/src/Language/Mimsa/Backend/Typescript/Printer.hs b/backends/src/Language/Mimsa/Backend/Typescript/Printer.hs deleted file mode 100644 index 7bdf2f9e..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/Printer.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Mimsa.Backend.Typescript.Printer - ( printModule, - printLiteral, - printType, - printExpr, - printStatement, - printTSName, - printDataType, - ) -where - -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Backend.Typescript.DataType -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core - -protected :: Set Text -protected = S.fromList ["const", "var", "delete", "default"] - -printTSName :: TSName -> Text -printTSName (TSName t) = if S.member t protected then t <> "_" else t - -{- maybe these shouldn't be typeclass instances at all? -} -printGeneric :: TSGeneric -> Text -printGeneric (TSGeneric t) = t - -printType :: TSType -> Text -printType (TSTypeVar name) = prettyPrint name -printType (TSType namespace name as) = - ns <> prettyPrint name <> generics - where - ns = case namespace of - Just typeName -> prettyPrint typeName <> "." - _ -> "" - generics = - case as of - [] -> "" - typeVar -> "<" <> T.intercalate "," (printType <$> typeVar) <> ">" -printType (TSTypeFun argName arg resp) = - "(" - <> prettyPrint argName - <> ": " - <> printType arg - <> ") => " - <> printType resp -printType (TSTypeArray as) = printType as <> "[]" -printType (TSTypeTuple as) = "readonly [" <> T.intercalate "," (printType <$> as) <> "]" -printType (TSTypeRecord as) = - let outputRecordItem (name, val) = - prettyPrint name <> ": " <> printType val - items = outputRecordItem <$> M.toList as - in "{ " - <> T.intercalate - ", " - items - <> " }" -printType (TSTypeAnd a b) = - printType a <> " & " <> printType b - -printConstructor :: TSConstructor -> Text -printConstructor (TSConstructor tyCon types) = - "{ type: \"" <> prettyPrint tyCon <> "\", vars: [" <> T.intercalate ", " (printType <$> types) <> "] }" - -printDataType :: TSDataType -> Text -printDataType dt@(TSDataType tyName generics constructors) = - let prettyGen = case generics of - [] -> "" - as -> "<" <> T.intercalate ", " (prettyPrint <$> as) <> ">" - prettyCons = case constructors of - [] -> "never" - as -> T.intercalate " | " (printConstructor <$> as) - prettyConsFns = - mconcat $ - (<>) "export " . printStatement - <$> createConstructorFunctions dt - in "export type " - <> prettyPrint tyName - <> prettyGen - <> " = " - <> prettyCons - <> "; " - <> prettyConsFns - -printLiteral :: TSLiteral -> Text -printLiteral (TSBool True) = "true" -printLiteral (TSBool False) = "false" -printLiteral (TSInt i) = prettyPrint i -printLiteral (TSString str) = "`" <> str <> "`" - -printLetBody :: TSLetBody -> Text -printLetBody (TSLetBody (TSBody [] body)) = printExpr body -printLetBody (TSLetBody (TSBody bindings body)) = - "{ " - <> mconcat (printStatement <$> bindings) - <> returnExpr body - <> " }; " - -returnExpr :: TSExpr -> Text -returnExpr tsExpr@TSError {} = printExpr tsExpr <> ";" -returnExpr other = "return " <> printExpr other <> ";" - -printStatement :: TSStatement -> Text -printStatement (TSAssignment lhsExpr exprType expr) = - let tsPrettyType = case exprType of - Just mt' -> ": " <> printType mt' - _ -> "" - in "const " - <> printExpr lhsExpr - <> tsPrettyType - <> " = " - <> printLetBody expr - <> "; " -printStatement (TSConditional predicate allBody@(TSLetBody (TSBody [] _))) = - "if (" - <> printExpr predicate - <> ") { return " - <> printLetBody allBody - <> "; }; " -printStatement (TSConditional predicate body) = - "if (" - <> printExpr predicate - <> ") " - <> printLetBody body - -printFunctionBody :: TSFunctionBody -> Text -printFunctionBody (TSFunctionBody (TSBody [] body)) = case body of - TSRecord {} -> "(" <> printExpr body <> ")" - TSData {} -> "(" <> printExpr body <> ")" - _ -> printExpr body -printFunctionBody (TSFunctionBody (TSBody bindings body)) = - "{ " - <> mconcat (printStatement <$> bindings) - <> returnExpr body - <> " }" - -printOp :: TSOp -> Text -printOp TSEquals = "===" -printOp TSAdd = "+" -printOp TSSubtract = "-" -printOp TSGreaterThan = ">" -printOp TSGreaterThanOrEqualTo = ">=" -printOp TSLessThan = "<" -printOp TSLessThanOrEqualTo = "<=" -printOp TSAnd = "&&" -printOp TSStringConcat = "+" - -printExpr :: TSExpr -> Text -printExpr (TSLit lit) = printLiteral lit -printExpr (TSFunction name generics mt maybeReturn expr) = - let prettyGen = case printGeneric <$> S.toList generics of - [] -> "" - as -> "<" <> T.intercalate "," as <> ">" - prettyReturnType = case maybeReturn of - Just mt' -> ": " <> printType mt' - _ -> "" - in prettyGen - <> "(" - <> printTSName name - <> ": " - <> printType mt - <> ")" - <> prettyReturnType - <> " => " - <> printFunctionBody expr -printExpr (TSVar var) = printTSName var -printExpr (TSApp func val) = - printExpr func <> "(" <> printExpr val <> ")" -printExpr (TSTuple as) = printExpr (TSArray (TSArrayItem <$> as)) <> " as const" -printExpr (TSArray as) = - "[" - <> T.intercalate - "," - (printArrayItem <$> as) - <> "]" - where - printArrayItem (TSArrayItem a) = printExpr a - printArrayItem (TSArraySpread var) = "..." <> printExpr var -printExpr (TSArrayAccess a expr) = - printExpr expr <> "[" <> prettyPrint a <> "]" -printExpr (TSInfix op a b) = - printExpr a - <> " " - <> printOp op - <> " " - <> printExpr b -printExpr (TSRecord as) = - let outputRecordItem (name, val) = - printTSName name <> ": " <> printExpr val - items = outputRecordItem <$> M.toList as - in "{ " - <> T.intercalate - ", " - items - <> " }" -printExpr (TSRecordAccess name expr) = - printExpr expr <> "." <> printTSName name -printExpr (TSTernary cond thenE elseE) = - printExpr cond - <> " ? " - <> printExpr thenE - <> " : " - <> printExpr elseE -printExpr (TSData constructor args) = - let prettyArgs = T.intercalate "," (printExpr <$> args) - in "{ type: \"" <> prettyPrint constructor <> "\", vars: [" <> prettyArgs <> "] }" -printExpr (TSError msg) = - "throw new Error(\"" <> msg <> "\")" -printExpr TSUnderscore = "_" - -printModule :: TSModule -> Text -printModule (TSModule dataTypes (TSBody assignments export)) = - T.intercalate "\n" (printDataType <$> dataTypes) - <> T.intercalate "\n" (printStatement <$> assignments) - <> "export const main = " - <> printExpr export diff --git a/backends/src/Language/Mimsa/Backend/Typescript/Types.hs b/backends/src/Language/Mimsa/Backend/Typescript/Types.hs deleted file mode 100644 index 57995dbd..00000000 --- a/backends/src/Language/Mimsa/Backend/Typescript/Types.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Backend.Typescript.Types - ( TSGeneric (..), - TSType (..), - TSConstructor (..), - TSDataType (..), - TSStringPart (..), - TSLiteral (..), - TSPattern (..), - TSSpread (..), - TSExpr (..), - TSLetBody (..), - TSArrayPart (..), - TSBody (..), - TSStatement (..), - TSFunctionBody (..), - TSOp (..), - TSModule (..), - TSName (..), - TSImport (..), - ) -where - -import Data.Map.Strict (Map) -import Data.Set (Set) -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core (Printer (..), TyCon (..), TypeName (..)) - -data TSImport - = TSImportValue Text - | TSImportType Text - deriving stock (Eq, Ord, Show) - -instance Printer TSImport where - prettyPrint (TSImportType t) = t - prettyPrint (TSImportValue t) = t - --- | which generics have been used already? -newtype TSGeneric = TSGeneric Text - deriving newtype (Eq, Ord, Show, Printer) - -data TSType - = TSType (Maybe Text) Text [TSType] -- namespace, typeName, inner types - | TSTypeVar Text - | TSTypeFun Text TSType TSType - | TSTypeArray TSType - | TSTypeTuple [TSType] - | TSTypeRecord (Map Text TSType) - | TSTypeAnd TSType TSType - deriving stock (Eq, Ord, Show) - -data TSConstructor = TSConstructor TyCon [TSType] - deriving stock (Eq, Ord, Show) - -data TSDataType = TSDataType TypeName [Text] [TSConstructor] - deriving stock (Eq, Ord, Show) - -data TSLiteral = TSBool Bool | TSString Text | TSInt Int - deriving stock (Eq, Ord, Show) - -data TSSpread - = TSNoSpread - | TSSpreadWildcard - | TSSpreadValue TSName - deriving stock (Eq, Ord, Show) - -data TSStringPart - = TSStringVar TSName - | TSStringWildcard - deriving stock (Eq, Ord, Show) - -data TSPattern - = TSPatternVar TSName - | TSPatternTuple [TSPattern] - | TSPatternRecord (Map TSName TSPattern) - | TSPatternConstructor TyCon [TSPattern] - | TSPatternLit TSLiteral - | TSPatternArray [TSPattern] TSSpread - | TSPatternWildcard - | TSPatternString TSStringPart TSStringPart - deriving stock (Eq, Ord, Show) - -newtype TSLetBody = TSLetBody TSBody - deriving newtype (Eq, Ord, Show) - -data TSStatement - = TSAssignment TSExpr (Maybe TSType) TSLetBody -- match pattern, type, body - | TSConditional TSExpr TSLetBody -- pattern to match, body - deriving stock (Eq, Ord, Show) - --- this could be top level or in a function body, it's a list of --- assignments followed by either the return or an export --- won't be prettyprinted directly as it depends on context -data TSBody = TSBody [TSStatement] TSExpr - deriving stock (Eq, Ord, Show) - -newtype TSFunctionBody = TSFunctionBody TSBody - deriving newtype (Eq, Ord, Show) - -data TSOp - = TSEquals - | TSAdd - | TSSubtract - | TSGreaterThan - | TSGreaterThanOrEqualTo - | TSLessThan - | TSLessThanOrEqualTo - | TSAnd - | TSStringConcat - deriving stock (Eq, Ord, Show) - -data TSArrayPart - = TSArrayItem TSExpr - | TSArraySpread TSExpr - deriving stock (Eq, Ord, Show) - -newtype TSName = TSName Text - deriving stock (Eq, Ord, Show) - -instance IsString TSName where - fromString = TSName . T.pack - -data TSExpr - = TSLit TSLiteral - | TSFunction TSName (Set TSGeneric) TSType (Maybe TSType) TSFunctionBody -- argName, generics, argType, returnType, body - | TSRecord (Map TSName TSExpr) - | TSRecordAccess TSName TSExpr - | TSArray [TSArrayPart] - | TSArrayAccess Int TSExpr - | TSTuple [TSExpr] - | TSVar TSName - | TSApp TSExpr TSExpr - | TSInfix TSOp TSExpr TSExpr - | TSTernary TSExpr TSExpr TSExpr - | TSData Text [TSExpr] - | TSError Text - | TSUnderscore - deriving stock (Eq, Ord, Show) - -data TSModule = TSModule [TSDataType] TSBody - deriving stock (Eq, Ord, Show) diff --git a/backends/static/backend/es-modules-js/stdlib.mjs b/backends/static/backend/es-modules-js/stdlib.mjs deleted file mode 100644 index 9535f1e2..00000000 --- a/backends/static/backend/es-modules-js/stdlib.mjs +++ /dev/null @@ -1,15 +0,0 @@ -export const equals_ = (a) => (b) => JSON.stringify(a) == JSON.stringify(b); - -export const next_ = (func) => ({ - func, -}); - -export const done_ = (value) => ({ value }); - -export const trampoline_ = (first) => { - let result = first; - while ("func" in result) { - result = result.func(); - } - return result.value; -}; diff --git a/backends/static/backend/typescript/stdlib.ts b/backends/static/backend/typescript/stdlib.ts deleted file mode 100644 index 27f36606..00000000 --- a/backends/static/backend/typescript/stdlib.ts +++ /dev/null @@ -1,18 +0,0 @@ -export const equals_ = (a: A) => (b: A) => - JSON.stringify(a) == JSON.stringify(b); - -export type Tramp_ = { func: () => Tramp_ } | { value: A }; - -export const next_ = (func: () => Tramp_): Tramp_ => ({ - func, -}); - -export const done_ = (value: A): Tramp_ => ({ value }); - -export const trampoline_ = (first: Tramp_): A => { - let result = first; - while ("func" in result) { - result = result.func(); - } - return result.value; -}; diff --git a/backends/test/Spec.hs b/backends/test/Spec.hs deleted file mode 100644 index 40040c35..00000000 --- a/backends/test/Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main - ( main, - ) -where - -import qualified Test.Backend.ESModulesJS -import qualified Test.Backend.Typescript -import Test.Hspec - -main :: IO () -main = - hspec $ do - Test.Backend.ESModulesJS.spec - Test.Backend.Typescript.spec diff --git a/backends/test/Test/Backend/ESModulesJS.hs b/backends/test/Test/Backend/ESModulesJS.hs deleted file mode 100644 index c619f5d1..00000000 --- a/backends/test/Test/Backend/ESModulesJS.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.ESModulesJS - ( spec, - ) -where - --- these are only the unit tests for ES modules output, testing individual --- expressions - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Backend.Javascript.Printer as JS -import Language.Mimsa.Backend.Typescript.DataType -import Language.Mimsa.Backend.Typescript.FromExpr -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Patterns -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core -import Test.Hspec -import Test.Utils.Helpers - -testFromExpr :: Expr Name MonoType -> (TSModule, Text) -testFromExpr expr = - let readerState = TSReaderState mempty mempty - startState = TSCodegenState mempty mempty mempty - in case fromExpr readerState startState expr of - Right (ejsModule, _) -> (ejsModule, JS.printModule ejsModule) - Left e -> error (T.unpack (prettyPrint e)) - -spec :: Spec -spec = do - describe "ESModulesJS" $ do - describe "pretty print AST" $ do - it "literals" $ do - JS.printLiteral (TSBool True) `shouldBe` "true" - JS.printLiteral (TSInt 100) `shouldBe` "100" - JS.printLiteral (TSString "egg") `shouldBe` "`egg`" - it "function" $ do - JS.printExpr - ( TSFunction - "a" - mempty - (TSType Nothing "boolean" []) - Nothing - (TSFunctionBody (TSBody mempty (TSLit (TSInt 1)))) - ) - `shouldBe` "(a) => 1" - JS.printExpr - ( TSFunction - "maybeA" - (S.singleton (TSGeneric "A")) - (TSType (Just "Maybe") "Maybe" [TSTypeVar "A"]) - Nothing - (TSFunctionBody (TSBody mempty (TSLit (TSInt 1)))) - ) - `shouldBe` "(maybeA) => 1" - JS.printExpr - ( TSFunction - "maybeA" - (S.singleton (TSGeneric "A")) - (TSType (Just "Maybe") "Maybe" [TSTypeVar "A"]) - Nothing - ( TSFunctionBody - ( TSBody - [ TSAssignment - (TSVar "b") - Nothing - (TSLetBody (TSBody [] (TSLit (TSBool True)))) - ] - (TSLit (TSInt 1)) - ) - ) - ) - `shouldBe` "(maybeA) => { const b = true; return 1; }" - it "function application" $ do - JS.printExpr (TSApp (TSVar "id") (TSLit (TSBool True))) - `shouldBe` "id(true)" - JS.printExpr (TSApp (TSApp (TSVar "id") (TSLit (TSBool True))) (TSLit (TSInt 1))) - `shouldBe` "id(true)(1)" - it "infix operators" $ do - JS.printExpr (TSInfix TSEquals (TSLit (TSInt 1)) (TSLit (TSInt 2))) - `shouldBe` "1 === 2" - it "record" $ do - JS.printExpr - ( TSRecord - ( M.fromList - [ ( "a", - TSLit (TSInt 1) - ), - ("b", TSLit (TSBool True)) - ] - ) - ) - `shouldBe` "{ a: 1, b: true }" - it "record access" $ do - JS.printExpr (TSRecordAccess "a" (TSVar "record")) `shouldBe` "record.a" - it "array" $ do - JS.printExpr - ( TSArray - [ TSArrayItem (TSLit (TSInt 1)), - TSArrayItem (TSLit (TSInt 2)), - TSArraySpread (TSVar "rest") - ] - ) - `shouldBe` "[1,2,...rest]" - it "array access" $ do - JS.printExpr (TSArrayAccess 2 (TSVar "array")) - `shouldBe` "array[2]" - it "ternary" $ do - JS.printExpr - ( TSTernary - (TSLit (TSBool True)) - (TSLit (TSInt 1)) - (TSLit (TSInt 2)) - ) - `shouldBe` "true ? 1 : 2" - describe "patterns" $ do - it "destructure" $ do - let destructure' = mconcat . fmap JS.printStatement . destructure - destructure' (TSPatternVar "a") `shouldBe` "const a = value; " - destructure' TSPatternWildcard `shouldBe` "" - destructure' - ( TSPatternTuple - [ TSPatternVar "a", - TSPatternVar "b" - ] - ) - `shouldBe` "const [a,b] = value; " - destructure' - ( TSPatternRecord - ( M.fromList - [("a", TSPatternVar "a"), ("b", TSPatternVar "b")] - ) - ) - `shouldBe` "const { a: a, b: b } = value; " - destructure' (TSPatternConstructor "Just" [TSPatternVar "a"]) - `shouldBe` "const { vars: [a] } = value; " - destructure' (TSPatternConstructor "Just" [TSPatternWildcard]) - `shouldBe` "" - destructure' (TSPatternString (TSStringVar "d") (TSStringVar "og")) - `shouldBe` "const d = value.charAt(0); const og = value.slice(1); " - destructure' (TSPatternConstructor "Just" [TSPatternString (TSStringVar "d") (TSStringVar "og")]) - `shouldBe` "const d = value.vars[0].charAt(0); const og = value.vars[0].slice(1); " - - it "conditions" $ do - let conditions' = JS.printExpr . conditions - conditions' (TSPatternVar "a") `shouldBe` "true" - conditions' TSPatternWildcard `shouldBe` "true" - conditions' - ( TSPatternTuple - [ TSPatternLit (TSInt 11), - TSPatternLit (TSInt 23) - ] - ) - `shouldBe` "value[0] === 11 && value[1] === 23" - conditions' - ( TSPatternRecord - ( M.fromList - [("a", TSPatternLit (TSInt 11)), ("b", TSPatternVar "b")] - ) - ) - `shouldBe` "value.a === 11" - conditions' (TSPatternConstructor "Just" [TSPatternLit (TSBool True)]) - `shouldBe` "value.type === `Just` && value.vars[0] === true" - conditions' (TSPatternConstructor "Just" [TSPatternWildcard]) - `shouldBe` "value.type === `Just`" - conditions' (TSPatternString (TSStringVar "d") (TSStringVar "og")) - `shouldBe` "value.length >= 1" - - it "top level module" $ do - JS.printModule (TSModule mempty (TSBody mempty (TSLit (TSBool True)))) - `shouldBe` "export const main = true" - JS.printModule - ( TSModule - mempty - ( TSBody - [ TSAssignment - (TSVar "a") - Nothing - (TSLetBody (TSBody mempty (TSLit (TSBool True)))) - ] - (TSVar "a") - ) - ) - `shouldBe` "const a = true; export const main = a" - describe "from typed expression" $ do - it "const bool" $ - testFromExpr (MyLiteral mtBool (MyBool True)) - `shouldBe` ( TSModule mempty (TSBody [] (TSLit (TSBool True))), - "export const main = true" - ) - - it "let a = true in a" $ - snd - ( testFromExpr - ( MyLet - mtBool - (Identifier mtBool "a") - ( MyLiteral mtBool (MyBool True) - ) - (MyVar mtBool Nothing "a") - ) - ) - `shouldBe` "const a = true; export const main = a" - - it "let (a,_) = (true,false) in a" $ do - snd - ( testFromExpr - ( MyLetPattern - (MTTuple mempty mtBool (NE.singleton mtBool)) - (PTuple (MTTuple mempty mtBool (NE.singleton mtBool)) (PVar mtBool "a") (NE.singleton $ PWildcard mtBool)) - ( MyTuple - (MTTuple mempty mtBool (NE.singleton mtBool)) - (MyLiteral mtBool (MyBool True)) - (NE.singleton $ MyLiteral mtBool (MyBool False)) - ) - (MyVar mtBool Nothing "a") - ) - ) - `shouldBe` "const [a,_] = [true,false]; export const main = a" - - it "function with known type" $ do - snd - ( testFromExpr - ( MyLambda - (MTFunction mempty mtString mtString) - (Identifier mtString "str") - (MyVar mtString Nothing "str") - ) - ) - `shouldBe` "export const main = (str) => str" - it "function with generic type used multiple times" $ do - snd - ( testFromExpr - ( MyLambda - (MTFunction mempty (mtVar "a") (mtVar "a")) - (Identifier (mtVar "a") "a") - ( MyLambda - (MTFunction mempty (mtVar "a") (mtVar "a")) - (Identifier (mtVar "a") "a2") - (MyVar (mtVar "a") Nothing "a") - ) - ) - ) - `shouldBe` "export const main = (a) => (a2) => a" - - describe "Create constructor functions" $ do - let tsMaybe = - TSDataType - "Maybe" - ["A"] - [ TSConstructor "Just" [TSTypeVar "A"], - TSConstructor "Nothing" mempty - ] - tsThese = - TSDataType - "These" - ["A", "B"] - [ TSConstructor "This" [TSTypeVar "A"], - TSConstructor "That" [TSTypeVar "B"], - TSConstructor "These" [TSTypeVar "A", TSTypeVar "B"] - ] - - it "Maybe" $ do - JS.printStatement <$> createConstructorFunctions tsMaybe - `shouldBe` [ "const Just = (a) => ({ type: \"Just\", vars: [a] }); ", - "const Nothing = { type: \"Nothing\", vars: [] }; " - ] - it "These" $ do - JS.printStatement <$> createConstructorFunctions tsThese - `shouldBe` [ "const This = (a) => ({ type: \"This\", vars: [a] }); ", - "const That = (b) => ({ type: \"That\", vars: [b] }); ", - "const These = (a) => (b) => ({ type: \"These\", vars: [a,b] }); " - ] diff --git a/backends/test/Test/Backend/Typescript.hs b/backends/test/Test/Backend/Typescript.hs deleted file mode 100644 index e2c1b57e..00000000 --- a/backends/test/Test/Backend/Typescript.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.Typescript - ( spec, - ) -where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Backend.Typescript.DataType -import Language.Mimsa.Backend.Typescript.FromExpr -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Patterns -import Language.Mimsa.Backend.Typescript.Printer -import Language.Mimsa.Backend.Typescript.Types -import Language.Mimsa.Core -import Test.Hspec -import Test.Utils.Helpers - -testFromExpr :: Expr Name MonoType -> (TSModule, Text) -testFromExpr expr = - let readerState = - TSReaderState (M.fromList [("Dog", "Pet"), ("Same", "Same")]) mempty - startState = TSCodegenState mempty mempty mempty - in case fromExpr readerState startState expr of - Right (tsModule, _) -> (tsModule, printModule tsModule) - Left e -> error (T.unpack (prettyPrint e)) - -spec :: Spec -spec = do - describe "Typescript" $ do - describe "pretty print Typescript AST" $ do - it "literals" $ do - printLiteral (TSBool True) `shouldBe` "true" - printLiteral (TSInt 100) `shouldBe` "100" - printLiteral (TSString "egg") `shouldBe` "`egg`" - it "function" $ do - printExpr - ( TSFunction - "a" - mempty - (TSType Nothing "boolean" []) - Nothing - (TSFunctionBody (TSBody mempty (TSLit (TSInt 1)))) - ) - `shouldBe` "(a: boolean) => 1" - printExpr - ( TSFunction - "maybeA" - (S.singleton (TSGeneric "A")) - (TSType (Just "Maybe") "Maybe" [TSTypeVar "A"]) - Nothing - (TSFunctionBody (TSBody mempty (TSLit (TSInt 1)))) - ) - `shouldBe` "(maybeA: Maybe.Maybe) => 1" - printExpr - ( TSFunction - "maybeA" - (S.singleton (TSGeneric "A")) - (TSType (Just "Maybe") "Maybe" [TSTypeVar "A"]) - Nothing - ( TSFunctionBody - ( TSBody - [ TSAssignment - (TSVar "b") - Nothing - (TSLetBody (TSBody [] (TSLit (TSBool True)))) - ] - (TSLit (TSInt 1)) - ) - ) - ) - `shouldBe` "(maybeA: Maybe.Maybe) => { const b = true; return 1; }" - it "function application" $ do - printExpr (TSApp (TSVar "id") (TSLit (TSBool True))) - `shouldBe` "id(true)" - printExpr (TSApp (TSApp (TSVar "id") (TSLit (TSBool True))) (TSLit (TSInt 1))) - `shouldBe` "id(true)(1)" - it "infix operators" $ do - printExpr (TSInfix TSEquals (TSLit (TSInt 1)) (TSLit (TSInt 2))) - `shouldBe` "1 === 2" - it "record" $ do - printExpr - ( TSRecord - ( M.fromList - [ ( "a", - TSLit (TSInt 1) - ), - ("b", TSLit (TSBool True)) - ] - ) - ) - `shouldBe` "{ a: 1, b: true }" - it "pair" $ do - printExpr (TSTuple [TSLit (TSInt 1), TSLit (TSInt 2)]) `shouldBe` "[1,2] as const" - it "record access" $ do - printExpr (TSRecordAccess "a" (TSVar "record")) `shouldBe` "record.a" - it "array" $ do - printExpr - ( TSArray - [ TSArrayItem (TSLit (TSInt 1)), - TSArrayItem (TSLit (TSInt 2)), - TSArraySpread (TSVar "rest") - ] - ) - `shouldBe` "[1,2,...rest]" - it "array access" $ do - printExpr (TSArrayAccess 2 (TSVar "array")) - `shouldBe` "array[2]" - it "ternary" $ do - printExpr - ( TSTernary - (TSLit (TSBool True)) - (TSLit (TSInt 1)) - (TSLit (TSInt 2)) - ) - `shouldBe` "true ? 1 : 2" - describe "patterns" $ do - it "destructure" $ do - let destructure' = mconcat . fmap printStatement . destructure - destructure' (TSPatternVar "a") `shouldBe` "const a = value; " - destructure' TSPatternWildcard `shouldBe` "" - destructure' - ( TSPatternTuple - [ TSPatternVar "a", - TSPatternVar "b" - ] - ) - `shouldBe` "const [a,b] = value; " - destructure' - ( TSPatternRecord - ( M.fromList - [("a", TSPatternVar "a"), ("b", TSPatternVar "b")] - ) - ) - `shouldBe` "const { a: a, b: b } = value; " - destructure' (TSPatternConstructor "Just" [TSPatternVar "a"]) - `shouldBe` "const { vars: [a] } = value; " - destructure' (TSPatternConstructor "Just" [TSPatternWildcard]) - `shouldBe` "" - destructure' (TSPatternString (TSStringVar "d") (TSStringVar "og")) - `shouldBe` "const d = value.charAt(0); const og = value.slice(1); " - destructure' (TSPatternConstructor "Just" [TSPatternString (TSStringVar "d") (TSStringVar "og")]) - `shouldBe` "const d = value.vars[0].charAt(0); const og = value.vars[0].slice(1); " - - it "conditions" $ do - let conditions' = printExpr . conditions - conditions' (TSPatternVar "a") `shouldBe` "true" - conditions' TSPatternWildcard `shouldBe` "true" - conditions' - ( TSPatternTuple - [ TSPatternLit (TSInt 11), - TSPatternLit (TSInt 23) - ] - ) - `shouldBe` "value[0] === 11 && value[1] === 23" - conditions' - ( TSPatternRecord - ( M.fromList - [("a", TSPatternLit (TSInt 11)), ("b", TSPatternVar "b")] - ) - ) - `shouldBe` "value.a === 11" - conditions' (TSPatternConstructor "Just" [TSPatternLit (TSBool True)]) - `shouldBe` "value.type === `Just` && value.vars[0] === true" - conditions' (TSPatternConstructor "Just" [TSPatternWildcard]) - `shouldBe` "value.type === `Just`" - conditions' (TSPatternString (TSStringVar "d") (TSStringVar "og")) - `shouldBe` "value.length >= 1" - - it "top level module" $ do - printModule (TSModule mempty (TSBody mempty (TSLit (TSBool True)))) - `shouldBe` "export const main = true" - printModule - ( TSModule - mempty - ( TSBody - [ TSAssignment - (TSVar "a") - Nothing - (TSLetBody (TSBody mempty (TSLit (TSBool True)))) - ] - (TSVar "a") - ) - ) - `shouldBe` "const a = true; export const main = a" - - describe "from typed expression" $ do - it "Namespaced constructor" $ do - testFromExpr (MyConstructor mtBool Nothing "Dog") - `shouldBe` ( TSModule mempty (TSBody [] $ TSRecordAccess "Dog" (TSVar "Pet")), - "export const main = Pet.Dog" - ) - - it "Namespaced constructor with same" $ do - testFromExpr (MyConstructor mtBool Nothing "Same") - `shouldBe` ( TSModule mempty (TSBody [] $ TSRecordAccess "Same" (TSVar "Same")), - "export const main = Same.Same" - ) - - it "Namespaced constructor with blah" $ do - testFromExpr (MyConstructor mtBool (Just "distraction") "Dog") - `shouldBe` ( TSModule mempty (TSBody [] $ TSRecordAccess "Dog" (TSVar "Pet")), - "export const main = Pet.Dog" - ) - - it "Not namespaced constructor" $ do - testFromExpr (MyConstructor mtBool Nothing "Log") - `shouldBe` (TSModule mempty (TSBody [] (TSVar "Log")), "export const main = Log") - - it "const bool" $ - testFromExpr (MyLiteral mtBool (MyBool True)) - `shouldBe` ( TSModule mempty (TSBody [] (TSLit (TSBool True))), - "export const main = true" - ) - - it "let a = true in a" $ - snd - ( testFromExpr - ( MyLet - mtBool - (Identifier mtBool "a") - ( MyLiteral mtBool (MyBool True) - ) - (MyVar mtBool Nothing "a") - ) - ) - `shouldBe` "const a = true; export const main = a" - - it "let (a,_) = (true,false) in a" $ do - snd - ( testFromExpr - ( MyLetPattern - (MTTuple mempty mtBool (NE.singleton mtBool)) - (PTuple (MTTuple mempty mtBool (NE.singleton mtBool)) (PVar mtBool "a") (NE.singleton $ PWildcard mtBool)) - ( MyTuple - (MTTuple mempty mtBool (NE.singleton mtBool)) - (MyLiteral mtBool (MyBool True)) - (NE.singleton $ MyLiteral mtBool (MyBool False)) - ) - (MyVar mtBool Nothing "a") - ) - ) - `shouldBe` "const [a,_] = [true,false] as const; export const main = a" - - it "function with known type" $ do - snd - ( testFromExpr - ( MyLambda - (MTFunction mempty mtString mtString) - (Identifier mtString "str") - (MyVar mtString Nothing "str") - ) - ) - `shouldBe` "export const main = (str: string) => str" - it "function with generic type used multiple times" $ do - snd - ( testFromExpr - ( MyLambda - (MTFunction mempty (mtVar "a") (mtVar "a")) - (Identifier (mtVar "a") "a") - ( MyLambda - (MTFunction mempty (mtVar "a") (mtVar "a")) - (Identifier (mtVar "a") "a2") - (MyVar (mtVar "a") Nothing "a") - ) - ) - ) - `shouldBe` "export const main = (a: A) => (a2: A) => a" - - describe "Create constructor functions" $ do - let tsMaybe = - TSDataType - "Maybe" - ["A"] - [ TSConstructor "Just" [TSTypeVar "A"], - TSConstructor "Nothing" mempty - ] - tsThese = - TSDataType - "These" - ["A", "B"] - [ TSConstructor "This" [TSTypeVar "A"], - TSConstructor "That" [TSTypeVar "B"], - TSConstructor "These" [TSTypeVar "A", TSTypeVar "B"] - ] - tsMonoid = - TSDataType - "Monoid" - ["A"] - [ TSConstructor - "Monoid" - [ TSTypeFun - "arg" - (TSTypeVar "A") - (TSTypeFun "arg" (TSTypeVar "A") (TSTypeVar "A")), - TSTypeVar "A" - ] - ] - - it "Maybe" $ do - printStatement <$> createConstructorFunctions tsMaybe - `shouldBe` [ "const Just = (a: A): Maybe => ({ type: \"Just\", vars: [a] }); ", - "const Nothing: Maybe = { type: \"Nothing\", vars: [] }; " - ] - it "These" $ do - printStatement <$> createConstructorFunctions tsThese - `shouldBe` [ "const This = (a: A): These => ({ type: \"This\", vars: [a] }); ", - "const That = (b: B): These => ({ type: \"That\", vars: [b] }); ", - "const These = (a: A) => (b: B): These => ({ type: \"These\", vars: [a,b] }); " - ] - it "Monoid" $ do - printStatement <$> createConstructorFunctions tsMonoid - `shouldBe` [ "const Monoid = (u1: (arg: A) => (arg: A) => A) => (a: A): Monoid => ({ type: \"Monoid\", vars: [u1,a] }); " - ] diff --git a/backends/test/Test/Codegen/Shared.hs b/backends/test/Test/Codegen/Shared.hs deleted file mode 100644 index 2fe910cb..00000000 --- a/backends/test/Test/Codegen/Shared.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Codegen.Shared - ( unsafeParse, - dtVoid, - dtTrafficLights, - dtWrappedString, - dtIdentity, - dtMaybe, - dtEither, - dtPair, - dtMonoPair, - dtThese, - dtList, - dtDoubleList, - dtTree, - dtReader, - dtMatchedPair, - dtConsoleF, - dtEnv, - ) -where - -import Data.Functor -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Test.Utils.Helpers - --- | has no constructors, we can do nothing with this -dtVoid :: DataType -dtVoid = DataType "Void" mempty mempty - --- | an enum, we can go to and from a string -dtTrafficLights :: DataType -dtTrafficLights = - DataType - "TrafficLights" - mempty - ( M.fromList - [ ("Red", mempty), - ("Yellow", mempty), - ("Green", mempty) - ] - ) - --- | A newtype around a string --- | we can wrap and unwrap maybe? -dtWrappedString :: DataType -dtWrappedString = - DataType - "WrappedString" - mempty - (M.singleton "Wrapped" [dataTypeWithVars mempty Nothing "String" mempty]) - --- | Identity monad -dtIdentity :: DataType -dtIdentity = - DataType - "Identity" - ["a"] - (M.singleton "Identity" [MTVar mempty (tvNamed "a")]) - --- | Maybe monad -dtMaybe :: DataType -dtMaybe = - DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [MTVar mempty (tvNamed "a")]), - ("Nothing", []) - ] - ) - --- | Either monad -dtEither :: DataType -dtEither = - DataType - "Either" - ["e", "a"] - ( M.fromList - [ ("Right", [MTVar mempty (tvNamed "a")]), - ("Left", [MTVar mempty (tvNamed "e")]) - ] - ) - --- | These monad -dtThese :: DataType -dtThese = - DataType - "These" - ["a", "b"] - ( M.fromList - [ ("This", [MTVar mempty (tvNamed "a")]), - ("That", [MTVar mempty (tvNamed "b")]), - ( "These", - [ MTVar mempty (tvNamed "a"), - MTVar - mempty - (tvNamed "b") - ] - ) - ] - ) - --- | List monad -dtList :: DataType -dtList = - DataType - "List" - ["a"] - ( M.fromList - [ ( "Cons", - [ MTVar mempty (tvNamed "a"), - dataTypeWithVars mempty Nothing "List" [MTVar mempty (tvNamed "a")] - ] - ), - ("Nil", []) - ] - ) - --- | List but with more type params so we can recurse around more complicated --- types -dtDoubleList :: DataType -dtDoubleList = - DataType - "DoubleList" - ["a", "b"] - ( M.fromList - [ ( "DoubleCons", - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b"), - dataTypeWithVars - mempty - Nothing - "DoubleList" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b") - ] - ] - ), - ("DoubleNil", []) - ] - ) - -dtTree :: DataType -dtTree = - DataType - "Tree" - ["a"] - ( M.fromList - [ ("Leaf", [MTVar mempty (tvNamed "a")]), - ( "Branch", - [ dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")], - dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")] - ] - ) - ] - ) - -dtReader :: DataType -dtReader = - DataType - "Reader" - ["r", "a"] - ( M.singleton - "Reader" - [ MTFunction - mempty - (MTVar mempty (tvNamed "r")) - (MTVar mempty (tvNamed "a")) - ] - ) - -dtMatchedPair :: DataType -dtMatchedPair = - DataType - "MatchedPair" - ["a"] - ( M.singleton - "MatchedPair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "a") - ] - ) - -dtConsoleF :: DataType -dtConsoleF = - DataType - "ConsoleF" - ["next"] - ( M.fromList - [ ( "Write", - [ dataTypeWithVars mempty Nothing "String" [], - MTVar mempty (tvNamed "next") - ] - ), - ( "Read", - [ MTFunction - mempty - (dataTypeWithVars mempty Nothing "String" []) - (MTVar mempty (tvNamed "next")) - ] - ) - ] - ) - -dtPair :: DataType -dtPair = - DataType - "Pair" - ["a", "b"] - ( M.singleton - "Pair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b") - ] - ) - -dtMonoPair :: DataType -dtMonoPair = - DataType - "MonoPair" - ["a"] - ( M.singleton - "MonoPair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "a") - ] - ) - -dtEnv :: DataType -dtEnv = - DataType - "Env" - ["w", "a"] - ( M.singleton - "Env" - [ MTVar mempty (tvNamed "w"), - MTVar mempty (tvNamed "a") - ] - ) - -unsafeParse :: Text -> Expr Name () -unsafeParse t = case parseExprAndFormatError t of - Right a -> a $> mempty - Left e -> error (T.unpack e) diff --git a/backends/test/Test/Utils/Helpers.hs b/backends/test/Test/Utils/Helpers.hs deleted file mode 100644 index ae9a6428..00000000 --- a/backends/test/Test/Utils/Helpers.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Test.Utils.Helpers (int, bool, unknown, str', str, mtBool, mtString, mtVar, mtInt, tvNamed, tvNum, typeName, mtFun) where - -import Data.Text (Text) -import Language.Mimsa.Core - -bool :: (Monoid ann) => Bool -> Expr a ann -bool a = MyLiteral mempty (MyBool a) - -int :: (Monoid ann) => Int -> Expr a ann -int a = MyLiteral mempty (MyInt a) - -str :: (Monoid ann) => StringType -> Expr a ann -str a = MyLiteral mempty (MyString a) - -str' :: (Monoid ann) => Text -> Expr a ann -str' = str . StringType - --- -unknown :: (Monoid ann) => Int -> Type ann -unknown = MTVar mempty . TVUnificationVar - -typeName :: (Monoid ann) => Text -> Type ann -typeName = MTVar mempty . TVName . mkTyVar - ---- - -tvNum :: Int -> TypeIdentifier -tvNum = TVUnificationVar - -tvNamed :: Text -> TypeIdentifier -tvNamed t = TVName $ mkTyVar t - ----- - -mtInt :: (Monoid ann) => Type ann -mtInt = MTPrim mempty MTInt - -mtBool :: (Monoid ann) => Type ann -mtBool = MTPrim mempty MTBool - -mtString :: (Monoid ann) => Type ann -mtString = MTPrim mempty MTString - -mtVar :: (Monoid ann) => Text -> Type ann -mtVar n = MTVar mempty (tvNamed n) - -mtFun :: (Monoid ann) => Type ann -> Type ann -> Type ann -mtFun = MTFunction mempty - ----- diff --git a/backends/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json b/backends/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json deleted file mode 100644 index eb62daa5..00000000 --- a/backends/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["6efce297c2d4351e9a7efe9843a834ba2898dbacb3f18472eca94b66e8a20353"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json b/backends/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json deleted file mode 100644 index 24eace25..00000000 --- a/backends/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["89ec42d372033b7a5d322f418c1c773b2cb72a25c3ee1fa00c0a6a16ca0dad92"],"aRecord":["67c91729b64f5e925ff20a372d655b09c22c8fe825692f49e44ee01b0571c7fe"],"addInt":["50d596f035ef2298486dfe76fce2eb559aa9790444b8fe198b1aa18fb8098f00"],"and":["dda72ee0b169eca331a8e82c7e2ea5e9eec65423a697fbd6c0c550f0658fa602"],"anyChar":["506016edce16d305a382b50895ba565b36591c777af422deab19d836a633992b"],"apState":["ccd75a4b14bbaac07de81f51ead2677e45e42f0e806a35cb5fb29363c6874df5"],"bindParser":["06c44f8b06787e06c9937a619acbd87b6cc30c0228fe13c0727b68da574e7bc0"],"bindState":["491e3832b8573dd503ce8ae77a33fe10e26230cd005391520115582431672268"],"compose":["e080b6add324eb92cbef140e85bff5adc3278371ae13b6ebcd954f941fecec69","21d6bf82bd841b80647b19055fcfff02e8f2a195bc97d0801388ee2d15911754"],"cons":["d9d8d53a5eb27950e916f5bc716e28fd80148de11437477af86439f87fecae22"],"const":["065947481f020264ce041ba551f5534fa49a7d81a5b2836b74069635ac7134a8"],"constFalse":["6887c73fa2acc5014df704ae64b0789fa13a631ece9829772d0b2f973892a657"],"constTrue":["3cbfc22aec69a1f929939a6e95db2562c2d7aef97817b76747f239153e44e69f"],"either":["2b50845346ae7befaad7d06ed4cbea233e01b2365d168792f0de0914d468c353"],"eq":["7865e0a2b8d0e86ff3c1538fbbab1e2b7637fb725068837106678b6c992955c4"],"eqTen":["ae67718536e7366d3e44624f024c5a2ade5396fc224fec2531c793d2820bbb48"],"evalState":["d618faa423396f0bb3a79ae01dd1940f51f4eb3a9c83daab2082e797deca8d39"],"execState":["9b5c8e929db9e174f1ce1394e835df1d8cc6cf1a7ff906c52f8ed4fe74cddba7"],"failParser":["fa5edee30d30af98e23ea1bffd2214cb652510fea5d0159cae92557de4ffe378"],"fmapMaybe":["22266c91dc63819a66db32fdcba6f8779d30ee789317a97b08f69bfa45516363"],"fmapParser":["cd42896cef20904082efe867f8704fef86d93e45036d3f6037b4d43fb579cc91"],"fmapState":["b3e0ec45ae5d3a6fa1962886e9531ceac3626bd3d9227498dd482fb926b41031"],"fst":["f978339d21f76522684de9dfe0cc33a1375356e813aae7e36169fb5ff7477067"],"fstPair":["140640e279b2ab46a2cd4f7c0c6f43974c23d4336f0c818c3f26934cf6a832fe"],"id":["6bcbfacffa7df2141fdaab499b254937055614a413d00bbaca98998028dabad4"],"ident":["47863facbb14b341c179244839967614be2682bb8999b8246107a48bd7928cb8"],"incrementInt":["41632fd3b67d33aa652e4057598b592deaf890763869aa88cd10fc17338d6845"],"int":["09cd4349c6c00d40e14689ad994bfb71a4512728bc12a71a10d3b152e9e0bba8"],"invertTree":["f128ac2dc2cd03b663886a45c92a993bfae3b18cb35695cd47a0e834056d891b"],"invertTreeTwice":["21acd81c00a43b6b3ce53b7bf9075de96c78fc6d8a570c96e48ea39444e3edba"],"liftA2State":["99110470e13a475f5968feb06acf7f4157667f28848b928bb79a66f76985369d"],"list":["07310ce985594d4b40df473d66f3a7b0dc6e245ce8fbd7f409ec02fcae961ce7"],"mapArray":["af09b9118c81903f2f1d1452ab9a2d8d2b8764115467c8f74a362e22d4b7b93a"],"maybeMonoid":["e720c445e6c1ca3efd534925c3d617ee11d62e96d321ec2a9ef78716edec1231"],"monoPair":["8dfd7bec63258df923500c9945740b2e6bef48120ef989c85ee27b7c4cc6e3c2"],"nil":["5488e660b1ca97664bafb058886a2dc02e182976fb244f56f4e8175fe1f7c68b"],"not":["eeb4c3a7f5a8dff2bf11d64864d39fafeadef96bd3d2cf8c6786b462c3e839db"],"pair":["b792651c6b6f38ee27bbc8bb471b4c9b9712ca89820625609c9d52a1a62bba77"],"parser":["d0c809ccb07f8a0e6242f19caf922734c00c5e382e247da40ed16dbc950fe899"],"predParser":["5b84e032adbb016f2b1fc5836936a0a4354b457c8373a97460098fea5366ca8f"],"pureState":["e9828be4d35ef15b9391b05c46830d82a6512506930e36273e82cc0466323e36"],"runParser":["d7f6ff73646c63539b4282a98cf9b432dcd5504900a3a1b5580d5055f25d197f"],"runState":["52f8cc7edcb587683bf83846d4afecb42444ba4ff38886c4e49308871eed0e11"],"snd":["27b0c6ec1fa2ae2b61809756a138cece632f47b2c46377065c32e81f0276ce8d"],"sndPair":["8b4e660d07a0f0fcd0b7b7f32d8d884a2b4480d75a8f5bd90e6411acae9ad1ae"],"state":["47e1c8e33c8646c744c513a752c4beda810f713176b426d2eee1a36ca7c94ba0"],"storeName":["8e9c28a29597c9fff7e8c520771e9d52c155a87a532cc3136291133f553f3851"],"stringMonoid":["019a523b2c4757f5949f06c9b961addcbad359c73945739ccc5f8ab606816da1"],"stringReduce":["68a148f7fc27644880c28c3fc48fc615e2cf0f52085ccc68f579962b9cfd0753"],"subtractInt":["c88909ec5c5c953982dae03632f48e6b5484168da1b3c2f822c212ed7f580b3c"],"sumMonoid":["7f9473b31145d179d7b24606e07d3d0d6e4e2de502f8d71440d6eea98714017f"],"testStateUsages":["f909477d250128aeed4e3996ea20bfd13b0036b28f1a380a5518ae30427d67bb"],"trafficLight":["29cfc3f9d88ccdfc1a42affc423abe2647a39b1aa0e95827ea0edb4975ee57b0"],"tree":["8b91340817fc53dd09a94c5ab008badb547d602917d0a7d07df405bf9335c02d"],"typePerson":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"typeState":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"typeThese":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Cons":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Either":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"Green":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Ident":["eaea1fa57623e4b29172d982c3fb03d5048391668504c0129ae3081497d9d2f6"],"Just":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Leaf":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Left":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"List":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Maybe":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"MonoPair":["bb6f10ce0fead888d2f2d85defc08e21919ee06c01503a769b8b7286865ae920"],"Monoid":["1d49dac60d3b201147ddad2493dd67e98be499e801db0897f86f5de37666422b"],"Nil":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Nothing":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Pair":["19817d3943f7ef924625ccb655e5492adf0168f29238edec61a0310eb999bc2c"],"Parser":["56c450b3dadc5621e7fc54162257f50aa3b0091c22fba1efce0d97935d60484f"],"Person":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"Red":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Right":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"State":["63469d9155ce6dcd64bfab0e3e40ec9d43f54905c7f236e3a3c568636d145697"],"That":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"These":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"This":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"TrafficLight":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Tree":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Yellow":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json b/backends/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json deleted file mode 100644 index 025c9c9d..00000000 --- a/backends/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"either":["e8dc919cf8b9bdcd8d6f28412ab099b4ede573c094b472284e9a0fa6ae9c341a"],"eitherAp":["2ffab3dd4460746288febd5b751fc94f6aae8371cdb2575b823e054840854728"],"eitherFmap":["b5008f7c34747cde95b7ed126ee49b0d6b5a5707aad77bec78b976224b061801"],"eitherPure":["c2d95f4066c787cbf265d8c9224afc234816256dcb6a3eaaa4ec264cf119e6fe"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json b/backends/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json deleted file mode 100644 index 2b9cc2ec..00000000 --- a/backends/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["083684fc6b7cb4d27b88a7863f67479e53b48a5f7674c468eef04b853e9433f5"],"apState":["5aa3c8c5b588c82e3fb2a485d8be1aa3ebc2d3e929ce260160da198f549ee36d"],"bindParser":["12f48a641846bc9fde215f4395602452f5765624b08d2c9bd1e3e8d7bb50d9b8"],"bindState":["bcc003d3140ecd5166b99e1cc7fddce3e05238d3d2567691b9400b42d5978ce8"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["a14881a7387acb9039631e994483db537509e46ae9f42cab84b47e39335a202f"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["3ccd9283de2206222b8cd95b47247dc7d7f1673a4c0f2e2bc664696ded151092"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["15f7b24a87ffe1b581fe010e63c8747761e05f2cf0ede98c4968a23a24f15901"],"fmapMaybe":["35e9d187aa7430499de7e4b67e7b5ea400b0f5446325fc7a3a16cbb78ee6d25e"],"fmapParser":["2899974ec4a5663b805ac436a7ca7254b661e7bacda2909024f1c81f038827e7"],"fmapState":["173f55349a3a743aede1435449ce50aa0c1131e257f362ba80b6d8e6d4177e03"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["2f1d8e4b6c3c23cbf30e27d43cb5191eb99b1ef326739bd30d6be47afa8b42af"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["bc810a57840e640ccc2e9e2e40be9480c4ea0ef7878ff75bac820f03fd851f1d"],"invertTreeTwice":["0eb26613c0044072286813a4f51ad25cddb01727f1a76ac02ef3965096bd69bf"],"liftA2State":["01245a64386ee8b54baa18f544df708f63f4ab89f61d64ed20708a5091f7ab63"],"list":["0e1c660f7d4b68d1c683a0da600bea35e16faf2efe67499f8aa27d7477f71b29"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["dd5ba6d519589e5c2d0a45e3cfb0e2707d0fdaaba43f9fef13d2fffe2e2f063b"],"monoPair":["002686d2b7391bd9c10be845cbb2f91c7faa74ecd391344d240841b0a7722a3c"],"nil":["ac695b5193a4664f86c249333e3adf61363deff8ae31f796eec3b70a350f107e"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["dd6b53e2749e55e65a23678733d02e8fb5822f49b2429823e137f12ab8e467af"],"parser":["daf281457d099413948cf496b8a4cae74bc8cc6c9dcb80ce73ae8fa1356b4c9b"],"predParser":["af017c1dc75e71de18a7dac3ff8b6be515000977fd4ccba1e499ddef03c614a0"],"pureState":["385d2ff93f84c1fc7796fc620b1f37ce540bb640a09ec00c97276f4abb0f14fc"],"runParser":["22672bf326ebd6307165f5cfcb37a4e25e0c1b00799a9c9b46ee4beabff44a17"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["afd99ec4e239f4c2f66270fde501d0de300ede9ab34bccf83afdd06eeb9caf6d"],"storeName":["14911c53fe5fe243a489a748ca66fbcb15318de65914310ab9fc33a7a4638265"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["0f02100d95b6bc3fdac0931255c29974de4242ab39c0451cb7949220eab35dad"],"tree":["e6d5d56773f95458450ad9f2f3188f397eadd0802090ddc17b4bca766b0439fe"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json b/backends/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json deleted file mode 100644 index 421556b1..00000000 --- a/backends/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["89ec42d372033b7a5d322f418c1c773b2cb72a25c3ee1fa00c0a6a16ca0dad92"],"aRecord":["67c91729b64f5e925ff20a372d655b09c22c8fe825692f49e44ee01b0571c7fe"],"addInt":["50d596f035ef2298486dfe76fce2eb559aa9790444b8fe198b1aa18fb8098f00"],"and":["dda72ee0b169eca331a8e82c7e2ea5e9eec65423a697fbd6c0c550f0658fa602"],"anyChar":["506016edce16d305a382b50895ba565b36591c777af422deab19d836a633992b"],"apState":["ccd75a4b14bbaac07de81f51ead2677e45e42f0e806a35cb5fb29363c6874df5"],"bindParser":["06c44f8b06787e06c9937a619acbd87b6cc30c0228fe13c0727b68da574e7bc0"],"bindState":["491e3832b8573dd503ce8ae77a33fe10e26230cd005391520115582431672268"],"compose":["e080b6add324eb92cbef140e85bff5adc3278371ae13b6ebcd954f941fecec69","21d6bf82bd841b80647b19055fcfff02e8f2a195bc97d0801388ee2d15911754"],"cons":["d9d8d53a5eb27950e916f5bc716e28fd80148de11437477af86439f87fecae22"],"const":["065947481f020264ce041ba551f5534fa49a7d81a5b2836b74069635ac7134a8"],"constFalse":["6887c73fa2acc5014df704ae64b0789fa13a631ece9829772d0b2f973892a657"],"constTrue":["3cbfc22aec69a1f929939a6e95db2562c2d7aef97817b76747f239153e44e69f"],"either":["2b50845346ae7befaad7d06ed4cbea233e01b2365d168792f0de0914d468c353"],"eq":["7865e0a2b8d0e86ff3c1538fbbab1e2b7637fb725068837106678b6c992955c4"],"eqTen":["ae67718536e7366d3e44624f024c5a2ade5396fc224fec2531c793d2820bbb48"],"evalState":["d618faa423396f0bb3a79ae01dd1940f51f4eb3a9c83daab2082e797deca8d39"],"execState":["9b5c8e929db9e174f1ce1394e835df1d8cc6cf1a7ff906c52f8ed4fe74cddba7"],"failParser":["fa5edee30d30af98e23ea1bffd2214cb652510fea5d0159cae92557de4ffe378"],"fmapMaybe":["22266c91dc63819a66db32fdcba6f8779d30ee789317a97b08f69bfa45516363"],"fmapParser":["cd42896cef20904082efe867f8704fef86d93e45036d3f6037b4d43fb579cc91"],"fmapState":["b3e0ec45ae5d3a6fa1962886e9531ceac3626bd3d9227498dd482fb926b41031"],"fst":["f978339d21f76522684de9dfe0cc33a1375356e813aae7e36169fb5ff7477067"],"fstPair":["140640e279b2ab46a2cd4f7c0c6f43974c23d4336f0c818c3f26934cf6a832fe"],"id":["6bcbfacffa7df2141fdaab499b254937055614a413d00bbaca98998028dabad4"],"ident":["47863facbb14b341c179244839967614be2682bb8999b8246107a48bd7928cb8"],"incrementInt":["41632fd3b67d33aa652e4057598b592deaf890763869aa88cd10fc17338d6845"],"int":["09cd4349c6c00d40e14689ad994bfb71a4512728bc12a71a10d3b152e9e0bba8"],"invertTree":["f128ac2dc2cd03b663886a45c92a993bfae3b18cb35695cd47a0e834056d891b"],"invertTreeTwice":["21acd81c00a43b6b3ce53b7bf9075de96c78fc6d8a570c96e48ea39444e3edba"],"liftA2State":["99110470e13a475f5968feb06acf7f4157667f28848b928bb79a66f76985369d"],"list":["07310ce985594d4b40df473d66f3a7b0dc6e245ce8fbd7f409ec02fcae961ce7"],"mapArray":["af09b9118c81903f2f1d1452ab9a2d8d2b8764115467c8f74a362e22d4b7b93a"],"maybeMonoid":["e720c445e6c1ca3efd534925c3d617ee11d62e96d321ec2a9ef78716edec1231"],"monoPair":["8dfd7bec63258df923500c9945740b2e6bef48120ef989c85ee27b7c4cc6e3c2"],"nil":["5488e660b1ca97664bafb058886a2dc02e182976fb244f56f4e8175fe1f7c68b"],"not":["eeb4c3a7f5a8dff2bf11d64864d39fafeadef96bd3d2cf8c6786b462c3e839db"],"pair":["b792651c6b6f38ee27bbc8bb471b4c9b9712ca89820625609c9d52a1a62bba77"],"parser":["d0c809ccb07f8a0e6242f19caf922734c00c5e382e247da40ed16dbc950fe899"],"predParser":["5b84e032adbb016f2b1fc5836936a0a4354b457c8373a97460098fea5366ca8f"],"pureState":["e9828be4d35ef15b9391b05c46830d82a6512506930e36273e82cc0466323e36"],"runParser":["d7f6ff73646c63539b4282a98cf9b432dcd5504900a3a1b5580d5055f25d197f"],"runState":["52f8cc7edcb587683bf83846d4afecb42444ba4ff38886c4e49308871eed0e11"],"snd":["27b0c6ec1fa2ae2b61809756a138cece632f47b2c46377065c32e81f0276ce8d"],"sndPair":["8b4e660d07a0f0fcd0b7b7f32d8d884a2b4480d75a8f5bd90e6411acae9ad1ae"],"state":["47e1c8e33c8646c744c513a752c4beda810f713176b426d2eee1a36ca7c94ba0"],"storeName":["8e9c28a29597c9fff7e8c520771e9d52c155a87a532cc3136291133f553f3851"],"stringMonoid":["019a523b2c4757f5949f06c9b961addcbad359c73945739ccc5f8ab606816da1"],"stringReduce":["68a148f7fc27644880c28c3fc48fc615e2cf0f52085ccc68f579962b9cfd0753"],"subtractInt":["c88909ec5c5c953982dae03632f48e6b5484168da1b3c2f822c212ed7f580b3c"],"sumMonoid":["7f9473b31145d179d7b24606e07d3d0d6e4e2de502f8d71440d6eea98714017f"],"testStateUsages":["f909477d250128aeed4e3996ea20bfd13b0036b28f1a380a5518ae30427d67bb"],"trafficLight":["29cfc3f9d88ccdfc1a42affc423abe2647a39b1aa0e95827ea0edb4975ee57b0"],"tree":["8b91340817fc53dd09a94c5ab008badb547d602917d0a7d07df405bf9335c02d"],"typePerson":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"typeState":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"typeThese":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"useEither":["569c11ec794434330f77e3e8782bd64a597a3a666159cb37ea4b9f41025a131b"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Cons":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Either":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"Green":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Ident":["eaea1fa57623e4b29172d982c3fb03d5048391668504c0129ae3081497d9d2f6"],"Just":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Leaf":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Left":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"List":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Maybe":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"MonoPair":["bb6f10ce0fead888d2f2d85defc08e21919ee06c01503a769b8b7286865ae920"],"Monoid":["1d49dac60d3b201147ddad2493dd67e98be499e801db0897f86f5de37666422b"],"Nil":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Nothing":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Pair":["19817d3943f7ef924625ccb655e5492adf0168f29238edec61a0310eb999bc2c"],"Parser":["56c450b3dadc5621e7fc54162257f50aa3b0091c22fba1efce0d97935d60484f"],"Person":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"Red":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Right":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"State":["63469d9155ce6dcd64bfab0e3e40ec9d43f54905c7f236e3a3c568636d145697"],"That":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"These":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"This":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"TrafficLight":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Tree":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Yellow":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json b/backends/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json deleted file mode 100644 index 1d941a0c..00000000 --- a/backends/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"either":["3ad39b95de874f41155ed120214a8b6bf4806de4724ca767a56e382fd41a918e"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"ident":["58a15454149ac2522fbabe8d0f02ebc337387a20ac6a1f69ec23695a25402d2e"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"list":["9efb85b4e31211f2d52625ff67322afde36666eaebb8916b410d74cba3908d1c"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"monoPair":["655b43c29357507b056375293896c57e6cfe54d76a1a2a40a4352cda0dac74b4"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"pair":["e10ed627d4bd04d627cf6a0be4a45cbc62edbf2e22abe313e708fc49733cd26f"],"parser":["7f7143df6b2f89939ff155b12af24a0a97bfe1484daf830c335b569ff4e716d5"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"state":["dcf1ef2c08c1633fa2856672b3c4c169090209b0b880640a7e1b26da8f5e59b6"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"trafficLight":["b26be775cce5d0c946bfe294e93487efced94cc3e6d078026fb7c41c169dba7d"],"tree":["539932969ffd5f80ded1860ba6f80bc14c5b81fc54c5a4d7fae6558e4ec5d726"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json b/backends/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json deleted file mode 100644 index 92de9233..00000000 --- a/backends/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["46cd0904b3b7e50e21f410f5d5a11eda60575cfa87a5e2416def629304edcc4f"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["f868615577ab7ce33c230ed080649c41c08adc20a5359d0309dffb82e72d2e14"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["65667097df805e67884fb5fddbb4fe3c73a45028aed63c51bdaa27ae8254a314"],"int":["ba787a0a0d3a4b0d6e37c94ec146f4570bb9d2a954c9861ffd633781be5874e3"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["e09bef28f58fa386b6f40b4c81d6ea840bf7c17636f017ff9a6ef83c09f96b49"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json b/backends/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json deleted file mode 100644 index 92a658be..00000000 --- a/backends/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["083684fc6b7cb4d27b88a7863f67479e53b48a5f7674c468eef04b853e9433f5"],"apState":["283f4fbab3788ba6117924600a3ba5230d332ee5a22eaf19d1f273af44ab534b"],"bindParser":["d66871ef7bedc9de45bcabdca4f971f70fee99a89a9a6a30b51ab3f3c30a66c9"],"bindState":["bfb2f0aee54fba387e9b258288b487744aab08dbf6907a7a013e6a6e4b0f872b"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["a14881a7387acb9039631e994483db537509e46ae9f42cab84b47e39335a202f"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["c84f48dee904724bc26d8bcf38865ecacf86c2bfd3bf6b04ccc3add9ca2b744e"],"execState":["6b733e012024944c0e9686148262783ba5b7b3c85c50156f795989958e36f1ad"],"failParser":["15f7b24a87ffe1b581fe010e63c8747761e05f2cf0ede98c4968a23a24f15901"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["8742d1ace60025e5284113e8ed502e6f23b6fae38f1d602a66e7e96f0908d69d"],"fmapState":["62dbcca5660c739a43007a754c944e828440235134c8b9ae54bf6531c4b84ecd"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["2e9a7bcf0300305fecec03664b6c2dc7f48619bb67454c4d7de247031aa2dccb"],"invertTreeTwice":["6ec6257fb10acf5e08a4efbbbbaf3e75b5bf452a8a07b960d7bf34334b300669"],"liftA2State":["089389e128e47062ee3731e811ae48a85e5dcc22b02fe402bcac0def8763eb80"],"list":["f0a2012a96469af95ec480d19ed6f69c027522d4a807527f9551ede6232ea9bd"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["ac695b5193a4664f86c249333e3adf61363deff8ae31f796eec3b70a350f107e"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["967935ec5c616814f8369b640795a2f0454670a50d6bc7f26768eeb38b9d427c"],"predParser":["de34ba51235c912fdd0e599ee18894c15b26d2b3c4e5f2472f373f927e4c7f28"],"pureState":["385d2ff93f84c1fc7796fc620b1f37ce540bb640a09ec00c97276f4abb0f14fc"],"runParser":["45d81aaff450c7b6734fc72895143d3261e39a66fde5c004bd383d54a76720c9"],"runState":["ddfcc8951fbb56683cd34c8f882ebf55b533106e5e36771594d269e01dd4ba37"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["71b57a7a7c7ddbbc7cc4a704933402abcd934022233149af984b8b6a09859c60"],"storeName":["14911c53fe5fe243a489a748ca66fbcb15318de65914310ab9fc33a7a4638265"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["66e1741d6b297340d8bb5dc3627797868309e951c7df851c76116a4cf7cfbc28"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["d363661cb79548b8233150614bc14002cbf49b996ec2ddbb834b2be9dd3fdf08"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json b/backends/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json deleted file mode 100644 index 478f5f98..00000000 --- a/backends/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["297e35cb517d517c2a24989483d6199a60db33ad8846dd26b97c839b2574fffd"],"apState":["54f3819144ac1b88d91d8c3a0a947619822f72e5aa9fd2052759809faa66e366"],"bindParser":["9d8762693b374bed27d371c55cd4595c7e86ebfa11b8ed17ecab776e1f27fa69"],"bindState":["cf847c5366c839b29b9339c0fa5f3f559c133d6b91371f2ff5f82539c9c3f181"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["7e4ef48720177021e3f48d4256d5848192e15a0bf94836ce774f6231213c33e4"],"execState":["82aefb756fb90bcfc41f85606376d57dcf9bf38fb92a9280a60287797ca495f9"],"failParser":["22bebbdde0911d354934c9b4886b6c2a12f27c2d2d0d5e3d7d2fb6aa0a0a07da"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["54d2b690ff720fdf3e7be4b773dc27014c6c9eb2deec2928cf70b70875b83757"],"fmapState":["e6f78e79bbaaf040c8208803711f63161ac54668044e0b77150e4e677f30f2d2"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["7872b1a76a424b43e388d3c7be328b1c8a4e535b0d1336a8e9627d1330f1407c"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["821d5e08fb08d5e515b5b82d910e3ed93896534838314a58e95ea780cfa0dac1"],"predParser":["6887ea3fb37cef9cfc0a6209836f61705971e69b9d2f724c1213421009f39c35"],"pureState":["77f4a6b4082798e873d900dc2207531f51337eba207eb2c9fccd944ab8cb90ee"],"runParser":["f95bd9b922e330b773141a8f680f5929c4abf3703259b12b0351efecfee03c42"],"runState":["7f9425beb1f577987d3ecfb740787862b0b50538de5d4e5e385d3966ca1c07fb"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["9f35b95d44c104db253fb00824ee8195d77c66de535ac379bf45524fbe412b11"],"storeName":["36db63e2d0b85d35ca8de30e390c7491fc1524eb010c46c327fa6d5ff06524c1"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["982c95f58d970572fc5eeffc6f5eea023173d5a6ddabec6521305bca1bc6db15"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["ae433b51c033cb923d998da0031fa93093860fde722ce633f82e2038a01406ac"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["32089fe4191be388f2dc157a799cebd2b45e85cea44bc3c2e9aed97015d68ce3"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json b/backends/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json deleted file mode 100644 index 7a215db7..00000000 --- a/backends/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["ed50f7f6cdc04f714265445332416837baf7b6622570eadc7a53b016fcbd562a"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["bd40bf8c67991238da566ac940e3d717539c2e1f68ecc518001092b0b54dbac7"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["079a166be166a599c628782ad851e4ac119cc6a19195d4660ac3c27c077df01c"],"int":["450f59bd44aa97758f440aabf38922a6f94517813e49078f6e60f573f21221db"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["e09bef28f58fa386b6f40b4c81d6ea840bf7c17636f017ff9a6ef83c09f96b49"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json b/backends/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json deleted file mode 100644 index 52d8f2cc..00000000 --- a/backends/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["cabc3adb3fd00d7ee7a630ff7e662a382985db903634e339265f7393c02d1a71"],"apState":["474c9e5812fc03307729b41cbdc5e4df39e02b93a241cffea9fc63f18b5906b0"],"bindParser":["e558af66bf0ddda0d31d22f065145d3b18c007b7da8be941439f3fe0a0b5cb9f"],"bindState":["94fea6cada757975ce1882a5a722387985171e5c02b054e69bc59d3f091cac3c"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["92c3ddb2e35f770b549f3d9dbef487f922cfa365ecdf26de5d956c27fd3262fb"],"execState":["50b79824541ff08d2c9be12836fa6212320e520c549d691a281d85947fc37add"],"failParser":["9f2fcc268d31d3c2a466c8e3ad553fe625930103d826df70747e5c6280fd7098"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["a4dd49f8f7146a432fd1b09c2f746b7239f722cb04c4e279ac6f63c74d3b933a"],"fmapState":["633aca8016215dccd72b7f0b399186d332aa9e4a055cbb5e852a4c88f841f48c"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["9742c8438dc255d6533367183aa89829253d339f9e103b9f7ff169815505fab0"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["f8b9f1ccfdb0efdc548c3a5a9c31074268cb38569a2518882874ad5376c01c7c"],"predParser":["96c65fa8156863c92273f3f15d41f5345e372e7d4dcc06996dae9472456df8ee"],"pureState":["eda0b66dbe5f9ebc4d756754e33f18d3e55c535e90d2de6b254d36e263096ee4"],"runParser":["cef56401f54aaac76d10bbdb61a461edbc84126607c996a018d540a98d21c271"],"runState":["b3bfa579d66dc2db77126258564e9d52eb35a5c77aed5a6c390327e5f23e3a44"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["b2ac90987336a46b8e305bc7e8d6ba79f12a0cc03008e3b8ffb54d2f954e37c3"],"storeName":["9ed928277b23cf65eb8b6b8dc4737cd168608a8bcd13a7e650512d17467c021e"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["52f37998002585c589d395e7f619b55a786a10a44cec7aed09eeb22bce3fe98a"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["6d2eb1958a3871f2688149259726370d6add5493a840c0848a2606c8d68cce3e"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["a0849d808771ff392b06f343f47848fb8340a323f682b6955f4a07cd3012e3bc"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json b/backends/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json deleted file mode 100644 index ce99f973..00000000 --- a/backends/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["46cd0904b3b7e50e21f410f5d5a11eda60575cfa87a5e2416def629304edcc4f"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["f868615577ab7ce33c230ed080649c41c08adc20a5359d0309dffb82e72d2e14"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["65667097df805e67884fb5fddbb4fe3c73a45028aed63c51bdaa27ae8254a314"],"int":["ba787a0a0d3a4b0d6e37c94ec146f4570bb9d2a954c9861ffd633781be5874e3"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["8afa91043e48beecbd5a72455026cb31b80c26092ef34edbd4be9fa9aebfdfa7"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json b/backends/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json deleted file mode 100644 index dac79196..00000000 --- a/backends/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["5515afaf798dd91ecbfc42b798a0c4670139b6dd45b238f05958e6cb26637e95"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json b/backends/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json deleted file mode 100644 index aafb314b..00000000 --- a/backends/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["cabc3adb3fd00d7ee7a630ff7e662a382985db903634e339265f7393c02d1a71"],"apState":["474c9e5812fc03307729b41cbdc5e4df39e02b93a241cffea9fc63f18b5906b0"],"bindParser":["e558af66bf0ddda0d31d22f065145d3b18c007b7da8be941439f3fe0a0b5cb9f"],"bindState":["94fea6cada757975ce1882a5a722387985171e5c02b054e69bc59d3f091cac3c"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["92c3ddb2e35f770b549f3d9dbef487f922cfa365ecdf26de5d956c27fd3262fb"],"execState":["50b79824541ff08d2c9be12836fa6212320e520c549d691a281d85947fc37add"],"failParser":["9f2fcc268d31d3c2a466c8e3ad553fe625930103d826df70747e5c6280fd7098"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["a4dd49f8f7146a432fd1b09c2f746b7239f722cb04c4e279ac6f63c74d3b933a"],"fmapState":["633aca8016215dccd72b7f0b399186d332aa9e4a055cbb5e852a4c88f841f48c"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["9742c8438dc255d6533367183aa89829253d339f9e103b9f7ff169815505fab0"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["f8b9f1ccfdb0efdc548c3a5a9c31074268cb38569a2518882874ad5376c01c7c"],"predParser":["96c65fa8156863c92273f3f15d41f5345e372e7d4dcc06996dae9472456df8ee"],"pureState":["eda0b66dbe5f9ebc4d756754e33f18d3e55c535e90d2de6b254d36e263096ee4"],"runParser":["cef56401f54aaac76d10bbdb61a461edbc84126607c996a018d540a98d21c271"],"runState":["b3bfa579d66dc2db77126258564e9d52eb35a5c77aed5a6c390327e5f23e3a44"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["b2ac90987336a46b8e305bc7e8d6ba79f12a0cc03008e3b8ffb54d2f954e37c3"],"storeName":["9ed928277b23cf65eb8b6b8dc4737cd168608a8bcd13a7e650512d17467c021e"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["52f37998002585c589d395e7f619b55a786a10a44cec7aed09eeb22bce3fe98a"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["6d2eb1958a3871f2688149259726370d6add5493a840c0848a2606c8d68cce3e"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["a0849d808771ff392b06f343f47848fb8340a323f682b6955f4a07cd3012e3bc"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json b/backends/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json deleted file mode 100644 index 0d504131..00000000 --- a/backends/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["32e3387df3b4b18ebeda0afca60225a154a48371d164789c956e4c5a49b17bdc"],"aRecord":["9112acc2cdf642f66a0a283a198207635beec1c7f04001b4d6e43f470031cfd1"],"addInt":["4772cc431963e0a86b168b003ea37e8d0fab7bda90fd1cc722645ac9e210cf23"],"and":["122ccf19f546518e39e0adbe9be33929a6c9314d487d5cb495286a28af106c38"],"anyChar":["b5f6acfcc3a056c960f31f84e6789d572b106e722f895fae747a4b87136fd273"],"apState":["d6e99bee2544b969d9d369c5a5f082d81e4740aa300a22f0946c542653691c84"],"bindParser":["47edb93a6b0b4a3c01d68a7fd52f08442d7289803237b5c2a8f200d448454005"],"bindState":["1eb908357b8e8223a981269e2adb22dc10d43ea0b201fab400c394014fd536c8"],"compose":["8a845c3ef5616a89a8927c68dc62a1908c326c5ede7add452d788ba0b7de05a4","bf3dc20eeb6614cd151e26c4aa7e2716ae7cb8f1cae69d793396ab5efa8fb273"],"cons":["3cad04611eaf137d0ad23f51e61260ff5120f20295606d917962ed7300bbcb58"],"const":["fec31c15ea368a9fbb4fe5ef038c8a37269530fe1117eba095731c79bd6a9635"],"constFalse":["0f58a12bda085f26872f0cbe6754222871855e08cd28d1444b6a12be97dd81ff"],"constTrue":["b12fb6d73184c100567007de6594066c2098ea8ad2be5f96a74bc6db455e4a16"],"either":["501147426d42ccfebbbb76d67bb16086184edd5bfe6715a8fd90f7ae59a59d71"],"eq":["c503c8739f0c22ddbb505011251b06c837d302a3397d6a901a2fad387eeb6d90"],"eqTen":["1990686d247f39d9954099a66811f6273809bb1a0ce42fe6e9894dd9de2fbd81"],"evalState":["6166462ac4206dfe75a6067bd36a2fa7811849804dbf843d404ba5047e370dfc"],"execState":["fc0d19e23f1c0784011960197dac06e0c08856a0e2e1582cb9b7865dcaca8177"],"failParser":["36b449f51c55b838bde50859be97322017e3c99bbfc484f7abf0b6e4d2c9a6bb"],"fmapMaybe":["fe5ed307a7ce88b1006e1f56dd8ba7e8d0db89e9c2fd1a9b82906102c2091657"],"fmapParser":["a8dc8a285cdb5ecfac122b77fb870d1ba454b06155606fc12d53b2145d481515"],"fmapState":["f618ae22fd8c9268fcfcc36c1a7e067f158979caaad1d531458150dadf244e6f"],"fst":["0932ee5bcebd5191c6ee76c6b3e16028f153be8f738023debdbba1a54aba26f0"],"fstPair":["57c8234c457d2b3a96168827901766394143904b2bfe1378cbeff671ff918464"],"id":["b65915cd81a715f5a614ca62c213fa670c869536f9a5596829fbb93e1b763d74"],"ident":["301583b4517c9de80b2c246026effc4e25c495d6107b4e640573560c6e851471"],"incrementInt":["654cec4400556acc4bd90bfacd28d49285a160be11802053dee3824b20d44590"],"int":["6ee873255b8121d6b3a82032eba1729dada717a88f4287c8d0be35395e3f1b0d"],"invertTree":["fc7e18d95ab90baafbe46cc5d146b2b4411bff5d0c7e6fb65845aa776d2ec23b"],"invertTreeTwice":["e6d841629e65d3a67f92dd3a05933e5564a46339ebce468abc844038a509f32f"],"liftA2State":["d3603a9866b9c80c4f75b2c1497f0f278bdec65d8da95541e1db3eb3d65b62f7"],"list":["3d426d272aa7c704c1b2ba3a0af626150ea51d1a2e43afca1edf3174e9b57d35"],"mapArray":["cb4124d901b6b4354db3cba0a747dfaa1d64d239b67149e765d7be8e0e63fae3"],"maybeMonoid":["3373d02343dd56a5ec29c9870643537b6bf636262c0a2ad1332e8c87285d9bfb"],"monoPair":["59ac207a8b04136bd54131b331385ce2c2cad80a9fff3541172a589d9d70dbfa"],"nil":["ab01638d0d4d4acd5f7e410d67d62635632128c47f861e8d1d6b3a40579d562f"],"not":["b0ae419acf10e7f7e6e3c7787a28ea08f73d442ac66107395b021e92bdf67590"],"pair":["3cca75d531ce66164655c3ff1778d81369c88ce7832322a4dd84d30c260d0538"],"parser":["2bc4d8d49e71ae2610cda34212ea2eded7aa843c571964fcc91b3ab4e1465adb"],"predParser":["7879f5e691cf64e7dca63d3ce4aa70de83e5c8fe81ff3f68b7936719ec55535a"],"pureState":["78e11f8742dc54c377915e272959439eb47ade103e053e02fcc5b5675e677587"],"runParser":["66f09524c3c60936d263f68393670689a9bb6709a8c238dbee769f81aeec0479"],"runState":["715e51086ffcb881f2d9a6eb66bf72d9d6017e39119a1cfe97d8f9fc14f8c06c"],"snd":["4ea0e511225f23fa2bd1b883405a8fbdb65aebb646bd3019d95ef94e7e4ba392"],"sndPair":["78abe012b8267506338e52d3fc2f7a554605647209da2c11f6c25755ab5db10f"],"state":["555e241ebdbd568940258bb94c2a18f28e6b62d4e8e31ff3066179b4cfec2ebf"],"storeName":["461a93b6f7fa70e49b3774f728e7332f1cfece99c66f0d75949bfadac00f1eab"],"stringMonoid":["61c95801905716d6cf2cece27014df746b7fc05c6c5ae90a1e05d98690ecc267"],"stringReduce":["fc432dde4c87422e85a6585ab669bfd2aa69eb2fae2e4017252f8fb712412af8"],"subtractInt":["8a17f7af7659c6de550e515c773294a9d1e22d705e94a0508ca3d6f3942b773a"],"sumMonoid":["1ea69033874f1e075b5c89d0d893953a09992b467d5dbb33dc26b5e1e19781a6"],"testStateUsages":["e5d73bbc3516962a12082c109e7466128d3460714e3da092fd0542f71aed5fdc"],"trafficLight":["cc4b8ba5bf82c9c52cdfad3f3ec24ca40c3f8a9c3b9b48d9ace366f50b48977a"],"tree":["4b6d3ab35108928f8c9ccf27045804de250c1c886883158352277a406d65f627"],"typePerson":["8eb8d8583595006f73b4b536962f4826fcf1ded91cd944a384b1fe772aaf8a16"],"typeState":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"typeThese":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"useEither":["9c553da783f2164588e81b4aea85c5aa953801d4d20c085ce0647d4ebdf43a21"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Cons":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Either":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"Green":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Ident":["de460e6d1f8c8114b101dae644aa659407c9f8b401a38bef23fd1d33f5b00246"],"Just":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"Leaf":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Left":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"List":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Maybe":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"MonoPair":["6349e9b3fb39d7fb47c8e5ae3eb966b584c0012d47a4a173c64dca37e2dc6348"],"Monoid":["8eae267c0cdbeb23a5ee80312d6a960cd80efc7bc573a27696f6193fc20b98b3"],"Nil":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Nothing":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"Pair":["ca3b8c870829ceba8372c653f8d78180a1d160823949faee41697fab90db6e80"],"Parser":["e872afb38fc0dfc021403a8787cd47423134dc707008edc1bc7f4feeb44f8a9c"],"Person":["8eb8d8583595006f73b4b536962f4826fcf1ded91cd944a384b1fe772aaf8a16"],"Red":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Right":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"State":["301e34ef7ef6b49db554874e444217a5da6403b8dcbd563a02502bfe86e5f7f4"],"That":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"These":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"This":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"TrafficLight":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Tree":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Yellow":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json b/backends/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json deleted file mode 100644 index f975f036..00000000 --- a/backends/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["297e35cb517d517c2a24989483d6199a60db33ad8846dd26b97c839b2574fffd"],"apState":["54f3819144ac1b88d91d8c3a0a947619822f72e5aa9fd2052759809faa66e366"],"bindParser":["9d8762693b374bed27d371c55cd4595c7e86ebfa11b8ed17ecab776e1f27fa69"],"bindState":["cf847c5366c839b29b9339c0fa5f3f559c133d6b91371f2ff5f82539c9c3f181"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["7e4ef48720177021e3f48d4256d5848192e15a0bf94836ce774f6231213c33e4"],"execState":["82aefb756fb90bcfc41f85606376d57dcf9bf38fb92a9280a60287797ca495f9"],"failParser":["22bebbdde0911d354934c9b4886b6c2a12f27c2d2d0d5e3d7d2fb6aa0a0a07da"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["54d2b690ff720fdf3e7be4b773dc27014c6c9eb2deec2928cf70b70875b83757"],"fmapState":["e6f78e79bbaaf040c8208803711f63161ac54668044e0b77150e4e677f30f2d2"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["7872b1a76a424b43e388d3c7be328b1c8a4e535b0d1336a8e9627d1330f1407c"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["821d5e08fb08d5e515b5b82d910e3ed93896534838314a58e95ea780cfa0dac1"],"predParser":["6887ea3fb37cef9cfc0a6209836f61705971e69b9d2f724c1213421009f39c35"],"pureState":["77f4a6b4082798e873d900dc2207531f51337eba207eb2c9fccd944ab8cb90ee"],"runParser":["f95bd9b922e330b773141a8f680f5929c4abf3703259b12b0351efecfee03c42"],"runState":["7f9425beb1f577987d3ecfb740787862b0b50538de5d4e5e385d3966ca1c07fb"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["9f35b95d44c104db253fb00824ee8195d77c66de535ac379bf45524fbe412b11"],"storeName":["36db63e2d0b85d35ca8de30e390c7491fc1524eb010c46c327fa6d5ff06524c1"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["982c95f58d970572fc5eeffc6f5eea023173d5a6ddabec6521305bca1bc6db15"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["ae433b51c033cb923d998da0031fa93093860fde722ce633f82e2038a01406ac"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["32089fe4191be388f2dc157a799cebd2b45e85cea44bc3c2e9aed97015d68ce3"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json b/backends/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json deleted file mode 100644 index ffe274ab..00000000 --- a/backends/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["35266e63ec46d7f16f410b90b353243cf6673d264e279a5db04bde1a54eeea92"],"apState":["9905c9b5f8072e86ab7fef59e876bcbc6f195c7532e6a381e145220c6ed317f1"],"bindParser":["b594c371f07dfe022baaeaa61088e3d7204a6c62e53ca9946ee1f9f4a499fc46"],"bindState":["ce99f0b83532da6261f39cf852a6524a255738254cf4c4b0ba40792f823dadbe"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["63a7a1a4337e0b36578d4fc675820b547be60672e12c06e6bd160aeb1e5dee41"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["0666576cfc3df7a65e79c1422c8f04b403c3b02c65ec95c168a693c19a9ee4d4"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["7d6feac67a11fa3a49d4511dca8e196ff091b4f1ffe8cedb27f7d7203245f13d"],"fmapParser":["c2cbd4d6a53c14f388edd5f2329c5771a04fe13a1ad26659da9b1f967df7fcb7"],"fmapState":["f2ac935429ee25923bf5212b48e2ddd3a03725bc596cd744e5ed1d69f29ddd74"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["97a41678b3bf32d877aaf23404f5cb09758e80b2856815222676ed36d33bc550"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["c010847a1c4fa1a43a04c2a27e69ce335146f1ebd61b8977d40a8c8deb545775"],"invertTreeTwice":["462e15d015da51e06785e2b17894809a26923a89a059eff50c2a1af2903fc0e8"],"liftA2State":["6b649dc6135514c20eca1745baf22ecb1b79ee56f672ad6f3affe3bf6860bafa"],"list":["3c14cea5ebbad925c63d1612369cdd840498105d9661d62edc55fd6f86b8ba74"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["c3fca83349cb5f786938fee7bf972b0b59776c150f3c73240e856fb595b32309"],"monoPair":["c5459a5d4896dfaf5d2c3d790fabeb4d2cb11a261dd3177365e6d5daeb0b2b82"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["5acc7f1fdb40e0cd3c652319edb3daa9649d39f5e057ea0aa60474bb2531509a"],"parser":["58c3caf3327c52048ccc8de05529d9a4a63b7c987cf06172305b247c0fe353d9"],"predParser":["750a6cdd2dc1f80f181e7d2a1d421bcbbb9956f50139e93b810da3cd0f93a023"],"pureState":["9c856307f18254ea5ebe0c7b155483e489080d35b12b8a65ded3d0888ba9016a"],"runParser":["397fa1cc7e750a73ff2e7c9d4bbd3b4accb2dbf3f6dcbd1cab86c0bbecc6ae9c"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["49d3792687fb9d010133cedee17453379e3109bf1b0252679e8d9492b21e0498"],"storeName":["2cfe0854f7983f78c262a2e9558b93e8de49e9b70b6f5766b3bc011d944ebf78"],"stringMonoid":["231ce2b454ffd520ee694022c7be72b432999bd49fb4f2809b2c6118ceca9545"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["fbb04dc15026fb41234d88fe94c661e7dd179b56879546f90c56bb76578e1df6"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["74393de28f2b32c60b82bb3439848e39c6ff7b874e732087893f425d2f21846b"],"tree":["6086e8fd70a725ba6dd51f4ecc531e87eb8391458aa9f641ad75a91650f477ce"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json b/backends/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json deleted file mode 100644 index 8e20a0c2..00000000 --- a/backends/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["2d8951923af0fe26996f48ba2ae9ccb2bd2abecb95a298cd60b3b1187017b96d"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json b/backends/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json deleted file mode 100644 index b59e3572..00000000 --- a/backends/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["9f8ecfb902d9606cb01a814b8d8bb0e9ebd9afb28b5d4c725846761f42567ef5"],"apState":["1d68cbed58eb17ed35708076893319b31291c909fa44ea0062a1680927725229"],"bindParser":["83c832b14532ecd033e36895a44c806b12eeab164a4139ff5eae3cfedf6e3130"],"bindState":["24b5d68e48b2ea9e4747c6a1aae092ad3bed564e19826a5171da7023d2cc40d7"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["9aabe059a7860bda9c3ea4333fcc72ec16bc8ac7cb834a0273505cf826ea2083"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["e6fb1010149ecc029d0a27c9e9043d3c7eec2e51e4d8278381a42212d62a856b"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["51fa29855f8c5c302ca63b7677bd7e4d0cfd7e9f0ace126011254ce26493fcae"],"execState":["7165d7ef023009f92cfe5e4640c0591dcd14c296404694fee2ff0866d9446999"],"failParser":["8d4cda3c93498584a19ecf0c03f5c1400fa270aa523724b6f4f56e3cd188f726"],"fmapMaybe":["b6a1213dee74d17f8c0cb7ec8cf7743f899d08989a7a294b38ec5f6f72ec87bd"],"fmapParser":["0843ca134a7637579eaf6769fae3fd56fd4a3db80b8e55db84733b86f3340868"],"fmapState":["58f6d000f9bc8ed24b9ea30da318cba9fcef1c6bd1787956028c66e33db0bb95"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["b8fbb39f50cfbcc44e457aa902c8f412fc182d6c5970e30cda69f2e9e3d511b3"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["0e40f97479498b172a1a78cd815984462f3d93fd7ece7840b61cdbdd0ee292c0"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["b1b1e5da7e2fcf29e2506552941740a87bf7aa1228747d015b78c8f4b29c4448"],"invertTreeTwice":["9c9519db71acf81d8edaee24f9c5b2054b839547868a50a1858a05e45debffac"],"liftA2State":["cf939392c57e54f48a2507e4c26378211bef4fe52dad56b9fc1cd3c7990f9a6b"],"list":["353cb03b02df1b560585a0da7d93fa10f7da710e3cb1453756c026c7e7343da0"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["e71fa9c8d1b80e77975794df26daf91fc183b4ea8e49d7cafba256385cc3dfea"],"monoPair":["f581cf0196c3212802b7b8620fb5a1bd7117b4b7c34a1594cfec80baa4a2efcd"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["3c1c9c70a3db62c7a31b50bffedf06b48396c1245105ee0a47e5bc5f5d5525e8"],"parser":["163c156f44d0e7f28d0742c19ef904c11d71cdd0602326940208959d60cfc37e"],"predParser":["4be1c8cba1622ff2640f0924153e5d986f7bd3626b9ef5100ff7d720aa23ea2b"],"pureState":["644628e25ade34269f484799ea7485bfd89df5d3c5b137d9b140be033341bb74"],"runParser":["0d38a5d84a2665b1cafe5d9483126ac872668e5626de65242bc746d6f7a7752f"],"runState":["9da6a20626dfbfeca6dfb7f36163c57011cf4792688796bbbab6db5e04251519"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["f1d8ff509761d7db377c28478c094ba8474a8482cd44a2b9eb94f1756dd3726e"],"state":["5ab94d165b820798534d5232b18c99ad344f71ac99688e1c0f70a4d62bf88ee7"],"storeName":["7878ae674578af5904a6b18572825e9a311aa95c49162c2a486f61de6a8ad9f2"],"stringMonoid":["69a03497a06eeaa289f2081bdbc6a325ae06886e18c9826cec3e717556deb82f"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["8fd08ed6d8a70e4e9784e028a862d605023cf183ce7b3fb9ee685fd27ad53ac6"],"testStateUsages":["84e854bf6edbc8984260877bb495a5c7091aa48621798bb464f3a80b72c8ca55"],"trafficLight":["86cc854bdb7bf9641b19e5c6f27bfa916f00f8c881fb100cc05660b656a349e5"],"tree":["a8cb80e978057cc9386b6fd569453824be23087b695f774e7a79a0ad025d92c8"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json b/backends/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json deleted file mode 100644 index 3bae2292..00000000 --- a/backends/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json b/backends/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json deleted file mode 100644 index 80a0edbe..00000000 --- a/backends/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json b/backends/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json deleted file mode 100644 index c2a346c9..00000000 --- a/backends/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["fed744690133c39eb9deeaaed372ec71873fd5254cac68a9b5412f9ea55cc562"],"aRecord":["052c2b3636065acfa936448c7238d6ff8d16ab08476fd816ec501d764ba6fe4f"],"addInt":["3ef93551066cafeb1d829466fd2dc6938571a5305487ef532de578b4f123854a"],"and":["308a904cb48bf5f1785e638b0b3f6596951e0ed30c2e849d6018a984a6050f60"],"anyChar":["4b90a9db9ed1e661233c549b67af42b5c755c041dd2879d28b9565d389297308"],"apState":["9018027dd79f09e2d69245a9b1f4eb50ddfd6770b1b7797dc9939293f759aa08"],"bindParser":["48a08149bf69b2e46d7475c99a53dc2b365925f7835e46f80c761f4da92df0a6"],"bindState":["ec4e1ed69dcae59734c825ef17307644ac08ce874bc715e936c50ad75211fa88"],"compose":["12166a16e2cbb289c2512b46357b34111d0afa4d2a8087e20b9687eeb0490a0b","bd71034cf006e85b5575763d5ea20eef506825c343b023e755efeacecf499e43"],"cons":["58cb7968d7e83a89016adb0672bea619731191928aae2db602e0507403efcd61"],"const":["9387a07499d50491fd082db3e66f8ffdea1c4189c82d380d6dc04c4349208e3b"],"constFalse":["f07f8ab6aa0503844f1878bc37848080af4a67e7353b53ab93b0f85849df8b88"],"constTrue":["f4112d90d8c27ae9015f1ee71c276168e137d0e5377a027081f971d10548661d"],"either":["6a01d802e0efe804d6158293189ea3f7ac540c1bc45e3f4dd3bfc0e694bdfe85"],"eitherAp":["31e1c8000ed68042ec3b3ecd14678486805cff96c354f43928c4ec7095c90959"],"eitherFmap":["c304ae93c70ba3cf64514c247e8d8ea52e0b7120f554a68d147562554ef29061"],"eitherPure":["3ebb49763d68268fbea25eaf6c18a115e99a8967e2dfc87037c5743a295c7905"],"eq":["85abca156c53397532609979d779ab160d68d6ad1612865b59af40f73ce4e887"],"eqTen":["804e87d2173c6c4b9368b95d441b0be3f9df46c9967f351066b82714adfdcde8"],"evalState":["37bb788a914d7c07252f034c327b3e2417ed62ab73700a2b20d0fad0278e3803"],"execState":["496d291d4d81d9c0dd63569a3cb5ef5db2bfd6d2234603a77b56eaeb314be70d"],"failParser":["ced41144d00431cb31ba72bf73aa6a9b1d67c42a4682bf3dbe62131447174a0f"],"fmapMaybe":["fd411c194d0c04498769f3effde3dc4856982a557335f2b354abd04d8e724dd9"],"fmapParser":["bb560587760531c3009a6dc52b153a18ead7b7b1ce5f4cfc773d56c91b5649a4"],"fmapState":["c4da1bf839d1fe79e30e3afa21293d0184a407f75ba5755581b487d53b6a54d6"],"fst":["048b062907abe8c0164c07000a90e2a8983ebaac1db93bc4d6c9353b57648515"],"fstPair":["1c8ceee1c36b78304cf8c8e1166a6e532927bc7ffba6c06fd66073922a4a256c"],"id":["9fc53499ba8adf4c325d7505c5a7c5836af8d45cb23e5e31624e28b9782e9ff1"],"incrementInt":["ecf3e463244841f5fbd0b8852cd1a500bf307a97f1198e7896ebd0fc5a41ac5d"],"int":["a4973324cdf38f405014214b19e112b32cda213ec707036b15ddff0d407ecb4a"],"invertTree":["0ea1834b5ad4fabd6dcf1ce8b61f3eab206e3ccaeb8fc615222d359fdd24a2c5"],"invertTreeTwice":["5bc3190d057e120329c5a9ab109993ddebed605fe73b4d9e59a378af242ce804"],"liftA2State":["5c2e5dff07af6a0715b9db00b4c93f6c733311d02c1936991eff6739f240f639"],"mapArray":["ca307ea04ae021bd3018ec19ceb14f425e6015bb5a586a20aa76b66a2764b1e6"],"maybeMonoid":["19ae0e05aa64bf5145058e08b508602b1d8fa9eb235651428d55c9b35966943d"],"nil":["3a86e9a8fffed70a7c4fdfcccd6a4126805b92cc68b83052087483e24f122869"],"not":["5c4b4a2cb55448c0a1359f96666bde45087bb232b436739dd54bde71d0068a8e"],"predParser":["a982e3f0d8d4750e90366a9442724482206fce622cf796464b0a59539a71c4fc"],"pureState":["f0ca5dff527b6b0017d060027c5f918287eed7e875110dd9165ddfedc8ac6cca"],"runParser":["2f7039c6ca426fba40ba8fa3c433b7fa70037c3ee2ee079f17e5100bdfe35f46"],"runState":["fd5311967def1abdf7fea307f165a1b8478b9624f4b78a18052f82a468d23301"],"snd":["3eb8d68d2c34de918b06b5bb9199953150d0fd7dabeb58f6b679c74362893b0b"],"sndPair":["0e342b303b4127c9df462d6cdd1361ee2f79797b81680afe018f9fa11faeb5dc"],"storeName":["8b703562918ccd5f0d0150f911c2deb381f6107736139b2c0478669ebc69949f"],"stringMonoid":["f0202326f9b8b65c906952d84ff57973cbf3feb0b0df96c8d44994ce3a9f8218"],"stringReduce":["d5029621929817a78e970bbf59f56af6e60911ac1c748d77ca08cfa18af52a86"],"subtractInt":["2bca4c46f1ae350ded077cb717b239ceca4301bd1e30f7534e368293f9f60836"],"sumMonoid":["82e70990b8aa56a94f74e978acf5430e1f41b63fec242035d0c10c275beae817"],"testStateUsages":["36ac78adb85711f877650f387afcf3d3e776729a5efd04d0f6c6e95fe21b3505"],"typePerson":["ce6e217349280fb2d7870186eeb5b3deac1597e0b5d04ef83c9d3ae10be2a928"],"typeState":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"typeThese":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"useEither":["a8e5f5d25c2bc388369c2f2ef79534e943084b5808e65821f27c3ca310f41ad3"]},"projectModules":{},"projectTypes":{"Branch":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Cons":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Either":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"Green":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Ident":["e895a099ce4c950b4e836dbaf22dc4d5a697bf15fee777719b1856aedd1d4b05"],"Just":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"Leaf":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Left":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"List":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Maybe":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"MonoPair":["d00356ba9544f564a9fba9996d1de5880fb1acfec335567f71efc127bd84f3d0"],"Monoid":["b5835570bca0b7e2aa75e190417bc6453d5fdecd26027fd29dfe77f7c65ee09e"],"Nil":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Nothing":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"Pair":["13db6dd3fab20132a3d9705f49212f5687b8fd4f33f57a5a5e7a6cc2e72feb85"],"Parser":["9ca802dfb7eeb599865cb5ea4211b465f4f838c7ca3fa9fd06a53a4a03188329"],"Person":["ce6e217349280fb2d7870186eeb5b3deac1597e0b5d04ef83c9d3ae10be2a928"],"Red":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Right":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"State":["968c8d82bd23200c3aa54ff82cfc426564719275869b9665ca851ca79274df84"],"That":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"These":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"This":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"TrafficLight":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Tree":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Yellow":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"]},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json b/backends/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json deleted file mode 100644 index 7ab22250..00000000 --- a/backends/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["3cc9a8f984a113b123d9500bc235b36c980ca2bd6d99e518a5ac2c5bfeab6f42"],"aRecord":["ee18a974bff1da16a4e4f1de2f3daf34266c21f70561766222e6154f3b9a5df6"],"addInt":["564fe022edea28ec30688de5b24d419bd1479c5e3efa6386314d976d7918f0fa"],"and":["983bdbd686db48a88339a2c37e1a64edf93d1f5bc1b783925509a0cfafb48612"],"anyChar":["f0b87f25ab2551a64cf76870a40203505a858140aba720a55697057d9e18b58c"],"apState":["754292fb4d010d5b9f81822f8cff5458c8e81b7e56d382bcd74b8465a742545f"],"bindParser":["969185e087e8a84264ca852df1b9a720d3bbea221632457f7abd81c7c5eef84b"],"bindState":["8c4a645c439a13c91236f4ab2bf1a16dba612898cb1b89b1ffedbac1c726cf47"],"compose":["9802567a9ddb3b25c6979f283601141a5c1a0b1a8eadf41ce64ab871f7b9d48c","f1a84537e946c764c38552185b442e3ed6853e6cd0139bc300df02594b9ebd92"],"cons":["8a7c26e1bb9f471c8cc88717546abbc055089224657d2fb96d98b9deecba3d3b"],"const":["40619e2c9bfa20111dcd95633cb1b78914d3c49d5ab485d12df1c3700a4ba5fc"],"constFalse":["f5e106addba3244db724d4674bff67ffe518c60c521d67d9f950f67b21bb8082"],"constTrue":["c51c58b3d2375908fd12628ba1e4bc146f2cfb3371625953490d97bbfdf1eba8"],"either":["14afa550ce281e9196044cb2ea107e982fa7848c12a9d13067d6ad04fe153bc3"],"eq":["98127c7994d0dc20e87dee10d0864070cc94ee7d3fc9909347194af244fcff11"],"eqTen":["7dff3edf448b2fac3908bcc5d77774469cb43d404754425462589a175aa57e7f"],"evalState":["6886a75a52fd35e96208ddd8db13c50412cd15c0911e9c13d5e16e06c33e9566"],"execState":["601b7dffe29ac215ce16d61eeb9b631448d4c89fa8639b9bb95ce2c76ddeb788"],"failParser":["02ccbe26109935d1fd1d31351428a7cb49957da79b4eac4d56f9dd069ad3b754"],"fmapMaybe":["acaa54ecf365cb128ab0d91bdeb39e2d6720567be884f62a80600fb73f8fbf71"],"fmapParser":["4f33514798d927b8f9cc0a3a48fdcc997b09fac57a711401790de3cec54626e2"],"fmapState":["93f29ab687f13b74d58a17d9e49e071d272945976bebbda90d57d84e4c203460"],"fst":["043df458ea1c0e2e55c92babc57f768b2366e531b5d881e2e89db9ef2f5e4172"],"fstPair":["a3018207d295b542c3d276608889e1a08c5de0283103e6f02432b9cef4bbcf4c"],"id":["177e7ddb0df8237a4e9b0376761fc0c74b397052e21fc43b7ef508cc18af7e80"],"ident":["61214b4316572596495924e7904c6e5724bf7620bc5e25a17a99040101579b11"],"incrementInt":["894e262a84ab339a2fbc5fd5eb3b0d03e8dcf91ba1e2c69b6d4592bcf07b7b2b"],"int":["ba3dbaa24506c0d4f9e20e6b8a53ca5ae02ed9590683278aef2d40455da6dd65"],"invertTree":["d2c52690c3ff11e4b531fa96cd26643fa9ff89d511ef8e30c247ab7c7f058878"],"invertTreeTwice":["9be11ab8d3e49acd919207699fefa9dfb0efe8f755f9728ee00d7e8dd8b411f1"],"liftA2State":["52190c14154da761fb420427bbcdc8cbcee9a4fdfd874781f12287498e7c49b8"],"list":["8393f59b10de70da08f696635167da6df4c790baaf10f61b43c739b21c55a66a"],"mapArray":["bf58fc7601c3510031b063cbe9ae857207e6ed785933f23b24d849317e3a51d0"],"maybeMonoid":["478068ac81705ccf3bb2cc7d0422a11104a05dfea430d9595a82ea1ff79fd282"],"monoPair":["16531f5c137dcd9f7db9ceeabfcc635251e0c096e39c810bbaad568226048d33"],"nil":["d9e543ea3b3a2761b2292855f666f32afc703a24ea1152894088f01578f5893a"],"not":["b5825daf1abb6f94bbc495dab53be4fbd9eb8010eb43b476464acb4cb561fac1"],"pair":["036537315507ac137c3eb206737afaa2180b02e16fc9ee017f88e4c04f218119"],"parser":["0a727ff2218cbd8385960e8f0848ac955ee90e7938b5ed886bb72711feea86d9"],"predParser":["553978e21e6426677ed67cb373d06ef8c1c88401d10f6fc066c1b92e328c7992"],"pureState":["8674e747ceb537f80b5931c08f8167b5db590d58af1aa4cbaf57279af3ae2abb"],"runParser":["3a040b24ee14f16ae774c6ed36a1863a1fc0cee6e559939f079fdd29fc6424d2"],"runState":["c8b1e583def0528e7308518305c095f6b92464c936be4ddf6453b2f098b16797"],"snd":["e1abb2c217c19aa7d92d1e9caaf4aaf120b3a62cd49bb6db6499a52a86026ad7"],"sndPair":["0f1e1edaeea414f9aa3b563d0831147bc977c550bb602354f4f2dbc4581a7e6d"],"state":["ce06ae8292af0cbcbb024d38faeb5987c8703c12566da7a908e83ae6501507c9"],"storeName":["1b605459ec2d16825896019ed04bab5859d77b941b5af91fcc1cacdce4d670b8"],"stringMonoid":["ab19b9174926c2797981aad834b345bc4bb1465d3b08888e2fc9e05d2d6376c4"],"stringReduce":["5de707fc94368a529da7175fa5f6775abac76dc9ecfbabb110116cea38759680"],"subtractInt":["a7ca7fa6302de8b7cdf2f80966cc62bf6a9d89d4648136bf271551d7d30849b7"],"sumMonoid":["713625cc16fdf819517becf021d06376e62d56a87daad47233b9a180fbf4d0f2"],"testStateUsages":["a5339f9c482857ccd113fb54cec09f77b29e7ac7da501e4b7d83dd4a9004525d"],"trafficLight":["e08c74299429366ee29d211ad142f58c7785d459295d731c4d23d3e6f1a9c3dd"],"tree":["0eff9607730498416aea2ef180bed2dcf0748c41bb006701842886e62e1f07b8"],"typePerson":["a3a24862f94d92c5c2c1a965e14e902aa34776834c2a2f7dfa157baf7407adc1"],"typeState":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"typeThese":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"]},"projectPropertyTests":{},"projectTypes":{"Branch":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Cons":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Either":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"Green":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Ident":["f387354763fda433ac316bbafee15a52d9ad38a15d8b443aed86c4278a35ed3d"],"Just":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"Leaf":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Left":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"List":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Maybe":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"MonoPair":["269637495b741c1c7d94c56a26b7a8ddd2475b8aea0460e6095026bb71413dd9"],"Monoid":["8e9411f0b59c7619b10e77721d02f2bf89ad0b9881a0dc7c93f38d0de55d988f"],"Nil":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Nothing":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"Pair":["36737c23643be94c5685b4f5bce2f4e6b3fd22aca18153dc03e3c97115b0b48b"],"Parser":["64ab0a53205e51f3e6b4b9856ec210b9129e920baa98bda23b026af219918905"],"Person":["a3a24862f94d92c5c2c1a965e14e902aa34776834c2a2f7dfa157baf7407adc1"],"Red":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Right":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"State":["a565d8df513a67c795efaa5ebeeaa65b4ff8343366c2f5942363dd472a475cb2"],"That":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"These":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"This":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"TrafficLight":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Tree":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Yellow":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json b/backends/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json deleted file mode 100644 index 262daf42..00000000 --- a/backends/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["35266e63ec46d7f16f410b90b353243cf6673d264e279a5db04bde1a54eeea92"],"apState":["9905c9b5f8072e86ab7fef59e876bcbc6f195c7532e6a381e145220c6ed317f1"],"bindParser":["b594c371f07dfe022baaeaa61088e3d7204a6c62e53ca9946ee1f9f4a499fc46"],"bindState":["ce99f0b83532da6261f39cf852a6524a255738254cf4c4b0ba40792f823dadbe"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["63a7a1a4337e0b36578d4fc675820b547be60672e12c06e6bd160aeb1e5dee41"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["0666576cfc3df7a65e79c1422c8f04b403c3b02c65ec95c168a693c19a9ee4d4"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["7d6feac67a11fa3a49d4511dca8e196ff091b4f1ffe8cedb27f7d7203245f13d"],"fmapParser":["c2cbd4d6a53c14f388edd5f2329c5771a04fe13a1ad26659da9b1f967df7fcb7"],"fmapState":["f2ac935429ee25923bf5212b48e2ddd3a03725bc596cd744e5ed1d69f29ddd74"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["97a41678b3bf32d877aaf23404f5cb09758e80b2856815222676ed36d33bc550"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["c010847a1c4fa1a43a04c2a27e69ce335146f1ebd61b8977d40a8c8deb545775"],"invertTreeTwice":["462e15d015da51e06785e2b17894809a26923a89a059eff50c2a1af2903fc0e8"],"liftA2State":["6b649dc6135514c20eca1745baf22ecb1b79ee56f672ad6f3affe3bf6860bafa"],"list":["3c14cea5ebbad925c63d1612369cdd840498105d9661d62edc55fd6f86b8ba74"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["c3fca83349cb5f786938fee7bf972b0b59776c150f3c73240e856fb595b32309"],"monoPair":["c5459a5d4896dfaf5d2c3d790fabeb4d2cb11a261dd3177365e6d5daeb0b2b82"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["5acc7f1fdb40e0cd3c652319edb3daa9649d39f5e057ea0aa60474bb2531509a"],"parser":["58c3caf3327c52048ccc8de05529d9a4a63b7c987cf06172305b247c0fe353d9"],"predParser":["750a6cdd2dc1f80f181e7d2a1d421bcbbb9956f50139e93b810da3cd0f93a023"],"pureState":["9c856307f18254ea5ebe0c7b155483e489080d35b12b8a65ded3d0888ba9016a"],"runParser":["397fa1cc7e750a73ff2e7c9d4bbd3b4accb2dbf3f6dcbd1cab86c0bbecc6ae9c"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["49d3792687fb9d010133cedee17453379e3109bf1b0252679e8d9492b21e0498"],"storeName":["2cfe0854f7983f78c262a2e9558b93e8de49e9b70b6f5766b3bc011d944ebf78"],"stringMonoid":["231ce2b454ffd520ee694022c7be72b432999bd49fb4f2809b2c6118ceca9545"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["fbb04dc15026fb41234d88fe94c661e7dd179b56879546f90c56bb76578e1df6"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["74393de28f2b32c60b82bb3439848e39c6ff7b874e732087893f425d2f21846b"],"tree":["6086e8fd70a725ba6dd51f4ecc531e87eb8391458aa9f641ad75a91650f477ce"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["86e0f761e230ab7a0a2e7f8c8e3fa3dc7bab10f62563e5d8010f99f1488f4ae9"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/backends/test/modules/1.mimsa b/backends/test/modules/1.mimsa deleted file mode 100644 index 08cb0dd8..00000000 --- a/backends/test/modules/1.mimsa +++ /dev/null @@ -1,20 +0,0 @@ -def main: String = fromMaybe (id log) (Just (const (exclaim horse) False)) - -def id a = a - -def const a b = id a - -def exclaim (str: String): String = str ++ "!!!!!!!" - -def horse = "fucking horse" - -def fromMaybe (default: a) (maybeA: Maybe a): a = - match maybeA with - Just a -> a - | _ -> default - -def log = const "Yes" True - -type Maybe a = Just a | Nothing - - diff --git a/backends/test/modules/10.mimsa b/backends/test/modules/10.mimsa deleted file mode 100644 index 524ea606..00000000 --- a/backends/test/modules/10.mimsa +++ /dev/null @@ -1,10 +0,0 @@ -export type Maybe a = Just a | Nothing - -def alt (mA: Maybe a) (mB: Maybe a): Maybe a = - match mA with - Just a -> Just a - | Nothing -> mB - -infix <|> = alt - -def useAlt = Nothing <|> Just 1 diff --git a/backends/test/modules/2.mimsa b/backends/test/modules/2.mimsa deleted file mode 100644 index e422a944..00000000 --- a/backends/test/modules/2.mimsa +++ /dev/null @@ -1,4 +0,0 @@ -def duplicate = 1 -def duplicate = 2 - - diff --git a/backends/test/modules/3.mimsa b/backends/test/modules/3.mimsa deleted file mode 100644 index 4a455ea2..00000000 --- a/backends/test/modules/3.mimsa +++ /dev/null @@ -1,3 +0,0 @@ -type Maybe a = Just a | Nothing -type Maybe b = Dogs | Horses - diff --git a/backends/test/modules/4.mimsa b/backends/test/modules/4.mimsa deleted file mode 100644 index 4833cd34..00000000 --- a/backends/test/modules/4.mimsa +++ /dev/null @@ -1,3 +0,0 @@ -type Maybe a = Just a | Nothing -type Other b = Dogs | Nothing - diff --git a/backends/test/modules/5.mimsa b/backends/test/modules/5.mimsa deleted file mode 100644 index 009f1e71..00000000 --- a/backends/test/modules/5.mimsa +++ /dev/null @@ -1 +0,0 @@ -def useMissingThing = eatEgg 100 diff --git a/backends/test/modules/6.mimsa b/backends/test/modules/6.mimsa deleted file mode 100644 index 2e9385c5..00000000 --- a/backends/test/modules/6.mimsa +++ /dev/null @@ -1 +0,0 @@ -def doesntTypecheck = 1 + True diff --git a/backends/test/modules/7.mimsa b/backends/test/modules/7.mimsa deleted file mode 100644 index ebbddc8b..00000000 --- a/backends/test/modules/7.mimsa +++ /dev/null @@ -1 +0,0 @@ -def doesntTypecheckBecauseAnnotation (a: String): String = 1 + a diff --git a/backends/test/modules/8.mimsa b/backends/test/modules/8.mimsa deleted file mode 100644 index 8ea45c5e..00000000 --- a/backends/test/modules/8.mimsa +++ /dev/null @@ -1,7 +0,0 @@ -def fullType (a: String) (b: String): String = a ++ b - -def partialTypeAndReturn (a: String) b : String = a ++ b - -def partialType (a: String) b = a ++ b - -def noType a b = a ++ b diff --git a/backends/test/modules/9.mimsa b/backends/test/modules/9.mimsa deleted file mode 100644 index cd6568b5..00000000 --- a/backends/test/modules/9.mimsa +++ /dev/null @@ -1 +0,0 @@ -def id (str: String): a = str diff --git a/builder/CHANGELOG.md b/builder/CHANGELOG.md deleted file mode 100644 index ac250af0..00000000 --- a/builder/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for builder - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/builder/LICENSE b/builder/LICENSE deleted file mode 100644 index 87a03cc3..00000000 --- a/builder/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2023, Daniel Harvey - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Daniel Harvey nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/builder/builder.cabal b/builder/builder.cabal deleted file mode 100644 index ed736297..00000000 --- a/builder/builder.cabal +++ /dev/null @@ -1,116 +0,0 @@ -cabal-version: 3.4 - --- The cabal-version field refers to the version of the .cabal specification, --- and can be different from the cabal-install (the tool) version and the --- Cabal (the library) version you are using. As such, the Cabal (the library) --- version used must be equal or greater than the version stated in this field. --- Starting from the specification version 2.2, the cabal-version field must be --- the first thing in the cabal file. - --- Initial package description 'builder' generated by --- 'cabal init'. For further documentation, see: --- http://haskell.org/cabal/users-guide/ --- --- The name of the package. -name: builder - --- The package version. --- See the Haskell package versioning policy (PVP) for standards --- guiding when and how versions should be incremented. --- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD-3-Clause - --- The file containing the license text. -license-file: LICENSE - --- The package author(s). -author: Daniel Harvey - --- An email address to which users can send suggestions, bug reports, and patches. -maintainer: danieljamesharvey@gmail.com - --- A copyright notice. --- copyright: -category: Concurrency -build-type: Simple - --- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. -extra-doc-files: CHANGELOG.md - --- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: - -common warnings - ghc-options: -Wall - -library - -- Import common warning flags. - import: warnings - - -- Modules exported by the library. - exposed-modules: - Builder - Builder.Polymorphic - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - , base ^>=4.16.4.0 - , containers - , parallel - , stm - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite builder-test - -- Import common warning flags. - import: warnings - - -- Base language which the package is written in. - default-language: Haskell2010 - - -- Modules included in this executable, other than Main. - other-modules: Test.Builder.BuilderSpec - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- The interface type and version of the test suite. - type: exitcode-stdio-1.0 - - -- Directories containing source files. - hs-source-dirs: test - - -- The entrypoint to the test suite. - main-is: Spec.hs - - -- Test dependencies. - build-depends: - , base ^>=4.16.4.0 - , builder - , containers - , hspec - , ki - , mtl - , text diff --git a/builder/src/Builder.hs b/builder/src/Builder.hs deleted file mode 100644 index 3af09761..00000000 --- a/builder/src/Builder.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Builder (module Builder.Polymorphic) where - -import Builder.Polymorphic diff --git a/builder/src/Builder/Polymorphic.hs b/builder/src/Builder/Polymorphic.hs deleted file mode 100644 index 08a5cca8..00000000 --- a/builder/src/Builder/Polymorphic.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Builder.Polymorphic (doJobs, getMissing, Plan (..), State (..), Job, Inputs) where - -import Control.Parallel.Strategies -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S - --- a thing we want to do -data Plan k input = Plan - { jbDeps :: Set k, - jbInput :: input - } - deriving stock (Eq, Ord, Show) - --- how we're going to do it -type Job m k input output = Map k output -> input -> m output - -type Inputs k input = Map k (Plan k input) - --- state of the job -data State k input output = State - { stInputs :: Inputs k input, - stOutputs :: Map k output - } - deriving stock (Eq, Ord, Show) - --- | one run of the builder builds everything that is currently ready, then --- updates the state -runBuilder :: - (Ord k, Monad m) => - Job m k input output -> - State k input output -> - m (State k input output) -runBuilder fn st = do - -- filter out finished stuff from inputs (lets us start with cached results) - let inputs = M.filterWithKey (\k _ -> M.notMember k (stOutputs st)) (stInputs st) - -- get jobs we are ready to do - let readyJobs = - M.filter - ( \plan -> - let requiredKeys = jbDeps plan - in and ((\depK -> M.member depK (stOutputs st)) <$> S.toList requiredKeys) - ) - inputs - - -- do the jobs - done <- - traverse - ( \(k, plan) -> do - let filteredOutput = - M.filterWithKey - (\depK _ -> S.member depK (jbDeps plan)) - (stOutputs st) - output <- fn filteredOutput (jbInput plan) - pure (k, output) - ) - (M.toList readyJobs) - - -- evaluate everything in parallel - let reallyDone = done `using` parTraversable rseq - - -- remove them from inputs - let newInputs = - M.filterWithKey - (\k _ -> S.notMember k (M.keysSet readyJobs)) - inputs - - -- add them to outputs - pure (State newInputs (stOutputs st <> M.fromList reallyDone)) - --- list the required deps that cannot possibly be provided (usually indicates --- an error with implementation) -getMissing :: (Ord k) => State k input output -> Set k -getMissing (State inputs outputs) = - let getMissingDeps (Plan deps _) = - S.filter - (\dep -> dep `M.notMember` inputs && dep `M.notMember` outputs) - deps - in mconcat (getMissingDeps <$> M.elems inputs) - --- run through a list of jobs and do them -doJobs :: - (Ord k, Show k, Monad m, Eq input, Eq output) => - Job m k input output -> - State k input output -> - m (State k input output) -doJobs fn st = do - let missingDeps = getMissing st - if not (S.null missingDeps) - then error ("Missing deps in build: " <> show missingDeps) - else do - newState <- runBuilder fn st - if M.null (stInputs newState) || newState == st -- no more inputs, or there was no change (to stop infinite loop) - then pure newState - else doJobs fn newState diff --git a/builder/test/Spec.hs b/builder/test/Spec.hs deleted file mode 100644 index 3e06bd9c..00000000 --- a/builder/test/Spec.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main - ( main, - ) -where - -import qualified Test.Builder.BuilderSpec -import Test.Hspec - -main :: IO () -main = - hspec $ do - Test.Builder.BuilderSpec.spec diff --git a/builder/test/Test/Builder/BuilderSpec.hs b/builder/test/Test/Builder/BuilderSpec.hs deleted file mode 100644 index 280f77d7..00000000 --- a/builder/test/Test/Builder/BuilderSpec.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Builder.BuilderSpec - ( spec, - ) -where - -import qualified Builder -import Control.Monad.IO.Class -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import Test.Hspec - -job :: Builder.Job IO Int Text [Text] -job deps input = - pure ([input] <> mconcat (M.elems deps)) - -spec :: Spec -spec = do - describe "Build" $ do - it "Empty state is a no-op" $ do - let state = Builder.State mempty mempty - newState <- liftIO $ Builder.doJobs job state - newState `shouldBe` state - it "Run job on single item" $ do - let inputs = M.singleton 1 (Builder.Plan mempty "Hello") - let state = Builder.State inputs mempty - newState <- liftIO $ Builder.doJobs job state - let expectedOutputs = M.singleton 1 ["Hello"] - Builder.stOutputs newState `shouldBe` expectedOutputs - it "Run job with a dep" $ do - let inputs = - M.fromList - [ (1, Builder.Plan mempty "Hello"), - (2, Builder.Plan (S.singleton 1) "Egg"), - (3, Builder.Plan (S.singleton 1) "Horse"), - (4, Builder.Plan (S.fromList [1, 3]) "Dog") - ] - let state = Builder.State inputs mempty - let run = Builder.doJobs job - newState <- liftIO $ run state - let expectedOutputs = - M.fromList - [ (1, ["Hello"]), - (2, ["Egg", "Hello"]), - (3, ["Horse", "Hello"]), - (4, ["Dog", "Hello", "Horse", "Hello"]) - ] - Builder.stOutputs newState `shouldBe` expectedOutputs - it "If all work is done, just return it" $ do - let inputs = - M.fromList - [ (1, Builder.Plan mempty "Hello"), - (2, Builder.Plan (S.singleton 1) "Egg"), - (3, Builder.Plan (S.singleton 1) "Horse") - ] - let outputs = - M.fromList - [ (1, ["Hello!"]), - (2, ["Egg!", "Hello!"]), - (3, ["Horse!", "Hello!"]) - ] - let state = Builder.State inputs outputs - let run = Builder.doJobs job - newState <- liftIO $ run state - Builder.stOutputs newState `shouldBe` outputs - it "If outputs already exist, uses them instead of calculating" $ do - let inputs = - M.fromList - [ (1, Builder.Plan mempty "Hello"), - (2, Builder.Plan (S.singleton 1) "Egg"), - (3, Builder.Plan (S.singleton 1) "Horse"), - (4, Builder.Plan (S.fromList [1, 3]) "Dog") - ] - let outputs = - M.fromList - [ (1, ["Hello!"]), - (2, ["Egg!", "Hello!"]), - (3, ["Horse!", "Hello!"]) - ] - let state = Builder.State inputs outputs - let run = Builder.doJobs job - newState <- liftIO $ run state - let expectedOutputs = - outputs - <> M.fromList - [ (4, ["Dog", "Hello!", "Horse!", "Hello!"]) - ] - Builder.stOutputs newState `shouldBe` expectedOutputs - it "Detects missing deps" $ do - let inputs = - M.fromList - [ ( 1, - Builder.Plan (S.singleton (100 :: Int)) ("100 doesn't exist" :: String) - ), - (2, Builder.Plan (S.fromList [101, 1]) "101 doesn't exist either") - ] - outputs = mempty - state = Builder.State inputs outputs - Builder.getMissing state `shouldBe` S.fromList [100, 101] diff --git a/cabal.project b/cabal.project index 4a2b8d16..db43579d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,13 +1,4 @@ packages: - benchmarks/benchmarks.cabal, - builder/builder.cabal, - compiler/mimsa.cabal, - backends/backends.cabal, - repl/repl.cabal, - core/core.cabal, - smol-backend/smol-backend.cabal, - smol-core/smol-core.cabal, - smol-repl/smol-repl.cabal, llvm-calc/llvm-calc.cabal, llvm-calc2/llvm-calc2.cabal, llvm-calc3/llvm-calc3.cabal, diff --git a/compiler/.dockerignore b/compiler/.dockerignore deleted file mode 100644 index d7e4614b..00000000 --- a/compiler/.dockerignore +++ /dev/null @@ -1,2 +0,0 @@ -.stack-work -dist-newstyle diff --git a/compiler/.gitignore b/compiler/.gitignore deleted file mode 100644 index e6a31718..00000000 --- a/compiler/.gitignore +++ /dev/null @@ -1,42 +0,0 @@ -.direnv/ - -.stack-work/ -*~ -store/*.json -result -result/ - -output/ - -*.hie -swagger.json - -compiler/ - -# files generated during tests - -# typescript tests -test/golden/Typescript/*.ts -test/golden/Typescript-result/*.json -test/golden/CompileTSProject/ -test/golden/CompileTSProject-result/ -test/golden/CompileTSModuleProject/ -test/golden/CompileTSModuleProject-result/ -test/golden/CompileTSProjectWhole/ -test/golden/CompileTSProjectWhole-result/ - -# esmodules compilation tests -test/golden/ESModulesJS-result/*.json -test/golden/ESModulesJS/ -test/golden/CompileJSProject/ -test/golden/CompileJSProject-result/ -test/golden/CompileJSModuleProject/ -test/golden/CompileJSModuleProject-result/ -test/golden/CompileJSProjectWhole/ -test/golden/CompileJSProjectWhole-result/ - -# .prof files generated for profiling -*.prof - -# cabal shit -dist-newstyle diff --git a/compiler/LICENSE b/compiler/LICENSE deleted file mode 100644 index e637cdee..00000000 --- a/compiler/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/compiler/mimsa.cabal b/compiler/mimsa.cabal deleted file mode 100644 index d4157568..00000000 --- a/compiler/mimsa.cabal +++ /dev/null @@ -1,279 +0,0 @@ -cabal-version: 2.2 -name: mimsa -version: 0.1.0.0 -description: - Please see the README on GitHub at - -homepage: https://github.com/danieljharvey/mimsa#readme -bug-reports: https://github.com/danieljharvey/mimsa/issues -author: Daniel J Harvey -maintainer: danieljamesharvey@gmail.com -copyright: 2021 Daniel J Harvey -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: - static/modules/Array.mimsa - static/modules/Either.mimsa - static/modules/Maybe.mimsa - static/modules/Monoid.mimsa - static/modules/NonEmptyArray.mimsa - static/modules/Parser.mimsa - static/modules/Prelude.mimsa - static/modules/Reader.mimsa - static/modules/State.mimsa - static/modules/String.mimsa - static/modules/These.mimsa - static/modules/Tree.mimsa - -source-repository head - type: git - location: https://github.com/danieljharvey/mimsa - -common common-all - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - -library - import: common-all - exposed-modules: - Language.Mimsa.Actions.Compile - Language.Mimsa.Actions.Helpers.Build - Language.Mimsa.Actions.Helpers.GetDepsForStoreExpression - Language.Mimsa.Actions.Helpers.LookupExpression - Language.Mimsa.Actions.Helpers.NumberStoreExpression - Language.Mimsa.Actions.Helpers.Parse - Language.Mimsa.Actions.Interpret - Language.Mimsa.Actions.Modules.Bind - Language.Mimsa.Actions.Modules.Check - Language.Mimsa.Actions.Modules.Evaluate - Language.Mimsa.Actions.Modules.Imports - Language.Mimsa.Actions.Modules.RunTests - Language.Mimsa.Actions.Modules.ToStoreExpressions - Language.Mimsa.Actions.Modules.Typecheck - Language.Mimsa.Actions.Monad - Language.Mimsa.Actions.Optimise - Language.Mimsa.Actions.Types - Language.Mimsa.Backend.Wasm.Compile - Language.Mimsa.Interpreter.App - Language.Mimsa.Interpreter.If - Language.Mimsa.Interpreter.Infix - Language.Mimsa.Interpreter.Interpret - Language.Mimsa.Interpreter.Let - Language.Mimsa.Interpreter.Monad - Language.Mimsa.Interpreter.PatternMatch - Language.Mimsa.Interpreter.RecordAccess - Language.Mimsa.Interpreter.SimpleExpr - Language.Mimsa.Interpreter.Types - Language.Mimsa.Logging - Language.Mimsa.Modules.Check - Language.Mimsa.Modules.Dependencies - Language.Mimsa.Modules.FromParts - Language.Mimsa.Modules.HashModule - Language.Mimsa.Modules.Monad - Language.Mimsa.Modules.Parse - Language.Mimsa.Modules.Prelude - Language.Mimsa.Modules.Pretty - Language.Mimsa.Modules.ToStoreExprs - Language.Mimsa.Modules.Typecheck - Language.Mimsa.Modules.Uses - Language.Mimsa.Project - Language.Mimsa.Project.Helpers - Language.Mimsa.Project.SourceSpan - Language.Mimsa.Project.Stdlib - Language.Mimsa.Project.TypeSearch - Language.Mimsa.Store - Language.Mimsa.Store.ExtractTypes - Language.Mimsa.Store.Hashing - Language.Mimsa.Store.Helpers - Language.Mimsa.Store.Persistence - Language.Mimsa.Store.ResolveDataTypes - Language.Mimsa.Store.ResolvedDeps - Language.Mimsa.Store.Storage - Language.Mimsa.Tests.Generate - Language.Mimsa.Tests.Helpers - Language.Mimsa.Tests.UnitTest - Language.Mimsa.Transform.BetaReduce - Language.Mimsa.Transform.EtaReduce - Language.Mimsa.Transform.FindUnused - Language.Mimsa.Transform.FindUses - Language.Mimsa.Transform.FlattenLets - Language.Mimsa.Transform.FloatDown - Language.Mimsa.Transform.FloatUp - Language.Mimsa.Transform.Inliner - Language.Mimsa.Transform.Shared - Language.Mimsa.Transform.SimplifyPatterns - Language.Mimsa.Transform.TrimDeps - Language.Mimsa.Typechecker - Language.Mimsa.Typechecker.BuiltIns - Language.Mimsa.Typechecker.CreateEnv - Language.Mimsa.Typechecker.DataTypes - Language.Mimsa.Typechecker.DisplayError - Language.Mimsa.Typechecker.Elaborate - Language.Mimsa.Typechecker.Environment - Language.Mimsa.Typechecker.Exhaustiveness - Language.Mimsa.Typechecker.FlattenRow - Language.Mimsa.Typechecker.Generalise - Language.Mimsa.Typechecker.NormaliseTypes - Language.Mimsa.Typechecker.NumberVars - Language.Mimsa.Typechecker.OutputTypes - Language.Mimsa.Typechecker.ScopeTypeVar - Language.Mimsa.Typechecker.Solve - Language.Mimsa.Typechecker.TcMonad - Language.Mimsa.Typechecker.Typecheck - Language.Mimsa.Typechecker.TypedHoles - Language.Mimsa.Typechecker.Unify - Language.Mimsa.Types.Error - Language.Mimsa.Types.Error.CodegenError - Language.Mimsa.Types.Error.InterpreterError - Language.Mimsa.Types.Error.ModuleError - Language.Mimsa.Types.Error.PatternMatchError - Language.Mimsa.Types.Error.ProjectError - Language.Mimsa.Types.Error.ResolverError - Language.Mimsa.Types.Error.StoreError - Language.Mimsa.Types.Error.TypeError - Language.Mimsa.Types.Interpreter.Stack - Language.Mimsa.Types.Project - Language.Mimsa.Types.Project.Project - Language.Mimsa.Types.Project.ProjectHash - Language.Mimsa.Types.Project.SaveProject - Language.Mimsa.Types.Project.SourceItem - Language.Mimsa.Types.Project.SourceSpan - Language.Mimsa.Types.Project.Usage - Language.Mimsa.Types.Project.Versioned - Language.Mimsa.Types.Project.VersionedMap - Language.Mimsa.Types.Store - Language.Mimsa.Types.Store.Bindings - Language.Mimsa.Types.Store.ExprHash - Language.Mimsa.Types.Store.ResolvedDeps - Language.Mimsa.Types.Store.RootPath - Language.Mimsa.Types.Store.Store - Language.Mimsa.Types.Store.StoreExpression - Language.Mimsa.Types.Store.TypeBindings - Language.Mimsa.Types.Tests - Language.Mimsa.Types.Typechecker - Language.Mimsa.Types.Typechecker.Constraint - Language.Mimsa.Types.Typechecker.Environment - Language.Mimsa.Types.Typechecker.FoundPath - Language.Mimsa.Types.Typechecker.Scheme - Language.Mimsa.Types.Typechecker.Substitutions - Language.Mimsa.Types.Typechecker.TypeConstructor - Language.Mimsa.Types.Typechecker.Unique - Language.Mimsa.Types.Typechecker.UniVar - - hs-source-dirs: src - default-extensions: Strict - build-depends: - , aeson - , backends - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , cryptonite - , diagnose - , directory - , exceptions - , file-embed - , hashable - , megaparsec - , memory - , monad-logger - , mtl - , openapi3 - , parallel - , parser-combinators - , prettyprinter - , QuickCheck - , text - , transformers - , wasm - - default-language: Haskell2010 - -test-suite mimsa-test - import: common-all - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.Actions.BindModule - Test.Actions.Build - Test.Actions.Compile - Test.Actions.Evaluate - Test.Backend.ESModulesJSEndToEnd - Test.Backend.RunNode - Test.Backend.TypescriptEndToEnd - Test.Backend.Wasm - Test.Codegen.Shared - Test.Data.Prelude - Test.Data.Project - Test.Modules.Check - Test.Modules.Repl - Test.Modules.Test - Test.Modules.ToStoreExprs - Test.Modules.Uses - Test.Project.NormaliseType - Test.Project.SourceSpan - Test.Project.Stdlib - Test.RenderErrors - Test.Serialisation - Test.Tests.Properties - Test.Transform.BetaReduce - Test.Transform.EtaReduce - Test.Transform.FindUnused - Test.Transform.FindUses - Test.Transform.FlattenLets - Test.Transform.FloatDown - Test.Transform.FloatUp - Test.Transform.Inliner - Test.Transform.SimplifyPatterns - Test.Typechecker.DataTypes - Test.Typechecker.Elaborate - Test.Typechecker.Exhaustiveness - Test.Typechecker.NumberVars - Test.Typechecker.ScopeTypeVar - Test.Typechecker.Substitutions - Test.Typechecker.Typecheck - Test.Typechecker.Unify - Test.Utils.Compilation - Test.Utils.Helpers - Test.Utils.Serialisation - - hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - , aeson - , backends - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , cryptonite - , diagnose - , directory - , exceptions - , file-embed - , hashable - , hspec - , megaparsec - , memory - , mimsa - , monad-logger - , mtl - , openapi3 - , parallel - , parser-combinators - , prettyprinter - , QuickCheck - , text - , transformers - , typed-process - , wasm - - default-language: Haskell2010 diff --git a/compiler/src/Language/Mimsa/Actions/Compile.hs b/compiler/src/Language/Mimsa/Actions/Compile.hs deleted file mode 100644 index 8d07af52..00000000 --- a/compiler/src/Language/Mimsa/Actions/Compile.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Actions.Compile (compileModule, compileProject) where - --- get expression --- optimise it --- work out what to compile for it --- compile it to Text --- compile stdLib to Text - -import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Coerce -import Data.Foldable (traverse_) -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T --- import qualified Language.Mimsa.Actions.Optimise as Actions -import qualified Language.Mimsa.Actions.Helpers.LookupExpression as Actions -import qualified Language.Mimsa.Actions.Modules.ToStoreExpressions as Actions -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Backend.Output -import Language.Mimsa.Backend.Shared -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Modules.Check -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.ToStoreExprs -import Language.Mimsa.Project -import Language.Mimsa.Store -import Language.Mimsa.Store.ResolveDataTypes -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store - --- | given a pile of StoreExpressions, turn them all into TS/JS etc -compileStoreExpressions :: - Backend -> - Map ExprHash (StoreExpression MonoType) -> - Actions.ActionM (Set ExprHash) -compileStoreExpressions be typedStoreExprs = do - -- transpile each required file and add to outputs - traverse_ - ( \se -> do - Actions.appendMessage ("Compiling " <> prettyPrint (getStoreExpressionHash se)) - transpileModule be se - ) - typedStoreExprs - - -- return all ExprHashes created - pure $ S.map getStoreExpressionHash (S.fromList $ M.elems typedStoreExprs) - -toBackendError :: BackendError MonoType -> Error Annotation -toBackendError err = BackendErr (getAnnotationForType <$> err) - --- | Each module comes from a StoreExpression --- | and is transpiled into a folder in the store -transpileModule :: - Backend -> - StoreExpression MonoType -> - Actions.ActionM () -transpileModule be se = do - project <- Actions.getProject - dataTypes <- - liftEither $ - first - StoreErr - (resolveTypeDeps (prjStore project) (storeTypeBindings se)) - let path = Actions.SavePath (T.pack $ symlinkedOutputPath be) - let filename = - Actions.SaveFilename $ - storeExprFilename - be - (getStoreExpressionHash se) - <> fileExtension be - js <- - liftEither $ - first - toBackendError - (outputStoreExpression be dataTypes (prjStore project) se) - let jsOutput = Actions.SaveContents (coerce js) - Actions.appendWriteFile path filename jsOutput - --- The stdlib is a set of functions needed to stuff like pattern matching -createStdlib :: Backend -> Actions.ActionM () -createStdlib be = do - let path = Actions.SavePath (T.pack $ symlinkedOutputPath be) - filename = Actions.SaveFilename (stdlibFilename be <> fileExtension be) - outputContent = Actions.SaveContents (outputStdlib be) - Actions.appendWriteFile path filename outputContent - --- | The project index file is a `index.ts` or `index.js` that exports --- | all the top-level items in the project -createProjectIndex :: - Backend -> Map Name ExprHash -> Map ModuleName ModuleHash -> Actions.ActionM () -createProjectIndex be exportMap moduleExportMap = do - let indexFileContents = outputIndexFile be exportMap moduleExportMap mempty - let path = Actions.SavePath (T.pack $ symlinkedOutputPath be) - outputContent = Actions.SaveContents (coerce indexFileContents) - filename = Actions.SaveFilename (projectIndexFilename be) - Actions.appendWriteFile path filename outputContent - --- | The project index file is a `index.ts` or `index.js` that exports --- | all the top-level items in the project -createModuleIndex :: - ModuleHash -> Backend -> Map Name ExprHash -> Map TypeName ExprHash -> Actions.ActionM () -createModuleIndex modHash be exportMap exportTypeMap = do - let path = Actions.SavePath (T.pack $ symlinkedOutputPath be) - outputContent = Actions.SaveContents (coerce $ outputIndexFile be exportMap mempty exportTypeMap) - filename = Actions.SaveFilename (moduleFilename be modHash) - Actions.appendWriteFile path filename outputContent - --- | get map of names -> storeexprs from compiled outputs -compiledModulesToMap :: CompiledModule ann -> Actions.ActionM (Map Name (StoreExpression ann)) -compiledModulesToMap compModule = - let findCompiled exprHash = case M.lookup exprHash (getStore $ cmStore compModule) of - Just mod' -> pure mod' - _ -> throwError (StoreErr (CouldNotFindStoreExpression exprHash)) - in traverse findCompiled (filterNameDefs (cmExprs compModule)) - -compiledModulesToTypeMap :: CompiledModule ann -> Actions.ActionM (Map TypeName (StoreExpression ann)) -compiledModulesToTypeMap compModule = - let findCompiled exprHash = case M.lookup exprHash (getStore $ cmStore compModule) of - Just mod' -> pure mod' - _ -> throwError (StoreErr (CouldNotFindStoreExpression exprHash)) - in traverse findCompiled (filterTypeDefs (cmExprs compModule)) - --- compile every expression bound at the top level -compileProject :: Backend -> Actions.ActionM (Map Name ExprHash) -compileProject be = do - project <- Actions.getProject - - -- include stdlib for runtime - createStdlib be - - -- get all top-level module bindings in the project - modules <- - traverse - Actions.lookupModule - (getCurrentModules $ prjModules project) - - -- compile these too! why the hell not! - exportModuleMap <- - traverse - ( \thisMod -> do - Actions.appendMessage ("Compiling module " <> prettyPrint (snd (serializeModule thisMod))) - (moduleHash, _, _) <- compileModule be thisMod - pure moduleHash - ) - modules - - -- also output a top level exports file - createProjectIndex be mempty exportModuleMap - - -- great job - pure mempty - --- | compile a Module and all of its dependents -compileModule :: - Backend -> - Module Annotation -> - Actions.ActionM (ModuleHash, Map Name ExprHash, Map TypeName ExprHash) -compileModule be compModule = do - -- typecheck module - typecheckedModule <- Actions.typecheckModule (prettyPrint compModule) compModule - - -- turn it into store expressions - compiledExps <- Actions.toStoreExpressions typecheckedModule - - -- optimise them all like a big legend -- needs them to be typechecked first - -- though - -- allOptimised <- Actions.optimiseAll (getStore (cmStore compiledExps)) - - -- compile them all - _ <- compileStoreExpressions be (getStore (cmStore compiledExps)) - - -- create map of items to hashes for index file - exportMap <- (fmap . fmap) getStoreExpressionHash (compiledModulesToMap compiledExps) - exportTypeMap <- (fmap . fmap) getStoreExpressionHash (compiledModulesToTypeMap compiledExps) - - -- get hash of module for index - let (_, moduleHash) = serializeModule compModule - - -- also output a top level exports file - createModuleIndex moduleHash be exportMap exportTypeMap - - -- great job - pure (moduleHash, exportMap, exportTypeMap) - --- | Need to also include any types mentioned but perhaps not explicitly used -outputStoreExpression :: - Backend -> - Map (Maybe ModuleName, TyCon) DataType -> - Store any -> - StoreExpression MonoType -> - BackendM MonoType Text -outputStoreExpression be dataTypes store se@(StoreExpression expr _ _ _ _) = do - let typeBindings = typeBindingsByType store (storeTypeBindings se) - renderExprWithDeps be dataTypes typeBindings (storeInfixes se) (storeBindings se) (storeTypes se) expr -outputStoreExpression be dataTypes _store (StoreDataType dt types) = - renderDataTypeWithDeps be dataTypes dt types - --- returns [Maybe, hash], [These, hash], [Either, hash] - used for imports -typeBindingsByType :: Store a -> Map (Maybe ModuleName, TyCon) ExprHash -> Map TypeName ExprHash -typeBindingsByType store tb = - let getTypeName' exprHash = - case lookupExprHashFromStore store exprHash of - Just se -> storeExprToDataTypes se $> exprHash - Nothing -> mempty - in stripModules $ mconcat (getTypeName' <$> M.elems tb) - --- remove moduleName from type. will probably need these later when we come to --- fix TS but for now YOLO -stripModules :: (Ord b) => Map (a, b) c -> Map b c -stripModules = M.fromList . fmap (first snd) . M.toList diff --git a/compiler/src/Language/Mimsa/Actions/Helpers/Build.hs b/compiler/src/Language/Mimsa/Actions/Helpers/Build.hs deleted file mode 100644 index c524cc88..00000000 --- a/compiler/src/Language/Mimsa/Actions/Helpers/Build.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Actions.Helpers.Build (doJobs, getMissing, Plan (..), State (..), Job, Inputs) where - -import Control.Parallel.Strategies -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core (Printer (..)) - --- a thing we want to do -data Plan k input = Plan - { jbDeps :: Set k, - jbInput :: input - } - deriving stock (Eq, Ord, Show) - -instance (Printer k, Printer input) => Printer (Plan k input) where - prettyPrint (Plan deps _input) = prettyPrint deps - --- how we're going to do it -type Job m k input output = Map k output -> input -> m output - -type Inputs k input = Map k (Plan k input) - --- state of the job -data State k input output = State - { stInputs :: Inputs k input, - stOutputs :: Map k output - } - deriving stock (Eq, Ord, Show) - -instance (Printer k, Printer input, Printer output) => Printer (State k input output) where - prettyPrint (State inputs _outputs) = - prettyPrint inputs - --- | one run of the builder builds everything that is currently ready, then --- updates the state -runBuilder :: - (Ord k, Monad m) => - Job m k input output -> - State k input output -> - m (State k input output) -runBuilder fn st = do - -- filter out finished stuff from inputs (lets us start with cached results) - let inputs = M.filterWithKey (\k _ -> M.notMember k (stOutputs st)) (stInputs st) - -- get jobs we are ready to do - let readyJobs = - M.filter - ( \plan -> - let requiredKeys = jbDeps plan - in and ((\depK -> M.member depK (stOutputs st)) <$> S.toList requiredKeys) - ) - inputs - - -- do the jobs - done <- - traverse - ( \(k, plan) -> do - let filteredOutput = - M.filterWithKey - (\depK _ -> S.member depK (jbDeps plan)) - (stOutputs st) - output <- fn filteredOutput (jbInput plan) - pure (k, output) - ) - (M.toList readyJobs) - - -- evaluate everything in parallel - let reallyDone = done `using` parTraversable rseq - - -- remove them from inputs - let newInputs = - M.filterWithKey - (\k _ -> S.notMember k (M.keysSet readyJobs)) - inputs - - -- add them to outputs - pure (State newInputs (stOutputs st <> M.fromList reallyDone)) - --- list the required deps that cannot possibly be provided (usually indicates --- an error with implementation) -getMissing :: (Ord k) => State k input output -> Set k -getMissing (State inputs outputs) = - let getMissingDeps (Plan deps _) = - S.filter - (\dep -> dep `M.notMember` inputs && dep `M.notMember` outputs) - deps - in mconcat (getMissingDeps <$> M.elems inputs) - --- run through a list of jobs and do them -doJobs :: - (Ord k, Show k, Monad m, Eq input, Eq output) => - Job m k input output -> - State k input output -> - m (State k input output) -doJobs fn st = do - let missingDeps = getMissing st - if not (S.null missingDeps) - then error ("Missing deps in build: " <> show missingDeps) - else do - newState <- runBuilder fn st - if M.null (stInputs newState) || newState == st -- no more inputs, or there was no change (to stop infinite loop) - then pure newState - else doJobs fn newState diff --git a/compiler/src/Language/Mimsa/Actions/Helpers/GetDepsForStoreExpression.hs b/compiler/src/Language/Mimsa/Actions/Helpers/GetDepsForStoreExpression.hs deleted file mode 100644 index 6194bb95..00000000 --- a/compiler/src/Language/Mimsa/Actions/Helpers/GetDepsForStoreExpression.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Actions.Helpers.GetDepsForStoreExpression - ( getDepsForStoreExpression, - ) -where - -import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store - ----------- - --- recursively get all the StoreExpressions required -getDepsForStoreExpression :: - StoreExpression Annotation -> - Actions.ActionM (Map ExprHash (StoreExpression Annotation, Text)) -getDepsForStoreExpression storeExpr = do - project <- Actions.getProject - depsList <- - liftEither $ - first - StoreErr - (recursiveResolve (prjStore project) storeExpr) - pure $ - M.singleton (getStoreExpressionHash storeExpr) (storeExpr, prettyPrint storeExpr) - <> M.fromList - ( ( \se -> - (getStoreExpressionHash se, (se, prettyPrint se)) - ) - <$> depsList - ) diff --git a/compiler/src/Language/Mimsa/Actions/Helpers/LookupExpression.hs b/compiler/src/Language/Mimsa/Actions/Helpers/LookupExpression.hs deleted file mode 100644 index 383f3f96..00000000 --- a/compiler/src/Language/Mimsa/Actions/Helpers/LookupExpression.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Language.Mimsa.Actions.Helpers.LookupExpression - ( lookupModule, - lookupModuleByName, - ) -where - -import Control.Monad.Except -import qualified Data.Map.Strict as M -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project - -lookupModuleByName :: ModuleName -> Actions.ActionM (Module Annotation) -lookupModuleByName modName = do - project <- Actions.getProject - case lookupModuleName project modName of - Right modHash -> lookupModule modHash - Left found -> throwError (ProjectErr (CannotFindModuleByName modName found)) - -lookupModule :: - ModuleHash -> - Actions.ActionM (Module Annotation) -lookupModule modHash = do - project <- Actions.getProject - case M.lookup modHash (prjModuleStore project) of - Just mod' -> pure mod' - Nothing -> throwError (StoreErr (CouldNotFindModule modHash)) diff --git a/compiler/src/Language/Mimsa/Actions/Helpers/NumberStoreExpression.hs b/compiler/src/Language/Mimsa/Actions/Helpers/NumberStoreExpression.hs deleted file mode 100644 index eeb4fc3e..00000000 --- a/compiler/src/Language/Mimsa/Actions/Helpers/NumberStoreExpression.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Actions.Helpers.NumberStoreExpression (numberStoreExpression) where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Map.Strict (Map) -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store -import Language.Mimsa.Types.Typechecker.Unique - -numberStoreExpression :: - (MonadError (Error ann) m) => - Expr Name Annotation -> - Map (Maybe ModuleName, Name) ExprHash -> - m (Expr (Name, Unique) Annotation) -numberStoreExpression expr bindings = - -- add numbers and mark imports - liftEither - ( first - (TypeErr (prettyPrint expr)) - (addNumbersToStoreExpression expr bindings) - ) diff --git a/compiler/src/Language/Mimsa/Actions/Helpers/Parse.hs b/compiler/src/Language/Mimsa/Actions/Helpers/Parse.hs deleted file mode 100644 index 03b18514..00000000 --- a/compiler/src/Language/Mimsa/Actions/Helpers/Parse.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Language.Mimsa.Actions.Helpers.Parse (parseExpr, parseDataType, parseModule) where - -import Control.Monad.Except -import Data.Text (Text) -import Language.Mimsa.Actions.Types -import Language.Mimsa.Core (Annotation, DataType, Expr, Module, Name) -import qualified Language.Mimsa.Core as Parser -import qualified Language.Mimsa.Modules.Parse as Module -import Language.Mimsa.Types.Error - -parseExpr :: Text -> ActionM (Expr Name Annotation) -parseExpr - input = case Parser.parseExpr input of - Right a -> pure a - Left e -> throwError (ParseError input e) - -parseDataType :: Text -> ActionM DataType -parseDataType input = - case Parser.parseTypeDecl input of - Right a -> pure a - Left e -> throwError (ParseError input e) - -parseModule :: Text -> ActionM (Module Annotation) -parseModule = - Module.parseModule mempty diff --git a/compiler/src/Language/Mimsa/Actions/Interpret.hs b/compiler/src/Language/Mimsa/Actions/Interpret.hs deleted file mode 100644 index 081e1cb4..00000000 --- a/compiler/src/Language/Mimsa/Actions/Interpret.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Actions.Interpret (interpreter) where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Language.Mimsa.Actions.Helpers.Build as Build -import qualified Language.Mimsa.Actions.Helpers.GetDepsForStoreExpression as Actions -import qualified Language.Mimsa.Actions.Helpers.NumberStoreExpression as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import qualified Language.Mimsa.Actions.Optimise as Actions -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Interpret -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Store - --- get all the deps --- change var to InterpretVar to point at imports --- also collect Map ExprHash (Expr InterpretVar ann) --- then interpret it --- ... --- profit? -interpreter :: StoreExpression Annotation -> Actions.ActionM (Expr Name Annotation) -interpreter se = do - -- get dependencies of StoreExpression - depsSe <- Actions.getDepsForStoreExpression se - - -- optimise them all like a big legend - allOptimised <- Actions.optimiseAll (fst <$> depsSe) - - -- what is this rootExprHash now we've messed with everything - newRootExprHash <- case M.lookup (getStoreExpressionHash se) allOptimised of - Just re -> pure (getStoreExpressionHash re) - _ -> throwError (StoreErr (CouldNotFindStoreExpression (getStoreExpressionHash se))) - - -- interpret everything - allInterpreted <- interpretAll (fixKeys allOptimised) - - -- pick out the value we're interested in - case M.lookup newRootExprHash allInterpreted of - Just re -> pure (bimap fst edAnnotation re) - _ -> throwError (StoreErr (CouldNotFindStoreExpression newRootExprHash)) - -fixKeys :: Map ExprHash (StoreExpression Annotation) -> Map ExprHash (StoreExpression Annotation) -fixKeys = foldMap (\se -> M.singleton (getStoreExpressionHash se) se) . M.elems - -squashify :: (Ord e) => Map e (Map e a) -> Map e a -squashify = mconcat . M.elems - --- Interpret a group of StoreExpressions --- This means each sub dep is only interpreted once -interpretAll :: - Map ExprHash (StoreExpression Annotation) -> - Actions.ActionM (Map ExprHash (InterpretExpr Name Annotation)) -interpretAll inputStoreExpressions = do - let action depMap se = - case storeExpression se of - Just expr -> do - -- get us out of this Map of Maps situation - let flatDeps = squashify depMap - - -- add numbers and mark imports - numberedSe <- - Actions.numberStoreExpression expr (storeBindings se) - - -- tag each `var` with it's location if it is an import - let withImports = addEmptyStackFrames numberedSe - -- get exprhashes for any infixOps we need - let infixHashes = storeInfixes se - -- interpret se - interpreted <- liftEither (first InterpreterErr (interpret flatDeps infixHashes withImports)) - -- we need to accumulate all deps - -- as we go, so pass them up too - let allDeps = flatDeps <> M.singleton (getStoreExpressionHash se) interpreted - pure allDeps - Nothing -> pure mempty -- do nothing with DataType - - -- create initial state for builder - -- we tag each StoreExpression we've found with the deps it needs - let state = - Build.State - { Build.stInputs = - ( \storeExpr -> - Build.Plan - { Build.jbDeps = - S.fromList - ( M.elems (storeBindings storeExpr) - <> M.elems (storeTypeBindings storeExpr) - <> M.elems (storeInfixes storeExpr) - ), - Build.jbInput = storeExpr - } - ) - <$> inputStoreExpressions, - Build.stOutputs = mempty -- we use caches here if we wanted - } - -- go! - squashify . Build.stOutputs <$> Build.doJobs action state diff --git a/compiler/src/Language/Mimsa/Actions/Modules/Bind.hs b/compiler/src/Language/Mimsa/Actions/Modules/Bind.hs deleted file mode 100644 index 7187a3d3..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/Bind.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Actions.Modules.Bind - ( bindModule, - addBindingToModule, - ) -where - -import Data.Map.Strict (Map) -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Modules.RunTests as Actions -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Check -import Language.Mimsa.Modules.FromParts -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Types.Tests - --- add/update a module -bindModule :: - Module Annotation -> - ModuleName -> - Text -> - Actions.ActionM (ModuleHash, Module MonoType) -bindModule inputModule moduleName input = do - project <- Actions.getProject - - -- typecheck it to make sure it's not silly - typecheckedModule <- Actions.typecheckModule input inputModule - - -- store the name/hash pair and save the module data in the store - Actions.bindModuleInProject typecheckedModule moduleName - - -- display messages depending on whether this is new or update - case lookupModuleName project moduleName of - Right _ -> - Actions.appendMessage - ( "Updated binding of " <> prettyPrint moduleName <> "." - ) - _ -> - Actions.appendMessage - ( "Bound " <> prettyPrint moduleName <> "." - ) - - -- return stuff - pure (snd (serializeModule typecheckedModule), typecheckedModule) - -addBindingToModule :: - Map ModuleHash (Module Annotation) -> - Module MonoType -> - ModuleItem Annotation -> - Actions.ActionM (Module MonoType, ModuleTestResults) -addBindingToModule modules mod' modItem = do - -- add our new definition - newModule <- addModulePart modules modItem (getAnnotationForType <$> mod') - -- check everything still makes sense - typecheckedModule <- Actions.typecheckModule (prettyPrint newModule) newModule - -- run tests - testResults <- Actions.runModuleTests typecheckedModule - -- output what's happened - case getModuleItemIdentifier modItem of - Just di -> - Actions.appendMessage - ("Added definition " <> prettyPrint di <> " to module") - Nothing -> Actions.appendMessage "Module updated" - - pure (typecheckedModule, testResults) diff --git a/compiler/src/Language/Mimsa/Actions/Modules/Check.hs b/compiler/src/Language/Mimsa/Actions/Modules/Check.hs deleted file mode 100644 index 02932c86..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/Check.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Actions.Modules.Check (checkModule) where - -import Data.Map.Strict (Map) -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Modules.RunTests as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core hiding (parseModule) -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Monad -import Language.Mimsa.Modules.Parse -import Language.Mimsa.Modules.Typecheck -import Language.Mimsa.Types.Tests - --- | This is where we load a file and check that it is "OK" as such --- so far this entails: --- 1. parsing it --- 2. ordering things --- 3. typechecking everything --- --- so far the features in modules are --- 1. definitions of values --- 2. types of values --- 3. definitions of datatypes --- 4. exports --- 5. imports --- 6. infix --- --- soon there will also need to be --- 1. tests --- 2. property tests --- 3. metadata / comments etc? -checkModule :: - Map ModuleHash (Module Annotation) -> - Text -> - Actions.ActionM (Module (Type Annotation), ModuleTestResults) -checkModule modules input = do - properMod <- parseModule modules input - - -- typecheck this module - tcMods <- typecheckAllModules modules input properMod - - let (_, rootModuleHash) = serializeModule properMod - - tcMod <- lookupModule tcMods rootModuleHash - - testResults <- Actions.runModuleTests tcMod - pure (tcMod, testResults) diff --git a/compiler/src/Language/Mimsa/Actions/Modules/Evaluate.hs b/compiler/src/Language/Mimsa/Actions/Modules/Evaluate.hs deleted file mode 100644 index b59d938f..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/Evaluate.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Language.Mimsa.Actions.Modules.Evaluate - ( evaluateModule, - ) -where - -import Data.Foldable -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust) -import qualified Data.Set as S -import qualified Language.Mimsa.Actions.Interpret as Actions -import qualified Language.Mimsa.Actions.Modules.Imports as Actions -import qualified Language.Mimsa.Actions.Modules.ToStoreExpressions as Actions -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Check -import Language.Mimsa.Modules.ToStoreExprs -import Language.Mimsa.Types.Store - --- when we evaluate an expression, really we are adding it to an open module --- then evaluating the expression in the context of that module --- this means we can bind successive values --- we should probably stop users adding the same type/value twice so we don't --- have to deal with all the confusion --- --- 1. work out what stuff the expression uses --- 2. turns those into a module (ie, implied imports, new defs etc) --- 3. combine that with the local module --- 4. typecheck it --- 5. get the expression type from the module type --- 6. compile into store expressions --- 6. interpret store expressions as normal -evaluateModule :: - Expr Name Annotation -> - Module Annotation -> - Actions.ActionM (MonoType, Expr Name Annotation, Module Annotation) -evaluateModule expr localModule = do - -- work out implied imports - moduleImports <- Actions.findUsesInProject expr localModule - - -- make a module for it, adding our expression as _repl - let newModule = - localModule - <> mempty - { moExpressions = - M.singleton Actions.evalId expr, - moExpressionExports = S.singleton Actions.evalId - } - <> moduleImports - - -- typecheck it - typecheckedModule <- Actions.typecheckModule (prettyPrint newModule) newModule - - -- compile to store expressions - compiled <- Actions.toStoreExpressions typecheckedModule - - -- find the root StoreExpression by name - rootStoreExpr <- Actions.lookupByName compiled Actions.evalId - - -- unsafe, yolo - let exprType = fromJust (lookupModuleDefType typecheckedModule Actions.evalId) - - -- need to get our new store items into the project so this works I reckon - traverse_ - (Actions.appendStoreExpression . fmap getAnnotationForType) - (getStore $ cmStore compiled) - - -- interpret - evaluatedExpression <- - Actions.interpreter (getAnnotationForType <$> rootStoreExpr) - - let moduleWithExpression = - newModule {moExpressions = M.singleton Actions.evalId evaluatedExpression} - - pure (exprType, evaluatedExpression, moduleWithExpression) diff --git a/compiler/src/Language/Mimsa/Actions/Modules/Imports.hs b/compiler/src/Language/Mimsa/Actions/Modules/Imports.hs deleted file mode 100644 index b4f2469c..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/Imports.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Actions.Modules.Imports - ( evalId, - importsFromEntities, - entitiesFromModule, - findUsesInProject, - ) -where - -import Control.Monad.Except -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Uses -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Types.Error - --- we need to bind our new expression to _something_ --- so we make a `Name` which is strictly broken, but it means --- we won't have name collisions with a real expression -evalId :: DefIdentifier -evalId = DIName (Name "_repl") - --- given deps that this expression requires, attempt to resolve these into --- imports we'll need from the Project environment -importsFromEntities :: Set Entity -> Actions.ActionM (Module Annotation) -importsFromEntities uses = do - prj <- Actions.getProject - let fromEntity = \case - ENamespacedName modName _ -> - case lookupModuleName prj modName of - Right modHash -> pure $ mempty {moNamedImports = M.singleton modName modHash} - Left found -> throwError (ProjectErr (CannotFindModuleByName modName found)) - ENamespacedType modName _ -> - case lookupModuleName prj modName of - Right modHash -> pure $ mempty {moNamedImports = M.singleton modName modHash} - Left found -> throwError (ProjectErr (CannotFindModuleByName modName found)) - ENamespacedConstructor modName _ -> - case lookupModuleName prj modName of - Right modHash -> pure $ mempty {moNamedImports = M.singleton modName modHash} - Left found -> throwError (ProjectErr (CannotFindModuleByName modName found)) - _ -> pure mempty - -- check them all, combine them - mconcat <$> traverse fromEntity (S.toList uses) - -entitiesFromModule :: (Eq ann) => Module ann -> Set Entity -entitiesFromModule localModule = - foldMap extractUses (M.elems (moExpressions localModule)) - -findUsesInProject :: - Expr Name Annotation -> - Module Annotation -> - Actions.ActionM (Module Annotation) -findUsesInProject expr localModule = do - -- work out implied imports - importsFromEntities - ( extractUses expr - <> entitiesFromModule localModule - ) diff --git a/compiler/src/Language/Mimsa/Actions/Modules/RunTests.hs b/compiler/src/Language/Mimsa/Actions/Modules/RunTests.hs deleted file mode 100644 index 3760309a..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/RunTests.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Actions.Modules.RunTests (runModuleTests) where - -import Control.Monad (void) -import Control.Monad.Except -import Data.Bifunctor -import Data.Map.Strict (Map) -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Tests.Helpers -import Language.Mimsa.Tests.UnitTest -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Tests - -filterTests :: Map DefIdentifier (Expr Name ann) -> Map TestName (Expr Name ann) -filterTests = - filterMapKeys - ( \case - (DITest tn) -> Just tn - _ -> Nothing - ) - --- | run unit tests --- although we do not take advantage of the typechecked module --- we specify it to make sure we only work with non-broken modules -runModuleTests :: - Module (Type Annotation) -> - Actions.ActionM ModuleTestResults -runModuleTests mod' = - let untypedModule = getAnnotationForType <$> mod' - in ModuleTestResults <$> traverse (runUnitTest untypedModule) (filterTests (moExpressions mod')) - --- check the type of the unit test expression `Boolean` --- explode if not -unifiesWithBoolean :: Expr Name MonoType -> Actions.ActionM () -unifiesWithBoolean testExpr = - void $ - liftEither $ - first (TypeErr (prettyPrint testExpr)) $ - resultIsBoolean (getTypeFromAnn testExpr) - -runUnitTest :: Module Annotation -> Expr Name MonoType -> Actions.ActionM ModuleTestResult -runUnitTest mod' testExpr = do - _ <- unifiesWithBoolean testExpr - let untypedExpr = getAnnotationForType <$> testExpr - (_, result, _) <- Actions.evaluateModule untypedExpr mod' - pure $ - if testIsSuccess result - then ModuleTestPassed - else ModuleTestFailed diff --git a/compiler/src/Language/Mimsa/Actions/Modules/ToStoreExpressions.hs b/compiler/src/Language/Mimsa/Actions/Modules/ToStoreExpressions.hs deleted file mode 100644 index f6b69c47..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/ToStoreExpressions.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Language.Mimsa.Actions.Modules.ToStoreExpressions - ( toStoreExpressions, - lookupByName, - ) -where - -import Control.Monad.Except -import Data.Foldable -import qualified Data.Map.Strict as M -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.ToStoreExprs (CompiledModule (..)) -import qualified Language.Mimsa.Modules.ToStoreExprs as Modules -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store - -toStoreExpressions :: - Module MonoType -> - Actions.ActionM (CompiledModule MonoType) -toStoreExpressions localModule = do - typecheckedModules <- Actions.typecheckModules (prettyPrint localModule) (getAnnotationForType <$> localModule) - - let (_, rootModuleHash) = serializeModule localModule - - -- pull root module out from pile of typechecked modules - typecheckedModule <- case M.lookup rootModuleHash typecheckedModules of - Just tcMod -> pure tcMod - _ -> throwError (ModuleErr $ MissingModule rootModuleHash) - - -- compile to store expressions - compiledModule <- Modules.toStoreExpressions typecheckedModules typecheckedModule - - -- need to get our new store items into the project so this works I reckon - traverse_ - (Actions.appendStoreExpression . fmap getAnnotationForType) - (getStore $ cmStore compiledModule) - - pure compiledModule - --- TODO: real errors -lookupByName :: - CompiledModule ann -> - DefIdentifier -> - Actions.ActionM (StoreExpression ann) -lookupByName compiled defId = - -- find the root StoreExpression by name - case M.lookup defId (cmExprs compiled) - >>= flip M.lookup (getStore $ cmStore compiled) of - Just se -> pure se - _ -> error $ "lookupByName: could not find " <> show defId <> " in compiled store expressions" diff --git a/compiler/src/Language/Mimsa/Actions/Modules/Typecheck.hs b/compiler/src/Language/Mimsa/Actions/Modules/Typecheck.hs deleted file mode 100644 index 6a9b2992..00000000 --- a/compiler/src/Language/Mimsa/Actions/Modules/Typecheck.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Language.Mimsa.Actions.Modules.Typecheck - ( typecheckModules, - typecheckModule, - typecheckExpression, - ) -where - -import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Modules.Imports as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Check -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Typecheck -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project - -typecheckModules :: - Text -> - Module Annotation -> - Actions.ActionM (Map ModuleHash (Module MonoType)) -typecheckModules input inputModule = do - modules <- prjModuleStore <$> Actions.getProject - - typecheckAllModules modules input inputModule - -typecheckModule :: Text -> Module Annotation -> Actions.ActionM (Module MonoType) -typecheckModule input inputModule = do - -- typecheck it to make sure it's not silly - typecheckedModules <- - typecheckModules input inputModule - - let (_, rootModuleHash) = serializeModule inputModule - case M.lookup rootModuleHash typecheckedModules of - Just tcMod -> pure tcMod - _ -> throwError (ModuleErr $ MissingModule rootModuleHash) - --- | typecheck a single expression in the context of modules -typecheckExpression :: - Expr Name Annotation -> - Module Annotation -> - Actions.ActionM (Expr Name MonoType) -typecheckExpression expr localModule = do - -- work out implied imports - moduleImports <- Actions.findUsesInProject expr localModule - - -- make a module for it, adding our expression as _repl - let newModule = - localModule - <> mempty - { moExpressions = - M.singleton Actions.evalId expr, - moExpressionExports = S.singleton Actions.evalId - } - <> moduleImports - - -- typecheck it - typecheckedModule <- typecheckModule (prettyPrint newModule) newModule - - -- unsafe, yolo - pure $ fromJust (lookupModuleDef typecheckedModule Actions.evalId) diff --git a/compiler/src/Language/Mimsa/Actions/Monad.hs b/compiler/src/Language/Mimsa/Actions/Monad.hs deleted file mode 100644 index 2c32c044..00000000 --- a/compiler/src/Language/Mimsa/Actions/Monad.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Actions.Monad - ( run, - getProject, - appendProject, - appendMessage, - appendDocMessage, - appendWriteFile, - cacheTypecheckedStoreExpression, - setProject, - appendStoreExpression, - bindModuleInProject, - messagesFromOutcomes, - modulesFromOutcomes, - storeExpressionsFromOutcomes, - writeFilesFromOutcomes, - getCachedTypecheckedStoreExpressions, - ActionM, - SavePath (..), - SaveContents (..), - SaveFilename (..), - ) -where - -import Control.Monad.Except -import Control.Monad.State -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import Language.Mimsa.Actions.Types -import Language.Mimsa.Core -import Language.Mimsa.Project -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store -import Prettyprinter - -emptyState :: Project Annotation -> ActionState -emptyState prj = - ActionState - { asProject = prj, - asCachedTypechecked = mempty, - asActionOutcomes = mempty - } - -run :: - Project Annotation -> - ActionM a -> - Either (Error Annotation) (Project Annotation, [ActionOutcome], a) -run project action = - let (result, ActionState newProject _ outcomes) = - runState (runExceptT (runActionM action)) (emptyState project) - in (,,) newProject outcomes <$> result - -getProject :: ActionM (Project Annotation) -getProject = gets asProject - -setProject :: Project Annotation -> ActionM () -setProject prj = - modify (\s -> s {asProject = prj}) - -appendProject :: Project Annotation -> ActionM () -appendProject prj = - modify (\s -> s {asProject = asProject s <> prj}) - -appendActionOutcome :: ActionOutcome -> ActionM () -appendActionOutcome ao = - modify (\s -> s {asActionOutcomes = asActionOutcomes s <> [ao]}) - -appendMessage :: Text -> ActionM () -appendMessage = - appendActionOutcome . NewMessage - -appendDocMessage :: Doc ann -> ActionM () -appendDocMessage = appendMessage . renderWithWidth 50 - --- | cache a resolved expression -cacheTypecheckedStoreExpression :: ExprHash -> StoreExpression (Type Annotation) -> ActionM () -cacheTypecheckedStoreExpression exprHash re = - modify - ( \s -> - s - { asCachedTypechecked = - asCachedTypechecked s <> M.singleton exprHash re - } - ) - -getCachedTypecheckedStoreExpressions :: ActionM (Map ExprHash (StoreExpression (Type Annotation))) -getCachedTypecheckedStoreExpressions = - gets asCachedTypechecked - -appendWriteFile :: - SavePath -> - SaveFilename -> - SaveContents -> - ActionM () -appendWriteFile savePath filename content = - appendActionOutcome $ NewWriteFile savePath filename content - -appendStoreExpression :: StoreExpression Annotation -> ActionM () -appendStoreExpression se = do - let newProject = fromStoreExpression se (getStoreExpressionHash se) - appendActionOutcome (NewStoreExpression se) - appendProject newProject - -appendModule :: Module Annotation -> ActionM () -appendModule = - appendActionOutcome . NewModule - -messagesFromOutcomes :: [ActionOutcome] -> [Text] -messagesFromOutcomes = - foldMap - ( \case - NewMessage tx -> pure tx - _ -> mempty - ) - -storeExpressionsFromOutcomes :: [ActionOutcome] -> Set (StoreExpression Annotation) -storeExpressionsFromOutcomes = - S.fromList - . foldMap - ( \case - NewStoreExpression se -> pure se - _ -> mempty - ) - -writeFilesFromOutcomes :: [ActionOutcome] -> [(SavePath, SaveFilename, SaveContents)] -writeFilesFromOutcomes = - foldMap - ( \case - NewWriteFile sp sf sc -> pure (sp, sf, sc) - _ -> mempty - ) - -modulesFromOutcomes :: [ActionOutcome] -> Set (Module Annotation) -modulesFromOutcomes = - S.fromList - . foldMap - ( \case - NewModule mod' -> pure mod' - _ -> mempty - ) - --- add binding for module and add it to store -bindModuleInProject :: - Module (Type Annotation) -> - ModuleName -> - ActionM () -bindModuleInProject typecheckedModule modName = do - let untypedModule = getAnnotationForType <$> typecheckedModule - appendModule untypedModule - appendProject - ( fromModule modName untypedModule - ) diff --git a/compiler/src/Language/Mimsa/Actions/Optimise.hs b/compiler/src/Language/Mimsa/Actions/Optimise.hs deleted file mode 100644 index af885384..00000000 --- a/compiler/src/Language/Mimsa/Actions/Optimise.hs +++ /dev/null @@ -1,131 +0,0 @@ -module Language.Mimsa.Actions.Optimise - ( optimiseAll, - ) -where - --- this module is currently unused, we should be using it --- to optimise StoreExpressions before Evaluating or Compiling them - -import Data.Bifunctor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Language.Mimsa.Actions.Helpers.Build as Build -import qualified Language.Mimsa.Actions.Helpers.NumberStoreExpression as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Store -import Language.Mimsa.Transform.BetaReduce -import Language.Mimsa.Transform.EtaReduce -import Language.Mimsa.Transform.FindUnused -import Language.Mimsa.Transform.FlattenLets -import Language.Mimsa.Transform.FloatDown -import Language.Mimsa.Transform.FloatUp -import Language.Mimsa.Transform.Inliner -import Language.Mimsa.Transform.Shared -import Language.Mimsa.Transform.SimplifyPatterns -import Language.Mimsa.Transform.TrimDeps -import Language.Mimsa.Types.Store - -inlineExpression :: (Ord ann, Ord var) => Expr var ann -> Expr var ann -inlineExpression = - repeatUntilEq - ( floatUp - . flattenLets - . simplifyPatterns - . etaReduce - . removeUnused - . betaReduce - . inline - ) - -optimiseStoreExpression :: - StoreExpression Annotation -> - Actions.ActionM (StoreExpression Annotation) -optimiseStoreExpression storeExpr = - do - case storeExpression storeExpr of - Nothing -> pure storeExpr - Just expr -> do - let originalBindings = storeBindings storeExpr - - withNumbers <- - Actions.numberStoreExpression expr originalBindings - - -- do the shit - let optimised = inlineExpression withNumbers - - -- make into Expr Name - let floatedUpExprName = first fst optimised - - -- float lets down into patterns - let floatedSe = - floatDown floatedUpExprName - - -- turn back into Expr Variable (fresh names for copied vars) - floatedWithNumbers <- - Actions.numberStoreExpression floatedSe originalBindings - - -- remove unused stuff - let newStoreExpr = trimDeps storeExpr (first fst (inlineExpression floatedWithNumbers)) - - -- save new store expr - Actions.appendStoreExpression - newStoreExpr - - pure newStoreExpr - -useSwaps :: Map ExprHash ExprHash -> Map k ExprHash -> Map k ExprHash -useSwaps swaps bindings = - ( \exprHash -> case M.lookup exprHash swaps of - Just newExprHash -> newExprHash - _ -> exprHash - ) - <$> bindings - --- - --- Optimise a group of StoreExpressions -optimiseAll :: - Map ExprHash (StoreExpression Annotation) -> - Actions.ActionM (Map ExprHash (StoreExpression Annotation)) -optimiseAll inputStoreExpressions = do - let action depMap se = do - -- optimise se - optimisedSe <- optimiseStoreExpression se - -- make a map of expected hash with new actual hash for swapping - let swaps = getStoreExpressionHash <$> depMap - -- use the optimised deps passed in - let newSe = - case optimisedSe of - ose@StoreExpression {} -> - ose - { seBindings = useSwaps swaps (storeBindings optimisedSe), - seTypeBindings = useSwaps swaps (storeTypeBindings optimisedSe), - seInfixes = useSwaps swaps (storeInfixes optimisedSe), - seTypes = useSwaps swaps (storeTypes optimisedSe) - } - sd -> sd - -- store it - Actions.appendStoreExpression newSe - pure newSe - - -- create initial state for builder - -- we tag each StoreExpression we've found with the deps it needs - let state = - Build.State - { Build.stInputs = - ( \storeExpr -> - Build.Plan - { Build.jbDeps = - S.fromList - ( M.elems (storeBindings storeExpr) - <> M.elems (storeTypeBindings storeExpr) - ), - Build.jbInput = storeExpr - } - ) - <$> inputStoreExpressions, - Build.stOutputs = mempty -- we use caches here if we wanted - } - Build.stOutputs <$> Build.doJobs action state diff --git a/compiler/src/Language/Mimsa/Actions/Types.hs b/compiler/src/Language/Mimsa/Actions/Types.hs deleted file mode 100644 index a1e2b6ca..00000000 --- a/compiler/src/Language/Mimsa/Actions/Types.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Actions.Types - ( ActionM (..), - SavePath (..), - SaveContents (..), - SaveFilename (..), - ActionOutcome (..), - ActionState (..), - ) -where - -import Control.Monad.Except -import Control.Monad.State -import Data.Hashable -import Data.Map.Strict (Map) -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store - -newtype SavePath = SavePath Text - deriving newtype (Eq, Ord, Hashable) - -instance Show SavePath where - show (SavePath s) = T.unpack s - -newtype SaveContents = SaveContents Text - deriving newtype (Eq, Ord, Show, Hashable) - -newtype SaveFilename = SaveFilename Text - deriving newtype (Eq, Ord, Hashable) - -instance Show SaveFilename where - show (SaveFilename s) = T.unpack s - -data ActionOutcome - = NewMessage Text - | NewStoreExpression (StoreExpression Annotation) - | NewWriteFile SavePath SaveFilename SaveContents - | NewModule (Module Annotation) - deriving stock (Eq, Ord, Show) - -data ActionState = ActionState - { asProject :: Project Annotation, - asCachedTypechecked :: Map ExprHash (StoreExpression (Type Annotation)), - asActionOutcomes :: [ActionOutcome] - } - deriving stock (Eq, Ord, Show) - -newtype ActionM a = ActionM - { runActionM :: - ExceptT - (Error Annotation) - (State ActionState) - a - } - deriving newtype - ( Functor, - Applicative, - Monad, - MonadError (Error Annotation), - MonadState ActionState - ) diff --git a/compiler/src/Language/Mimsa/Backend/Wasm/Compile.hs b/compiler/src/Language/Mimsa/Backend/Wasm/Compile.hs deleted file mode 100644 index e3655fac..00000000 --- a/compiler/src/Language/Mimsa/Backend/Wasm/Compile.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Mimsa.Backend.Wasm.Compile where - --- this stays in the main compiler for now because the tests use the --- typechecker --- once those are moved, it can go into `backends` - -import Control.Monad.Except -import Control.Monad.State -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Text as T -import GHC.Natural -import Language.Mimsa.Core -import qualified Language.Wasm.Structure as Wasm - -type WasmModule = Wasm.Module - -data WasmState var = WasmState - { wsEnv :: Map var (Natural, Wasm.ValueType), - wsCounter :: Natural, - wsFuncs :: Map Int (WasmFunction var) - } - -data WasmFunction var = WasmFunction - { wfRetType :: Type (), - wfArgs :: [Type ()], - wfBody :: Expr var (Type ()) - } - -newtype WasmError var - = CouldNotFindVar var - deriving newtype (Show) - -emptyState :: (Ord var) => WasmState var -emptyState = WasmState mempty 0 mempty - -addEnvItem :: (Ord var) => var -> Wasm.ValueType -> WasmM var Natural -addEnvItem var wasmType = - state - ( \(WasmState env count funcs) -> - let newCount = count + 1 - in ( count, - WasmState (env <> M.singleton var (count, wasmType)) newCount funcs - ) - ) - -lookupEnvItem :: (Ord var) => var -> WasmM var (Natural, Wasm.ValueType) -lookupEnvItem var = do - maybeVal <- gets (\(WasmState env _ _) -> M.lookup var env) - case maybeVal of - Just a -> pure a - Nothing -> throwError (CouldNotFindVar var) - -newtype WasmM var a = WasmM - { getWasmM :: - StateT (WasmState var) (Except (WasmError var)) a - } - deriving newtype - ( Functor, - Applicative, - Monad, - MonadState (WasmState var), - MonadError (WasmError var) - ) - -runWasmM :: - (Ord var) => - WasmM var a -> - Either (WasmError var) (a, WasmState var) -runWasmM (WasmM comp) = runExcept $ runStateT comp emptyState - -compileRaw :: - forall var. - (Ord var, Show var, Printer (Expr var (Type ()))) => - Expr var (Type ()) -> - WasmModule -compileRaw expr = - let func = compileTestFunc expr - localTypes = [] - funcType = Wasm.FuncType localTypes [Wasm.I32] -- assumption - return is an I32 - export = - Wasm.Export "test" (Wasm.ExportFunc 0) - in Wasm.Module - { Wasm.types = [funcType], - Wasm.functions = [func], - Wasm.tables = mempty, - Wasm.mems = mempty, - Wasm.globals = mempty, - Wasm.elems = mempty, - Wasm.datas = mempty, - Wasm.start = Nothing, - Wasm.imports = mempty, - Wasm.exports = [export] - } - -localTypesFromState :: WasmState var -> [Wasm.ValueType] -localTypesFromState = - fmap snd . M.elems . wsEnv - -compileTestFunc :: - forall var ann. - (Ord var, Show var, Printer (Expr var ann)) => - Expr var ann -> - Wasm.Function -compileTestFunc expr = - case runWasmM (mainFn emptyState expr) of - Right (body, wsState) -> - let locals = localTypesFromState wsState - in Wasm.Function 0 locals body - Left e -> error (show e) - where - mainFn :: WasmState var -> Expr var ann -> WasmM var [Wasm.Instruction Natural] - mainFn ws exp' = case exp' of - (MyLiteral _ (MyInt i)) -> - pure [Wasm.I32Const (fromIntegral i)] - (MyLiteral _ (MyBool True)) -> - pure [Wasm.I32Const 1] - (MyLiteral _ (MyBool False)) -> - pure [Wasm.I32Const 0] - (MyIf _ predExpr thenExpr elseExpr) -> do - let block = Wasm.Inline (Just Wasm.I32) -- return type - predW <- mainFn ws predExpr - ifW <- - Wasm.If - block - <$> mainFn ws thenExpr - <*> mainFn ws elseExpr - pure $ predW <> [ifW] - (MyInfix _ op a b) -> do - valA <- mainFn ws a - valB <- mainFn ws b - pure $ valA <> valB <> [compileBinOp op] - (MyLet _ (Identifier _ ident) letExpr body') -> do - index <- addEnvItem ident Wasm.I32 - letW <- mainFn ws letExpr - let setW = [Wasm.SetLocal index] - bodyW <- mainFn ws body' - pure $ letW <> setW <> bodyW - (MyVar _ _ ident) -> do - -- ignoring namespaces - -- should think about that at some point - (n, _) <- lookupEnvItem ident - pure [Wasm.GetLocal n] - (MyApp _ (MyVar _ _ f) a) -> do - (fIndex, _) <- lookupEnvItem f - fA <- mainFn ws a - pure $ fA <> [Wasm.Call fIndex] - other -> error (T.unpack (prettyPrint other)) - -compileBinOp :: Operator -> Wasm.Instruction i -compileBinOp op = - case op of - Add -> Wasm.IBinOp Wasm.BS32 Wasm.IAdd - Subtract -> Wasm.IBinOp Wasm.BS32 Wasm.ISub - Equals -> Wasm.IRelOp Wasm.BS32 Wasm.IEq - GreaterThan -> Wasm.IRelOp Wasm.BS32 Wasm.IGtU - LessThan -> Wasm.IRelOp Wasm.BS32 Wasm.ILtU - GreaterThanOrEqualTo -> Wasm.IRelOp Wasm.BS32 Wasm.IGeU - LessThanOrEqualTo -> Wasm.IRelOp Wasm.BS32 Wasm.ILeU - op' -> error (T.unpack (prettyPrint op')) diff --git a/compiler/src/Language/Mimsa/Interpreter/App.hs b/compiler/src/Language/Mimsa/Interpreter/App.hs deleted file mode 100644 index 04c8f3e9..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/App.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Language.Mimsa.Interpreter.App (interpretApp) where - -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Monad -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Interpreter.Stack - -varFromIdent :: Identifier var ann -> var -varFromIdent (Identifier _ var) = var - -interpretApp :: - (Ord var, Eq ann) => - InterpretFn var ann -> - ExprData var ann -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretApp interpretFn ann myFn value = - case myFn of - (MyLambda (ExprData closure _ _) ident body) -> do - -- interpret arg first - intValue <- interpretFn value - -- add arg to context - let newStackFrame = addVarToFrame (varFromIdent ident) intValue closure - -- run body with closure + new arg - withNewStackFrame newStackFrame (interpretFn body) - (MyConstructor ann' modName const') -> - MyApp ann (MyConstructor ann' modName const') - <$> interpretFn value - fn -> do - -- try and resolve it into something we recognise - intFn <- interpretFn fn - if intFn == fn -- if it hasn't changed, we don't want to end up looping so give up and error - then do - intValue <- interpretFn value - -- at least change the value - pure (MyApp ann intFn intValue) - else interpretFn (MyApp ann intFn value) diff --git a/compiler/src/Language/Mimsa/Interpreter/If.hs b/compiler/src/Language/Mimsa/Interpreter/If.hs deleted file mode 100644 index 2c3ede1e..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/If.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Language.Mimsa.Interpreter.If (interpretIf) where - -import Control.Monad.Except -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Interpreter.Stack - -interpretIf :: - InterpretFn var ann -> - ExprData var ann -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretIf interpretFn ann predicate true false = - case predicate of - (MyLiteral _ (MyBool pred')) -> - if pred' - then interpretFn true - else interpretFn false - all'@MyLiteral {} -> - throwError $ PredicateForIfMustBeABoolean all' - all'@MyLambda {} -> - throwError $ PredicateForIfMustBeABoolean all' - pred' -> do - predExpr <- interpretFn pred' - interpretFn (MyIf ann predExpr true false) diff --git a/compiler/src/Language/Mimsa/Interpreter/Infix.hs b/compiler/src/Language/Mimsa/Interpreter/Infix.hs deleted file mode 100644 index 63ffd608..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/Infix.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Language.Mimsa.Interpreter.Infix (interpretInfix) where - -import Control.Monad ((<=<)) -import Control.Monad.Except -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Monad -import Language.Mimsa.Interpreter.SimpleExpr -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError - --- | this assumes that -interpretInfix :: - (Ord var, Monoid ann) => - InterpretFn var ann -> - Operator -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretInfix interpretFn operator a b = do - plainA <- interpretFn <=< interpretFn $ a - plainB <- interpretFn <=< interpretFn $ b - case operator of - Equals -> do - let withBool = pure . MyLiteral mempty . MyBool - if simpleExpr plainA == simpleExpr plainB - then withBool True - else withBool False - Add -> do - let withInt = pure . MyLiteral mempty . MyInt - let getNum exp' = case exp' of - (MyLiteral _ (MyInt i)) -> Right i - _ -> Left $ AdditionWithNonNumber a - case (,) <$> getNum plainA <*> getNum plainB of - Right (a', b') -> withInt (a' + b') - Left e -> throwError e - Subtract -> do - let withInt = pure . MyLiteral mempty . MyInt - let getNum exp' = case exp' of - (MyLiteral _ (MyInt i)) -> Right i - _ -> Left $ SubtractionWithNonNumber exp' - case (,) <$> getNum plainA <*> getNum plainB of - Right (a', b') -> withInt (a' - b') - Left e -> throwError e - GreaterThan -> - numericComparison - (>) - (ComparisonWithNonNumber GreaterThan) - plainA - plainB - GreaterThanOrEqualTo -> - numericComparison - (>=) - (ComparisonWithNonNumber GreaterThanOrEqualTo) - plainA - plainB - LessThan -> - numericComparison - (<) - (ComparisonWithNonNumber LessThan) - plainA - plainB - LessThanOrEqualTo -> - numericComparison - (<=) - (ComparisonWithNonNumber LessThanOrEqualTo) - plainA - plainB - StringConcat -> - interpretStringConcat plainA plainB - ArrayConcat -> - interpretArrayConcat plainA plainB - (Custom infixOp) -> do - opFn <- findOperator infixOp - iFn <- interpretFn opFn - interpretFn - ( MyApp - mempty - (MyApp mempty iFn plainA) - plainB - ) - --- | lift a numeric comparison into the Expr type -numericComparison :: - (Ord var, Monoid ann) => - (Int -> Int -> Bool) -> - (InterpretExpr var ann -> InterpreterError var ann) -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -numericComparison f withErr plainA plainB = do - let withBool = pure . MyLiteral mempty . MyBool - let getNum exp' = case exp' of - (MyLiteral _ (MyInt i)) -> Right i - _ -> Left $ withErr exp' - case (,) <$> getNum plainA <*> getNum plainB of - Right (a', b') -> withBool (f a' b') - Left e -> throwError e - -interpretStringConcat :: - (Ord var, Monoid ann) => - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretStringConcat plainA plainB = do - let withStr = pure . MyLiteral mempty . MyString . StringType - getStr exp' = case exp' of - (MyLiteral _ (MyString (StringType i))) -> Right i - _ -> Left $ StringConcatenationFailure plainA plainB - case (,) <$> getStr plainA <*> getStr plainB of - Right (a', b') -> withStr (a' <> b') - Left e -> throwError e - -interpretArrayConcat :: - (Ord var, Monoid ann) => - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretArrayConcat plainA plainB = do - let withArr = pure . MyArray mempty - getArr exp' = case exp' of - (MyArray _ i) -> Right i - _ -> Left $ ArrayConcatenationFailure plainA plainB - case (,) <$> getArr plainA <*> getArr plainB of - Right (a', b') -> withArr (a' <> b') - Left e -> throwError e diff --git a/compiler/src/Language/Mimsa/Interpreter/Interpret.hs b/compiler/src/Language/Mimsa/Interpreter/Interpret.hs deleted file mode 100644 index e35cca18..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/Interpret.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Language.Mimsa.Interpreter.Interpret (interpret, addEmptyStackFrames) where - -import Control.Monad.Reader -import Data.Functor -import Data.Map.Strict (Map) -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.App -import Language.Mimsa.Interpreter.If -import Language.Mimsa.Interpreter.Infix -import Language.Mimsa.Interpreter.Let -import Language.Mimsa.Interpreter.Monad -import Language.Mimsa.Interpreter.PatternMatch -import Language.Mimsa.Interpreter.RecordAccess -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Typechecker.Unique - -initialStack :: (Ord var) => StackFrame var ann -initialStack = StackFrame mempty mempty - -addEmptyStackFrames :: - (Ord var, Monoid ann) => - Expr (var, Unique) ann -> - Expr (var, Unique) (ExprData var ann) -addEmptyStackFrames expr = - expr $> mempty - -interpret :: - (Eq ann, Ord var, Show var, Printer var, Monoid ann, Show ann) => - Map ExprHash (InterpretExpr var ann) -> - Map InfixOp ExprHash -> - InterpretExpr var ann -> - Either (InterpreterError var ann) (InterpretExpr var ann) -interpret deps infixes expr = - runReaderT (interpretExpr expr) (InterpretReaderEnv initialStack deps infixes) - --- somewhat pointless separate function to make debug logging each value out --- easier -interpretExpr :: - (Eq ann, Ord var, Show var, Printer var, Monoid ann, Show ann) => - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretExpr = - interpretExpr' - -interpretExpr' :: - (Eq ann, Ord var, Show var, Printer var, Monoid ann, Show ann) => - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretExpr' (MyLiteral _ val) = pure (MyLiteral mempty val) -interpretExpr' (MyAnnotation _ _ expr) = interpretExpr' expr -interpretExpr' (MyLet _ ident expr body) = - interpretLet interpretExpr ident expr body -interpretExpr' (MyVar _ _ var) = - lookupVar var >>= interpretExpr -interpretExpr' (MyLambda (ExprData current isRec ann) ident body) = do - -- capture current environment - stackFrame <- - getCurrentStackFrame - -- add it to already captured vars - let newExprData = - ExprData - (current <> stackFrame) - isRec - ann - -- return it - pure - (MyLambda newExprData ident body) -interpretExpr' (MyTuple ann a as) = - MyTuple ann <$> interpretExpr a <*> traverse interpretExpr as -interpretExpr' (MyInfix _ op a b) = - interpretInfix interpretExpr op a b -interpretExpr' (MyIf ann predExpr thenExpr elseExpr) = - interpretIf interpretExpr ann predExpr thenExpr elseExpr -interpretExpr' (MyApp ann fn a) = - interpretApp interpretExpr ann fn a -interpretExpr' (MyRecordAccess ann expr name) = - interpretRecordAccess interpretExpr ann expr name -interpretExpr' (MyTupleAccess ann expr index) = - interpretTupleAccess interpretExpr ann expr index -interpretExpr' (MyPatternMatch _ matchExpr patterns) = do - interpretPatternMatch interpretExpr matchExpr patterns -interpretExpr' (MyLetPattern _ pat patExpr body) = - interpretLetPattern interpretExpr pat patExpr body -interpretExpr' (MyRecord ann as) = - MyRecord ann <$> traverse interpretExpr as -interpretExpr' (MyArray ann as) = - MyArray ann <$> traverse interpretExpr as -interpretExpr' (MyConstructor as modName const') = - pure (MyConstructor as modName const') -interpretExpr' (MyTypedHole ann name) = - pure (MyTypedHole ann name) diff --git a/compiler/src/Language/Mimsa/Interpreter/Let.hs b/compiler/src/Language/Mimsa/Interpreter/Let.hs deleted file mode 100644 index a592abe2..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/Let.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Language.Mimsa.Interpreter.Let (interpretLet) where - -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Monad -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Typechecker.Unique - -varFromIdent :: Identifier var ann -> var -varFromIdent (Identifier _ var) = var - --- need to interpret the expr in the let binding --- BUT it needs to refer to itself --- this is NOT the one, we need some form of indirection so the closure can say --- "and look up whatever 'var' is pls" -interpretLetExpr :: - (Ord var, Monoid ann) => - InterpretFn var ann -> - (var, Unique) -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretLetExpr interpretFn var expr = do - intExpr <- interpretFn expr - case intExpr of - lambdaExpr@MyLambda {} -> - if isRecursive var lambdaExpr - then -- make this a function of \binding -> actualFunction - interpretFn (MyLambda (ExprData mempty True mempty) (Identifier mempty var) lambdaExpr) - else -- non-recursive, run as normal - interpretFn lambdaExpr - _ -> pure intExpr - -interpretLet :: - (Ord var, Monoid ann) => - InterpretFn var ann -> - Identifier (var, Unique) (ExprData var ann) -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretLet interpretFn ident expr body = do - -- calc expr, including itself to sort recursion - intExpr <- - interpretLetExpr - interpretFn - (varFromIdent ident) - expr - - -- calc rest, with new binding added to the current stack frame - extendStackFrame - [(varFromIdent ident, intExpr)] - (interpretFn body) - -isRecursive :: (Ord var) => var -> Expr var ann -> Bool -isRecursive var expr = - memberInUses var Nothing (findUses expr) diff --git a/compiler/src/Language/Mimsa/Interpreter/Monad.hs b/compiler/src/Language/Mimsa/Interpreter/Monad.hs deleted file mode 100644 index 3956b78e..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/Monad.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Language.Mimsa.Interpreter.Monad - ( withNewStackFrame, - extendStackFrame, - getCurrentStackFrame, - lookupVar, - addVarToFrame, - findOperator, - addOperator, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Typechecker.Unique - --- | run action with entirely new frame --- | useful for running functions from their closures -withNewStackFrame :: - StackFrame var ann -> - InterpreterM var ann a -> - InterpreterM var ann a -withNewStackFrame sf = - local - (\ire -> ire {ireStack = sf}) - -extendStackFrame :: - (Ord var) => - [ ( (var, Unique), - InterpretExpr var ann - ) - ] -> - InterpreterM var ann a -> - InterpreterM var ann a -extendStackFrame bindings = - local - ( \ire -> - ire - { ireStack = - foldr (uncurry addVarToFrame) (ireStack ire) bindings - } - ) - -getCurrentStackFrame :: InterpreterM var ann (StackFrame var ann) -getCurrentStackFrame = asks ireStack - -lookupInGlobals :: ExprHash -> InterpreterM var ann (InterpretExpr var ann) -lookupInGlobals exprHash = do - globals <- asks ireGlobals - case M.lookup exprHash globals of - Just found -> pure found - _ -> throwError (CouldNotFindGlobal globals exprHash) - -lookupVar :: - (Ord var, Monoid ann, Show var, Show ann) => - (var, Unique) -> - InterpreterM var ann (InterpretExpr var ann) -lookupVar (var, maybeExprHash) = - case maybeExprHash of - Dependency exprHash -> do - intExpr <- lookupInGlobals exprHash - case intExpr of - -- if it points to another var, fetch that - (MyVar _ Nothing a) -> lookupVar a - other -> pure other - _ -> do - (StackFrame entries _) <- getCurrentStackFrame - case M.lookup var entries of - Just myLam@(MyLambda (ExprData _ isRec _) _ _) -> - -- when we save functions on the stack we save them as - -- \letName -> function - -- so that recursion works - -- therefore when fetching it we apply it to itself - -- like a fixpoint combinator thing - if isRec - then pure (MyApp mempty myLam myLam) - else pure myLam - -- if it's another var, fetch that - Just (MyVar _ Nothing a) -> lookupVar a - -- otherwise return it - Just other -> pure other - -- could not find var - _ -> throwError (CouldNotFindVar entries var) - -addOperator :: InfixOp -> InterpretExpr var ann -> InterpreterM var ann a -> InterpreterM var ann a -addOperator infixOp expr = do - local - ( \ire -> - ire - { ireStack = - addOperatorToFrame infixOp expr (ireStack ire) - } - ) - --- lookup custom infixOp in stack and then global scope -findOperator :: InfixOp -> InterpreterM var ann (InterpretExpr var ann) -findOperator infixOp = do - (StackFrame _ infixes) <- getCurrentStackFrame - case M.lookup infixOp infixes of - Just entry -> pure entry - _ -> do - allInfixes <- asks ireInfixes - case M.lookup infixOp allInfixes of - Just infixHash -> lookupInGlobals infixHash - _ -> throwError (CouldNotFindInfix infixes infixOp) - -addOperatorToFrame :: InfixOp -> InterpretExpr var ann -> StackFrame var ann -> StackFrame var ann -addOperatorToFrame infixOp expr (StackFrame entries infixes) = - StackFrame entries (M.singleton infixOp expr <> infixes) - -addVarToFrame :: - (Ord var) => - (var, Unique) -> - InterpretExpr var ann -> - StackFrame var ann -> - StackFrame var ann -addVarToFrame (var, _) expr (StackFrame entries infixes) = - StackFrame (M.singleton var expr <> entries) infixes diff --git a/compiler/src/Language/Mimsa/Interpreter/PatternMatch.hs b/compiler/src/Language/Mimsa/Interpreter/PatternMatch.hs deleted file mode 100644 index 5925355a..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/PatternMatch.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Language.Mimsa.Interpreter.PatternMatch - ( interpretPatternMatch, - interpretLetPattern, - ) -where - -import Control.Monad.Except -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Monad -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Typechecker.Unique - -interpretLetPattern :: - (Ord var) => - InterpretFn var ann -> - InterpretPattern var ann -> - InterpretExpr var ann -> - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) -interpretLetPattern interpretFn pat expr body = do - -- interpret input - intExpr <- interpretFn expr - -- get new bound variables - let bindings = fromMaybe [] (patternMatches pat intExpr) - -- run body with closure + new arg - extendStackFrame bindings (interpretFn body) - -interpretPatternMatch :: - (Ord var) => - InterpretFn var ann -> - InterpretExpr var ann -> - [(InterpretPattern var ann, InterpretExpr var ann)] -> - InterpreterM var ann (InterpretExpr var ann) -interpretPatternMatch interpretFn expr' patterns = do - -- interpret match expression - intExpr <- interpretFn expr' - let foldF (pat, patExpr) = case patternMatches pat intExpr of - Just bindings -> First (Just (patExpr, bindings)) - _ -> First Nothing - -- get first matching pattern - case getFirst (foldMap foldF patterns) of - Just (patExpr, bindings) -> - do - -- run body with closure + new arg - extendStackFrame bindings (interpretFn patExpr) - _ -> - throwError $ PatternMatchFailure expr' - --- pull vars out of expr to match patterns -patternMatches :: - InterpretPattern var ann -> - InterpretExpr var ann -> - Maybe [((var, Unique), InterpretExpr var ann)] -patternMatches (PWildcard _) _ = pure [] -patternMatches (PVar _ name) expr = pure [(name, expr)] -patternMatches (PTuple _ pA pAs) (MyTuple _ a as) = do - matchA <- patternMatches pA a - matchAs <- - traverse - (uncurry patternMatches) - (zip (NE.toList pAs) (NE.toList as)) - pure $ matchA <> mconcat matchAs -patternMatches (PRecord _ pAs) (MyRecord _ as) - | S.null (S.difference (M.keysSet pAs) (M.keysSet as)) = do - let usefulInputs = M.intersection as pAs - allPairs = zip (M.elems pAs) (M.elems usefulInputs) - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PLit _ pB) (MyLiteral _ b) - | pB == b = pure mempty -patternMatches (PConstructor _ _ _pTyCon []) (MyConstructor _ _ _tyCon) = - pure mempty -patternMatches (PConstructor _ _ pTyCon pArgs) (MyApp ann fn val) = do - (tyCon, args) <- consAppToPattern (MyApp ann fn val) - if tyCon /= pTyCon - then Nothing - else do - let allPairs = zip pArgs args - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs NoSpread) (MyArray _ as) - | length pAs == length as = do - let allPairs = zip pAs as - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs (SpreadWildcard _)) (MyArray _ as) - | length pAs <= length as = do - let allPairs = zip pAs as - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs (SpreadValue _ a)) (MyArray ann as) - | length pAs <= length as = do - let binding = (a, MyArray ann (drop (length pAs) as)) - let allPairs = zip pAs as - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice <> [binding]) -patternMatches (PString _ pA pAs) (MyLiteral _ (MyString (StringType str))) | not (T.null str) = - do - let bindingA = case pA of - (StrValue ann a) -> - [ ( a, - MyLiteral - ann - ( MyString - ( StringType (T.singleton (T.head str)) - ) - ) - ) - ] - _ -> [] - bindingAs = case pAs of - (StrValue ann as) -> - [ ( as, - MyLiteral - ann - ( MyString (StringType (T.drop 1 str)) - ) - ) - ] - _ -> [] - pure (bindingA <> bindingAs) -patternMatches _ _ = Nothing - -consAppToPattern :: InterpretExpr var ann -> Maybe (TyCon, [InterpretExpr var ann]) -consAppToPattern (MyApp _ fn val) = do - (tyCon, more) <- consAppToPattern fn - pure (tyCon, more <> [val]) -consAppToPattern (MyConstructor _ _ tyCon) = pure (tyCon, mempty) -consAppToPattern _ = Nothing diff --git a/compiler/src/Language/Mimsa/Interpreter/RecordAccess.hs b/compiler/src/Language/Mimsa/Interpreter/RecordAccess.hs deleted file mode 100644 index 7c15b127..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/RecordAccess.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Language.Mimsa.Interpreter.RecordAccess (interpretRecordAccess, interpretTupleAccess) where - -import Control.Monad.Except -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) -import GHC.Natural -import Language.Mimsa.Core -import Language.Mimsa.Interpreter.Types -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Interpreter.Stack - -interpretRecordAccess :: - InterpretFn var ann -> - ExprData var ann -> - InterpretExpr var ann -> - Name -> - InterpreterM var ann (InterpretExpr var ann) -interpretRecordAccess interpretFn _ (MyRecord _ record) name = - case M.lookup name record of - Just item -> interpretFn item - _ -> throwError $ CannotFindMemberInRecord record name -interpretRecordAccess interpretFn ann (MyVar ann' modName a) name = do - intExpr <- interpretFn (MyVar ann' modName a) - interpretFn (MyRecordAccess ann intExpr name) -interpretRecordAccess interpretFn ann (MyRecordAccess ann' a name') name = do - intExpr <- interpretFn (MyRecordAccess ann' a name') - interpretFn (MyRecordAccess ann intExpr name) -interpretRecordAccess interpretFn ann (MyApp ann' fn arg) name = do - res <- interpretFn (MyApp ann' fn arg) - interpretFn (MyRecordAccess ann res name) -interpretRecordAccess _ _ recordExpr name = do - throwError $ CannotDestructureAsRecord recordExpr name - -interpretTupleAccess :: - InterpretFn var ann -> - ExprData var ann -> - InterpretExpr var ann -> - Natural -> - InterpreterM var ann (InterpretExpr var ann) -interpretTupleAccess interpretFn _ (MyTuple _ a as) index = - let allItems = [a] <> NE.toList as - in case listToMaybe (drop (fromIntegral index - 1) allItems) of - Just item -> interpretFn item - _ -> throwError $ CannotFindMemberInTuple allItems index -interpretTupleAccess interpretFn ann (MyVar ann' modName a) index = do - intExpr <- interpretFn (MyVar ann' modName a) - interpretFn (MyTupleAccess ann intExpr index) -interpretTupleAccess interpretFn ann (MyTupleAccess ann' a index') index = do - intExpr <- interpretFn (MyTupleAccess ann' a index') - interpretFn (MyTupleAccess ann intExpr index) -interpretTupleAccess _ _ recordExpr index = - throwError $ CannotDestructureAsTuple recordExpr index diff --git a/compiler/src/Language/Mimsa/Interpreter/SimpleExpr.hs b/compiler/src/Language/Mimsa/Interpreter/SimpleExpr.hs deleted file mode 100644 index aceb98e2..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/SimpleExpr.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Language.Mimsa.Interpreter.SimpleExpr (simpleExpr) where - -import Data.Bifunctor -import Data.Functor -import Language.Mimsa.Core - --- | simpleExpr -simpleExpr :: Expr var ann -> Expr var () -simpleExpr (MyConstructor _ _ tyCon) = - MyConstructor mempty Nothing tyCon -simpleExpr (MyVar _ _ var) = - MyVar mempty Nothing var -simpleExpr (MyLetPattern _ pat expr body) = - MyLetPattern mempty (simplePattern pat) (simpleExpr expr) (simpleExpr body) -simpleExpr (MyLiteral _ lit) = MyLiteral mempty lit -simpleExpr (MyAnnotation _ mt expr) = - MyAnnotation mempty (mt $> mempty) (simpleExpr expr) -simpleExpr (MyLet _ ident expr body) = - MyLet mempty (ident $> mempty) (simpleExpr expr) (simpleExpr body) -simpleExpr (MyInfix _ op a b) = MyInfix mempty op (simpleExpr a) (simpleExpr b) -simpleExpr (MyLambda _ ident body) = MyLambda mempty (ident $> mempty) (simpleExpr body) -simpleExpr (MyApp _ fn val) = MyApp mempty (simpleExpr fn) (simpleExpr val) -simpleExpr (MyIf _ predExpr thenExpr elseExpr) = - MyIf mempty (simpleExpr predExpr) (simpleExpr thenExpr) (simpleExpr elseExpr) -simpleExpr (MyTuple _ a as) = MyTuple mempty (simpleExpr a) (simpleExpr <$> as) -simpleExpr (MyRecord _ as) = MyRecord mempty (simpleExpr <$> as) -simpleExpr (MyRecordAccess _ expr name) = MyRecordAccess mempty (simpleExpr expr) name -simpleExpr (MyTupleAccess _ expr index) = MyTupleAccess mempty (simpleExpr expr) index -simpleExpr (MyArray _ as) = MyArray mempty (simpleExpr <$> as) -simpleExpr (MyPatternMatch _ expr pats) = - MyPatternMatch mempty (simpleExpr expr) (bimap simplePattern simpleExpr <$> pats) -simpleExpr (MyTypedHole _ var) = MyTypedHole mempty var - -simplePattern :: Pattern var ann -> Pattern var () -simplePattern (PVar _ var) = PVar mempty var -simplePattern (PConstructor _ _ tyCon args) = - PConstructor mempty Nothing tyCon (simplePattern <$> args) -simplePattern (PWildcard _) = PWildcard mempty -simplePattern (PTuple _ a as) = PTuple mempty (simplePattern a) (simplePattern <$> as) -simplePattern (PRecord _ as) = PRecord mempty (simplePattern <$> as) -simplePattern (PLit _ lit) = PLit mempty lit -simplePattern (PArray _ vals spread) = - let simpleSpread = case spread of - SpreadValue _ a -> SpreadValue mempty a - SpreadWildcard _ -> SpreadWildcard mempty - NoSpread -> NoSpread - in PArray mempty (simplePattern <$> vals) simpleSpread -simplePattern (PString _ pHead pTail) = - let simplePart s = case s of - StrValue _ a -> StrValue mempty a - StrWildcard _ -> StrWildcard mempty - in PString mempty (simplePart pHead) (simplePart pTail) diff --git a/compiler/src/Language/Mimsa/Interpreter/Types.hs b/compiler/src/Language/Mimsa/Interpreter/Types.hs deleted file mode 100644 index 2d4565e1..00000000 --- a/compiler/src/Language/Mimsa/Interpreter/Types.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Interpreter.Types - ( InterpreterM, - InterpretExpr, - InterpretFn, - InterpretReaderEnv (..), - InterpretPattern, - ) -where - -import Control.Monad.Reader -import Data.Map.Strict (Map) -import Language.Mimsa.Core -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Typechecker.Unique - -type InterpreterM var ann a = - ReaderT - (InterpretReaderEnv var ann) - (Either (InterpreterError var ann)) - a - -data InterpretReaderEnv var ann = InterpretReaderEnv - { ireStack :: StackFrame var ann, - ireGlobals :: Map ExprHash (InterpretExpr var ann), - ireInfixes :: Map InfixOp ExprHash - } - -type InterpretExpr var ann = Expr (var, Unique) (ExprData var ann) - -type InterpretPattern var ann = - Pattern (var, Unique) (ExprData var ann) - -type InterpretFn var ann = - InterpretExpr var ann -> - InterpreterM var ann (InterpretExpr var ann) diff --git a/compiler/src/Language/Mimsa/Logging.hs b/compiler/src/Language/Mimsa/Logging.hs deleted file mode 100644 index afcd6526..00000000 --- a/compiler/src/Language/Mimsa/Logging.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Language.Mimsa.Logging where - -import qualified Data.Text as T -import Debug.Trace -import Language.Mimsa.Core (Printer (..)) - --- useless change to trigger CI - -debugLog :: (Show b) => String -> b -> b -debugLog title item = snd (traceShowId (title, item)) - -debugPretty :: (Printer b) => String -> b -> b -debugPretty title !item = - let !output = title <> ":\n" <> T.unpack (prettyPrint item) - in trace output item diff --git a/compiler/src/Language/Mimsa/Modules/Check.hs b/compiler/src/Language/Mimsa/Modules/Check.hs deleted file mode 100644 index 659e11e0..00000000 --- a/compiler/src/Language/Mimsa/Modules/Check.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Modules.Check - ( getModuleType, - getModuleItemIdentifier, - lookupModuleDefType, - lookupModuleDef, - filterNameDefs, - filterTypeDefs, - ) -where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Elaborate - -lookupModuleDef :: Module (Type Annotation) -> DefIdentifier -> Maybe (Expr Name (Type Annotation)) -lookupModuleDef mod' defId = - let defs = - M.filterWithKey - (\k _ -> S.member k (moExpressionExports mod')) - (moExpressions mod') - in M.lookup defId defs - -lookupModuleDefType :: Module (Type Annotation) -> DefIdentifier -> Maybe (Type Annotation) -lookupModuleDefType = (fmap . fmap) getTypeFromAnn . lookupModuleDef - --- used in logging etc, "what is this thing" -getModuleItemIdentifier :: ModuleItem ann -> Maybe DefIdentifier -getModuleItemIdentifier (ModuleInfix infixOp _) = Just (DIInfix infixOp) -getModuleItemIdentifier (ModuleExpression name _ _) = Just (DIName name) -getModuleItemIdentifier (ModuleDataType (DataType typeName _ _)) = Just (DIType typeName) -getModuleItemIdentifier (ModuleExport a) = getModuleItemIdentifier a -getModuleItemIdentifier (ModuleImport _) = Nothing -getModuleItemIdentifier (ModuleTest testName _) = Just (DITest testName) - --- return type of module as a MTRecord of dep -> monotype --- TODO: module should probably be it's own MTModule or something --- as we'll want to pass them about at some point I think -getModuleType :: Module (Type Annotation) -> Type Annotation -getModuleType mod' = - let defs = - M.filterWithKey - (\k _ -> S.member k (moExpressionExports mod')) - (moExpressions mod') - in MTRecord mempty (getTypeFromAnn <$> filterNameDefs defs) Nothing - -filterNameDefs :: Map DefIdentifier a -> Map Name a -filterNameDefs = - filterMapKeys - ( \case - DIName name -> Just name - _ -> Nothing - ) - -filterTypeDefs :: Map DefIdentifier a -> Map TypeName a -filterTypeDefs = - filterMapKeys - ( \case - DIType typeName -> Just typeName - _ -> Nothing - ) diff --git a/compiler/src/Language/Mimsa/Modules/Dependencies.hs b/compiler/src/Language/Mimsa/Modules/Dependencies.hs deleted file mode 100644 index cd6b287d..00000000 --- a/compiler/src/Language/Mimsa/Modules/Dependencies.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Modules.Dependencies - ( getDependencies, - getModuleDeps, - filterExprs, - filterDataTypes, - DepType (..), - ) -where - --- work out the dependencies between definitions inside a module - -import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Monoid (First (..)) -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Monad -import Language.Mimsa.Modules.Uses -import Language.Mimsa.Types.Error - -data DepType ann - = DTExpr (Expr Name ann) - | DTData DataType - deriving stock (Eq, Ord, Show) - -instance (Printer ann) => Printer (DepType ann) where - prettyPrint (DTExpr expr) = prettyPrint expr - prettyPrint (DTData dt) = prettyPrint dt - -filterExprs :: Map k (DepType ann) -> Map k (Expr Name ann) -filterExprs = - M.mapMaybe - ( \case - (DTExpr expr) -> Just expr - _ -> Nothing - ) - -filterDataTypes :: Map k (DepType ann) -> Map k DataType -filterDataTypes = - M.mapMaybe - ( \case - (DTData dt) -> Just dt - _ -> Nothing - ) - -filterDefs :: Set Entity -> Set DefIdentifier -filterDefs = - S.fromList - . mapMaybe - ( \case - EName name -> Just (DIName name) - EInfix infixOp -> Just (DIInfix infixOp) - _ -> Nothing - ) - . S.toList - -filterConstructors :: Set Entity -> Set TyCon -filterConstructors = - S.fromList - . mapMaybe - ( \case - EConstructor tyCon -> Just tyCon - _ -> Nothing - ) - . S.toList - -filterTypes :: Set Entity -> Set TypeName -filterTypes = - S.fromList - . mapMaybe - ( \case - EType typeName -> Just typeName - _ -> Nothing - ) - . S.toList - --- get the vars used by each def --- explode if there's not available -getDependencies :: - (MonadError (Error Annotation) m) => - (Expr Name ann -> Set Entity) -> - Module ann -> - m - ( Map - DefIdentifier - ( DepType ann, - Set DefIdentifier, - Set Entity - ) - ) -getDependencies getUses mod' = do - exprDeps <- - traverse - (getExprDependencies getUses mod') - (moExpressions mod') - typeDeps <- - mapKeys DIType - <$> traverse - (getTypeDependencies mod') - (moDataTypes mod') - pure (exprDeps <> typeDeps) - --- get all dependencies of a type definition -getTypeDependencies :: - (MonadError (Error Annotation) m) => - Module ann -> - DataType -> - m (DepType ann, Set DefIdentifier, Set Entity) -getTypeDependencies mod' dt = do - let allUses = extractDataTypeUses dt - typeDefIds <- getTypeUses mod' allUses - exprDefIds <- getExprDeps mod' allUses - pure (DTData dt, typeDefIds <> exprDefIds, allUses) - -getTypeUses :: - (MonadError (Error Annotation) m) => - Module ann -> - Set Entity -> - m (Set DefIdentifier) -getTypeUses mod' uses = - let typeDeps = filterTypes uses - unknownTypeDeps = - S.filter - ( \typeName -> - S.notMember typeName (M.keysSet (moDataTypes mod')) - && S.notMember typeName (M.keysSet (moDataTypeImports mod')) - ) - typeDeps - in if S.null unknownTypeDeps - then - let localTypeDeps = - S.filter - ( \typeName -> - typeName `S.member` M.keysSet (moDataTypes mod') - ) - typeDeps - in pure (S.map DIType localTypeDeps) - else throwError (ModuleErr (CannotFindTypes unknownTypeDeps)) - -findTypenameInModule :: - Module ann -> - TyCon -> - Maybe TypeName -findTypenameInModule mod' tyCon = - let lookupInDataType (DataType typeName _ constructors) = - if M.member tyCon constructors then First (Just typeName) else First Nothing - in getFirst $ foldMap lookupInDataType (M.elems (moDataTypes mod')) - --- get typenames where we can, ignore missing ones as they're from another --- module --- (fingers crosseD!???!) -findTypesForConstructors :: Module ann -> Set TyCon -> Set TypeName -findTypesForConstructors mod' = - S.fromList . mapMaybe (findTypenameInModule mod') . S.toList - -getConstructorUses :: - (MonadError (Error Annotation) m) => - Module ann -> - Set Entity -> - m (Set DefIdentifier) -getConstructorUses mod' uses = do - let typeDeps = findTypesForConstructors mod' (filterConstructors uses) - let unknownTypeDeps = - S.filter - ( \typeName -> - S.notMember typeName (M.keysSet (moDataTypes mod')) - && S.notMember typeName (M.keysSet (moDataTypeImports mod')) - ) - typeDeps - in if S.null unknownTypeDeps - then - let localTypeDeps = - S.filter - ( \typeName -> - typeName `S.member` M.keysSet (moDataTypes mod') - ) - typeDeps - in pure (S.map DIType localTypeDeps) - else throwError (ModuleErr (CannotFindTypes unknownTypeDeps)) - -getExprDependencies :: - (MonadError (Error Annotation) m) => - (Expr Name ann -> Set Entity) -> - Module ann -> - Expr Name ann -> - m (DepType ann, Set DefIdentifier, Set Entity) -getExprDependencies getUses mod' expr = do - let allUses = getUses expr - exprDefIds <- getExprDeps mod' allUses - consDefIds <- getConstructorUses mod' allUses - typeDefIds <- getTypeUses mod' allUses - pure (DTExpr expr, exprDefIds <> typeDefIds <> consDefIds, allUses) - -getExprDeps :: - (MonadError (Error Annotation) m) => - Module ann -> - Set Entity -> - m (Set DefIdentifier) -getExprDeps mod' uses = - let nameDeps = filterDefs uses - unknownNameDeps = - S.filter - ( \dep -> - S.notMember dep (M.keysSet (moExpressions mod')) - && S.notMember dep (M.keysSet (moExpressionImports mod')) - ) - nameDeps - in if S.null unknownNameDeps - then - let localNameDeps = - S.filter - ( `S.member` - M.keysSet (moExpressions mod') - ) - nameDeps - in pure localNameDeps - else throwError (ModuleErr (CannotFindValues unknownNameDeps)) - --- starting at a root module, --- create a map of each expr hash along with the modules it needs --- so that we can typecheck them all -getModuleDeps :: - (MonadError (Error Annotation) m, Show ann) => - Map ModuleHash (Module ann) -> - Module ann -> - m - ( Map - ModuleHash - ( Module ann, - Set ModuleHash - ) - ) -getModuleDeps moduleDeps inputModule = do - -- get this module's deps - let deps = - S.fromList - ( M.elems (moExpressionImports inputModule) - <> M.elems (moNamedImports inputModule) - <> M.elems (moDataTypeImports inputModule) - ) - mHash = snd $ serializeModule inputModule - - -- recursively fetch sub-deps - depModules <- traverse (lookupModule moduleDeps) (S.toList deps) - subDeps <- traverse (getModuleDeps moduleDeps) depModules - - pure $ M.singleton mHash (inputModule, deps) <> mconcat subDeps diff --git a/compiler/src/Language/Mimsa/Modules/FromParts.hs b/compiler/src/Language/Mimsa/Modules/FromParts.hs deleted file mode 100644 index 310f0b9c..00000000 --- a/compiler/src/Language/Mimsa/Modules/FromParts.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Modules.FromParts (addModulePart, moduleFromModuleParts, exprAndTypeFromParts) where - -import Control.Monad (void, when) -import Control.Monad.Except -import Data.Coerce -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Modules.Monad -import Language.Mimsa.Types.Error - -moduleFromModuleParts :: - ( MonadError (Error Annotation) m, - Monoid ann - ) => - Map ModuleHash (Module Annotation) -> - [ModuleItem ann] -> - m (Module ann) -moduleFromModuleParts modules parts = - let addPart part output = do - mod' <- output - addModulePart modules part mod' - in foldr addPart (pure mempty) parts - -addModulePart :: - (MonadError (Error Annotation) m, Monoid ann) => - Map ModuleHash (Module Annotation) -> - ModuleItem ann -> - Module ann -> - m (Module ann) -addModulePart modules part mod' = - case part of - ModuleExpression name bits expr -> do - errorIfExpressionAlreadyDefined mod' (DIName name) - exp' <- exprAndTypeFromParts (DIName name) bits expr - pure $ - mod' - { moExpressions = - M.singleton (DIName name) exp' <> moExpressions mod' - } - ModuleDataType dt@(DataType tyCon _ _) -> do - let typeName = coerce tyCon - checkDataType mod' dt - pure $ - mod' - { moDataTypes = - M.singleton typeName dt - <> moDataTypes mod' - } - ModuleInfix infixOp expr -> do - errorIfExpressionAlreadyDefined mod' (DIInfix infixOp) - pure $ - mod' - { moExpressions = - M.singleton (DIInfix infixOp) expr - <> moExpressions mod' - } - ModuleTest testName expr -> do - errorIfExpressionAlreadyDefined mod' (DITest testName) - when - (testName == TestName "") - ( throwError (ModuleErr (EmptyTestName $ void expr)) - ) - - pure $ - mod' - { moExpressions = - M.singleton (DITest testName) expr - <> moExpressions mod' - } - ModuleExport modItem -> do - -- get whatever is inside - innerModule <- addModulePart modules modItem mod' - -- get the keys, add them to exports - let defExports = case modItem of - ModuleExpression name _ _ -> S.singleton (DIName name) - ModuleInfix infixOp _ -> S.singleton (DIInfix infixOp) - _ -> mempty - let typeExports = case modItem of - ModuleDataType (DataType tn _ _) -> S.singleton (coerce tn) - _ -> mempty - pure $ - innerModule - { moExpressionExports = - defExports <> moExpressionExports innerModule, - moDataTypeExports = - typeExports <> moDataTypeExports innerModule - } - ModuleImport (ImportNamedFromHash mHash mName) -> - pure $ mod' {moNamedImports = M.singleton mName mHash <> moNamedImports mod'} - ModuleImport (ImportAllFromHash mHash) -> do - importMod <- lookupModule modules mHash - let defImports = - M.fromList - . fmap (,mHash) - . S.toList - . moExpressionExports - $ importMod - - -- explode if these are defined already - _ <- - M.traverseWithKey - (errorIfImportAlreadyDefined mod') - defImports - - let typeImports = - M.fromList - . fmap (,mHash) - . S.toList - . moDataTypeExports - $ importMod - - -- explode if these types are defined already - _ <- - M.traverseWithKey - (errorIfTypeImportAlreadyDefined mod') - typeImports - - pure $ - mod' - { moExpressionImports = - defImports - <> moExpressionImports mod', - moDataTypeImports = - typeImports - <> moDataTypeImports mod' - } - -addAnnotation :: Maybe (Type ann) -> Expr Name ann -> Expr Name ann -addAnnotation mt expr = - -- add type annotation to expression - case mt of - Just typeAnnotation -> - MyAnnotation - (getAnnotationForType typeAnnotation) - typeAnnotation - expr - _ -> expr - -includesExplicitTypes :: [DefPart ann] -> Bool -includesExplicitTypes = - any - ( \case - (DefArg _) -> False - _ -> True - ) - -includesReturnType :: [DefPart ann] -> Bool -includesReturnType = - any - ( \case - (DefType _) -> True - _ -> False - ) - --- given the bits of things, make a coherent type and expression --- 1) check we have any type annotations --- 2) if so - ensure we have a full set (error if not) and create annotation --- 3) if not, just return expr -exprAndTypeFromParts :: - (MonadError (Error Annotation) m, Monoid ann) => - DefIdentifier -> - [DefPart ann] -> - Expr Name ann -> - m (Expr Name ann) -exprAndTypeFromParts def parts expr = do - let expr' = - foldr - ( \part rest -> case part of - (DefArg ident) -> MyLambda mempty ident rest - (DefTypedArg ident _) -> MyLambda mempty ident rest - (DefType _) -> rest - ) - expr - parts - -- if we only have un-typed args, don't bother, we only want them as - -- placeholders - if not (includesExplicitTypes parts) - then pure expr' - else do - if includesReturnType parts - then pure () - else throwError (ModuleErr (DefMissingReturnType def)) - mt <- - foldr - ( \part mRest -> do - rest <- mRest - case part of - (DefArg (Identifier _ name)) -> - throwError (ModuleErr (DefMissingTypeAnnotation def name)) - (DefTypedArg _ thisMt) -> pure $ case rest of - Just rest' -> - Just - (MTFunction mempty thisMt rest') - _ -> Just thisMt - (DefType thisMt) -> pure $ case rest of - Just rest' -> - Just - (MTFunction mempty rest' thisMt) - _ -> Just thisMt - ) - (pure Nothing) - parts - pure $ addAnnotation mt expr' diff --git a/compiler/src/Language/Mimsa/Modules/HashModule.hs b/compiler/src/Language/Mimsa/Modules/HashModule.hs deleted file mode 100644 index 73eb81a6..00000000 --- a/compiler/src/Language/Mimsa/Modules/HashModule.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Language.Mimsa.Modules.HashModule (serializeModule, deserializeModule) where - -import qualified Data.Aeson as JSON -import Data.Bifunctor -import qualified Data.ByteString.Lazy as LBS -import Data.Coerce -import Data.Functor -import Language.Mimsa.Core -import Language.Mimsa.Store.Hashing -import Language.Mimsa.Types.Project.ProjectHash - --- we remove annotations before producing the hash --- so formatting does not affect it -hashModule :: Module ann -> (LBS.ByteString, ModuleHash) -hashModule mod' = second coerce . contentAndHash $ mod' $> () - --- this is the only encode we should be doing -serializeModule :: Module ann -> (LBS.ByteString, ModuleHash) -serializeModule = hashModule - --- this is the only json decode we should be doing -deserializeModule :: LBS.ByteString -> Maybe (Module ()) -deserializeModule = - JSON.decode diff --git a/compiler/src/Language/Mimsa/Modules/Monad.hs b/compiler/src/Language/Mimsa/Modules/Monad.hs deleted file mode 100644 index 77bb035a..00000000 --- a/compiler/src/Language/Mimsa/Modules/Monad.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Modules.Monad - ( lookupModule, - lookupModuleDep, - lookupModuleType, - errorIfExpressionAlreadyDefined, - checkDataType, - errorIfImportAlreadyDefined, - errorIfTypeImportAlreadyDefined, - ) -where - -import Control.Monad (when) -import Control.Monad.Except -import Data.Coerce -import Data.Foldable -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Types.Error - -lookupModule :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module ann) -> - ModuleHash -> - m (Module ann) -lookupModule mods modHash = do - case M.lookup modHash mods of - Just foundModule -> pure foundModule - _ -> throwError (ModuleErr (MissingModule modHash)) - -lookupModuleDep :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module (Type Annotation)) -> - DefIdentifier -> - ModuleHash -> - m (Expr Name (Type Annotation)) -lookupModuleDep typecheckedModules def modHash = do - case M.lookup modHash typecheckedModules of - Just mod' -> - case M.lookup def (moExpressions mod') of - Just expr -> pure expr - _ -> throwError (ModuleErr (MissingModuleDep def modHash)) - _ -> throwError (ModuleErr (MissingModule modHash)) - -lookupModuleType :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module (Type Annotation)) -> - TypeName -> - ModuleHash -> - m DataType -lookupModuleType typecheckedModules typeName modHash = do - case M.lookup modHash typecheckedModules of - Just mod' -> - case M.lookup typeName (moDataTypes mod') of - Just dt -> pure dt - _ -> throwError (ModuleErr (MissingModuleTypeDep typeName modHash)) - _ -> throwError (ModuleErr (MissingModule modHash)) - -errorIfExpressionAlreadyDefined :: - (MonadError (Error Annotation) m) => - Module ann -> - DefIdentifier -> - m () -errorIfExpressionAlreadyDefined mod' def = - when - ( M.member def (moExpressions mod') - || M.member def (moExpressionImports mod') - ) - (throwError (ModuleErr $ DuplicateDefinition def)) - -checkDataType :: - (MonadError (Error Annotation) m) => - Module ann -> - DataType -> - m () -checkDataType mod' (DataType typeName _ constructors) = do - errorIfTypeAlreadyDefined mod' (coerce typeName) - traverse_ (errorIfConstructorAlreadyDefined mod') (M.keys constructors) - -errorIfTypeAlreadyDefined :: - (MonadError (Error Annotation) m) => - Module ann -> - TypeName -> - m () -errorIfTypeAlreadyDefined mod' typeName = - when - ( M.member typeName (moDataTypes mod') - || M.member typeName (moDataTypeImports mod') - ) - (throwError (ModuleErr $ DuplicateTypeName typeName)) - -errorIfConstructorAlreadyDefined :: - (MonadError (Error Annotation) m) => - Module ann -> - TyCon -> - m () -errorIfConstructorAlreadyDefined mod' tyCon = - let allCons = mconcat (M.keysSet . dtConstructors <$> M.elems (moDataTypes mod')) - in when - (S.member tyCon allCons) - (throwError (ModuleErr $ DuplicateConstructor tyCon)) - -errorIfImportAlreadyDefined :: - (MonadError (Error Annotation) m) => - Module ann -> - DefIdentifier -> - ModuleHash -> - m () -errorIfImportAlreadyDefined mod' def moduleHash = - when - ( M.member def (moExpressions mod') - || M.member def (moExpressionImports mod') - ) - (throwError (ModuleErr $ DefinitionConflictsWithImport def moduleHash)) - -errorIfTypeImportAlreadyDefined :: - (MonadError (Error Annotation) m) => - Module ann -> - TypeName -> - ModuleHash -> - m () -errorIfTypeImportAlreadyDefined mod' typeName moduleHash = - when - ( M.member typeName (moDataTypes mod') - || M.member typeName (moDataTypeImports mod') - ) - (throwError (ModuleErr $ TypeConflictsWithImport typeName moduleHash)) diff --git a/compiler/src/Language/Mimsa/Modules/Parse.hs b/compiler/src/Language/Mimsa/Modules/Parse.hs deleted file mode 100644 index a8d3773e..00000000 --- a/compiler/src/Language/Mimsa/Modules/Parse.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Modules.Parse (parseModule) where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Map.Strict (Map) -import Data.Text (Text) -import Language.Mimsa.Core (Annotation, Module, ModuleHash) -import qualified Language.Mimsa.Core as Parser -import Language.Mimsa.Modules.FromParts -import Language.Mimsa.Types.Error - -parseModule :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module Annotation) -> - Text -> - m (Module Annotation) -parseModule modules input = do - moduleItems <- - liftEither $ - first (ParseError input) (Parser.parseModule input) - -- create module from parsed items - moduleFromModuleParts modules moduleItems diff --git a/compiler/src/Language/Mimsa/Modules/Prelude.hs b/compiler/src/Language/Mimsa/Modules/Prelude.hs deleted file mode 100644 index fcbc17a6..00000000 --- a/compiler/src/Language/Mimsa/Modules/Prelude.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Modules.Prelude - ( maybeInput, - preludeInput, - stateInput, - parserInput, - nonEmptyArrayInput, - arrayInput, - stringInput, - monoidInput, - readerInput, - eitherInput, - theseInput, - treeInput, - ) -where - -import Data.FileEmbed -import Data.Text (Text) -import qualified Data.Text.Encoding as T - -maybeInput :: Text -maybeInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Maybe.mimsa" >>= embedFile) - -stateInput :: Text -stateInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/State.mimsa" >>= embedFile) - -preludeInput :: Text -preludeInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Prelude.mimsa" >>= embedFile) - -parserInput :: Text -parserInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Parser.mimsa" >>= embedFile) - -arrayInput :: Text -arrayInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Array.mimsa" >>= embedFile) - -nonEmptyArrayInput :: Text -nonEmptyArrayInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/NonEmptyArray.mimsa" >>= embedFile) - -stringInput :: Text -stringInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/String.mimsa" >>= embedFile) - -monoidInput :: Text -monoidInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Monoid.mimsa" >>= embedFile) - -readerInput :: Text -readerInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Reader.mimsa" >>= embedFile) - -eitherInput :: Text -eitherInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Either.mimsa" >>= embedFile) - -theseInput :: Text -theseInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/These.mimsa" >>= embedFile) - -treeInput :: Text -treeInput = T.decodeUtf8 $(makeRelativeToProject "static/modules/Tree.mimsa" >>= embedFile) diff --git a/compiler/src/Language/Mimsa/Modules/Pretty.hs b/compiler/src/Language/Mimsa/Modules/Pretty.hs deleted file mode 100644 index 21b6e569..00000000 --- a/compiler/src/Language/Mimsa/Modules/Pretty.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Modules.Pretty (modulePretty, filterExported) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Types.Typechecker -import Prettyprinter - --- | display types for module in a nice way -modulePretty :: Module (Type Annotation) -> Doc a -modulePretty mod' = - let prettyExp (k, a) = indentMulti 2 (prettyDoc k <> ":" <+> prettyDoc (getTypeFromAnn a)) - prettyType (k, a) = indentMulti 2 (prettyDoc k <> ":" <+> prettyDoc a) - in align - ( encloseSep - lbrace - rbrace - comma - ( ( prettyExp - <$> M.toList (moExpressions mod') - ) - <> ( prettyType - <$> M.toList (moDataTypes mod') - ) - ) - ) - -filterByKey :: (k -> Bool) -> Map k a -> Map k a -filterByKey f = M.filterWithKey (\k _ -> f k) - -filterExported :: Module ann -> Module ann -filterExported mod' = - mod' - { moDataTypes = - filterByKey - (\k -> S.member k (moDataTypeExports mod')) - (moDataTypes mod'), - moExpressions = - filterByKey - (\k -> S.member k (moExpressionExports mod')) - (moExpressions mod') - } diff --git a/compiler/src/Language/Mimsa/Modules/ToStoreExprs.hs b/compiler/src/Language/Mimsa/Modules/ToStoreExprs.hs deleted file mode 100644 index e5a0c66b..00000000 --- a/compiler/src/Language/Mimsa/Modules/ToStoreExprs.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Modules.ToStoreExprs (toStoreExpressions, CompiledModule (..)) where - -import Control.Monad.Except -import Control.Monad.Identity -import Data.Bifunctor -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Helpers.Build as Build -import Language.Mimsa.Core -import Language.Mimsa.Modules.Dependencies -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Uses -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store - -data CompiledModule ann = CompiledModule - { cmStore :: Store ann, - cmExprs :: Map DefIdentifier ExprHash - } - deriving stock (Eq, Ord, Show, Functor) - -instance Semigroup (CompiledModule ann) where - (CompiledModule a b) <> (CompiledModule a' b') = - CompiledModule (a <> a') (b <> b') - -instance Monoid (CompiledModule ann) where - mempty = CompiledModule mempty mempty - -instance (Printer ann) => Printer (CompiledModule ann) where - prettyPrint (CompiledModule store exprs) = - prettyPrint - ( M.fromList - [ ("store" :: Text, prettyPrint store), - ("exprs", prettyPrint exprs) - ] - ) - -toStoreExpressions :: - ( MonadError (Error Annotation) m, - Eq ann, - Show ann - ) => - Map ModuleHash (Module (Type ann)) -> - Module (Type ann) -> - m (CompiledModule (Type ann)) -toStoreExpressions typecheckedModules inputModule = do - allCompiledModules <- compileAllModules typecheckedModules inputModule - let (_, rootModuleHash) = serializeModule inputModule - case M.lookup rootModuleHash allCompiledModules of - Just (CompiledModule _ compiledMod) -> - -- we want the compiled module for the main thing but with all the store - -- items - let withBigStore = mconcat (M.elems allCompiledModules) - in pure $ withBigStore {cmExprs = compiledMod} - Nothing -> throwError (ModuleErr $ MissingModule rootModuleHash) - --- if `b` needs `a`, and `c` needs `b`, add `a` to the deps for `c` -includeTransitiveDeps :: (Eq a, Ord k, Show k) => Map k (a, Set k) -> Map k (a, Set k) -includeTransitiveDeps depsMap = runIdentity $ do - let state = - Build.State - { Build.stInputs = - ( \(a, deps') -> - Build.Plan - { Build.jbDeps = deps', - Build.jbInput = a - } - ) - <$> depsMap, - Build.stOutputs = mempty - } - - let action deps' a = do - let allDeps = M.keysSet deps' <> foldMap snd deps' - pure (a, allDeps) - - Build.stOutputs <$> Build.doJobs action state - ---- compile many modules -compileAllModules :: - ( MonadError (Error Annotation) m, - Eq ann, - Show ann - ) => - Map ModuleHash (Module (Type ann)) -> - Module (Type ann) -> - m (Map ModuleHash (CompiledModule (Type ann))) -compileAllModules myDeps rootModule = do - -- which other modules do we need to compile in order to compile this one? - inputWithDeps <- includeTransitiveDeps <$> getModuleDeps myDeps rootModule - - let state = - Build.State - { Build.stInputs = - ( \(mod', deps) -> - Build.Plan - { Build.jbDeps = deps, - Build.jbInput = mod' - } - ) - <$> inputWithDeps, - Build.stOutputs = mempty - } - -- go! - Build.stOutputs - <$> Build.doJobs compileModuleDefinitions state - ---- compile a module into StoreExpressions -compileModuleDefinitions :: - ( MonadError (Error Annotation) m, - Eq ann - ) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - m (CompiledModule (Type ann)) -compileModuleDefinitions compiledModules inputModule = do - -- create initial state for builder - -- we tag each StoreExpression we've found with the deps it needs - inputWithDeps <- - getDependencies extractUsesTyped inputModule - - let inputWithDepsAndName = M.mapWithKey (,) inputWithDeps - - let state = - Build.State - { Build.stInputs = - ( \(name, (expr, deps, uses)) -> - Build.Plan - { Build.jbDeps = deps, - Build.jbInput = (name, expr, uses) - } - ) - <$> inputWithDepsAndName, - Build.stOutputs = mempty - } - - -- go! - storeExprs <- - Build.stOutputs - <$> Build.doJobs (toStoreExpression compiledModules inputModule) state - - pure $ - CompiledModule - { cmStore = toStore storeExprs, - cmExprs = getStoreExpressionHash <$> storeExprs - } - -toStoreExpression :: - ( MonadError (Error Annotation) m - ) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - (DefIdentifier, DepType (Type ann), Set Entity) -> - m (StoreExpression (Type ann)) -toStoreExpression compiledModules inputModule inputs (_, dep, uses) = - case dep of - (DTExpr expr) -> exprToStoreExpression compiledModules inputModule inputs (expr, uses) - (DTData dt) -> dataTypeToStoreExpression compiledModules inputModule inputs dt - --- this is crap, need to add type bindings -dataTypeToStoreExpression :: - ( MonadError (Error Annotation) m - ) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - DataType -> - m (StoreExpression (Type ann)) -dataTypeToStoreExpression compiledModules inputModule inputs dt = do - let uses = extractDataTypeUses dt - types <- typesFromEntities compiledModules inputModule inputs uses - pure $ StoreDataType dt types - --- to make a store expression we need to --- a) work out all the deps this expression has --- - values --- - infix operators --- - type constructors --- - type names --- b) map them to specific ExprHashes -exprToStoreExpression :: - (MonadError (Error Annotation) m) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - (Expr Name (Type ann), Set Entity) -> - m (StoreExpression (Type ann)) -exprToStoreExpression compiledModules inputModule inputs (expr, uses) = do - bindings <- bindingsFromEntities compiledModules inputModule inputs uses - infixes <- infixesFromEntities inputs uses - constructors <- constructorsFromEntities compiledModules inputModule inputs uses - types <- typesFromEntities compiledModules inputModule inputs uses - pure $ StoreExpression expr bindings constructors infixes types - --- given our dependencies and the entities used by the expression, create the --- bindings -bindingsFromEntities :: - (MonadError (Error Annotation) m) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - Set Entity -> - m (Map (Maybe ModuleName, Name) ExprHash) -bindingsFromEntities compiledModules inputModule inputs uses = do - let fromUse = \case - EName name -> case M.lookup (DIName name) inputs of - Just se -> pure $ M.singleton (Nothing, name) (getStoreExpressionHash se) - _ -> throwError (ModuleErr $ CannotFindValues (S.singleton (DIName name))) - ENamespacedName modName name -> - case resolveNamespacedName compiledModules inputModule modName name of - Just hash -> pure $ M.singleton (Just modName, name) hash - _ -> pure mempty -- should this be an error? - _ -> pure mempty - - -- combine results - mconcat <$> traverse fromUse (S.toList uses) - --- given our dependencies and the entities used by the expression, create the --- bindings -infixesFromEntities :: - (MonadError (Error Annotation) m) => - Map DefIdentifier (StoreExpression (Type ann)) -> - Set Entity -> - m (Map InfixOp ExprHash) -infixesFromEntities inputs uses = do - let fromUse = \case - EInfix infixOp -> case M.lookup (DIInfix infixOp) inputs of - Just se -> pure $ M.singleton infixOp (getStoreExpressionHash se) - _ -> throwError (ModuleErr $ CannotFindValues (S.singleton (DIInfix infixOp))) - _ -> pure mempty - - -- combine results - mconcat <$> traverse fromUse (S.toList uses) - --- turns a bunch of StoreExpressions into a Store -toStore :: Map a (StoreExpression ann) -> Store ann -toStore = Store . M.fromList . fmap (\a -> (getStoreExpressionHash a, a)) . M.elems - --- | where can I find this function? -resolveNamespacedName :: - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - ModuleName -> - Name -> - Maybe ExprHash -resolveNamespacedName compiledModules inputModule modName name = do - -- find out which module the modName refers to - modHash <- M.lookup modName (moNamedImports inputModule) - -- find the module in our pile of already compiled modules - compiledMod <- M.lookup modHash compiledModules - -- lookup the name in the module - M.lookup (DIName name) (cmExprs compiledMod) - -lookupImportedModule :: Module ann -> ModuleName -> Either ModuleError ModuleHash -lookupImportedModule inputModule modName = - let namedImports = moNamedImports inputModule - in case M.lookup modName namedImports of - Just modHash -> pure modHash - Nothing -> - throwError - ( NamedImportNotFound - (M.keysSet namedImports) - modName - ) - -lookupCompiledModule :: - Map ModuleHash (CompiledModule ann) -> - ModuleHash -> - Either ModuleError (CompiledModule ann) -lookupCompiledModule mods modHash = do - case M.lookup modHash mods of - Just foundModule -> pure foundModule - _ -> throwError (MissingModule modHash) - -lookupCompiledDef :: CompiledModule ann -> DefIdentifier -> Either ModuleError ExprHash -lookupCompiledDef compiledModule defId = - let compiledExprs = cmExprs compiledModule - in case M.lookup defId compiledExprs of - Just exprHash -> pure exprHash - Nothing -> throwError (CannotFindValues (S.singleton defId)) - --- filter data types out, and put in a map keyed by TyCon -dataTypesByTyCon :: - Map DefIdentifier (StoreExpression (Type ann)) -> - Map - TyCon - ( StoreExpression (Type ann) - ) -dataTypesByTyCon items = - let withSe se = - fmap (se,) - . extractDataType - $ se - - dataTypes = mapMaybe withSe (M.elems items) - in mconcat $ - ( \(se, DataType _ _ constructors) -> - constructors $> se - ) - <$> dataTypes - -extractDataType :: StoreExpression ann -> Maybe DataType -extractDataType (StoreDataType dt _) = Just dt -extractDataType _ = Nothing - -flattenCompiled :: - CompiledModule (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -flattenCompiled cm = - let lookupHash exprHash = - M.lookup exprHash (getStore $ cmStore cm) - in M.mapMaybe lookupHash (cmExprs cm) - --- | given our dependencies and the entities used by the expressions, create --- the type bindings -constructorsFromEntities :: - (MonadError (Error Annotation) m) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - Set Entity -> - m (Map (Maybe ModuleName, TyCon) ExprHash) -constructorsFromEntities compiledModules inputModule inputs uses = do - let fromUse = \case - EConstructor tyCon -> - case getStoreExpressionHash <$> M.lookup tyCon (dataTypesByTyCon inputs) of - Just exprHash -> pure $ M.singleton (Nothing, tyCon) exprHash - _ -> throwError (ModuleErr $ CannotFindConstructors (S.singleton tyCon)) - ENamespacedConstructor modName tyCon -> liftEither $ - first ModuleErr $ do - -- find out which module the modName refers to - modHash <- lookupImportedModule inputModule modName - - -- find the module in our pile of already compiled modules - compiledMod <- lookupCompiledModule compiledModules modHash - - -- lookup the name in the module - case M.lookup tyCon (dataTypesByTyCon (flattenCompiled compiledMod)) of - Just se -> pure $ M.singleton (Just modName, tyCon) (getStoreExpressionHash se) - Nothing -> throwError (CannotFindConstructors (S.singleton tyCon)) - _ -> pure mempty - - -- combine results - mconcat <$> traverse fromUse (S.toList uses) - --- this is weird and probably bad, but if we can't find a type, just look --- through all the other shit we found and look for something with the right --- name --- maybe in future to reduce how bad this is, explode if more than one are found? -findTypeInCompiled :: - Map ModuleHash (CompiledModule (Type ann)) -> - TypeName -> - Either ModuleError ExprHash -findTypeInCompiled compiledModules typeName = do - let lookInCompiled cm = - M.lookup (DIType typeName) (cmExprs cm) - >>= flip M.lookup (getStore $ cmStore cm) - case listToMaybe $ mapMaybe lookInCompiled (M.elems compiledModules) of - Just exprHash -> pure (getStoreExpressionHash exprHash) - _ -> throwError (CannotFindTypes (S.singleton typeName)) - --- | given our dependencies and the entities used by the expressions, create --- the type bindings -typesFromEntities :: - (MonadError (Error Annotation) m) => - Map ModuleHash (CompiledModule (Type ann)) -> - Module (Type ann) -> - Map DefIdentifier (StoreExpression (Type ann)) -> - Set Entity -> - m (Map (Maybe ModuleName, TypeName) ExprHash) -typesFromEntities compiledModules inputModule inputs uses = do - let fromUse = \case - EType typeName -> - case getStoreExpressionHash <$> M.lookup (DIType typeName) inputs of - Just exprHash -> pure $ M.singleton (Nothing, typeName) exprHash - _ -> throwError (ModuleErr $ CannotFindTypes (S.singleton typeName)) - ENamespacedType modName typeName -> - liftEither $ - first ModuleErr $ do - let perhapsExprHash = do - -- find out which module the modName refers to - modHash <- lookupImportedModule inputModule modName - -- find the module in our pile of already compiled modules - compiledMod <- lookupCompiledModule compiledModules modHash - -- lookup the name in the module - lookupCompiledDef compiledMod (DIType typeName) - - exprHash <- case perhapsExprHash of - Right exprHash -> pure exprHash - Left _ -> findTypeInCompiled compiledModules typeName - -- return it - pure (M.singleton (Just modName, typeName) exprHash) - _ -> pure mempty - - -- combine results - mconcat <$> traverse fromUse (S.toList uses) diff --git a/compiler/src/Language/Mimsa/Modules/Typecheck.hs b/compiler/src/Language/Mimsa/Modules/Typecheck.hs deleted file mode 100644 index 235b61e3..00000000 --- a/compiler/src/Language/Mimsa/Modules/Typecheck.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Modules.Typecheck (typecheckAllModules) where - -import Control.Monad.Except -import Data.Bifunctor -import Data.Coerce -import Data.Foldable -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Helpers.Build as Build -import Language.Mimsa.Core -import Language.Mimsa.Modules.Dependencies -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Monad -import Language.Mimsa.Modules.Uses -import Language.Mimsa.Typechecker.CreateEnv -import Language.Mimsa.Typechecker.DataTypes -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Typechecker.Typecheck -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Typechecker - --- given the upstream modules, typecheck a module --- 1. recursively fetch imports from Reader environment --- 2. setup builder input --- 3. do it! -typecheckAllModules :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module Annotation) -> - Text -> - Module Annotation -> - m (Map ModuleHash (Module (Type Annotation))) -typecheckAllModules modules rootModuleInput rootModule = do - -- create initial state for builder - -- we tag each StoreExpression we've found with the deps it needs - inputWithDeps <- getModuleDeps modules rootModule - - let (_, rootModuleHash) = serializeModule rootModule - - let stInputs = - ( \(mod', deps) -> - Build.Plan - { Build.jbDeps = deps, - Build.jbInput = - let (_, moduleHash) = serializeModule mod' - in if moduleHash == rootModuleHash - then (rootModuleInput, mod') - else (prettyPrint mod', mod') - } - ) - <$> inputWithDeps - - let state = - Build.State - { Build.stInputs = stInputs, - Build.stOutputs = mempty - } - -- go! - Build.stOutputs - <$> Build.doJobs - ( \deps (input, mod') -> - typecheckAllModuleDefs deps input mod' - ) - state - ---- typecheck a single module -typecheckAllModuleDefs :: - (MonadError (Error Annotation) m) => - Map ModuleHash (Module (Type Annotation)) -> - Text -> - Module Annotation -> - m (Module (Type Annotation)) -typecheckAllModuleDefs typecheckedDeps input inputModule = do - -- create initial state for builder - -- we tag each StoreExpression we've found with the deps it needs - inputWithDeps <- getDependencies extractUses inputModule - let inputWithDepsAndName = M.mapWithKey (,) inputWithDeps - - let stInputs = - ( \(name, (expr, deps, _)) -> - Build.Plan - { Build.jbDeps = deps, - Build.jbInput = (name, expr) - } - ) - <$> inputWithDepsAndName - - let state = - Build.State - { Build.stInputs = stInputs, - Build.stOutputs = mempty - } - -- go! - typecheckedDefs <- - Build.stOutputs - <$> Build.doJobs (typecheckOneDef input inputModule typecheckedDeps) state - - -- replace input module with typechecked versions - pure $ - inputModule - { moExpressions = filterExprs typecheckedDefs - } - --- return type of module as a MTRecord of dep -> monotype --- TODO: module should probably be it's own MTModule or something --- as we'll want to pass them about at some point I think --- also if any types defined in this module are used in it's types, namespace --- those too --- so if the module defines `export type Tree a = ...` --- and is imported as `Tree`, change "Tree" types to "Tree.Tree" so they unify -getModuleType :: ModuleName -> Module (Type Annotation) -> Type Annotation -getModuleType modName mod' = - let defs = - M.filterWithKey - (\k _ -> S.member k (moExpressionExports mod')) - (moExpressions mod') - moduleTypeNames = M.keysSet (moDataTypes mod') - in MTRecord - mempty - ( addNamespaceToType modName moduleTypeNames - . getTypeFromAnn - <$> filterNameDefs defs - ) - Nothing - -addNamespaceToType :: ModuleName -> Set TypeName -> MonoType -> MonoType -addNamespaceToType modName swapTypes = - addNS - where - addNS old@(MTConstructor ann Nothing typeName) = - if S.member typeName swapTypes - then MTConstructor ann (Just modName) typeName - else old - addNS other = mapType addNS other - --- pass types to the typechecker -makeTypeDeclMap :: - Map ModuleHash (Module (Type Annotation)) -> - Map TypeName DataType -> - Module ann -> - Map (Maybe ModuleName, TypeName) DataType -makeTypeDeclMap typecheckedModules importedTypes inputModule = - let regularScopeTypes = - mapKeys - (\tyCon -> (Nothing, coerce tyCon)) - ( moDataTypes inputModule - <> importedTypes - ) - namespacedTypes = - mconcat $ - fmap - ( \(modName, modHash) -> - let byTyCon = case M.lookup modHash typecheckedModules of - Just foundModule -> - getModuleDataTypesByConstructor foundModule - _ -> error "could not find module" - in mapKeys (Just modName,) byTyCon - ) - (M.toList $ moNamedImports inputModule) - in regularScopeTypes <> namespacedTypes - --- for any given module, return a Map of its DataTypes -getModuleDataTypesByConstructor :: Module ann -> Map TypeName DataType -getModuleDataTypesByConstructor inputModule = - let exportedDts = - M.filterWithKey - ( \k _ -> - S.member - k - (moDataTypeExports inputModule) - ) - (moDataTypes inputModule) - in mapKeys coerce exportedDts - -filterNameDefs :: Map DefIdentifier a -> Map Name a -filterNameDefs = - filterMapKeys - ( \case - DIName name -> Just name - _ -> Nothing - ) - -filterInfixDefs :: Map DefIdentifier a -> Map InfixOp a -filterInfixDefs = - filterMapKeys - ( \case - DIInfix infixOp -> Just infixOp - _ -> Nothing - ) - -createTypecheckEnvironment :: - (MonadError (Error Annotation) m) => - Module Annotation -> - Map DefIdentifier (Expr Name MonoType) -> - Map ModuleHash (Module (Type Annotation)) -> - m Environment -createTypecheckEnvironment inputModule deps typecheckedModules = do - -- these need to be typechecked - importedDeps <- - M.traverseWithKey - (lookupModuleDep typecheckedModules) - (moExpressionImports inputModule) - - importedTypes <- - M.traverseWithKey - (lookupModuleType typecheckedModules) - (moDataTypeImports inputModule) - - pure $ - createEnv - (getTypeFromAnn <$> filterNameDefs (deps <> importedDeps)) - (makeTypeDeclMap typecheckedModules importedTypes inputModule) - (getTypeFromAnn <$> filterInfixDefs (deps <> importedDeps)) - (getModuleTypes inputModule typecheckedModules) - -getModuleTypes :: - Module Annotation -> - Map ModuleHash (Module (Type Annotation)) -> - Map ModuleHash (Map Name MonoType) -getModuleTypes inputModule typecheckedModules = - let getTypes (modName, hash) = case M.lookup hash typecheckedModules of - Just mod' -> case getModuleType modName mod' of - MTRecord _ parts _ -> (hash, parts) - _ -> error "expected getModuleType to return a MTRecord but it did not" - Nothing -> error "Could not find module for hash in getModuleTypes" - in M.fromList (getTypes <$> M.toList (moNamedImports inputModule)) - -namespacedModules :: - Module Annotation -> - Map ModuleHash (Module (Type Annotation)) -> - Map ModuleName (ModuleHash, Set Name) -namespacedModules inputModule typecheckedModules = - let getPair hash = case M.lookup hash typecheckedModules of - Just mod' -> (hash, namesOnly (moExpressionExports mod')) - Nothing -> (hash, mempty) - in getPair <$> moNamedImports inputModule - -namesOnly :: Set DefIdentifier -> Set Name -namesOnly = - S.fromList - . mapMaybe - ( \case - DIName name -> Just name - _ -> Nothing - ) - . S.toList - --- given types for other required definition, typecheck a definition -typecheckOneDef :: - (MonadError (Error Annotation) m) => - Text -> - Module Annotation -> - Map ModuleHash (Module (Type Annotation)) -> - Map DefIdentifier (DepType MonoType) -> - (DefIdentifier, DepType Annotation) -> - m (DepType MonoType) -typecheckOneDef input inputModule typecheckedModules deps (def, dep) = - case dep of - DTExpr expr -> - DTExpr - <$> typecheckOneExprDef input inputModule typecheckedModules (filterExprs deps) (def, expr) - DTData dt -> - DTData - <$> typecheckOneTypeDef input inputModule typecheckedModules (filterDataTypes deps) (def, dt) - -_keyDeps :: - Module Annotation -> - Map DefIdentifier DataType -> - Map (Maybe ModuleName, TypeName) DataType -_keyDeps _mod = - filterMapKeys - ( \case - DIType typeName -> Just (Nothing, typeName) - _ -> Nothing - ) - --- typechecking in this context means "does this data type make sense" --- and "do we know about all external datatypes it mentions" -typecheckOneTypeDef :: - (MonadError (Error Annotation) m) => - Text -> - Module Annotation -> - Map ModuleHash (Module (Type Annotation)) -> - Map DefIdentifier DataType -> - (DefIdentifier, DataType) -> - m DataType -typecheckOneTypeDef input _inputModule _typecheckedModules _typeDeps (def, dt) = do - -- ideally we'd attach annotations to the DefIdentifiers or something, so we - -- can show the original code in errors - let ann = mempty - - let action = do - validateConstructorsArentBuiltIns ann dt - validateDataTypeVariables ann dt - -- validateDataTypeUses (keyDeps inputModule typeDeps) ann dt - - -- typecheck it - liftEither $ - first - (ModuleErr . DefDoesNotTypeCheck input def) - action - - pure dt - --- when adding a new datatype, check none of the constructors are built in ones -validateConstructorsArentBuiltIns :: - (MonadError TypeError m) => - Annotation -> - DataType -> - m () -validateConstructorsArentBuiltIns ann (DataType _ _ constructors) = do - traverse_ - ( \(tyCon, _) -> - case lookupBuiltIn (coerce tyCon) of - Just _ -> throwError (CannotUseBuiltInTypeAsConstructor ann (coerce tyCon)) - _ -> pure () - ) - (M.toList constructors) - --- check all types vars are part of dataytpe definition --- `type Maybe a | Just b` would be a problem because `b` is a mystery -validateDataTypeVariables :: - (MonadError TypeError m) => - Annotation -> - DataType -> - m () -validateDataTypeVariables ann (DataType typeName vars constructors) = - let requiredForCons = foldMap getVariablesInType - requiredVars = foldMap requiredForCons constructors - availableVars = S.fromList vars - unavailableVars = S.filter (`S.notMember` availableVars) requiredVars - in if S.null unavailableVars - then pure () - else - throwError $ - TypeVariablesNotInDataType ann typeName unavailableVars availableVars - --- type Broken a = Broken (Maybe a a) --- should not make sense because it's using `Maybe` wrong -_validateDataTypeUses :: - (MonadError TypeError m) => - Map (Maybe ModuleName, TypeName) DataType -> - Annotation -> - DataType -> - m () -_validateDataTypeUses deps ann (DataType _ _ constructors) = do - let allUses = foldMap (foldMap getConstructorUses) (M.elems constructors) - traverse_ - ( \(modName, typeName, kind) -> do - let foundKind = lookupDepKind deps (modName, typeName) - if foundKind == kind - then pure () - else throwError (KindMismatchInDataDeclaration ann modName typeName kind foundKind) - ) - (S.toList allUses) - -lookupDepKind :: - Map (Maybe ModuleName, TypeName) DataType -> - (Maybe ModuleName, TypeName) -> - Int -lookupDepKind deps defId = - case M.lookup defId deps of - Just (DataType _ vars _) -> length vars - Nothing -> 0 - --- which vars are used in this type? -getVariablesInType :: Type ann -> Set Name -getVariablesInType (MTVar _ (TVScopedVar _ name)) = S.singleton name -getVariablesInType (MTVar _ (TVName n)) = S.singleton (coerce n) -getVariablesInType other = withMonoidType getVariablesInType other - --- TODO: this is wrong -getConstructorUses :: Type ann -> Set (Maybe ModuleName, TypeName, Int) -getConstructorUses (MTConstructor _ modName typeName) = - S.singleton (modName, typeName, 0) -getConstructorUses other = withMonoidType getConstructorUses other - --- given types for other required definition, typecheck a definition -typecheckOneExprDef :: - (MonadError (Error Annotation) m) => - Text -> - Module Annotation -> - Map ModuleHash (Module (Type Annotation)) -> - Map DefIdentifier (Expr Name MonoType) -> - (DefIdentifier, Expr Name Annotation) -> - m (Expr Name MonoType) -typecheckOneExprDef input inputModule typecheckedModules deps (def, expr) = do - let typeMap = getTypeFromAnn <$> filterNameDefs deps - - -- number the vars - numberedExpr <- - liftEither $ - first - (ModuleErr . DefDoesNotTypeCheck input def) - ( addNumbersToExpression - (M.keysSet (filterNameDefs deps)) - (coerce <$> filterNameDefs (moExpressionImports inputModule)) - (namespacedModules inputModule typecheckedModules) - expr - ) - - -- initial typechecking environment - env <- createTypecheckEnvironment inputModule deps typecheckedModules - - -- typecheck it - (_subs, _constraints, typedExpr, _mt) <- - liftEither $ - first - (ModuleErr . DefDoesNotTypeCheck input def) - (typecheck typeMap env numberedExpr) - - pure (first fst typedExpr) diff --git a/compiler/src/Language/Mimsa/Modules/Uses.hs b/compiler/src/Language/Mimsa/Modules/Uses.hs deleted file mode 100644 index ce2832a3..00000000 --- a/compiler/src/Language/Mimsa/Modules/Uses.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Modules.Uses - ( extractUses, - extractUsesTyped, - extractDataTypeUses, - ) -where - -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core - -extractUses :: (Eq ann) => Expr Name ann -> Set Entity -extractUses expr = - let typeNames = dataTypeNames expr - in S.filter - (\ent -> not $ S.member ent typeNames) - ( extractUses_ expr - ) - --- | extract uses in an expression annotated with types -extractUsesTyped :: (Eq ann) => Expr Name (Type ann) -> Set Entity -extractUsesTyped expr = - let typeNames = dataTypeNames expr - in S.filter - (\ent -> not $ S.member ent typeNames) - ( extractUses_ expr - <> foldMap extractTypeUses expr - ) - --- | find all uses of external vars, types, infix operators etc --- used in dependency analysis --- important - we must not count variables brought in via lambdas or let --- bindings as those aren't external deps -extractUses_ :: (Eq ann) => Expr Name ann -> Set Entity -extractUses_ (MyVar _ (Just modName) a) = S.singleton (ENamespacedName modName a) -extractUses_ (MyVar _ _ a) = S.singleton (EName a) -extractUses_ (MyAnnotation _ mt expr) = - extractUses_ expr <> extractTypeUses mt -extractUses_ (MyIf _ a b c) = - extractUses_ a <> extractUses_ b <> extractUses_ c -extractUses_ (MyLet _ ident a b) = - S.difference (extractUses_ a <> extractUses_ b) (extractIdentUses ident) -extractUses_ (MyLetPattern _ pat expr body) = - let patUses = extractPatternUses pat - in filterVarsIntroducedInPatterns - patUses - (extractUses_ expr <> extractUses_ body) -extractUses_ (MyInfix _ op a b) = - let infixUses = case op of - Custom infixOp -> S.singleton (EInfix infixOp) - _ -> mempty - in infixUses - <> extractUses_ a - <> extractUses_ b -extractUses_ (MyLambda _ ident a) = - S.difference (extractUses_ a) (extractIdentUses ident) -extractUses_ (MyApp _ a b) = extractUses_ a <> extractUses_ b -extractUses_ (MyLiteral _ _) = mempty -extractUses_ (MyTuple _ a as) = extractUses_ a <> foldMap extractUses_ as -extractUses_ (MyRecord _ map') = foldMap extractUses_ map' -extractUses_ (MyRecordAccess _ a _) = extractUses_ a -extractUses_ (MyTupleAccess _ a _) = extractUses_ a -extractUses_ (MyArray _ map') = foldMap extractUses_ map' -extractUses_ (MyConstructor _ (Just modName) tyCon) = - S.singleton (ENamespacedConstructor modName tyCon) -extractUses_ (MyConstructor _ Nothing tyCon) = - S.singleton (EConstructor tyCon) -extractUses_ (MyTypedHole _ _) = mempty -extractUses_ (MyPatternMatch _ match patterns) = - extractUses match <> mconcat patternUses - where - patternUses :: [Set Entity] - patternUses = - ( \(pat, expr) -> - filterVarsIntroducedInPatterns - (extractPatternUses pat) - (extractUses expr) - ) - <$> patterns - --- for vars, remove any vars introduced in patterns in the expressions --- for everything else, keep both -filterVarsIntroducedInPatterns :: Set Entity -> Set Entity -> Set Entity -filterVarsIntroducedInPatterns patUses exprUses = - let patVarUses = - S.filter - ( \case - EName _ -> True - EInfix _ -> True - _ -> False - ) - patUses - in S.filter (`S.notMember` patVarUses) (patUses <> exprUses) - -extractIdentUses :: Identifier Name ann -> Set Entity -extractIdentUses (Identifier _ name) = S.singleton (EName name) - -extractPatternUses :: (Eq ann) => Pattern Name ann -> Set Entity -extractPatternUses (PWildcard _) = mempty -extractPatternUses (PLit _ _) = mempty -extractPatternUses (PVar _ a) = S.singleton (EName a) -extractPatternUses (PRecord _ as) = - mconcat (extractPatternUses <$> M.elems as) -extractPatternUses (PTuple _ a as) = - extractPatternUses a <> foldMap extractPatternUses as -extractPatternUses (PConstructor _ maybeMod tyCon args) = - let modEntity = case maybeMod of - Just modName -> S.singleton (ENamespacedConstructor modName tyCon) - _ -> S.singleton (EConstructor tyCon) - in modEntity <> mconcat (extractPatternUses <$> args) -extractPatternUses (PArray _ as spread) = - mconcat (extractPatternUses <$> as) <> extractSpreadUses spread -extractPatternUses (PString _ a as) = - extractStringPart a <> extractStringPart as - -extractSpreadUses :: Spread Name ann -> Set Entity -extractSpreadUses NoSpread = mempty -extractSpreadUses (SpreadWildcard _) = mempty -extractSpreadUses (SpreadValue _ a) = S.singleton (EName a) - -extractStringPart :: StringPart Name ann -> Set Entity -extractStringPart (StrWildcard _) = mempty -extractStringPart (StrValue _ a) = S.singleton (EName a) - --- extract uses in a type -extractTypeUses :: Type ann -> Set Entity -extractTypeUses (MTConstructor _ (Just modName) typeName) = - S.singleton (ENamespacedType modName typeName) -extractTypeUses (MTConstructor _ Nothing typeName) = - S.singleton (EType typeName) -extractTypeUses other = withMonoidType extractTypeUses other - --- | find other types used in the declaration of a datatype -extractDataTypeUses :: DataType -> Set Entity -extractDataTypeUses (DataType typeName _ constructors) = - S.filter - (\entity -> entity /= EType typeName) - ( foldMap (foldMap extractTypeUses) constructors - ) - -dataTypeNames :: Expr Name ann -> Set Entity -dataTypeNames (MyLet _ _ expr body) = dataTypeNames expr <> dataTypeNames body -dataTypeNames _ = mempty diff --git a/compiler/src/Language/Mimsa/Project.hs b/compiler/src/Language/Mimsa/Project.hs deleted file mode 100644 index 1811641a..00000000 --- a/compiler/src/Language/Mimsa/Project.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.Mimsa.Project - ( module Language.Mimsa.Project.Helpers, - ) -where - -import Language.Mimsa.Project.Helpers diff --git a/compiler/src/Language/Mimsa/Project/Helpers.hs b/compiler/src/Language/Mimsa/Project/Helpers.hs deleted file mode 100644 index aacc491a..00000000 --- a/compiler/src/Language/Mimsa/Project/Helpers.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Language.Mimsa.Project.Helpers - ( fromStoreExpression, - fromModuleDeps, - fromStore, - fromModuleStore, - fromModule, - lookupModuleHash, - lookupExprHash, - lookupExprHashFromStore, - typeBindingsToVersioned, - bindingsToVersioned, - toVersioned, - projectFromSaved, - projectToSaved, - getCurrentBindings, - getCurrentTypeBindings, - getCurrentModules, - getItemsForAllVersions, - getDependencyHashes, - getModuleDependencyHashes, - lookupModuleName, - ) -where - -import Data.Coerce -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store - ----------- - -projectFromSaved :: - Map ModuleHash (Module ann) -> - Store ann -> - SaveProject -> - Project ann -projectFromSaved moduleStore store' sp = - Project - { prjStore = store', - prjModules = projectModules sp, - prjModuleStore = moduleStore - } - -projectToSaved :: Project a -> SaveProject -projectToSaved proj = - SaveProject - { projectVersion = 1, - projectModules = prjModules proj - } - -fromStoreExpression :: StoreExpression ann -> ExprHash -> Project ann -fromStoreExpression storeExpr exprHash = - mempty {prjStore = Store $ M.singleton exprHash storeExpr} - -fromModule :: ModuleName -> Module ann -> Project ann -fromModule modName newModule = - let (_, moduleHash) = serializeModule newModule - in mempty - { prjModules = VersionedMap $ M.singleton modName (pure moduleHash), - prjModuleStore = M.singleton moduleHash newModule - } - -fromStore :: Store ann -> Project ann -fromStore store' = mempty {prjStore = store'} - -fromModuleStore :: Map ModuleHash (Module ann) -> Project ann -fromModuleStore modules = mempty {prjModuleStore = modules} - --- | create a project where all the bindings of a store expression are --- available in global scope -fromModuleDeps :: Map ModuleHash (Module ann) -> Module ann -> Project ann -fromModuleDeps _moduleStore _mod' = - mempty - { prjModules = mempty - } - -lookupExprHash :: Project ann -> ExprHash -> Maybe (StoreExpression ann) -lookupExprHash project = - lookupExprHashFromStore (prjStore project) - -lookupExprHashFromStore :: Store ann -> ExprHash -> Maybe (StoreExpression ann) -lookupExprHashFromStore store exprHash' = - M.lookup exprHash' (getStore store) - -lookupModuleHash :: Project ann -> ModuleHash -> Maybe (Module ann) -lookupModuleHash project modHash = - M.lookup modHash (prjModuleStore project) - -lookupModuleName :: Project ann -> ModuleName -> Either (Set ModuleName) ModuleHash -lookupModuleName project modName = - let b = getCurrentModules . prjModules $ project - in case M.lookup modName b of - Just a -> pure a - _ -> Left (M.keysSet b) - -toVersioned :: Map k a -> VersionedMap k a -toVersioned b = VersionedMap (pure <$> b) - -bindingsToVersioned :: Bindings -> VersionedBindings -bindingsToVersioned (Bindings b) = VersionedMap (pure <$> b) - -typeBindingsToVersioned :: TypeBindings -> VersionedTypeBindings -typeBindingsToVersioned (TypeBindings b) = VersionedMap (pure <$> b) - -getCurrentBindings :: VersionedBindings -> Bindings -getCurrentBindings versioned = - Bindings (NE.last <$> getVersionedMap versioned) - -getCurrentTypeBindings :: VersionedTypeBindings -> TypeBindings -getCurrentTypeBindings versioned = - TypeBindings (NE.last <$> getVersionedMap versioned) - -getCurrentModules :: VersionedModules -> Map ModuleName ModuleHash -getCurrentModules = fmap NE.last . getVersionedMap - -getItemsForAllVersions :: (Ord a) => VersionedMap k a -> Set a -getItemsForAllVersions versioned = - mconcat $ M.elems (S.fromList . NE.toList <$> coerce versioned) - -getDependencyHashes :: StoreExpression ann -> Set ExprHash -getDependencyHashes = - S.fromList . M.elems . storeBindings - <> S.fromList . M.elems . storeTypeBindings - -getModuleDependencyHashes :: Module ann -> Set ModuleHash -getModuleDependencyHashes inputModule = - S.fromList - ( M.elems (moExpressionImports inputModule) - <> M.elems (moNamedImports inputModule) - ) diff --git a/compiler/src/Language/Mimsa/Project/SourceSpan.hs b/compiler/src/Language/Mimsa/Project/SourceSpan.hs deleted file mode 100644 index 28fad318..00000000 --- a/compiler/src/Language/Mimsa/Project/SourceSpan.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Language.Mimsa.Project.SourceSpan where - -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Project.SourceSpan - -lineLengths :: Text -> [Int] -lineLengths tx = T.length <$> T.lines tx - -toColumnAndRow :: [Int] -> Int -> (Int, Int) -toColumnAndRow = go 1 - where - go row [] col = - (row, col) - go row (line : rest) col - | (col - 1) >= line = - go (row + 1) rest (col - line - 1) - go row _ col = (row, col) - -sourceSpan :: Text -> Annotation -> Maybe SourceSpan -sourceSpan tx (Location start end) = - let (startRow, startCol) = - toColumnAndRow (lineLengths tx) start - (endRow, endCol) = - toColumnAndRow (lineLengths tx) end - in Just - ( SourceSpan - { ssRowStart = startRow, - ssRowEnd = endRow, - ssColStart = startCol + 1, - ssColEnd = endCol + 1 - } - ) -sourceSpan _ _ = Nothing diff --git a/compiler/src/Language/Mimsa/Project/Stdlib.hs b/compiler/src/Language/Mimsa/Project/Stdlib.hs deleted file mode 100644 index dcb30778..00000000 --- a/compiler/src/Language/Mimsa/Project/Stdlib.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Project.Stdlib - ( buildStdlib, - stdModules, - stdlib, - addModule, - ) -where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Helpers.Parse as Actions -import qualified Language.Mimsa.Actions.Modules.Bind as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Prelude -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project - -buildStdlib :: Either (Error Annotation) (Project Annotation) -buildStdlib = - Actions.run mempty stdModules >>= \(proj, _, _) -> pure proj - --- | these are files in /static/modules folder that we import -stdModules :: Actions.ActionM () -stdModules = do - maybeHash <- - addModule "Maybe" mempty maybeInput - preludeHash <- - addModule "Prelude" mempty preludeInput - arrayHash <- - addModule "Array" (M.fromList [("Maybe", maybeHash)]) arrayInput - nonEmptyArrayHash <- - addModule "NonEmptyArray" (M.fromList [("Array", arrayHash)]) nonEmptyArrayInput - _ <- - addModule "Either" mempty eitherInput - _ <- - addModule "Reader" (M.fromList [("Prelude", preludeHash)]) readerInput - _ <- - addModule "These" mempty theseInput - _ <- - addModule "Monoid" (M.fromList [("Array", arrayHash), ("Prelude", preludeHash), ("Maybe", maybeHash)]) monoidInput - _ <- - addModule "State" (M.fromList [("Prelude", preludeHash)]) stateInput - _ <- - addModule "String" (M.fromList [("Array", arrayHash)]) stringInput - _ <- - addModule - "Parser" - ( M.fromList - [ ("Maybe", maybeHash), - ("Prelude", preludeHash), - ("NonEmptyArray", nonEmptyArrayHash) - ] - ) - parserInput - _ <- - addModule "Tree" mempty treeInput - pure () - --- | add a module to the stdlib, adding some named imports -addModule :: ModuleName -> Map ModuleName ModuleHash -> Text -> Actions.ActionM ModuleHash -addModule moduleName deps input = do - mod' <- Actions.parseModule input - let modWithImports = mod' {moNamedImports = moNamedImports mod' <> deps} - _ <- Actions.bindModule modWithImports moduleName (prettyPrint modWithImports) - pure (snd $ serializeModule modWithImports) - -fromRight :: (Printer e) => Either e a -> a -fromRight = \case - Left e -> error (T.unpack (prettyPrint e)) - Right a -> a - -stdlib :: Project Annotation -stdlib = fromRight buildStdlib diff --git a/compiler/src/Language/Mimsa/Project/TypeSearch.hs b/compiler/src/Language/Mimsa/Project/TypeSearch.hs deleted file mode 100644 index c4208eb6..00000000 --- a/compiler/src/Language/Mimsa/Project/TypeSearch.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Project.TypeSearch - ( typeSearch, - typeSearchFromText, - FoundPath, - ) -where - -import Control.Monad ((<=<)) -import Control.Monad.Except -import Control.Monad.State -import Data.Bifunctor (first) -import Data.Either (isRight) -import Data.Functor -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Monoid -import Data.Text (Text) -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.NormaliseTypes -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Language.Mimsa.Types.Typechecker.Substitutions - -normalise :: MonoType -> Type () -normalise mt = normaliseType mt $> () - -typeSearch :: Map Name MonoType -> MonoType -> Map FoundPath MonoType -typeSearch items mt = M.filter (typeEquals mt) (typeMapToFoundPath items) - --- two types are Equal in this context if we can unify them together -typeEquals :: MonoType -> MonoType -> Bool -typeEquals needle mtB = - if isSimple needle - then isRight (unify' needle mtB) - else normalise needle == normalise mtB - --- | isSimple == no vars -isSimple :: MonoType -> Bool -isSimple = - getAll . isSimple' - where - isSimple' :: MonoType -> All - isSimple' (MTVar _ _) = All False - isSimple' (MTPrim _ _) = All True - isSimple' MTConstructor {} = All True - isSimple' other = withMonoidType isSimple' other - -unify' :: MonoType -> MonoType -> Either TypeError Substitutions -unify' mtA mtB = runUnifyM (unify mtA mtB) - -type UnifyM = ExceptT TypeError (State TypecheckState) - -runUnifyM :: - UnifyM a -> - Either TypeError a -runUnifyM value = - case either' of - (Right a, _) -> Right a - (Left e, _) -> Left e - where - either' = - runState - (runExceptT value) - (defaultTcState mempty) - --- | given a type map, split it into paths -typeMapToFoundPath :: Map Name MonoType -> Map FoundPath MonoType -typeMapToFoundPath = - M.fromList - . ( ( splitRecords - . (\(k, a) -> (FoundPath (NE.singleton k), a)) - ) - <=< M.toList - ) - -splitRecords :: (FoundPath, MonoType) -> [(FoundPath, MonoType)] -splitRecords (path, mt) = case mt of - MTRecord _ mtS _ -> - let toSubPath (k, v) = (appendNameToFoundPath k path, v) - in (splitRecords <$> toSubPath) =<< M.toList mtS - _ -> [(path, mt)] - -typeSearchFromText :: - Map Name MonoType -> - Text -> - Either (Error Annotation) (Map FoundPath MonoType) -typeSearchFromText typeMap input = do - mt <- first (ParseError input) (parseMonoType input) - let found = typeSearch typeMap mt - pure (normaliseType <$> found) diff --git a/compiler/src/Language/Mimsa/Store.hs b/compiler/src/Language/Mimsa/Store.hs deleted file mode 100644 index 558db562..00000000 --- a/compiler/src/Language/Mimsa/Store.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Language.Mimsa.Store - ( module Language.Mimsa.Store.Storage, - module Language.Mimsa.Store.Helpers, - module Language.Mimsa.Store.ResolvedDeps, - ) -where - -import Language.Mimsa.Store.Helpers -import Language.Mimsa.Store.ResolvedDeps -import Language.Mimsa.Store.Storage diff --git a/compiler/src/Language/Mimsa/Store/ExtractTypes.hs b/compiler/src/Language/Mimsa/Store/ExtractTypes.hs deleted file mode 100644 index fd2fd448..00000000 --- a/compiler/src/Language/Mimsa/Store/ExtractTypes.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Language.Mimsa.Store.ExtractTypes - ( extractNamedTypeVars, - extractTypenames, - ) -where - -import Data.Coerce -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core - --- these functions don't really feel Store-specific anymore - -extractTypenames :: Type ann -> Set TypeName -extractTypenames (MTConstructor _ _ typeName) = - S.singleton typeName -extractTypenames other = withMonoidType extractTypenames other - ------ - -extractNamedTypeVars :: Type ann -> Set TyVar -extractNamedTypeVars (MTVar _ (TVName tv)) = S.singleton tv -extractNamedTypeVars (MTVar _ (TVScopedVar _ name)) = S.singleton (coerce name) -extractNamedTypeVars other = withMonoidType extractNamedTypeVars other diff --git a/compiler/src/Language/Mimsa/Store/Hashing.hs b/compiler/src/Language/Mimsa/Store/Hashing.hs deleted file mode 100644 index ab80d22b..00000000 --- a/compiler/src/Language/Mimsa/Store/Hashing.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Language.Mimsa.Store.Hashing - ( contentAndHash, - ) -where - -import Crypto.Hash (SHA256 (..), hashWith) -import qualified Data.Aeson as JSON -import Data.ByteArray.Encoding (Base (Base16), convertToBase) -import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Lazy.Char8 (toStrict) -import Data.Text.Encoding -import Language.Mimsa.Types.Project - -contentAndHash :: (JSON.ToJSON a) => a -> (LBS.ByteString, ProjectHash) -contentAndHash a = - let json' = JSON.encode a - hash' = - ProjectHash - . decodeUtf8 - . convertToBase Base16 - . hashWith SHA256 - . toStrict - $ json' - in (json', hash') diff --git a/compiler/src/Language/Mimsa/Store/Helpers.hs b/compiler/src/Language/Mimsa/Store/Helpers.hs deleted file mode 100644 index d5cd3e73..00000000 --- a/compiler/src/Language/Mimsa/Store/Helpers.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Store.Helpers (lookupExprHashInStore, setStoreExpression) where - -import Control.Monad.Except -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Types.Error.StoreError -import Language.Mimsa.Types.Store - -lookupExprHashInStore :: - (MonadError StoreError m) => - Store ann -> - ExprHash -> - m (StoreExpression ann) -lookupExprHashInStore store exprHash = - case M.lookup exprHash (getStore store) of - Just se -> pure se - _ -> throwError (CouldNotFindStoreExpression exprHash) - -setStoreExpression :: StoreExpression ann -> Expr Name annB -> StoreExpression annB -setStoreExpression se@StoreExpression {} expr = - se {seExpr = expr} -setStoreExpression (StoreDataType a b) _ = StoreDataType a b diff --git a/compiler/src/Language/Mimsa/Store/Persistence.hs b/compiler/src/Language/Mimsa/Store/Persistence.hs deleted file mode 100644 index 54398311..00000000 --- a/compiler/src/Language/Mimsa/Store/Persistence.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Mimsa.Store.Persistence - ( fetchProjectItems, - recursiveLoadModules, - ) -where - --- functions for Projects as opposed to the larger Store - -import Control.Monad.Except -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Logger -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Store.Storage -import Language.Mimsa.Types.Error.StoreError -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store -import Language.Mimsa.Types.Store.RootPath - -fetchProjectItems :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - Store () -> - Map ModuleHash (Module ()) -> - SaveProject -> - m (Project ()) -fetchProjectItems rootPath existingStore existingModuleStore sp = do - moduleStore <- - recursiveLoadModules - rootPath - existingModuleStore - (getItemsForAllVersions . projectModules $ sp) - pure $ - projectFromSaved - moduleStore - existingStore - sp - --- - -loadModules :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - Set ModuleHash -> - m (Map ModuleHash (Module ())) -loadModules rootPath hashes = do - M.fromList - <$> traverse - ( \hash -> do - item <- findModule rootPath hash - pure (hash, item) - ) - (S.toList hashes) - -recursiveLoadModules :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - Map ModuleHash (Module ()) -> - Set ModuleHash -> - m (Map ModuleHash (Module ())) -recursiveLoadModules rootPath existingStore hashes = do - newStore <- - loadModules - rootPath - (S.difference hashes (M.keysSet existingStore)) - let newHashes = - S.difference - ( S.unions $ - getModuleDependencyHashes <$> M.elems newStore - ) - hashes - if S.null newHashes - then pure (existingStore <> newStore) - else do - moreStore <- - recursiveLoadModules - rootPath - (existingStore <> newStore) - newHashes - pure (existingStore <> newStore <> moreStore) - --- diff --git a/compiler/src/Language/Mimsa/Store/ResolveDataTypes.hs b/compiler/src/Language/Mimsa/Store/ResolveDataTypes.hs deleted file mode 100644 index 407dd4dd..00000000 --- a/compiler/src/Language/Mimsa/Store/ResolveDataTypes.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Store.ResolveDataTypes (resolveDataTypes, createTypeMap, storeExprToDataTypes) where - -import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Store.Helpers -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store - --- given a StoreExpression (and the Store), return all DataTypes used in the --- expression -resolveDataTypes :: - (MonadError StoreError m) => - Store ann -> - StoreExpression ann -> - m (Map (Maybe ModuleName, TypeName) DataType) -resolveDataTypes store' storeExpr = do - exprs <- - traverse - (lookupExprHashInStore store') - (M.elems (storeTypeBindings storeExpr)) - pure (createTypeMap exprs) - -createTypeMap :: [StoreExpression ann] -> Map (Maybe ModuleName, TypeName) DataType -createTypeMap dataTypes = - mconcat (storeExprToDataTypes <$> dataTypes) - -storeExprToDataTypes :: StoreExpression ann -> Map (Maybe ModuleName, TypeName) DataType -storeExprToDataTypes (StoreDataType dt@(DataType tn _ _) _) = - M.singleton (Nothing, tn) dt -storeExprToDataTypes _ = mempty diff --git a/compiler/src/Language/Mimsa/Store/ResolvedDeps.hs b/compiler/src/Language/Mimsa/Store/ResolvedDeps.hs deleted file mode 100644 index 3643d29d..00000000 --- a/compiler/src/Language/Mimsa/Store/ResolvedDeps.hs +++ /dev/null @@ -1,128 +0,0 @@ -module Language.Mimsa.Store.ResolvedDeps - ( resolveDeps, - resolveTypeDeps, - resolveTypeNameDeps, - recursiveResolve, - ) -where - -import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store - --- given a list of bindings and the store, grab them all -resolveDeps :: - Store ann -> - Map (Maybe ModuleName, Name) ExprHash -> - Either StoreError (ResolvedDeps ann) -resolveDeps (Store items) bindings' = - case partitionEithers foundItems of - ([], found) -> Right (ResolvedDeps (M.fromList found)) - (fails, _) -> Left $ CouldNotFindExprHashForBindings fails - where - foundItems = - ( \(name, hash) -> case M.lookup hash items of - Just storeExpr' -> - Right (name, (hash, storeExpr')) - Nothing -> Left name - ) - <$> M.toList bindings' - --- given a list of bindings and the store, grab them all -resolveInfixDeps :: - Store ann -> - Map InfixOp ExprHash -> - Either StoreError (Map InfixOp (ExprHash, StoreExpression ann)) -resolveInfixDeps (Store items) infixes = - case partitionEithers foundItems of - ([], found) -> Right (M.fromList found) - (fails, _) -> Left $ CouldNotFindExprHashForInfixes fails - where - foundItems = - ( \(infixOp, hash) -> case M.lookup hash items of - Just storeExpr' -> - Right (infixOp, (hash, storeExpr')) - Nothing -> Left infixOp - ) - <$> M.toList infixes - -extractDataType :: - StoreExpression ann -> - Maybe DataType -extractDataType (StoreDataType dt _) = Just dt -extractDataType _ = Nothing - -resolveTypeDeps :: - Store ann -> - Map (Maybe ModuleName, TyCon) ExprHash -> - Either StoreError (Map (Maybe ModuleName, TyCon) DataType) -resolveTypeDeps (Store items) typeBindings = - case partitionEithers foundItems of - ([], found) -> Right (M.fromList found) - (fails, _) -> Left $ CouldNotFindExprHashForTypeBindings (snd <$> fails) - where - foundItems = - ( \(tyCon, hash) -> case M.lookup hash items of - Just storeExpr -> do - case extractDataType storeExpr of - Just dt -> Right (tyCon, dt) - _ -> Left tyCon - Nothing -> Left tyCon - ) - <$> M.toList typeBindings - -resolveTypeNameDeps :: - Store ann -> - Map (Maybe ModuleName, TypeName) ExprHash -> - Either StoreError (Map (Maybe ModuleName, TypeName) (ExprHash, DataType)) -resolveTypeNameDeps (Store items) typeBindings = - case partitionEithers foundItems of - ([], found) -> Right (M.fromList found) - (fails, _) -> Left $ CouldNotFindExprHashForTypeNameBindings (snd <$> fails) - where - foundItems = - ( \(typeName, hash) -> case M.lookup hash items of - Just storeExpr -> do - case extractDataType storeExpr of - Just dt -> Right (typeName, (hash, dt)) - _ -> Left typeName - Nothing -> Left typeName - ) - <$> M.toList typeBindings - -resolveTypeStoreExpressions :: - Store ann -> - Map (Maybe ModuleName, TyCon) ExprHash -> - Either StoreError (Map (Maybe ModuleName, TyCon) (ExprHash, StoreExpression ann)) -resolveTypeStoreExpressions (Store items) typeBindings = - case partitionEithers foundItems of - ([], found) -> Right (M.fromList found) - (fails, _) -> Left $ CouldNotFindExprHashForTypeBindings (snd <$> fails) - where - foundItems = - ( \(tyCon, hash) -> case M.lookup hash items of - Just storeExpr -> - Right (tyCon, (hash, storeExpr)) - Nothing -> Left tyCon - ) - <$> M.toList typeBindings - --- given a StoreExpression, get all the StoreExpressions it requires, --- recursively -recursiveResolve :: - Store ann -> - StoreExpression ann -> - Either StoreError [StoreExpression ann] -recursiveResolve store' storeExpr = do - (ResolvedDeps deps) <- resolveDeps store' (storeBindings storeExpr) - infixDeps <- resolveInfixDeps store' (storeInfixes storeExpr) - typeDeps <- resolveTypeStoreExpressions store' (storeTypeBindings storeExpr) - let storeExprs = snd <$> M.elems deps - storeTypeExprs = snd <$> M.elems typeDeps - storeInfixExprs = snd <$> M.elems infixDeps - allStoreExprs = storeExprs <> storeTypeExprs <> storeInfixExprs - subExprs <- traverse (recursiveResolve store') allStoreExprs - pure $ mconcat subExprs <> allStoreExprs diff --git a/compiler/src/Language/Mimsa/Store/Storage.hs b/compiler/src/Language/Mimsa/Store/Storage.hs deleted file mode 100644 index 8440c306..00000000 --- a/compiler/src/Language/Mimsa/Store/Storage.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Store.Storage - ( saveExpr, - findExpr, - findModule, - getStoreExpressionHash, - getStoreFolder, - tryCopy, - storeSize, - saveFile, - saveAllInStore, - saveModulesInStore, - serialiseStoreExpression, - deserialiseStoreExpression, - getModuleHash, - ) -where - -import Control.Exception -import Control.Monad.Except -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as BS -import Data.Coerce -import Data.Foldable -import Data.Functor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.Mimsa.Actions.Types as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Store.Hashing -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project.ProjectHash -import Language.Mimsa.Types.Store -import Language.Mimsa.Types.Store.RootPath -import System.Directory - --- create subfolder in store, creating if necessary -getStoreFolder :: (MonadIO m) => RootPath -> String -> m FilePath -getStoreFolder (RootPath rootPath) subFolder = do - let path = rootPath <> "/" <> subFolder - liftIO $ createDirectoryIfMissing True path - pure (path <> "/") - --- try copying a file from a to b -tryCopy :: - (MonadIO m, MonadLogger m) => - String -> - String -> - m () -tryCopy from to = do - fileCopied <- liftIO $ try (copyFile from to) - case (fileCopied :: Either IOError ()) of - Right _ -> do - logDebugN $ T.pack $ "File copied from " <> from <> " to " <> to - Left _ -> pure () - -getExpressionFolder :: (MonadIO m) => RootPath -> m FilePath -getExpressionFolder rootPath = getStoreFolder rootPath "expressions" - -getModuleFolder :: (MonadIO m) => RootPath -> m FilePath -getModuleFolder rootPath = getStoreFolder rootPath "modules" - -filePath :: FilePath -> ExprHash -> String -filePath storePath hash = storePath <> show hash <> ".json" - -storeSize :: Store a -> Int -storeSize (Store s) = M.size s - --- the store is where we save all the fucking bullshit - -saveAllInStore :: - (MonadIO m, MonadLogger m) => - RootPath -> - Store ann -> - m () -saveAllInStore rootPath store = do - traverse_ (saveExpr rootPath) (getStore store) - -saveModulesInStore :: - (MonadIO m, MonadLogger m) => - RootPath -> - Map ModuleHash (Module ann) -> - m () -saveModulesInStore rootPath = - traverse_ (saveModule rootPath) - -getModuleHash :: Module ann -> ModuleHash -getModuleHash = snd . serializeModule - --- | check a loaded store expression matches its hash -validateModule :: - Module () -> - ModuleHash -> - Either StoreError (Module ()) -validateModule mod' moduleHash = - if getModuleHash mod' == moduleHash - then pure mod' - else - Left $ - ExpressionDoesNotMatchHash - (coerce moduleHash) - (coerce $ getModuleHash mod') - -getStoreExpressionHash :: StoreExpression ann -> ExprHash -getStoreExpressionHash = snd . serialiseStoreExpression - --- | check a loaded store expression matches its hash -validateStoreExpression :: - StoreExpression () -> - ExprHash -> - Either StoreError (StoreExpression ()) -validateStoreExpression storeExpr exprHash = - if getStoreExpressionHash storeExpr == exprHash - then pure storeExpr - else - Left $ - ExpressionDoesNotMatchHash - exprHash - (getStoreExpressionHash storeExpr) - -saveExpr :: - (MonadIO m, MonadLogger m) => - RootPath -> - StoreExpression ann -> - m ExprHash -saveExpr rootPath se = - saveExpr' rootPath (se $> ()) - --- take an expression, save it, return ExprHash -saveExpr' :: - (MonadIO m, MonadLogger m) => - RootPath -> - StoreExpression () -> - m ExprHash -saveExpr' rootPath storeExpr = do - storePath <- getExpressionFolder rootPath - let path = filePath storePath exprHash - (json, exprHash) = serialiseStoreExpression storeExpr - exists <- liftIO $ doesFileExist path - if exists - then logDebugN $ "Expression for " <> prettyPrint exprHash <> " already exists" - else do - logDebugN $ "Saved expression for " <> prettyPrint exprHash - liftIO $ BS.writeFile (filePath storePath exprHash) json - pure exprHash - ----- save modules - -saveModule :: - (MonadIO m, MonadLogger m) => - RootPath -> - Module ann -> - m ModuleHash -saveModule rootPath mod' = - saveModule' rootPath (mod' $> ()) - --- take an expression, save it, return ExprHash -saveModule' :: - (MonadIO m, MonadLogger m) => - RootPath -> - Module () -> - m ModuleHash -saveModule' rootPath mod' = do - storePath <- getModuleFolder rootPath - let (json, moduleHash) = serializeModule mod' - path = filePath storePath (coerce moduleHash) - exists <- liftIO $ doesFileExist path - if exists - then logDebugN $ "Module for " <> prettyPrint moduleHash <> " already exists" - else do - logDebugN $ "Saved module for " <> prettyPrint moduleHash - liftIO $ BS.writeFile (filePath storePath (coerce moduleHash)) json - pure moduleHash - --- this is the only encode we should be doing -serialiseStoreExpression :: StoreExpression ann -> (BS.ByteString, ExprHash) -serialiseStoreExpression se = coerce $ contentAndHash (se $> ()) - --- this is the only json decode we should be doing -deserialiseStoreExpression :: BS.ByteString -> Maybe (StoreExpression ()) -deserialiseStoreExpression = - JSON.decode - -findExpr :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - ExprHash -> - m (StoreExpression ()) -findExpr rootPath = fmap ($> ()) . findExprInLocalStore rootPath - --- find in the store -findExprInLocalStore :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - ExprHash -> - m (StoreExpression ()) -findExprInLocalStore rootPath hash = do - storePath <- getExpressionFolder rootPath - json <- liftIO $ try $ BS.readFile (filePath storePath hash) - case (json :: Either IOError BS.ByteString) of - Left _ -> throwError $ CouldNotReadFilePath StoreExprFile (filePath storePath hash) - Right json' -> do - case deserialiseStoreExpression json' of - Nothing -> throwError CouldNotDecodeByteString - Just storeExpr -> - case validateStoreExpression storeExpr hash of - Right se -> do - logDebugN $ "Found expression for " <> prettyPrint hash - pure se - Left e -> throwError e - -findModule :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - ModuleHash -> - m (Module ()) -findModule rootPath = fmap ($> ()) . findModuleInLocalStore rootPath - --- find in the store -findModuleInLocalStore :: - (MonadIO m, MonadError StoreError m, MonadLogger m) => - RootPath -> - ModuleHash -> - m (Module ()) -findModuleInLocalStore rootPath hash = do - storePath <- getModuleFolder rootPath - json <- liftIO $ try $ BS.readFile (filePath storePath (coerce hash)) - case (json :: Either IOError BS.ByteString) of - Left _ -> throwError $ CouldNotReadFilePath ModuleFile (filePath storePath (coerce hash)) - Right json' -> do - case deserializeModule json' of - Nothing -> throwError CouldNotDecodeByteString - Just mod' -> - case validateModule mod' hash of - Right validatedModule -> do - logDebugN $ "Found module for " <> prettyPrint hash - pure validatedModule - Left e -> throwError e - --- | given an expression to save, save it --- | some sort of catch / error? -saveFile :: - (MonadIO m, MonadLogger m) => - RootPath -> - (Actions.SavePath, Actions.SaveFilename, Actions.SaveContents) -> - m () -saveFile rootPath (path, filename, content) = do - fullPath <- getStoreFolder rootPath (show path) - let savePath = fullPath <> show filename - logDebugN $ "Saving to " <> T.pack savePath - liftIO $ T.writeFile savePath (coerce content) diff --git a/compiler/src/Language/Mimsa/Tests/Generate.hs b/compiler/src/Language/Mimsa/Tests/Generate.hs deleted file mode 100644 index e7dd52bd..00000000 --- a/compiler/src/Language/Mimsa/Tests/Generate.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Tests.Generate - ( generateFromMonoType, - isRecursive, - ) -where - -import Data.Coerce -import Data.Functor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Store.ExtractTypes -import Language.Mimsa.Typechecker.FlattenRow -import Language.Mimsa.Types.Typechecker.Substitutions -import Test.QuickCheck - --- TODO: we'll need a namespace in the MTConstructor to make sure we generate --- the right thing -data GenerateState = GenerateState - { gsDataTypes :: Map (Maybe ModuleName, TypeName) DataType, - gsDepth :: Int - } - -fromMonoType :: - (Monoid ann) => - GenerateState -> - MonoType -> - Gen (Expr Name ann) -fromMonoType gs mt = - case flattenRow mt of - (MTPrim _ prim) -> - MyLiteral mempty <$> fromPrimitive prim - (MTArray _ arrMt) -> - if shouldWeStopRecursing gs - then pure (MyArray mempty mempty) - else MyArray mempty <$> listOf (fromMonoType gs arrMt) - (MTTuple _ a as) -> - MyTuple mempty <$> fromMonoType gs a <*> traverse (fromMonoType gs) as - (MTRecord _ as _) -> - -- as we've already run flattenRow on this to remove nested rows, assume the - -- part on the end is just an unknown and ignore it - - MyRecord mempty <$> traverse (fromMonoType gs) as - (MTFunction _ _from to) -> - MyLambda mempty (Identifier mempty "a") - <$> fromMonoType gs to - (MTVar _ _) -> fromMonoType gs (MTPrim mempty MTBool) -- for unknowns, use bool for now - mtTA@MTTypeApp {} -> case varsFromDataType mtTA of - Just (_, typeName, args) -> fromType gs typeName args - Nothing -> error "could not work out datatype" - mtCons@MTConstructor {} -> case varsFromDataType mtCons of - Just (_, typeName, args) -> fromType gs typeName args - Nothing -> error "could not work out datatype" - (MTGlobals _ _ _ inner) -> fromMonoType gs inner - --- | take the args for the type and apply them to the type -typeApply :: [MonoType] -> DataType -> Map TyCon [Type ()] -typeApply mts (DataType _ vars constructors) = - let subs = - Substitutions $ - M.fromList $ - (\(k, a) -> (TVName (coerce k), a)) <$> zip vars mts - in (fmap . fmap) (applySubst subs) constructors - -fromType :: - (Monoid ann) => - GenerateState -> - TypeName -> - [MonoType] -> - Gen (Expr Name ann) -fromType gs typeName args = case M.lookup (Nothing, typeName) (gsDataTypes gs) of - Just dt -> do - let newGs = incrementDepth gs - dtApplied = typeApply args dt - info (tyCon, args') = do - ( constructorWeighting newGs typeName args', - fromConstructor newGs tyCon args' - ) - frequency (info <$> M.toList dtApplied) - Nothing -> error "could not find datatype" - -constructorWeighting :: GenerateState -> TypeName -> [Type ()] -> Int -constructorWeighting gs typeName args = - if shouldWeStopRecursing gs - then - if isRecursive typeName args - then 1 -- use recursive constructors less - else 3 -- and non-recursive ones more - else 1 -- equal weighting pls - --- | adjust this number to balance out good testing and interpreter crashing -shouldWeStopRecursing :: GenerateState -> Bool -shouldWeStopRecursing gs = gsDepth gs > 2 - --- | To stop recursive datatypes getting ridiculous we make a depth limit -incrementDepth :: GenerateState -> GenerateState -incrementDepth (GenerateState dts depth) = GenerateState dts (depth + 1) - --- | does the type use itself? -isRecursive :: TypeName -> [Type ()] -> Bool -isRecursive typeName args = - or - ( S.member typeName - . extractTypenames - <$> args - ) - -fromConstructor :: - (Monoid ann) => - GenerateState -> - TyCon -> - [Type ()] -> - Gen (Expr Name ann) -fromConstructor gs tyCon args = - let applyArg arg mA = do - a <- mA - let mtArg = arg $> mempty - MyApp mempty a <$> fromMonoType gs mtArg - in foldr - applyArg - (pure (MyConstructor mempty Nothing tyCon)) - args - -fromPrimitive :: Primitive -> Gen Literal -fromPrimitive MTBool = - MyBool <$> chooseAny -fromPrimitive MTInt = - MyInt <$> chooseAny -fromPrimitive MTString = - -- TODO: are these valid StringType values? probably not, may be a beef when - -- we come to Interpret these in tests - MyString . StringType . T.pack <$> listOf chooseAny - -generateFromMonoType :: - (Monoid ann) => - Map (Maybe ModuleName, TypeName) DataType -> - MonoType -> - IO [Expr Name ann] -generateFromMonoType dataTypes mt = - let generateState = GenerateState dataTypes 1 - in do - let generator = fromMonoType generateState (flattenRow mt) - sample' (resize 1000 generator) diff --git a/compiler/src/Language/Mimsa/Tests/Helpers.hs b/compiler/src/Language/Mimsa/Tests/Helpers.hs deleted file mode 100644 index bf90f899..00000000 --- a/compiler/src/Language/Mimsa/Tests/Helpers.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Tests.Helpers (toMonadError, unifies, exprEqualsTrue, testIsSuccess) where - -import Control.Monad.Except -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Solve -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Error - -toMonadError :: (MonadError e m) => Either e a -> m a -toMonadError = \case - Right a -> pure a - Left e -> throwError e - --- do these two types work together? -unifies :: - MonoType -> - MonoType -> - Either TypeError () -unifies mtA mtB = do - _ <- - runSolveM - (defaultTcState mempty) - (unify mtA mtB) - pure () - --- | take response of test and == it with True to make it is easy to check for --- truthiness -exprEqualsTrue :: - (Monoid ann) => - Expr var ann -> - Expr var ann -exprEqualsTrue = - MyInfix - mempty - Equals - (MyLiteral mempty (MyBool True)) - --- | did the test succeed? -testIsSuccess :: Expr var ann -> Bool -testIsSuccess (MyLiteral _ (MyBool True)) = True -testIsSuccess _ = False diff --git a/compiler/src/Language/Mimsa/Tests/UnitTest.hs b/compiler/src/Language/Mimsa/Tests/UnitTest.hs deleted file mode 100644 index c7d6ae95..00000000 --- a/compiler/src/Language/Mimsa/Tests/UnitTest.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Tests.UnitTest - ( resultIsBoolean, - ) -where - -import Language.Mimsa.Core -import Language.Mimsa.Tests.Helpers -import Language.Mimsa.Types.Error - -resultIsBoolean :: MonoType -> Either TypeError () -resultIsBoolean mt = do - unifies - mt - (MTPrim mempty MTBool) diff --git a/compiler/src/Language/Mimsa/Transform/BetaReduce.hs b/compiler/src/Language/Mimsa/Transform/BetaReduce.hs deleted file mode 100644 index 018c99eb..00000000 --- a/compiler/src/Language/Mimsa/Transform/BetaReduce.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Language.Mimsa.Transform.BetaReduce (betaReduce) where - -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Transform.Shared - -betaReduce :: (Eq ann, Eq var) => Expr var ann -> Expr var ann -betaReduce = repeatUntilEq betaReduceInternal - --- | turn (\x -> e) a into `let x = a in e` -betaReduceInternal :: Expr var ann -> Expr var ann -betaReduceInternal (MyApp ann (MyLambda _ann ident body) val) = - let (var, ann') = detailsFromIdent ident - in MyLet ann (Identifier ann' var) val (betaReduceInternal body) -betaReduceInternal (MyApp ann (MyAnnotation _ _ (MyLambda _ann ident body)) val) = - let (var, ann') = detailsFromIdent ident - in MyLet ann (Identifier ann' var) val (betaReduceInternal body) -betaReduceInternal (MyIf _ (MyLiteral _ (MyBool True)) thenExpr _) = - betaReduceInternal thenExpr -betaReduceInternal (MyIf _ (MyLiteral _ (MyBool False)) _ elseExpr) = - betaReduceInternal elseExpr -betaReduceInternal (MyRecordAccess ann myRec@(MyRecord _ as) name) = - case M.lookup name as of - Just inner -> inner - _ -> MyRecordAccess ann (betaReduceInternal myRec) name -betaReduceInternal other = mapExpr betaReduceInternal other diff --git a/compiler/src/Language/Mimsa/Transform/EtaReduce.hs b/compiler/src/Language/Mimsa/Transform/EtaReduce.hs deleted file mode 100644 index 2c84ba8a..00000000 --- a/compiler/src/Language/Mimsa/Transform/EtaReduce.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Language.Mimsa.Transform.EtaReduce (etaReduce) where - -import Language.Mimsa.Core -import Language.Mimsa.Transform.Shared - -etaReduce :: (Eq ann, Eq var) => Expr var ann -> Expr var ann -etaReduce = repeatUntilEq etaReduceInternal - --- | turn `\a -> id a` into `id` -etaReduceInternal :: (Eq var) => Expr var ann -> Expr var ann -etaReduceInternal - ( MyLambda - _ - (Identifier _ varA) - (MyApp _ fn (MyVar _ Nothing varB)) - ) - | varA == varB = fn -etaReduceInternal other = mapExpr etaReduceInternal other diff --git a/compiler/src/Language/Mimsa/Transform/FindUnused.hs b/compiler/src/Language/Mimsa/Transform/FindUnused.hs deleted file mode 100644 index 4152cc64..00000000 --- a/compiler/src/Language/Mimsa/Transform/FindUnused.hs +++ /dev/null @@ -1,117 +0,0 @@ -module Language.Mimsa.Transform.FindUnused (findUnused, removeBindings, removeUnused) where - -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Transform.Shared - -removeUnused :: (Ord ann, Ord var) => Expr var ann -> Expr var ann -removeUnused = repeatUntilEq removeUnusedInternal - -removeUnusedInternal :: - (Ord ann, Ord var) => - Expr var ann -> - Expr var ann -removeUnusedInternal expr = - let unused = findUnused expr - in removeBindings (S.map fst unused) expr - -removeBindings :: (Ord var) => Set var -> Expr var ann -> Expr var ann -removeBindings remove = f - where - f (MyLet ann ident letExpr letBody) = - let a = case ident of - Identifier _ var -> var - in if S.member a remove - then letBody - else MyLet ann ident (f letExpr) (f letBody) - f (MyPatternMatch ann expr patterns) = - let tidyPattern (pat, patExpr) = - ( removeBindingsInPattern remove pat, - f patExpr - ) - in MyPatternMatch ann (f expr) (tidyPattern <$> patterns) - f (MyLetPattern ann pat expr body) = - MyLetPattern - ann - (removeBindingsInPattern remove pat) - (f expr) - (f body) - f other = mapExpr f other - -removeBindingsInPattern :: - (Ord var) => - Set var -> - Pattern var ann -> - Pattern var ann -removeBindingsInPattern remove = f - where - f wholePat@(PVar ann a) = - if S.member a remove - then PWildcard ann - else wholePat - f (PString ann pHead pTail) = - let removeFromStringPart sp = case sp of - StrValue strAnn a -> - if S.member a remove - then StrWildcard strAnn - else sp - other -> other - in PString - ann - (removeFromStringPart pHead) - (removeFromStringPart pTail) - f (PArray ann pParts pSpread) = - let rmSpread = case pSpread of - SpreadValue sprAnn' a -> - if S.member a remove - then SpreadWildcard sprAnn' - else pSpread - other -> other - in PArray ann (f <$> pParts) rmSpread - f other = mapPattern f other - -findUnused :: (Ord ann, Ord var) => Expr var ann -> Set (var, ann) -findUnused expr = - let uses = findUses expr - in S.filter (\(var, _) -> not $ memberInUses var Nothing uses) (findVariables expr) - --- | find all variables introduced into expression --- | we don't need to worry about shadowing because we'll have made everything --- unique that needs to be in a previous step (otherwise typechecking would --- choke) -findVariables :: (Ord ann, Ord var) => Expr var ann -> Set (var, ann) -findVariables = withMonoid f - where - f (MyLet _ (Identifier ann a) _ _) = - (True, S.singleton (a, ann)) - f (MyPatternMatch _ _ patterns) = - (True, mconcat (findVariableInPattern . fst <$> patterns)) - f (MyLetPattern _ pat _ _) = - (True, findVariableInPattern pat) - f _other = (True, mempty) - --- | Find all variables in pattern match -findVariableInPattern :: (Ord ann, Ord var) => Pattern var ann -> Set (var, ann) -findVariableInPattern (PVar ann a) = - S.singleton (a, ann) -findVariableInPattern (PTuple _ a as) = - findVariableInPattern a <> foldMap findVariableInPattern as -findVariableInPattern (PConstructor _ _ _ vars) = - mconcat (findVariableInPattern <$> vars) -findVariableInPattern (PRecord _ as) = - mconcat (findVariableInPattern <$> M.elems as) -findVariableInPattern (PArray _ as spread) = - let spreadVars = case spread of - SpreadValue ann a -> S.singleton (a, ann) - _ -> mempty - in mconcat (findVariableInPattern <$> as) <> spreadVars -findVariableInPattern (PString _ sHead sTail) = - let findStringPartVar var = case var of - StrValue ann a -> S.singleton (a, ann) - _ -> mempty - in findStringPartVar sHead <> findStringPartVar sTail -findVariableInPattern PWildcard {} = mempty -findVariableInPattern PLit {} = mempty diff --git a/compiler/src/Language/Mimsa/Transform/FindUses.hs b/compiler/src/Language/Mimsa/Transform/FindUses.hs deleted file mode 100644 index bb669cc8..00000000 --- a/compiler/src/Language/Mimsa/Transform/FindUses.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Language.Mimsa.Transform.FindUses (findUses, memberInUses, numberOfUses, Uses (..)) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Monoid -import Language.Mimsa.Core - -newtype Uses var = Uses (Map (Maybe ModuleName, var) (Sum Int)) - deriving newtype (Eq, Ord, Show) - -instance (Ord var) => Semigroup (Uses var) where - (Uses a) <> (Uses b) = Uses (M.unionWith (<>) a b) - -instance (Ord var) => Monoid (Uses var) where - mempty = Uses mempty - -findUses :: (Ord var) => Expr var ann -> Uses var -findUses = withMonoid f - where - f (MyLet _ ident body expr) = - let var = nameFromIdent ident - usesInBody = clearVarFromUses var (findUses body) - usesInExpr = findUses expr - in (False, usesInBody <> usesInExpr) - f (MyVar _ modName a) = (False, Uses (M.singleton (modName, a) 1)) - f _ = (True, mempty) - --- | remove recursive uses of a var from it's body -clearVarFromUses :: (Ord var) => var -> Uses var -> Uses var -clearVarFromUses var (Uses uses) = - Uses (M.insert (Nothing, var) (Sum 0) uses) - --- var in use and used over 0 times -memberInUses :: (Ord var) => var -> Maybe ModuleName -> Uses var -> Bool -memberInUses var modName (Uses as) = - maybe - False - (\(Sum a) -> a > 0) - (M.lookup (modName, var) as) - -numberOfUses :: (Ord var) => var -> Maybe ModuleName -> Uses var -> Int -numberOfUses var modName (Uses as) = maybe 0 getSum (M.lookup (modName, var) as) diff --git a/compiler/src/Language/Mimsa/Transform/FlattenLets.hs b/compiler/src/Language/Mimsa/Transform/FlattenLets.hs deleted file mode 100644 index 15764223..00000000 --- a/compiler/src/Language/Mimsa/Transform/FlattenLets.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Language.Mimsa.Transform.FlattenLets (flattenLets) where - -import Language.Mimsa.Core - --- | We don't want `let a = (let b = 1 in b + 1) in a + 1` --- instead we want `let b = 1; let a = b + 1; a + 1 -flattenLets :: Expr var ann -> Expr var ann -flattenLets (MyLet ann ident (MyLet ann' ident' expr' body') body) = - flattenLets $ - MyLet - ann' - ident' - (flattenLets expr') - ( MyLet - ann - ident - (flattenLets body') - (flattenLets body) - ) --- make simple LetPatterns into Let to enable --- further simplications -flattenLets (MyLetPattern ann (PVar pAnn var) expr body) = - MyLet ann (Identifier pAnn var) (flattenLets expr) (flattenLets body) --- flatten single pattern matches into let patterns to enable --- further simplifications -flattenLets (MyPatternMatch ann expr [(pat, patExpr)]) = - MyLetPattern ann pat (flattenLets expr) (flattenLets patExpr) --- if we don't use expression, bin it -flattenLets (MyLetPattern _ (PWildcard _) _ body) = flattenLets body -flattenLets other = mapExpr flattenLets other diff --git a/compiler/src/Language/Mimsa/Transform/FloatDown.hs b/compiler/src/Language/Mimsa/Transform/FloatDown.hs deleted file mode 100644 index abe63481..00000000 --- a/compiler/src/Language/Mimsa/Transform/FloatDown.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Language.Mimsa.Transform.FloatDown (floatDown) where - -import Data.Bifunctor (second) -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Transform.Shared - --- if a let is above a pattern, it pushes it down into each branch of the --- pattern match --- this is so that it can be removed by dead code elimination on branches that --- don't use it -floatDownInternal :: Expr Name ann -> Expr Name ann -floatDownInternal original@(MyLet ann ident expr (MyPatternMatch pAnn matchExpr pats)) = - if memberInUses (extractIdentVar ident) Nothing (findUses matchExpr) -- if let var is in the matchExpr, don't float up - then original - else - let newPatterns = second (MyLet ann ident expr) <$> pats - in floatDownInternal $ MyPatternMatch pAnn matchExpr newPatterns -floatDownInternal other = mapExpr floatDownInternal other - -floatDown :: (Eq ann) => Expr Name ann -> Expr Name ann -floatDown = repeatUntilEq floatDownInternal diff --git a/compiler/src/Language/Mimsa/Transform/FloatUp.hs b/compiler/src/Language/Mimsa/Transform/FloatUp.hs deleted file mode 100644 index 43a16235..00000000 --- a/compiler/src/Language/Mimsa/Transform/FloatUp.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Language.Mimsa.Transform.FloatUp (floatUp) where - -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Transform.Shared - --- if a let is above a pattern, it pushes it down into each branch of the --- pattern match --- this is so that it can be removed by dead code elimination on branches that --- don't use it -floatUpInternal :: (Ord var) => Expr var ann -> Expr var ann -floatUpInternal original@(MyLambda ann ident (MyLet ann' ident' expr body)) = - let lambdaVar = extractIdentVar ident - vars = findUses expr - in if memberInUses lambdaVar Nothing vars -- if lambda var is in the expr, don't float up - then original - else MyLet ann' ident' expr (MyLambda ann ident body) -floatUpInternal other = mapExpr floatUpInternal other - -floatUp :: (Eq ann, Ord var) => Expr var ann -> Expr var ann -floatUp = repeatUntilEq floatUpInternal diff --git a/compiler/src/Language/Mimsa/Transform/Inliner.hs b/compiler/src/Language/Mimsa/Transform/Inliner.hs deleted file mode 100644 index d6e2fdfc..00000000 --- a/compiler/src/Language/Mimsa/Transform/Inliner.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Transform.Inliner - ( inlineInternal, - InlineState (..), - inline, - storeExprInState, - howTrivial, - shouldInline, - ) -where - -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Transform.Shared - -type InlineM var ann a = - StateT (InlineState var ann) (Reader (InlineEnv var)) a - -data IsRecursive = Recursive | NotRecursive - -data IsWithinLambda = WithinLambda | NotWithinLambda - -newtype VarUses = VarUses Int - --- item that can be inlined, we can add useful info here to help our choices -data InlineItem var ann = InlineItem - { iiExpression :: Expr var ann, - _iiRecursive :: IsRecursive - } - --- as we traverse the expression we learn shit -newtype InlineState var ann = InlineState - { isExpressions :: Map var (InlineItem var ann) - } - --- static info we can use -data InlineEnv var = InlineEnv - { ieUses :: Uses var, - ieIsWithinLambda :: IsWithinLambda - } - --- | should we inline this expression? --- if it's only used in one place, not within a lambda, yes -shouldInline :: VarUses -> IsWithinLambda -> InlineItem var ann -> Bool --- item is recursive, never inline it -shouldInline _ _ (InlineItem _ Recursive) = False --- item is used once, always inline it -shouldInline (VarUses 1) NotWithinLambda _expr = True --- item is not within a lambda, and is trivial, move it -shouldInline _ NotWithinLambda (InlineItem expr _) = isJust (howTrivial expr) -shouldInline _ WithinLambda _ = False - --- | complexity measure of trivial expression -howTrivial :: Expr var ann -> Maybe Int -howTrivial (MyLiteral _ _) = Just 1 -howTrivial (MyArray _ as) = (+ 1) . sum <$> traverse howTrivial as -howTrivial (MyRecord _ as) = (+ 1) . sum <$> traverse howTrivial as -howTrivial (MyTuple _ a as) = (+ 2) . sum <$> traverse howTrivial ([a] <> NE.toList as) -howTrivial MyVar {} = Just 1 -howTrivial _ = Nothing - -inlineInternal :: (Ord var) => InlineState var ann -> Expr var ann -> Expr var ann -inlineInternal initialState expr = - let initialEnv = InlineEnv (findUses expr) NotWithinLambda - in runReader (evalStateT (inlineExpression expr) initialState) initialEnv - -inline :: (Ord var, Eq ann) => Expr var ann -> Expr var ann -inline = repeatUntilEq (inlineInternal (InlineState mempty)) - -storeExprInState :: - (Ord var, MonadState (InlineState var ann) m) => - var -> - Maybe ModuleName -> - Expr var ann -> - m () -storeExprInState var modName expr = - let isRecursive = memberInUses var modName (findUses expr) - inlineItem = InlineItem expr (if isRecursive then Recursive else NotRecursive) - in modify - ( \s -> - s - { isExpressions = - isExpressions s - <> M.singleton var inlineItem - } - ) - -lookupVar :: - (Ord var) => - var -> - InlineM var ann (Maybe (InlineItem var ann)) -lookupVar var = do - gets (M.lookup var . isExpressions) - -getUsesCount :: (Ord var) => var -> Maybe ModuleName -> InlineM var ann VarUses -getUsesCount var modName = do - i <- asks (numberOfUses var modName . ieUses) - pure (VarUses i) - -substituteVar :: (Ord var) => var -> Maybe ModuleName -> InlineM var ann (Maybe (Expr var ann)) -substituteVar var modName = do - maybeItem <- lookupVar var - uses <- getUsesCount var modName - inLambda <- asks ieIsWithinLambda - case maybeItem of - Just item - | shouldInline uses inLambda item -> - pure $ Just (iiExpression item) - _ -> pure Nothing - -withinLambda :: InlineM var ann a -> InlineM var ann a -withinLambda = local (\ie -> ie {ieIsWithinLambda = WithinLambda}) - -inlineExpression :: (Ord var) => Expr var ann -> InlineM var ann (Expr var ann) -inlineExpression (MyLet ann ident expr rest) = do - storeExprInState (nameFromIdent ident) Nothing expr - MyLet ann ident <$> inlineExpression expr <*> inlineExpression rest -inlineExpression (MyVar ann modName var) = do - substitute <- substituteVar var modName - case substitute of - Just new -> pure new - _ -> pure (MyVar ann modName var) -inlineExpression (MyLambda ann ident body) = do - body' <- withinLambda (inlineExpression body) - pure (MyLambda ann ident body') -inlineExpression other = - bindExpr inlineExpression other diff --git a/compiler/src/Language/Mimsa/Transform/Shared.hs b/compiler/src/Language/Mimsa/Transform/Shared.hs deleted file mode 100644 index 2216132e..00000000 --- a/compiler/src/Language/Mimsa/Transform/Shared.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Language.Mimsa.Transform.Shared (extractIdentVar, repeatUntilEq, repeatUntilEqM) where - -import Language.Mimsa.Core - -repeatUntilEq :: (Eq a) => (a -> a) -> a -> a -repeatUntilEq f = - let repeat' i a = - let new = f a - in if new == a || i < 1 then a else repeat' (i - 1) new - in repeat' (10 :: Int) - -repeatUntilEqM :: (Eq a, Monad m) => (a -> m a) -> a -> m a -repeatUntilEqM f = - let repeat' i a = do - new <- f a - if new == a || i < 1 then pure a else repeat' (i - 1) new - in repeat' (10 :: Int) - -extractIdentVar :: Identifier var ann -> var -extractIdentVar (Identifier _ name) = name diff --git a/compiler/src/Language/Mimsa/Transform/SimplifyPatterns.hs b/compiler/src/Language/Mimsa/Transform/SimplifyPatterns.hs deleted file mode 100644 index 8afe929a..00000000 --- a/compiler/src/Language/Mimsa/Transform/SimplifyPatterns.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Language.Mimsa.Transform.SimplifyPatterns where - -import Data.Foldable -import qualified Data.List.NonEmpty as NE -import Data.Maybe -import Language.Mimsa.Core - -{- - -RULE 1: reduce patterns (currently only works with 1 or 2 arg constructors) - -TODO: we can do loads now because of tuples - -match (Just (("dog", "log"))) with - (Just (b, c)) -> - b ++ c - | _ -> - "" - -should becomes - -match ("dog", "log") with - (b, c) -> - b ++ c - -1) if the match arm is known, reduce any outer constructors -2) then remove them from patterns below -3) and remove ones that are no longer relevant - --} - -simplifyPatterns :: Expr var ann -> Expr var ann --- constructor with single arg -simplifyPatterns orig@(MyPatternMatch ann (MyApp _ (MyConstructor _ _ tc) argA) patterns) = - case filterPatterns tc patterns of - Just newPatterns -> - MyPatternMatch ann argA newPatterns - Nothing -> orig --- constructor with two args -simplifyPatterns orig@(MyPatternMatch ann (MyApp appAnn (MyApp _ (MyConstructor _ _ tc) argA) argB) patterns) = - case filterPatterns tc patterns of - Just newPatterns -> - MyPatternMatch ann (MyTuple appAnn argA (NE.singleton argB)) newPatterns - Nothing -> orig --- otherwise look through expr looking for more -simplifyPatterns other = mapExpr simplifyPatterns other - -filterPatterns :: TyCon -> [(Pattern var ann, Expr var ann)] -> Maybe [(Pattern var ann, Expr var ann)] -filterPatterns tc pats = - let filterPatternExprs (pat, patExpr) = - (,) - <$> filterPattern tc pat - <*> pure (simplifyPatterns patExpr) - filtered = mapMaybe filterPatternExprs pats - in if null filtered - then Nothing - else Just (removeDuplicateWildcards filtered) - --- we're creating more general patterns so may need to remove our previous --- catches -removeDuplicateWildcards :: - [(Pattern var ann, Expr var ann)] -> - [(Pattern var ann, Expr var ann)] -removeDuplicateWildcards = - snd - . foldl' - ( \(found, pats) thisPat -> case thisPat of - (PWildcard _, _) -> - if found - then (found, pats) - else (True, pats <> [thisPat]) - (PVar _ _, _) -> - if found - then (found, pats) - else (True, pats <> [thisPat]) - _ -> (found, pats <> [thisPat]) - ) - (False, mempty) - -filterPattern :: TyCon -> Pattern var ann -> Maybe (Pattern var ann) -filterPattern tc (PConstructor _ _ tc2 [a]) | tc == tc2 = Just a -- TODO: check this works with namespace -filterPattern tc (PConstructor pAnn _ tc2 [a, b]) | tc == tc2 = Just (PTuple pAnn a (NE.singleton b)) -filterPattern _ (PWildcard ann) = Just (PWildcard ann) -filterPattern _ (PVar ann var) = Just (PVar ann var) -filterPattern _ _ = Nothing diff --git a/compiler/src/Language/Mimsa/Transform/TrimDeps.hs b/compiler/src/Language/Mimsa/Transform/TrimDeps.hs deleted file mode 100644 index 2cf85d88..00000000 --- a/compiler/src/Language/Mimsa/Transform/TrimDeps.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Language.Mimsa.Transform.TrimDeps where - -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Language.Mimsa.Types.Store - --- | given a store expression and updated expr --- bin off any unused stuff --- doesn't do types yet -trimDeps :: StoreExpression ann -> Expr Name ann -> StoreExpression ann -trimDeps se newExpr = - let vars = findUses newExpr - newBindings = - M.filterWithKey - (\(modName, k) _ -> memberInUses k modName vars) - (storeBindings se) - in StoreExpression - { seExpr = newExpr, - seBindings = newBindings, - seTypeBindings = storeTypeBindings se, - seTypes = storeTypes se, - seInfixes = storeInfixes se - } diff --git a/compiler/src/Language/Mimsa/Typechecker.hs b/compiler/src/Language/Mimsa/Typechecker.hs deleted file mode 100644 index d171c761..00000000 --- a/compiler/src/Language/Mimsa/Typechecker.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.Mimsa.Typechecker - ( module Language.Mimsa.Typechecker.Typecheck, - ) -where - -import Language.Mimsa.Typechecker.Typecheck diff --git a/compiler/src/Language/Mimsa/Typechecker/BuiltIns.hs b/compiler/src/Language/Mimsa/Typechecker/BuiltIns.hs deleted file mode 100644 index bec969d2..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/BuiltIns.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Typechecker.BuiltIns - ( builtInTypes, - lookupBuiltIn, - ) -where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core - -builtInTypes :: Map TypeName MonoType -builtInTypes = - M.fromList - [ ("String", MTPrim mempty MTString), - ("Int", MTPrim mempty MTInt), - ("Boolean", MTPrim mempty MTBool) - ] - -lookupBuiltIn :: TypeName -> Maybe MonoType -lookupBuiltIn name = M.lookup name builtInTypes diff --git a/compiler/src/Language/Mimsa/Typechecker/CreateEnv.hs b/compiler/src/Language/Mimsa/Typechecker/CreateEnv.hs deleted file mode 100644 index 8ad8a292..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/CreateEnv.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Language.Mimsa.Typechecker.CreateEnv - ( createEnv, - ) -where - -import Data.Bifunctor -import Data.Coerce -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.BuiltIns -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Typechecker - -createEnv :: - Map Name MonoType -> - Map (Maybe ModuleName, TypeName) DataType -> - Map InfixOp MonoType -> - Map ModuleHash (Map Name MonoType) -> - Environment -createEnv typeMap dataTypes infixTypes modTypes = - createDepsEnv typeMap - <> createTypesEnv dataTypes - <> createInfixEnv infixTypes - <> createModuleEnv modTypes - -createTypesEnv :: Map (Maybe ModuleName, TypeName) DataType -> Environment -createTypesEnv dataTypes = - Environment - { getSchemes = mempty, - getDataTypes = builtInDts <> dataTypes, - getInfix = mempty, - getTypeVarsInScope = mempty, - getNamespacedSchemes = mempty - } - where - makeDT (name, _) = - M.singleton (Nothing, name) (DataType name mempty mempty) - builtInDts = - mconcat $ makeDT <$> M.toList builtInTypes - -createDepsEnv :: Map Name MonoType -> Environment -createDepsEnv typeMap = - Environment - { getSchemes = mkSchemes typeMap, - getDataTypes = mempty, - getInfix = mempty, - getTypeVarsInScope = mempty, - getNamespacedSchemes = mempty - } - where - toScheme = - bimap - (\(Name n) -> TVName (coerce n)) - schemeFromMonoType - mkSchemes = - M.fromList . fmap toScheme . M.toList - -createInfixEnv :: Map InfixOp MonoType -> Environment -createInfixEnv infixTypes = - Environment - { getSchemes = mempty, - getDataTypes = mempty, - getInfix = schemeFromMonoType <$> infixTypes, - getTypeVarsInScope = mempty, - getNamespacedSchemes = mempty - } - -createModuleEnv :: Map ModuleHash (Map Name MonoType) -> Environment -createModuleEnv modTypes = - mempty - { getNamespacedSchemes = (fmap . fmap) schemeFromMonoType modTypes - } - --- | Make all free variables polymorphic so that we get a fresh version of --- everything each time -schemeFromMonoType :: MonoType -> Scheme -schemeFromMonoType mt = Scheme (S.toList $ freeTypeVars mt) mt diff --git a/compiler/src/Language/Mimsa/Typechecker/DataTypes.hs b/compiler/src/Language/Mimsa/Typechecker/DataTypes.hs deleted file mode 100644 index 098da5be..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/DataTypes.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.DataTypes - ( builtInTypes, - lookupBuiltIn, - storeDataDeclaration, - inferDataConstructor, - inferConstructorTypes, - validateDataType, - ) -where - -import Control.Monad (when) -import Control.Monad.Except -import Control.Monad.State -import Data.Bifunctor -import Data.Coerce -import Data.Foldable (traverse_) -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.BuiltIns -import Language.Mimsa.Typechecker.Environment -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker - --- on declaring a datatype, basically is it ok -validateDataType :: - (MonadError TypeError m) => - Environment -> - Annotation -> - DataType -> - m () -validateDataType _env ann dt = do - validateDataTypeVariables ann dt - validateConstructorsArentBuiltIns ann dt - --- given a datatype declaration, checks it makes sense and if so, --- add it to the Environment -storeDataDeclaration :: - (MonadError TypeError m) => - Environment -> - Annotation -> - DataType -> - m Environment -storeDataDeclaration env ann dt@(DataType tyName _ _) = do - validateDataTypeVariables ann dt - validateConstructors env ann dt - if M.member (Nothing, tyName) (getDataTypes env) - then throwError (DuplicateTypeDeclaration ann tyName) - else - let newEnv = mempty {getDataTypes = M.singleton (Nothing, tyName) dt} - in pure (newEnv <> env) - -errorOnBuiltIn :: (MonadError TypeError m) => Annotation -> TyCon -> m () -errorOnBuiltIn ann tc = case lookupBuiltIn (coerce tc) of - Just _ -> throwError (InternalConstructorUsedOutsidePatternMatch ann tc) - _ -> pure () - --- infer the type of a data constructor --- if it has no args, it's a simple MTConstructor --- however if it has args it becomes a MTFun from args to the MTConstructor && --- MTTypeApp -inferDataConstructor :: - ( MonadState TypecheckState m, - MonadError TypeError m - ) => - Environment -> - Annotation -> - Maybe ModuleName -> - TyCon -> - m MonoType -inferDataConstructor env ann modName tyCon = do - errorOnBuiltIn ann tyCon - dataType <- lookupConstructor env ann modName tyCon - (_, allArgs) <- inferConstructorTypes ann modName dataType - case M.lookup tyCon allArgs of - Just tyArg -> - pure (constructorToType tyArg) - Nothing -> throwError UnknownTypeError -- shouldn't happen (but will) - --- which vars are used in this type? -getVariablesForField :: Type ann -> Set Name -getVariablesForField (MTVar _ (TVScopedVar _ name)) = S.singleton name -getVariablesForField (MTVar _ (TVName n)) = S.singleton (coerce n) -getVariablesForField other = withMonoidType getVariablesForField other - --- when adding a new datatype, check none of the constructors already exist -validateConstructors :: - (MonadError TypeError m) => - Environment -> - Annotation -> - DataType -> - m () -validateConstructors env ann (DataType _ _ constructors) = do - traverse_ - ( \(tyCon, _) -> - when - (M.member (Nothing, coerce tyCon) (getDataTypes env)) - (throwError (CannotUseBuiltInTypeAsConstructor ann (coerce tyCon))) - ) - (M.toList constructors) - --- when adding a new datatype, check none of the constructors already exist -validateConstructorsArentBuiltIns :: - (MonadError TypeError m) => - Annotation -> - DataType -> - m () -validateConstructorsArentBuiltIns ann (DataType _ _ constructors) = do - traverse_ - ( \(tyCon, _) -> - case lookupBuiltIn (coerce tyCon) of - Just _ -> throwError (CannotUseBuiltInTypeAsConstructor ann (coerce tyCon)) - _ -> pure () - ) - (M.toList constructors) - -validateDataTypeVariables :: - (MonadError TypeError m) => - Annotation -> - DataType -> - m () -validateDataTypeVariables ann (DataType typeName vars constructors) = - let requiredForCons = foldMap getVariablesForField - requiredVars = foldMap requiredForCons constructors - availableVars = S.fromList vars - unavailableVars = S.filter (`S.notMember` availableVars) requiredVars - in if S.null unavailableVars - then pure () - else - throwError $ - TypeVariablesNotInDataType ann typeName unavailableVars availableVars - --- infer types for data type and it's constructor in one big go -inferConstructorTypes :: - (MonadError TypeError m, MonadState TypecheckState m) => - Annotation -> - Maybe ModuleName -> - DataType -> - m (MonoType, Map TyCon TypeConstructor) -inferConstructorTypes ann modName (DataType typeName tyVarNames constructors) = do - tyVars <- traverse (\tyName -> (,) tyName <$> getUnknown mempty) tyVarNames - let findType ty = case ty of - MTVar _ (TVName var) -> - case filter (\(tyName, _) -> tyName == coerce var) tyVars of - [(_, tyFound)] -> pure tyFound - _ -> - throwError $ - TypeVariablesNotInDataType - ann - typeName - (S.singleton (coerce var)) - (S.fromList (fst <$> tyVars)) - MTVar _ (TVScopedVar _ var) -> - case filter (\(tyName, _) -> tyName == coerce var) tyVars of - [(_, tyFound)] -> pure tyFound - _ -> - throwError $ - TypeVariablesNotInDataType - ann - typeName - (S.singleton (coerce var)) - (S.fromList (fst <$> tyVars)) - MTConstructor _ localModName tn -> - -- if this is the datatype we are creating types for - -- then make sure it's constructors match the namespace - -- we are using the type in - let newModName = - if tn == typeName - then modName - else localModName - in pure (MTConstructor mempty newModName tn) - MTVar _ (TVUnificationVar _) -> - throwError UnknownTypeError -- should not happen but yolo - other -> bindType findType other - let inferConstructor (consName, tyArgs) = do - tyCons <- traverse findType tyArgs - let constructor = TypeConstructor modName typeName (snd <$> tyVars) tyCons - pure $ M.singleton consName constructor - let mtConstructors :: [(TyCon, [MonoType])] - mtConstructors = second (($> mempty) <$>) <$> M.toList constructors - cons' <- traverse inferConstructor mtConstructors - let dt = dataTypeWithVars mempty modName typeName (snd <$> tyVars) - pure (dt, mconcat cons') - ------ - -constructorToType :: TypeConstructor -> MonoType -constructorToType (TypeConstructor modName typeName tyVars constructTypes) = - foldr - (MTFunction mempty) - (dataTypeWithVars mempty modName typeName tyVars) - constructTypes diff --git a/compiler/src/Language/Mimsa/Typechecker/DisplayError.hs b/compiler/src/Language/Mimsa/Typechecker/DisplayError.hs deleted file mode 100644 index 6eedd264..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/DisplayError.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Typechecker.DisplayError - ( displayError, - ) -where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Types.Error.TypeError -import Text.Megaparsec - -displayError :: Text -> TypeError -> Text -displayError input typeError = - T.pack $ errorBundlePretty $ createErrorBundle input typeError - -toFancy :: TypeError -> ParseError Text TypeError -toFancy typeErr = - let (start, _) = getErrorPos typeErr - in FancyError start (S.singleton (ErrorCustom typeErr)) - -createErrorBundle :: Text -> TypeError -> ParseErrorBundle Text TypeError -createErrorBundle input typeError = - let initialState = - PosState - { pstateInput = input, - pstateOffset = 0, - pstateSourcePos = initialPos "repl", - pstateTabWidth = defaultTabWidth, - pstateLinePrefix = "" - } - in ParseErrorBundle - { bundleErrors = NE.fromList [toFancy typeError], - bundlePosState = initialState - } diff --git a/compiler/src/Language/Mimsa/Typechecker/Elaborate.hs b/compiler/src/Language/Mimsa/Typechecker/Elaborate.hs deleted file mode 100644 index ec5b474d..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Elaborate.hs +++ /dev/null @@ -1,827 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} - -module Language.Mimsa.Typechecker.Elaborate - ( elab, - infer, - recoverAnn, - getTypeFromAnn, - ) -where - -import Control.Monad (when) -import Control.Monad.Except -import Control.Monad.State (State) -import Control.Monad.Writer.CPS -import Data.Bifunctor -import Data.Foldable -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) -import Data.Monoid (Any (..)) -import GHC.Natural -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.DataTypes -import Language.Mimsa.Typechecker.Environment -import Language.Mimsa.Typechecker.Exhaustiveness -import Language.Mimsa.Typechecker.Generalise -import Language.Mimsa.Typechecker.ScopeTypeVar -import Language.Mimsa.Typechecker.Solve -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Language.Mimsa.Types.Typechecker.Substitutions -import Language.Mimsa.Types.Typechecker.Unique - -type ElabM = - ExceptT - TypeError - ( WriterT - [Constraint] - (State TypecheckState) - ) - -type TcExpr = Expr (Name, Unique) Annotation - -recoverAnn :: MonoType -> Annotation -recoverAnn = getAnnotationForType - -getTypeFromAnn :: Expr var MonoType -> MonoType -getTypeFromAnn = getAnnotation - -getPatternTypeFromAnn :: Pattern (Name, Unique) MonoType -> MonoType -getPatternTypeFromAnn pat = - case pat of - PLit ann _ -> ann - PWildcard ann -> ann - PVar ann _ -> ann - PConstructor ann _ _ _ -> ann - PTuple ann _ _ -> ann - PRecord ann _ -> ann - PArray ann _ _ -> ann - PString ann _ _ -> ann - -getSpreadTypeFromAnn :: Spread (Name, Unique) MonoType -> Maybe MonoType -getSpreadTypeFromAnn (SpreadValue ann _) = Just ann -getSpreadTypeFromAnn _ = Nothing - -type ElabExpr = Expr (Name, Unique) MonoType - --------------- - -inferLiteral :: Annotation -> Literal -> ElabM ElabExpr -inferLiteral ann lit = - let tyLit = case lit of - (MyInt _) -> MTInt - (MyBool _) -> MTBool - (MyString _) -> MTString - in pure (MyLiteral (MTPrim ann tyLit) lit) - -lookupInEnv :: (Name, Unique) -> Environment -> Maybe Scheme -lookupInEnv (name, ModuleDep mHash) env = - M.lookup mHash (getNamespacedSchemes env) >>= M.lookup name -lookupInEnv (name, unique) env = - let look v = M.lookup v (getSchemes env) - in look (variableToTypeIdentifier (name, unique)) - -inferVarFromScope :: - Environment -> - Annotation -> - (Name, Unique) -> - ElabM MonoType -inferVarFromScope env ann var' = - case lookupInEnv var' env of - Just mt -> - instantiate ann mt - _ -> - throwError $ - VariableNotFound - ann - (M.keysSet $ getSchemes env) - (fst var') - -envFromVar :: (Name, Unique) -> Scheme -> Environment -envFromVar binder scheme = - Environment (M.singleton (variableToTypeIdentifier binder) scheme) mempty mempty mempty mempty - -lookupInfixOp :: - Environment -> - Annotation -> - InfixOp -> - ElabM MonoType -lookupInfixOp env ann infixOp = do - case M.lookup infixOp (getInfix env) of - Just scheme -> instantiate ann scheme - Nothing -> - throwError - ( CouldNotFindInfixOperator - ann - infixOp - (M.keysSet (getInfix env)) - ) - --- let's pattern match on exactly what's inside more clearly -inferApplication :: - Environment -> - Annotation -> - TcExpr -> - TcExpr -> - ElabM ElabExpr -inferApplication env ann function argument = do - tyRes <- getUnknown ann - argument' <- infer env argument - - -- run substitutions on the fn type so we can make better errors - (elabFunction, constraints) <- listen (infer env function) - subst <- solve constraints - let tyFunc = applySubst subst (getTypeFromAnn elabFunction) - - -- check the argument against the function input - -- to create a better error - case tyFunc of - (MTFunction fnAnn mtArg _mtRet) -> do - _ <- - unify mtArg (getTypeFromAnn argument') - `catchError` \_ -> - throwError - ( FunctionArgumentMismatch - fnAnn - mtArg - (getTypeFromAnn argument') - ) - - pure () - MTVar {} -> pure () -- we still don't know what this is yet, leave it to be worked out in constraint solving - other -> - throwError (ApplicationToNonFunction (getAnnotation function) other) - - tell - [ ShouldEqual - (getTypeFromAnn elabFunction) - (MTFunction ann (getTypeFromAnn argument') tyRes) - ] - pure (MyApp tyRes elabFunction argument') - -bindingIsRecursive :: Identifier (Name, Unique) ann -> TcExpr -> Bool -bindingIsRecursive ident = getAny . withMonoid findBinding - where - variable = case ident of - (Identifier _ a) -> a - findBinding (MyVar _ _ binding) | binding == variable = (False, Any True) - findBinding _ = (True, mempty) - -binderFromIdentifier :: Identifier var ann -> var -binderFromIdentifier = \case - (Identifier _ a) -> a - -annotationFromIdentifier :: Identifier var ann -> ann -annotationFromIdentifier = \case - (Identifier ann _) -> ann - --- if type is recursive we make it monomorphic --- if not, we make it polymorphic -inferLetBinding :: - Environment -> - Annotation -> - Identifier (Name, Unique) Annotation -> - TcExpr -> - TcExpr -> - ElabM ElabExpr -inferLetBinding env ann ident expr body = do - if bindingIsRecursive ident expr - then inferRecursiveLetBinding env ann ident expr body - else do - let bindAnn = annotationFromIdentifier ident - bindName = binderFromIdentifier ident - -- we have to run substitutions on this before "saving" it - (inferExpr, constraints) <- listen (infer env expr) - subst <- solve constraints - let tySubstExpr = applySubst subst (getTypeFromAnn inferExpr) - let newEnv = - envFromVar bindName (generalise env tySubstExpr) - <> env - inferBody <- infer newEnv body - pure - ( MyLet - (getTypeFromAnn inferBody $> ann) -- we want to make sure we keep the original source location - (ident $> (tySubstExpr $> bindAnn)) - inferExpr - inferBody - ) - -inferRecursiveLetBinding :: - Environment -> - Annotation -> - Identifier (Name, Unique) Annotation -> - TcExpr -> - TcExpr -> - ElabM ElabExpr -inferRecursiveLetBinding env ann ident expr body = do - let bindName = binderFromIdentifier ident - bindAnn = annotationFromIdentifier ident - tyRecExpr <- getUnknown ann - let envWithRecursiveFn = envFromVar bindName (Scheme [] tyRecExpr) <> env - inferExpr <- infer envWithRecursiveFn expr - - let tyExpr = getTypeFromAnn inferExpr - newEnv = - envFromVar bindName (Scheme [] tyExpr) <> env - - inferBody <- infer newEnv body - tell [ShouldEqual tyRecExpr (getTypeFromAnn inferExpr)] - - pure - ( MyLet - (getTypeFromAnn inferBody) - (ident $> (tyExpr $> bindAnn)) - inferExpr - inferBody - ) - -unifyTypeOrError :: MonoType -> MonoType -> TypeError -> ElabM () -unifyTypeOrError got expected typeErr = - do - _ <- unify got expected `catchError` \_ -> throwError typeErr - pure () - -inferIf :: Environment -> Annotation -> TcExpr -> TcExpr -> TcExpr -> ElabM ElabExpr -inferIf env ann condition thenExpr elseExpr = do - condExpr <- infer env condition - - -- check condition matches Boolean now as we can raise - -- a more accurate error, we ignore any substitutions as we'll use the constraint - -- below to create them later and learn about variables etc - unifyTypeOrError - (expAnn condExpr) - (MTPrim mempty MTBool) - (IfPredicateIsNotBoolean ann (expAnn condExpr)) - - thenExpr' <- infer env thenExpr - elseExpr' <- infer env elseExpr - tell - [ -- check the two clauses have the same reply type - ShouldEqual - (getTypeFromAnn thenExpr') - (getTypeFromAnn elseExpr'), - -- we still need this constraint to learn about any variables - -- from the comparison with Boolean - ShouldEqual - (getTypeFromAnn condExpr) - (MTPrim (getAnnotation condition) MTBool) - ] - pure - ( MyIf - (getTypeFromAnn thenExpr') - condExpr - thenExpr' - elseExpr' - ) - ------ - --- check a list of types are all the same -matchList :: NE.NonEmpty MonoType -> ElabM MonoType -matchList mts = do - foldl - ( \ty' tyB' -> do - tyA <- ty' - tell [ShouldEqual tyA tyB'] - pure tyB' - ) - ( pure (NE.head mts) - ) - (NE.tail mts) - --- check type of input expr --- check input against patterns --- check patterns are complete --- check output types are the same -inferPatternMatch :: - Environment -> - Annotation -> - TcExpr -> - [(Pattern (Name, Unique) Annotation, TcExpr)] -> - ElabM ElabExpr -inferPatternMatch env ann expr patterns = do - -- ensure we even have any patterns to match on - nePatterns <- checkEmptyPatterns ann patterns - -- inferorate source expression that we are matching - inferExpr <- infer env expr - -- infer types of all patterns - inferPatterns <- - traverse - ( \(pat, patternExpr) -> do - (inferPat, newEnv) <- inferPattern env pat - tell - [ ShouldEqual - (getPatternTypeFromAnn inferPat) - (getTypeFromAnn inferExpr) - ] - tyPatternExpr <- infer newEnv patternExpr - pure (inferPat, tyPatternExpr) - ) - nePatterns - -- combine all patterns to check their types match - tyMatchedPattern <- matchList (getPatternTypeFromAnn . fst <$> inferPatterns) - -- match patterns with match expr - tell [ShouldEqual tyMatchedPattern (getTypeFromAnn inferExpr)] - -- combine all output expr types - tyMatchedExprs <- matchList (getTypeFromAnn . snd <$> inferPatterns) - -- remove (,unique) from var - let patternsWithoutUnique = first fst . fst <$> patterns - -- perform exhaustiveness checking at end so it doesn't mask more basic errors - validatePatterns env ann patternsWithoutUnique - -- wrap up the pattern match again - pure - ( MyPatternMatch - tyMatchedExprs - inferExpr - (NE.toList inferPatterns) - ) - --- get non-empty list from list and error if not -checkEmptyPatterns :: Annotation -> [a] -> ElabM (NE.NonEmpty a) -checkEmptyPatterns ann as = case as of - [] -> throwError (PatternMatchErr $ EmptyPatternMatch ann) - other -> pure (NE.fromList other) - -inferPattern :: - Environment -> - Pattern (Name, Unique) Annotation -> - ElabM (Pattern (Name, Unique) MonoType, Environment) -inferPattern env (PLit ann lit) = do - inferExpr <- infer env (MyLiteral ann lit) - pure - ( PLit (getTypeFromAnn inferExpr) lit, - env - ) -inferPattern env (PVar ann binder) = do - tyBinder <- getUnknown ann - let tmpCtx = - envFromVar binder (Scheme [] tyBinder) <> env - pure - ( PVar tyBinder binder, - tmpCtx - ) -inferPattern env (PWildcard ann) = do - tyUnknown <- getUnknown ann - pure - ( PWildcard tyUnknown, - env - ) -inferPattern env (PConstructor ann modName tyCon args) = do - inferEverything <- traverse (inferPattern env) args - let inferArgs = fst <$> inferEverything - let newEnv = mconcat (snd <$> inferEverything) <> env - dt@(DataType ty _ _) <- lookupConstructor newEnv ann modName tyCon - -- we get the types for the constructor in question - -- and unify them with the tests in the pattern - consType <- inferConstructorTypes ann modName dt - tyTypeVars <- case M.lookup tyCon (snd consType) of - Just (TypeConstructor _ _ dtTypeVars tyDtArgs) -> do - let tyPairs = zip (getPatternTypeFromAnn <$> inferArgs) tyDtArgs - traverse_ (\(a, b) -> tell [ShouldEqual a b]) tyPairs - pure dtTypeVars - _ -> throwError UnknownTypeError - checkArgsLength ann dt tyCon inferArgs - pure - ( PConstructor (dataTypeWithVars ann modName ty tyTypeVars) modName tyCon inferArgs, - newEnv - ) -inferPattern env (PTuple ann a as) = do - (inferA, envA) <- inferPattern env a - lump <- traverse (inferPattern envA) as - pure - ( PTuple - ( MTTuple - ann - (getPatternTypeFromAnn inferA) - (getPatternTypeFromAnn . fst <$> lump) - ) - inferA - (fst <$> lump), - foldMap snd lump - ) -inferPattern env (PRecord ann items) = do - let inferRow (k, v) = do - (tyValue, envNew) <- inferPattern env v - pure (M.singleton k tyValue, envNew) - inferEverything <- traverse inferRow (M.toList items) - let inferItems = mconcat (fst <$> inferEverything) - let newEnv = mconcat (snd <$> inferEverything) <> env - tyRest <- getUnknown ann - pure - ( PRecord - ( MTRecord - ann - (getPatternTypeFromAnn <$> inferItems) - (Just tyRest) - ) - inferItems, - newEnv - ) -inferPattern env (PArray ann items spread) = do - inferEverything <- traverse (inferPattern env) items - (inferSpread, env2) <- case spread of - SpreadValue ann2 binder -> do - tyBinder <- getUnknown ann2 - let tmpCtx = - envFromVar binder (Scheme [] (MTArray ann2 tyBinder)) <> env - pure - ( SpreadValue tyBinder binder, - tmpCtx - ) - NoSpread -> pure (NoSpread, env) - SpreadWildcard ann2 -> do - tyUnknown <- getUnknown ann2 - pure (SpreadWildcard tyUnknown, env) - tyItems <- case NE.nonEmpty - ( (getPatternTypeFromAnn . fst <$> inferEverything) - <> maybe mempty pure (getSpreadTypeFromAnn inferSpread) - ) of - Just neItems -> matchList neItems - _ -> getUnknown ann - let newEnv = mconcat (snd <$> inferEverything) <> env2 - pure - ( PArray - ( MTArray - ann - tyItems - ) - (fst <$> inferEverything) - inferSpread, - newEnv - ) -inferPattern env (PString ann a as) = do - let envFromStrPart x = case x of - (StrValue ann' name) -> - envFromVar name (Scheme [] (MTPrim ann' MTString)) - _ -> mempty - let newEnv = envFromStrPart a <> envFromStrPart as <> env - let inferStringPart (StrValue ann' name) = - StrValue (MTPrim ann' MTString) name - inferStringPart (StrWildcard ann') = - StrWildcard (MTPrim ann' MTString) - pure - ( PString - (MTPrim ann MTString) - (inferStringPart a) - (inferStringPart as), - newEnv - ) - -checkArgsLength :: Annotation -> DataType -> TyCon -> [a] -> ElabM () -checkArgsLength ann (DataType _ _ cons) tyCon args = do - case M.lookup tyCon cons of - Just consArgs -> - if length consArgs == length args - then pure () - else - throwError $ - PatternMatchErr - ( ConstructorArgumentLengthMismatch - ann - tyCon - (length consArgs) - (length args) - ) - Nothing -> throwError UnknownTypeError -- shouldn't happen (but will) - -inferOperator :: - Environment -> - Annotation -> - Operator -> - TcExpr -> - TcExpr -> - ElabM ElabExpr -inferOperator env ann Equals a b = do - inferA <- infer env a - inferB <- infer env b - let tyA = getTypeFromAnn inferA - tyB = getTypeFromAnn inferB - case tyA of - MTFunction {} -> throwError $ NoFunctionEquality tyA tyB - _ -> do - tell - [ ShouldEqual - tyA - tyB -- Equals wants them to be the same - ] - pure - ( MyInfix - (MTPrim ann MTBool) - Equals - inferA - inferB - ) -inferOperator env ann Add a b = do - (mt, inferA, inferB) <- inferInfix env (MTPrim ann MTInt) a b - pure (MyInfix mt Add inferA inferB) -inferOperator env ann Subtract a b = do - (mt, inferA, inferB) <- inferInfix env (MTPrim ann MTInt) a b - pure (MyInfix mt Subtract inferA inferB) -inferOperator env ann StringConcat a b = do - (mt, inferA, inferB) <- inferInfix env (MTPrim ann MTString) a b - pure (MyInfix mt StringConcat inferA inferB) -inferOperator env ann ArrayConcat a b = do - tyArr <- getUnknown ann - (mt, inferA, inferB) <- inferInfix env (MTArray ann tyArr) a b - pure (MyInfix mt ArrayConcat inferA inferB) -inferOperator env ann GreaterThan a b = do - (mt, inferA, inferB) <- - inferComparison - env - (MTPrim ann MTInt) - (MTPrim ann MTBool) - a - b - pure (MyInfix mt GreaterThan inferA inferB) -inferOperator env ann GreaterThanOrEqualTo a b = do - (mt, inferA, inferB) <- - inferComparison - env - (MTPrim ann MTInt) - (MTPrim ann MTBool) - a - b - pure (MyInfix mt GreaterThanOrEqualTo inferA inferB) -inferOperator env ann LessThan a b = do - (mt, inferA, inferB) <- - inferComparison - env - (MTPrim ann MTInt) - (MTPrim ann MTBool) - a - b - pure (MyInfix mt LessThan inferA inferB) -inferOperator env ann LessThanOrEqualTo a b = do - (mt, inferA, inferB) <- - inferComparison - env - (MTPrim ann MTInt) - (MTPrim ann MTBool) - a - b - pure (MyInfix mt LessThanOrEqualTo inferA inferB) -inferOperator env ann (Custom infixOp) a b = do - tyRes <- getUnknown ann - tyFun <- lookupInfixOp env ann infixOp - inferA <- infer env a - inferB <- infer env b - tell - [ ShouldEqual - tyFun - ( MTFunction - ann - (getTypeFromAnn inferA) - (MTFunction ann (getTypeFromAnn inferB) tyRes) - ) - ] - pure (MyInfix tyRes (Custom infixOp) inferA inferB) - --- | infix operator where inputs and output are the same -inferInfix :: - Environment -> - MonoType -> - TcExpr -> - TcExpr -> - ElabM (MonoType, ElabExpr, ElabExpr) -inferInfix env mt a b = do - inferA <- infer env a - inferB <- infer env b - let tyA = getTypeFromAnn inferA - tyB = getTypeFromAnn inferB - tell [ShouldEqual tyA tyB, ShouldEqual tyB mt, ShouldEqual tyA mt] - pure (mt, inferA, inferB) - --- | infix operator where inputs match but output could be different --- | for instance, 1 < 2 == True would be `Int -> Int -> Bool` -inferComparison :: - Environment -> - MonoType -> - MonoType -> - TcExpr -> - TcExpr -> - ElabM (MonoType, ElabExpr, ElabExpr) -inferComparison env inputMt outputMt a b = do - inferA <- infer env a - inferB <- infer env b - let tyA = getTypeFromAnn inferA - tyB = getTypeFromAnn inferB - tell - [ ShouldEqual tyA tyB, - ShouldEqual tyA inputMt, - ShouldEqual tyB inputMt - ] - pure (outputMt, inferA, inferB) - -inferRecordAccess :: - Environment -> - Annotation -> - TcExpr -> - Name -> - ElabM ElabExpr -inferRecordAccess env ann a name = do - inferItems <- infer env a - let inferRow = \case - (MTRecord _ bits Nothing) -> - case M.lookup name bits of - Just mt -> pure mt - _ -> - throwError $ MissingRecordTypeMember ann name bits - (MTRecord _ as (Just rest)) -> - case M.lookup name as of - Just mt -> pure mt - _ -> inferRow rest - (MTVar ann' _) -> do - tyRest <- getUnknown ann' - tyItem <- getUnknown ann' - tell - [ ShouldEqual - (getTypeFromAnn inferItems) - ( MTRecord - ann' - (M.singleton name tyItem) - (Just tyRest) - ) - ] - pure tyItem - _ -> throwError $ CannotMatchRecord env ann (getTypeFromAnn inferItems) - mt <- inferRow (getTypeFromAnn inferItems) - pure (MyRecordAccess mt inferItems name) - -inferTupleAccess :: - Environment -> - Annotation -> - TcExpr -> - Natural -> - ElabM ElabExpr -inferTupleAccess env ann expr index = do - inferItems <- infer env expr - -- bin off stupid numbers - when - (index < 1) - (throwError $ CannotMatchTuple env ann (getTypeFromAnn inferItems)) - - let inferRow = \case - (MTTuple _ a as) -> do - let allItems = [a] <> NE.toList as - case listToMaybe (drop (fromIntegral index - 1) allItems) of - Just mt -> pure mt - _ -> - throwError $ MissingTupleTypeMember ann index ([a] <> NE.toList as) - _ -> throwError $ CannotMatchTuple env ann (getTypeFromAnn inferItems) - mt <- inferRow (getTypeFromAnn inferItems) - pure (MyTupleAccess mt inferItems index) - -inferLetPattern :: - Environment -> - Annotation -> - Pattern (Name, Unique) Annotation -> - TcExpr -> - TcExpr -> - ElabM ElabExpr -inferLetPattern env ann pat expr body = do - inferExpr <- infer env expr - (inferPat, newEnv) <- inferPattern env pat - inferBody <- infer newEnv body - tell - [ ShouldEqual (getPatternTypeFromAnn inferPat) (getTypeFromAnn inferExpr) - ] - - -- perform exhaustiveness checking at end so it doesn't mask more basic errors - validatePatterns env ann [first fst pat] - - pure (MyLetPattern (getTypeFromAnn inferBody) inferPat inferExpr inferBody) - -inferLambda :: - Environment -> - Annotation -> - Identifier (Name, Unique) Annotation -> - TcExpr -> - ElabM ElabExpr -inferLambda env ann ident body = do - let binder = binderFromIdentifier ident - bindAnn = annotationFromIdentifier ident - - tyBinder <- getUnknown bindAnn - - let tmpCtx = - envFromVar binder (Scheme [] tyBinder) <> env - - inferBody <- infer tmpCtx body - let tyReturn = MTFunction ann tyBinder (getTypeFromAnn inferBody) - pure - ( MyLambda - tyReturn - (ident $> (tyBinder $> bindAnn)) - inferBody - ) - -inferArray :: - Environment -> - Annotation -> - [TcExpr] -> - ElabM ElabExpr -inferArray env ann items = do - inferItems <- traverse (infer env) items - tyItems <- case NE.nonEmpty inferItems of - Just neElabItems -> matchList (getTypeFromAnn <$> neElabItems) - Nothing -> getUnknown ann - pure (MyArray (MTArray ann tyItems) inferItems) - -elab :: Environment -> TcExpr -> ElabM ElabExpr -elab = infer - -checkLambda :: - Environment -> - Annotation -> - Identifier (Name, Unique) Annotation -> - TcExpr -> - MonoType -> - MonoType -> - ElabM ElabExpr -checkLambda env ann ident body tyBinder tyBody = do - let binder = binderFromIdentifier ident - bindAnn = annotationFromIdentifier ident - - -- convert TVName to TVScopedVar and scope them where necessary - (newEnv1, tyBinder') <- freshNamedType env tyBinder - (newEnv2, tyBody') <- freshNamedType newEnv1 tyBody - - let envWithBinder = - envFromVar binder (Scheme [] tyBinder') - <> newEnv2 - - -- check body type - inferBody <- check envWithBinder body tyBody' - - let tyReturn = MTFunction ann tyBinder' (expAnn inferBody) - pure - ( MyLambda - tyReturn - (ident $> (tyBinder' $> bindAnn)) - inferBody - ) - -check :: Environment -> TcExpr -> MonoType -> ElabM ElabExpr -check env expr mt = - case (expr, mt) of - (MyLambda ann ident body, MTFunction _ tyBinder tyBody) -> - checkLambda env ann ident body tyBinder tyBody - _ -> do - typedExpr <- infer env expr - subs <- unify (expAnn typedExpr) mt - pure (applySubst subs typedExpr) - -infer :: - Environment -> - TcExpr -> - ElabM ElabExpr -infer env inferExpr = - case inferExpr of - (MyLiteral ann a) -> inferLiteral ann a - (MyAnnotation _ann mt expr) -> do - elabExpr <- check env expr mt - pure (MyAnnotation (expAnn elabExpr) (mt $> mt) elabExpr) - (MyVar ann maybeMod name) -> do - mt <- inferVarFromScope env ann name - pure (MyVar mt maybeMod name) - (MyRecord ann map') -> do - inferItems <- traverse (infer env) map' - let tyItems = getTypeFromAnn <$> inferItems - pure (MyRecord (MTRecord ann tyItems Nothing) inferItems) - (MyInfix ann op a b) -> inferOperator env ann op a b - (MyTypedHole ann (name, unique)) -> do - tyHole <- addTypedHole env ann name - pure (MyVar tyHole Nothing (name, unique)) - (MyLet ann binder expr body) -> - inferLetBinding env ann binder expr body - (MyLetPattern ann pat expr body) -> - inferLetPattern env ann pat expr body - (MyRecordAccess ann a name) -> - inferRecordAccess env ann a name - (MyTupleAccess ann a index) -> - inferTupleAccess env ann a index - (MyLambda ann binder body) -> - inferLambda env ann binder body - (MyApp ann function argument) -> - inferApplication env ann function argument - (MyIf ann condition thenCase elseCase) -> - inferIf env ann condition thenCase elseCase - (MyTuple ann a as) -> do - inferA <- infer env a - inferAs <- traverse (infer env) as - let tyA = getTypeFromAnn inferA - tyAs = getTypeFromAnn <$> inferAs - pure (MyTuple (MTTuple ann tyA tyAs) inferA inferAs) - (MyArray ann items) -> do - inferArray env ann items - (MyConstructor ann modName name) -> do - tyData <- inferDataConstructor env ann modName name - pure (MyConstructor tyData modName name) - (MyPatternMatch ann expr patterns) -> - inferPatternMatch env ann expr patterns diff --git a/compiler/src/Language/Mimsa/Typechecker/Environment.hs b/compiler/src/Language/Mimsa/Typechecker/Environment.hs deleted file mode 100644 index 3d2e885e..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Environment.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.Environment (lookupConstructor) where - -import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker - --- given a constructor name, return the type it lives in -lookupConstructor :: - (MonadError (TypeErrorF var Annotation) m) => - Environment -> - Annotation -> - Maybe ModuleName -> - TyCon -> - m DataType -lookupConstructor env ann modName name = - let dts = inMatchingNamespace modName (getDataTypes env) - in case M.toList $ M.filter (containsConstructor name) dts of - [(_, a)] -> pure a -- we only want a single match - (_ : _) -> throwError (ConflictingConstructors ann name) - _ -> throwError (TypeConstructorNotInScope env ann modName name) - --- only look at stuff in the same namespace -inMatchingNamespace :: (Eq a) => a -> Map (a, b) c -> Map (a, b) c -inMatchingNamespace match = M.filterWithKey (\(k1, _) _ -> k1 == match) - --- does this data type contain the given constructor? -containsConstructor :: TyCon -> DataType -> Bool -containsConstructor name (DataType _tyName _tyVars constructors) = - M.member name constructors diff --git a/compiler/src/Language/Mimsa/Typechecker/Exhaustiveness.hs b/compiler/src/Language/Mimsa/Typechecker/Exhaustiveness.hs deleted file mode 100644 index 2a7cca33..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Exhaustiveness.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Typechecker.Exhaustiveness - ( isExhaustive, - redundantCases, - validatePatterns, - noDuplicateVariables, - smallerListVersions, - ) -where - -import Control.Monad.Except -import Data.Foldable -import Data.Functor -import Data.List (nub) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Monoid -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Environment -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker.Environment - -validatePatterns :: - ( MonadError (TypeErrorF var Annotation) m, - Ord var, - Printer var, - Show var - ) => - Environment -> - Annotation -> - [Pattern var Annotation] -> - m () -validatePatterns env ann patterns = do - traverse_ noDuplicateVariables patterns - missing <- isExhaustive env patterns - _ <- case missing of - [] -> pure () - _ -> - throwError (PatternMatchErr (MissingPatterns ann missing)) - redundant <- redundantCases env patterns - case redundant of - [] -> pure () - _ -> - throwError (PatternMatchErr (RedundantPatterns ann redundant)) - -noDuplicateVariables :: - ( MonadError (TypeErrorF var Annotation) m, - Ord var - ) => - Pattern var Annotation -> - m () -noDuplicateVariables pat = do - let dupes = - M.keysSet - . M.filter (> 1) - . getVariables - $ pat - in if S.null dupes - then pure () - else - throwError - ( PatternMatchErr - ( DuplicateVariableUse - (getPatternAnnotation pat) - dupes - ) - ) - -getVariables :: - (Ord var) => - Pattern var Annotation -> - Map var Int -getVariables (PWildcard _) = mempty -getVariables (PLit _ _) = mempty -getVariables (PVar _ a) = M.singleton a 1 -getVariables (PTuple _ a as) = - M.unionWith (+) (getVariables a) (foldMap getVariables as) -getVariables (PRecord _ as) = - foldr (M.unionWith (+)) mempty (getVariables <$> as) -getVariables (PArray _ as spread) = - let vars = [getSpreadVariables spread] <> (getVariables <$> as) - in foldr (M.unionWith (+)) mempty vars -getVariables (PConstructor _ _ _ args) = - foldr (M.unionWith (+)) mempty (getVariables <$> args) -getVariables (PString _ a as) = - M.unionWith (+) (getStringPartVariables a) (getStringPartVariables as) - -getSpreadVariables :: (Ord var) => Spread var Annotation -> Map var Int -getSpreadVariables (SpreadValue _ a) = M.singleton a 1 -getSpreadVariables _ = mempty - -getStringPartVariables :: (Ord var) => StringPart var Annotation -> Map var Int -getStringPartVariables (StrWildcard _) = mempty -getStringPartVariables (StrValue _ a) = M.singleton a 1 - --- | given a list of patterns, return a list of missing patterns -isExhaustive :: - ( Eq var, - MonadError (TypeErrorF var Annotation) m, - Printer var, - Show var - ) => - Environment -> - [Pattern var Annotation] -> - m [Pattern var Annotation] -isExhaustive env patterns = do - generated <- - mconcat - <$> traverse (generate env) patterns - pure $ filterMissing patterns generated - -generate :: - ( MonadError (TypeErrorF var Annotation) m, - Printer var, - Show var - ) => - Environment -> - Pattern var Annotation -> - m [Pattern var Annotation] -generate env pat = (<>) [pat] <$> generateRequired env pat - --- | Given a pattern, generate others required for it -generateRequired :: - ( MonadError (TypeErrorF var Annotation) m, - Printer var, - Show var - ) => - Environment -> - Pattern var Annotation -> - m [Pattern var Annotation] -generateRequired _ (PLit _ (MyBool True)) = - pure [PLit mempty (MyBool False)] -generateRequired _ (PLit _ (MyBool False)) = - pure [PLit mempty (MyBool True)] -generateRequired _ (PLit _ (MyInt _)) = - pure [PWildcard mempty] -generateRequired _ (PLit _ (MyString "")) = - pure [PString mempty (StrWildcard mempty) (StrWildcard mempty)] -generateRequired _ (PLit _ (MyString _)) = - pure [PWildcard mempty] -generateRequired env (PTuple _ a as) = do - -- the thing that sucks here is that you don't want to annihilate - -- unnecessarily, but also you don't want to create too many extra lads - let genOrOriginal pat = do - generated <- generateRequired env pat - case generated of - [] -> pure [pat] - items -> pure items - genAs <- traverse genOrOriginal (NE.cons a as) - let tuple ne = PTuple mempty (NE.head ne) (NE.fromList $ NE.tail ne) - pure (tuple <$> sequence genAs) -generateRequired env (PRecord _ items) = do - items' <- traverse (generateRequired env) items - pure (PRecord mempty <$> sequence items') -generateRequired env (PConstructor ann modName tyCon args) = do - dt <- lookupConstructor env ann modName tyCon - newFromArgs <- traverse (generateRequired env) args - newDataTypes <- requiredFromDataType dt - let newCons = PConstructor mempty modName tyCon <$> sequence newFromArgs - pure (newCons <> newDataTypes) -generateRequired env (PArray _ items _) = do - items' <- traverse (generateRequired env) items - let allItems = smallerListVersions (sequence items') - pure $ - (PArray mempty <$> allItems <*> pure (SpreadWildcard mempty)) - <> [PArray mempty mempty NoSpread] - <> [PArray mempty [PWildcard mempty] (SpreadWildcard mempty)] -generateRequired _ PString {} = pure [PLit mempty (MyString "")] -generateRequired _ _ = pure mempty - --- given a list [[1,2,3]], return [[1,2,3], [1,2], [1]] -smallerListVersions :: [[a]] -> [[a]] -smallerListVersions aas = - let get x = case x of - [] -> [] - (_ : as) -> get as <> [x] - in get =<< aas - -requiredFromDataType :: - (MonadError (TypeErrorF var Annotation) m) => - DataType -> - m [Pattern var Annotation] -requiredFromDataType (DataType _ _ cons) = - if length cons < 2 -- if there is only one constructor don't generate more - then pure mempty - else do - let new (n, as) = - [ PConstructor - mempty - Nothing - n - (PWildcard mempty <$ as) - ] - pure $ mconcat (new <$> M.toList cons) - --- filter outstanding items -filterMissing :: - (Eq var, Eq ann, Show var) => - [Pattern var ann] -> - [Pattern var ann] -> - [Pattern var ann] -filterMissing patterns required = - nub $ foldr annihiliatePattern required patterns - where - annihiliatePattern pat = - filter - ( not - . annihilate - (removeAnn pat) - . removeAnn - ) - -removeAnn :: Pattern var ann -> Pattern var () -removeAnn p = p $> () - --- does left pattern satisfy right pattern? -annihilateAll :: - (Eq var, Show var) => - [(Pattern var (), Pattern var ())] -> - Bool -annihilateAll = - foldr - (\(a, b) keep -> keep && annihilate a b) - True - --- | if left is on the right, should we get rid? -annihilate :: (Eq var, Show var) => Pattern var () -> Pattern var () -> Bool -annihilate a b | a == b = True -annihilate (PWildcard _) _ = True -- wildcard trumps all -annihilate (PVar _ _) _ = True -- as does var -annihilate (PTuple _ a as) (PTuple _ b bs) = - let allPairs = zip ([a] <> NE.toList as) ([b] <> NE.toList bs) - in annihilateAll allPairs -annihilate (PRecord _ as) (PRecord _ bs) = - let diffKeys = S.difference (M.keysSet as) (M.keysSet bs) - in S.null diffKeys - && annihilateAll (zip (M.elems as) (M.elems bs)) -annihilate (PConstructor _ _ tyConA argsA) (PConstructor _ _ tyConB argsB) = - (tyConA == tyConB) - && annihilateAll - (zip argsA argsB) -annihilate PString {} PString {} = True -annihilate (PTuple _ a as) _ = - isComplete a && getAll (foldMap (All . isComplete) as) -annihilate (PRecord _ as) _ = - foldr (\a total -> total && isComplete a) True as -annihilate (PArray _ itemsA (SpreadWildcard _)) (PArray _ itemsB (SpreadValue _ _)) = - annihilateAll - (zip itemsA itemsB) -annihilate (PArray _ itemsA (SpreadValue _ _)) (PArray _ itemsB (SpreadWildcard _)) = - annihilateAll - (zip itemsA itemsB) -annihilate _ _as = False - --- is this item total, as such, ie, is it always true? -isComplete :: Pattern var ann -> Bool -isComplete (PWildcard _) = True -isComplete (PVar _ _) = True -isComplete (PTuple _ a as) = isComplete a && getAll (foldMap (All . isComplete) (NE.toList as)) -isComplete _ = False - -redundantCases :: - ( MonadError (TypeErrorF var Annotation) m, - Eq var, - Printer var, - Show var - ) => - Environment -> - [Pattern var Annotation] -> - m [Pattern var Annotation] -redundantCases env patterns = do - generated <- - mconcat - <$> traverse (generate env) patterns - let annihiliatePattern pat = - filter - ( not - . annihilate - (removeAnn pat) - . removeAnn - ) - -- add index, the first pattern is never redundant - let patternsWithIndex = zip patterns ([0 ..] :: [Int]) - pure $ - snd $ - foldl' - ( \(remaining, redundant) (pat, i) -> - let rest = annihiliatePattern pat remaining - in if length rest == length remaining && i > 0 - then (rest, redundant <> [pat]) - else (rest, redundant) - ) - (generated, mempty) - patternsWithIndex diff --git a/compiler/src/Language/Mimsa/Typechecker/FlattenRow.hs b/compiler/src/Language/Mimsa/Typechecker/FlattenRow.hs deleted file mode 100644 index 8cbb196c..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/FlattenRow.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.FlattenRow - ( flattenRow, - ) -where - -import Language.Mimsa.Core - --- these are tricky to deal with, so flatten them on the way in -flattenRow :: Type ann -> Type ann -flattenRow (MTRecord ann as (Just (MTRecord _ann' bs (Just rest)))) = - flattenRow (MTRecord ann (as <> bs) (Just rest)) -flattenRow other = other diff --git a/compiler/src/Language/Mimsa/Typechecker/Generalise.hs b/compiler/src/Language/Mimsa/Typechecker/Generalise.hs deleted file mode 100644 index 7c31b864..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Generalise.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Language.Mimsa.Typechecker.Generalise - ( generalise, - freeTypeVars, - freeTypeVarsCtx, - ) -where - -import Data.List ((\\)) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Types.Typechecker - -freeTypeVars :: MonoType -> S.Set TypeIdentifier -freeTypeVars ty = case ty of - MTVar _ var -> - S.singleton var - other -> withMonoidType freeTypeVars other - -freeTypeVarsScheme :: Scheme -> [TypeIdentifier] -freeTypeVarsScheme (Scheme vars t) = - S.toList (freeTypeVars t) \\ vars - -freeTypeVarsCtx :: Environment -> [TypeIdentifier] -freeTypeVarsCtx (Environment env _ _ _ _) = - foldMap freeTypeVarsScheme (M.elems env) - -generalise :: Environment -> MonoType -> Scheme -generalise env ty = - Scheme (S.toList $ S.fromList vars) ty - where - vars = - S.toList (freeTypeVars ty) \\ freeTypeVarsCtx env diff --git a/compiler/src/Language/Mimsa/Typechecker/NormaliseTypes.hs b/compiler/src/Language/Mimsa/Typechecker/NormaliseTypes.hs deleted file mode 100644 index 5062a80f..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/NormaliseTypes.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Language.Mimsa.Typechecker.NormaliseTypes (normaliseType) where - -import Control.Monad.State -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core - -data NormaliseState = NormaliseState - { _nsNext :: Int, - _nsAllocated :: Map TypeIdentifier Int - } - -normaliseType :: (Monoid ann) => Type ann -> Type ann -normaliseType mt = - evalState - (normaliseType' mt) - (NormaliseState 1 mempty) - -findVar :: TypeIdentifier -> State NormaliseState Int -findVar i = do - (NormaliseState next alloc) <- get - case M.lookup i alloc of - Just a -> pure a - Nothing -> do - put (NormaliseState (next + 1) (alloc <> M.singleton i next)) - pure next - -normaliseType' :: (Monoid ann) => Type ann -> State NormaliseState (Type ann) -normaliseType' (MTVar ann tyIdent) = do - index <- findVar tyIdent - pure $ MTVar ann (TVUnificationVar index) -normaliseType' other = bindType normaliseType' other diff --git a/compiler/src/Language/Mimsa/Typechecker/NumberVars.hs b/compiler/src/Language/Mimsa/Typechecker/NumberVars.hs deleted file mode 100644 index fac70ebd..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/NumberVars.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Typechecker.NumberVars - ( addNumbersToStoreExpression, - addNumbersToExpression, - NumberedExpr, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Types.Error.TypeError -import Language.Mimsa.Types.Store -import Language.Mimsa.Types.Typechecker.Unique - -newtype SubsState var ann = SubsState - { ssCounter :: Int - } - deriving newtype (Eq, Ord, Show) - -newtype SubsEnv var ann = SubsEnv - { seScope :: Map (var, Maybe ModuleName) Unique - } - deriving newtype (Eq, Ord, Show, Semigroup, Monoid) - -type App var ann = - ExceptT - (TypeErrorF var ann) - ( ReaderT - (SubsEnv var ann) - (State (SubsState var ann)) - ) - -type NumberedExpr var ann = Expr (var, Unique) ann - -addNumbersToStoreExpression :: - (Show ann) => - Expr Name ann -> - Map (Maybe ModuleName, Name) ExprHash -> - Either (TypeErrorF Name ann) (NumberedExpr Name ann) -addNumbersToStoreExpression expr bindings = - let action = do - -- add dependencies to scope - let varsFromDeps = - mconcat $ - ( \((modName, name), hash) -> - M.singleton (name, modName) (Dependency hash) - ) - <$> M.toList bindings - -- evaluate rest of expression using these - withLambda - varsFromDeps - (markImports expr) - in evalState - ( runReaderT - (runExceptT action) - mempty - ) - (SubsState 0) - -addNumbersToExpression :: - (Show ann) => - Set Name -> - Map Name ExprHash -> - Map ModuleName (ModuleHash, Set Name) -> - Expr Name ann -> - Either (TypeErrorF Name ann) (NumberedExpr Name ann) -addNumbersToExpression locals imports modules expr = - let action = do - -- add dependencies to scope - let localVars = - mconcat $ - (\name -> M.singleton (name, Nothing) Local) - <$> S.toList locals - - let importVars = - mconcat $ - (\(name, hash) -> M.singleton (name, Nothing) (Dependency hash)) - <$> M.toList imports - let moduleVars = - mconcat $ - ( \(modName, (hash, names)) -> - M.fromList - ( (\name -> ((name, Just modName), ModuleDep hash)) - <$> S.toList names - ) - ) - <$> M.toList modules - - -- evaluate rest of expression using these - withLambda - (localVars <> importVars <> moduleVars) - (markImports expr) - in evalState - ( runReaderT - (runExceptT action) - mempty - ) - (SubsState 0) - -varFromIdent :: Identifier var ann -> var -varFromIdent ident = case ident of - Identifier _ v -> v - -varsFromPattern :: (Ord var) => Pattern var ann -> Set var -varsFromPattern (PVar _ var) = S.singleton var -varsFromPattern (PWildcard _) = mempty -varsFromPattern (PLit _ _) = mempty -varsFromPattern (PConstructor _ _ _ as) = mconcat (varsFromPattern <$> as) -varsFromPattern (PTuple _ a as) = varsFromPattern a <> mconcat (varsFromPattern <$> NE.toList as) -varsFromPattern (PRecord _ as) = mconcat (varsFromPattern <$> M.elems as) -varsFromPattern (PArray _ as spread) = - let spreadVars = case spread of - SpreadValue _ a -> S.singleton a - SpreadWildcard _ -> mempty - NoSpread -> mempty - in spreadVars <> mconcat (varsFromPattern <$> as) -varsFromPattern (PString _ sHead sTail) = - let stringPartVars sp = case sp of - StrValue _ a -> S.singleton a - StrWildcard _ -> mempty - in stringPartVars sHead <> stringPartVars sTail - -freshVarsFromPattern :: - (Ord var) => - Pattern var ann -> - App var ann (Map (var, Maybe ModuleName) Unique) -freshVarsFromPattern pat = - M.fromList - <$> traverse - (\var -> (,) (var, Nothing) <$> nextNum) - (S.toList (varsFromPattern pat)) - -withLambda :: (Ord var) => Map (var, Maybe ModuleName) Unique -> App var ann a -> App var ann a -withLambda newVars = - local (\env -> env {seScope = newVars <> seScope env}) - -nextNum :: App var ann Unique -nextNum = do - unique <- gets ssCounter - modify - ( \s -> - s - { ssCounter = unique + 1 - } - ) - pure (Unique unique) - -lookupVar :: - (Ord var) => - var -> - Maybe ModuleName -> - App var ann (Maybe Unique) -lookupVar var maybeMod = - asks (M.lookup (var, maybeMod) . seScope) - --- given a var, given it a fresh number unless we already have a number for it -getVar :: (Ord var) => ann -> var -> Maybe ModuleName -> App var ann (var, Unique) -getVar ann var maybeMod = do - found <- lookupVar var maybeMod - case found of - Just unique -> pure (var, unique) - Nothing -> do - scope <- asks (M.keysSet . seScope) - throwError (NameNotFoundInScope ann scope maybeMod var) - --- step through Expr, replacing vars with numbered variables -markImports :: - (Ord var, Show var, Show ann) => - Expr var ann -> - App var ann (NumberedExpr var ann) -markImports (MyVar ann modName var) = - MyVar ann modName <$> getVar ann var modName -markImports (MyAnnotation ann mt expr) = - MyAnnotation ann mt - <$> markImports expr -markImports (MyLet ann ident expr body) = do - let var = varFromIdent ident - unique <- nextNum - MyLet - ann - (markIdentImports ident unique) - <$> withLambda - (M.singleton (var, Nothing) unique) - (markImports expr) -- include var in case it is used recursively - <*> withLambda - (M.singleton (var, Nothing) unique) - (markImports body) -markImports (MyLetPattern ann pat expr body) = do - vars <- freshVarsFromPattern pat - MyLetPattern ann - <$> withLambda vars (markPatternImports pat) - <*> markImports expr - <*> withLambda vars (markImports body) -markImports (MyLiteral ann lit) = - pure (MyLiteral ann lit) -markImports (MyInfix ann op a b) = - MyInfix ann op <$> markImports a <*> markImports b -markImports (MyLambda ann ident body) = do - unique <- nextNum - MyLambda - ann - (markIdentImports ident unique) - <$> withLambda (M.singleton (varFromIdent ident, Nothing) unique) (markImports body) -markImports (MyApp ann fn val) = - MyApp ann <$> markImports fn <*> markImports val -markImports (MyIf ann predExpr thenExpr elseExpr) = - MyIf ann - <$> markImports predExpr - <*> markImports thenExpr - <*> markImports elseExpr -markImports (MyTuple ann a as) = - MyTuple ann <$> markImports a <*> traverse markImports as -markImports (MyRecord ann as) = - MyRecord ann <$> traverse markImports as -markImports (MyRecordAccess ann recExpr name) = - MyRecordAccess ann <$> markImports recExpr <*> pure name -markImports (MyTupleAccess ann tupleExpr index) = - MyTupleAccess ann <$> markImports tupleExpr <*> pure index -markImports (MyArray ann as) = - MyArray ann <$> traverse markImports as -markImports (MyConstructor ann modName const') = - pure (MyConstructor ann modName const') -markImports (MyPatternMatch ann patExpr patterns) = - let markPatterns (pat, pExpr) = do - uniqueMap <- freshVarsFromPattern pat - withLambda - uniqueMap - ( (,) - <$> markPatternImports pat - <*> markImports pExpr - ) - in MyPatternMatch ann - <$> markImports patExpr - <*> traverse markPatterns patterns -markImports (MyTypedHole ann name) = do - -- always a unique number for these - unique <- nextNum - pure (MyTypedHole ann (name, unique)) - -markPatternImports :: - (Ord var, Show var, Show ann) => - Pattern var ann -> - App var ann (Pattern (var, Unique) ann) -markPatternImports pat = - case pat of - (PVar ann from) -> - PVar ann <$> getVar ann from Nothing - (PWildcard ann) -> - pure $ PWildcard ann - (PLit ann l) -> pure $ PLit ann l - (PConstructor ann c d e) -> - PConstructor ann c d - <$> traverse markPatternImports e - (PTuple ann a as) -> - PTuple - ann - <$> markPatternImports a - <*> traverse markPatternImports as - (PRecord ann as) -> - PRecord ann <$> traverse markPatternImports as - (PArray ann as a) -> - PArray - ann - <$> traverse markPatternImports as - <*> markSpreadNameImports a - (PString ann as a) -> - PString - ann - <$> markStringPartImports as - <*> markStringPartImports a - -markSpreadNameImports :: - (Ord var) => - Spread var ann -> - App var ann (Spread (var, Unique) ann) -markSpreadNameImports (SpreadValue ann from') = - SpreadValue ann <$> getVar ann from' Nothing -markSpreadNameImports (SpreadWildcard ann) = pure (SpreadWildcard ann) -markSpreadNameImports NoSpread = pure NoSpread - -markStringPartImports :: - (Ord var) => - StringPart var ann -> - App var ann (StringPart (var, Unique) ann) -markStringPartImports (StrValue ann from') = - StrValue ann <$> getVar ann from' Nothing -markStringPartImports (StrWildcard ann) = pure (StrWildcard ann) - -markIdentImports :: - Identifier var ann -> - Unique -> - Identifier (var, Unique) ann -markIdentImports (Identifier ann from') unique = - Identifier ann (from', unique) diff --git a/compiler/src/Language/Mimsa/Typechecker/OutputTypes.hs b/compiler/src/Language/Mimsa/Typechecker/OutputTypes.hs deleted file mode 100644 index c3af98c1..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/OutputTypes.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Typechecker.OutputTypes (getExpressionSourceItems) where - -import Data.Text (Text) -import Language.Mimsa.Core -import Language.Mimsa.Project.SourceSpan -import Language.Mimsa.Types.Project.SourceItem - --- return types inside spans for server - -getExpressionSourceItems :: Text -> Expr Name MonoType -> [SourceItem] -getExpressionSourceItems input = foldExpr fn - where - fn label monoType = - let sSpan = - sourceSpan - input - (getAnnotationForType monoType) - in case sSpan of - Just sSpan' -> - [SourceItem (label <> " :: " <> prettyPrint monoType) sSpan'] - Nothing -> mempty - -foldPattern :: (Monoid a) => (Text -> ann -> a) -> Pattern Name ann -> a -foldPattern fn pat = - foldPattern' pat - where - f = fn (prettyPrint pat) - foldPattern' (PVar ann _) = f ann - foldPattern' (PWildcard ann) = f ann - foldPattern' (PLit ann _) = f ann - foldPattern' (PConstructor ann _ _ as) = - f ann <> foldMap (foldPattern fn) as - foldPattern' (PTuple ann a as) = - f ann <> foldPattern fn a <> foldMap (foldPattern fn) as - foldPattern' (PRecord ann as) = - f ann <> foldMap (foldPattern fn) as - foldPattern' (PArray ann as spread) = - f ann <> foldMap (foldPattern fn) as <> foldSpread fn spread - foldPattern' (PString ann _ _) = - f ann - -foldIdentifier :: (Text -> ann -> a) -> Identifier Name ann -> a -foldIdentifier fn ident = - foldIdentifier' ident - where - f = fn (prettyPrint ident) - foldIdentifier' (Identifier ann _) = f ann - -foldSpread :: (Monoid a) => (Text -> ann -> a) -> Spread Name ann -> a -foldSpread fn spread = - foldSpread' spread - where - f = fn (prettyPrint spread) - foldSpread' NoSpread = mempty - foldSpread' (SpreadWildcard ann) = f ann - foldSpread' (SpreadValue ann _) = f ann - --- fold a function through all annotations in an expression and attached -foldExpr :: (Monoid a) => (Text -> ann -> a) -> Expr Name ann -> a -foldExpr fn expression = - foldExpr' expression - where - f = fn (prettyPrint expression) - foldExpr' (MyLiteral ann _) = f ann - foldExpr' (MyAnnotation ann mt expr) = - f ann <> foldExpr fn expr <> f (getAnnotationForType mt) - foldExpr' (MyVar ann _ _) = f ann - foldExpr' (MyLet ann binder expr body) = - f ann - <> foldIdentifier fn binder - <> foldExpr fn expr - <> foldExpr fn body - foldExpr' (MyPatternMatch ann expr pats) = - f ann - <> foldMap (foldPattern fn . fst) pats - <> foldMap (foldExpr fn . snd) pats - <> foldExpr fn expr - foldExpr' (MyLetPattern ann pat expr body) = - f ann <> foldPattern fn pat <> foldExpr fn expr <> foldExpr fn body - foldExpr' (MyInfix ann _ a b) = - f ann <> foldExpr fn a <> foldExpr fn b - foldExpr' (MyLambda ann ident body) = - f ann <> foldIdentifier fn ident <> foldExpr fn body - foldExpr' (MyApp ann func arg) = - f ann <> foldExpr fn func <> foldExpr fn arg - foldExpr' (MyIf ann predExpr thenExpr elseExpr) = - f ann <> foldExpr fn predExpr <> foldExpr fn thenExpr <> foldExpr fn elseExpr - foldExpr' (MyTuple ann a as) = f ann <> foldExpr fn a <> foldMap (foldExpr fn) as - foldExpr' (MyRecord ann as) = f ann <> foldMap (foldExpr fn) as - foldExpr' (MyTupleAccess ann tuple _) = - f ann <> foldExpr fn tuple - foldExpr' (MyRecordAccess ann record _) = - f ann <> foldExpr fn record - foldExpr' (MyArray ann as) = - f ann <> foldMap (foldExpr fn) as - foldExpr' (MyConstructor ann _ _) = f ann - foldExpr' (MyTypedHole ann _) = f ann diff --git a/compiler/src/Language/Mimsa/Typechecker/ScopeTypeVar.hs b/compiler/src/Language/Mimsa/Typechecker/ScopeTypeVar.hs deleted file mode 100644 index 0da5115b..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/ScopeTypeVar.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Typechecker.ScopeTypeVar (freshNamedType) where - -import Control.Monad.State -import Data.Coerce -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Store.ExtractTypes -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Typechecker - --- | if we've seen these type vars before, they're the same --- if not, return fresh versions and a set of things we've now seen -freshNamedType :: - (MonadState TypecheckState m) => - Environment -> - MonoType -> - m (Environment, MonoType) -freshNamedType env mt = do - let currentVars = M.keysSet $ getTypeVarsInScope env - newNamesSet = extractNamedTypeVars mt - unseenSet = S.difference newNamesSet currentVars - - unseen <- setToFreshMap unseenSet - let allSubs = getTypeVarsInScope env <> unseen - let newEnv = env {getTypeVarsInScope = allSubs} - - newMt <- freshenNamedTypeVars allSubs mt - pure (newEnv, newMt) - -setToFreshMap :: - (MonadState TypecheckState m, Ord k) => - Set k -> - m (Map k Int) -setToFreshMap keys = - let emptyMap = M.fromList . fmap (,0 :: Int) . S.toList - in traverse (const getNextUniVar) (emptyMap keys) - -freshenNamedTypeVars :: - (MonadState TypecheckState m) => - Map TyVar Int -> - Type ann -> - m (Type ann) -freshenNamedTypeVars known = - freshen - where - freshen (MTVar ann (TVName tv)) = do - -- get an index for this name, or find an existing one - case M.lookup tv known of - Just index -> - pure (MTVar ann (TVScopedVar index (coerce tv))) - _ -> error "what?" -- this should have been created above? - freshen mtV@(MTVar ann (TVScopedVar _ tv)) = - case M.lookup (coerce tv) known of -- if we've already scoped it - Nothing -> pure mtV -- leave it - Just i -> do - pure (MTVar ann (TVScopedVar i tv)) - freshen other = bindType freshen other diff --git a/compiler/src/Language/Mimsa/Typechecker/Solve.hs b/compiler/src/Language/Mimsa/Typechecker/Solve.hs deleted file mode 100644 index b9931417..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Solve.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.Solve (solve, runSolveM, SolveM) where - -import Control.Monad.Except -import Control.Monad.State -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Language.Mimsa.Types.Typechecker.Substitutions - -type SolveM = ExceptT TypeError (State TypecheckState) - -runSolveM :: - TypecheckState -> - SolveM a -> - Either TypeError (TypecheckState, a) -runSolveM tcState value = - case either' of - (Right a, newTcState) -> Right (newTcState, a) - (Left e, _) -> Left e - where - either' = - runState - (runExceptT value) - tcState - -solve :: - ( MonadState TypecheckState m, - MonadError TypeError m - ) => - [Constraint] -> - m Substitutions -solve = go mempty - where - go s [] = pure s - go s1 (constraint : rest) = - case constraint of - ShouldEqual a b -> do - s2 <- unify a b - go (s2 <> s1) (applyToConstraint (s1 <> s2) <$> rest) - -applyToConstraint :: Substitutions -> Constraint -> Constraint -applyToConstraint subs (ShouldEqual a b) = - ShouldEqual (applySubst subs a) (applySubst subs b) diff --git a/compiler/src/Language/Mimsa/Typechecker/TcMonad.hs b/compiler/src/Language/Mimsa/Typechecker/TcMonad.hs deleted file mode 100644 index 4c2bd127..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/TcMonad.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.TcMonad - ( defaultTcState, - getUnknown, - instantiate, - addTypedHole, - getTypedHoles, - TypecheckState (..), - variableToTypeIdentifier, - getNextUniVar, - ) -where - -import Control.Monad.Except -import Control.Monad.State (MonadState, gets, modify) -import Data.Coerce -import Data.Functor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Generalise -import Language.Mimsa.Types.Error.TypeError -import Language.Mimsa.Types.Typechecker -import Language.Mimsa.Types.Typechecker.Substitutions -import Language.Mimsa.Types.Typechecker.Unique - -data TypecheckState = TypecheckState - { tcsNum :: Int, - tcsTypedHoles :: Map Name (Annotation, Int, Map Name MonoType) - } - -instantiate :: - (MonadState TypecheckState m) => Annotation -> Scheme -> m MonoType -instantiate ann (Scheme vars ty) = do - newVars <- traverse (const (getUnknown ann)) vars - let pairs = zip vars newVars - let subst = Substitutions $ M.fromList pairs - let substitutedType = applySubst subst ty - pure (substitutedType $> ann) -- use original annotation - --- | get starting typechecker state, --- make sure our fresh vars number is higher than any we've seen before -defaultTcState :: Environment -> TypecheckState -defaultTcState env = - let maxInTypeMap = case getUniVar <$> freeTypeVarsCtx env of - [] -> 0 - as -> maximum (catMaybes as) - in TypecheckState (maxInTypeMap + 1) mempty - -getNextUniVar :: (MonadState TypecheckState m) => m Int -getNextUniVar = do - nextUniVar <- gets tcsNum - modify (\s -> s {tcsNum = nextUniVar + 1}) - pure nextUniVar - -typeFromUniVar :: Annotation -> Int -> MonoType -typeFromUniVar ann = MTVar ann . TVUnificationVar - -getUnknown :: (MonadState TypecheckState m) => Annotation -> m MonoType -getUnknown ann = - typeFromUniVar ann - <$> getNextUniVar - --- | Get a new unknown for a typed hole and return it's monotype -addTypedHole :: - ( MonadState TypecheckState m, - MonadError TypeError m - ) => - Environment -> - Annotation -> - Name -> - m MonoType -addTypedHole env ann name = do - i <- getNextUniVar - localTypeMap <- schemesToTypeMap (getSchemes env) - modify - ( \s -> - s - { tcsTypedHoles = - tcsTypedHoles s - <> M.singleton name (ann, i, localTypeMap) - } - ) - pure $ MTVar ann (TVUnificationVar i) - --- capture type schemes currently in scope --- instantiate them now -schemesToTypeMap :: - (MonadState TypecheckState m, MonadError TypeError m) => - Map TypeIdentifier Scheme -> - m (Map Name MonoType) -schemesToTypeMap schemes = do - let fn (k, v) = - let leName = case k of - TVName n -> pure (Name $ coerce n) - TVUnificationVar _i -> - throwError UnknownTypeError -- TODO: bespoke error - TVScopedVar _ name -> pure name - in (,) <$> leName <*> instantiate mempty v - typeMap <- traverse fn (M.toList schemes) - pure (M.fromList typeMap) - -getTypedHoles :: - (MonadState TypecheckState m) => - Substitutions -> - m (Map Name (MonoType, Map Name MonoType)) -getTypedHoles subs'@(Substitutions subs) = do - holes <- gets tcsTypedHoles - let getMonoType _ (ann, i, localTypeMap) = - case M.lookup (TVUnificationVar i) subs of - Just a -> - ( applySubst subs' a, - applySubst subs' localTypeMap - ) - Nothing -> - ( applySubst subs' (MTVar ann (TVUnificationVar i)), - applySubst subs' localTypeMap - ) - pure $ M.mapWithKey getMonoType holes - -variableToTypeIdentifier :: (Name, Unique) -> TypeIdentifier -variableToTypeIdentifier (name, Unique i) = TVScopedVar i name -variableToTypeIdentifier (name, _) = - TVName (coerce name) diff --git a/compiler/src/Language/Mimsa/Typechecker/Typecheck.hs b/compiler/src/Language/Mimsa/Typechecker/Typecheck.hs deleted file mode 100644 index 26f13233..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Typecheck.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Typechecker.Typecheck - ( typecheck, - ) -where - -import Control.Monad.Except -import Control.Monad.State (State, runState) -import Control.Monad.Trans.Writer.CPS (runWriterT) -import Control.Monad.Writer.CPS -import Data.Map.Strict (Map) -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Typechecker.Solve -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.TypedHoles -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Language.Mimsa.Types.Typechecker.Substitutions -import Language.Mimsa.Types.Typechecker.Unique - -type ElabM = - ExceptT - TypeError - ( WriterT - [Constraint] - (State TypecheckState) - ) - -runElabM :: - TypecheckState -> - ElabM a -> - Either TypeError ([Constraint], TypecheckState, a) -runElabM tcState value = - case either' of - ((Right a, constraints), newTcState) -> - Right (constraints, newTcState, a) - ((Left e, _), _) -> Left e - where - either' = - runState - (runWriterT (runExceptT value)) - tcState - --- run inference, and substitute everything possible -typecheck :: - Map Name MonoType -> - Environment -> - Expr (Name, Unique) Annotation -> - Either - TypeError - ( Substitutions, - [Constraint], - Expr (Name, Unique) MonoType, - MonoType - ) -typecheck typeMap env expr = do - let tcAction = do - (elabExpr, constraints) <- listen (elab env expr) - subs <- solve constraints - typedHolesCheck typeMap subs - pure (subs, constraints, elabExpr) - (_, _, (subs, constraints, tyExpr)) <- runElabM (defaultTcState env) tcAction - let typedExpr = applySubst subs tyExpr - pure (subs, constraints, typedExpr, getTypeFromAnn typedExpr) diff --git a/compiler/src/Language/Mimsa/Typechecker/TypedHoles.hs b/compiler/src/Language/Mimsa/Typechecker/TypedHoles.hs deleted file mode 100644 index dc638b44..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/TypedHoles.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.TypedHoles - ( typedHolesCheck, - ) -where - -import Control.Monad.Except -import Control.Monad.State -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import Language.Mimsa.Core -import Language.Mimsa.Project.TypeSearch -import Language.Mimsa.Typechecker.NormaliseTypes -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker.Substitutions - -typedHolesCheck :: - (MonadError TypeError m, MonadState TypecheckState m) => - Map Name MonoType -> - Substitutions -> - m () -typedHolesCheck typeMap subs = do - holes <- getTypedHoles subs - if M.null holes - then pure () - else throwError (TypedHoles (getTypedHoleSuggestions typeMap <$> holes)) - -getTypedHoleSuggestions :: - Map Name MonoType -> - (MonoType, Map Name MonoType) -> - (MonoType, Set FoundPath) -getTypedHoleSuggestions typeMap (mt, localTypeMap) = - (normaliseType mt, suggestGlobal <> suggestLocal) - where - suggestGlobal = M.keysSet $ typeSearch typeMap mt - suggestLocal = M.keysSet $ typeSearch localTypeMap mt diff --git a/compiler/src/Language/Mimsa/Typechecker/Unify.hs b/compiler/src/Language/Mimsa/Typechecker/Unify.hs deleted file mode 100644 index e087d7cc..00000000 --- a/compiler/src/Language/Mimsa/Typechecker/Unify.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} - -module Language.Mimsa.Typechecker.Unify - ( unify, - freeTypeVars, - ) -where - -import Control.Monad.Except -import Control.Monad.State -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.FlattenRow -import Language.Mimsa.Typechecker.Generalise -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker.Substitutions - --- | Creates a fresh unification variable and binds it to the given type -varBind :: - (MonadError TypeError m) => - Annotation -> - TypeIdentifier -> - MonoType -> - m Substitutions -varBind ann var@(TVName _) _ = - -- these should always be scoped when found, so if we find them, error - throwError (UnscopedTypeVarFound ann var) -varBind ann var@(TVScopedVar _ _) mt@(MTVar _ (TVUnificationVar _)) = - -- numbered vars always combine with unification vars - pure (Substitutions (M.singleton var (mt $> ann))) -varBind ann var@(TVScopedVar a nameA) mt@(MTVar _ (TVScopedVar b nameB)) = - -- names and numbers must match to unify - if nameA == nameB && a == b - then pure (Substitutions (M.singleton var (mt $> ann))) - else throwError (UnificationError mt (MTVar ann var)) -varBind ann var@(TVScopedVar _ _) mt = - -- named vars only unify with themselves - throwError (UnificationError mt (MTVar ann var)) -varBind ann var mt - | typeEquals mt (MTVar mempty var) = pure mempty - | S.member var (freeTypeVars mt) = do - throwError $ - FailsOccursCheck var mt - | otherwise = do - let mt' = mt $> ann - pure $ Substitutions (M.singleton var mt') - -checkMatching :: - ( MonadState TypecheckState m, - MonadError TypeError m - ) => - Annotation -> - Annotation -> - Map Name MonoType -> - Map Name MonoType -> - Name -> - m Substitutions -checkMatching ann ann' as bs k = do - tyLeft <- getRecordItemType ann k as - tyRight <- getRecordItemType ann' k bs - unify tyLeft tyRight - -unifyRecords :: - ( MonadError TypeError m, - MonadState TypecheckState m - ) => - (Annotation, Map Name MonoType) -> - (Annotation, Map Name MonoType) -> - m Substitutions -unifyRecords (ann, as) (ann', bs) = do - let diffKeys = S.difference (M.keysSet as) (M.keysSet bs) - if not $ S.null diffKeys - then throwError (RecordKeyMismatch diffKeys) - else do - let allKeys = S.toList $ M.keysSet as <> M.keysSet bs - s <- traverse (checkMatching ann ann' as bs) allKeys - pure (mconcat s) - -unifyRecordRows :: - ( MonadError TypeError m, - MonadState TypecheckState m - ) => - (Annotation, Map Name MonoType, MonoType) -> - (Annotation, Map Name MonoType, MonoType) -> - m Substitutions -unifyRecordRows (ann, as, restA) (ann', bs, restB) = do - let matchingKeys = S.intersection (M.keysSet as) (M.keysSet bs) - s1 <- traverse (checkMatching ann ann' as bs) (S.toList matchingKeys) - let leftKeys = S.difference (M.keysSet as) matchingKeys - rightKeys = S.difference (M.keysSet bs) matchingKeys - let filterMap keys = - M.filterWithKey (\k _ -> S.member k keys) - newUnknown <- getUnknown ann - s2 <- unify (MTRecord ann (filterMap leftKeys as) (Just newUnknown)) restB - s3 <- unify (MTRecord ann' (filterMap rightKeys bs) (Just newUnknown)) restA - pure (mconcat s1 <> s2 <> s3) - -unifyRecordWithRow :: - ( MonadError TypeError m, - MonadState TypecheckState m - ) => - (Annotation, Map Name MonoType) -> - (Annotation, Map Name MonoType, MonoType) -> - m Substitutions -unifyRecordWithRow (ann, as) (ann', bs, rest) = do - let rowKeys = M.keysSet bs - s1 <- traverse (checkMatching ann ann' as bs) (S.toList rowKeys) - let extraRecordKeys = S.difference (M.keysSet as) rowKeys - extraRecordMap = M.filterWithKey (\k _ -> S.member k extraRecordKeys) as - newUnknown <- getUnknown ann' - s2 <- - if M.null extraRecordMap - then pure mempty - else unify (MTRecord ann' extraRecordMap (Just newUnknown)) rest - pure (mconcat s1 <> s2) - -unifyPairs :: - ( MonadError TypeError m, - MonadState TypecheckState m - ) => - (MonoType, MonoType) -> - (MonoType, MonoType) -> - m Substitutions -unifyPairs (a, b) (a', b') = do - s1 <- unify a a' - s2 <- unify (applySubst s1 b) (applySubst s1 b') - pure (s2 <> s1) - -typeEquals :: MonoType -> MonoType -> Bool -typeEquals mtA mtB = (mtA $> ()) == (mtB $> ()) - -unify :: - ( MonadError TypeError m, - MonadState TypecheckState m - ) => - MonoType -> - MonoType -> - m Substitutions -unify tyA tyB = - case (flattenRow tyA, flattenRow tyB) of - (a, b) - | typeEquals a b -> - pure mempty - (MTFunction _ l r, MTFunction _ l' r') -> - unifyPairs (l, r) (l', r') - (MTTuple _ a as, MTTuple _ a' as') -> - let pairs = zip ([a] <> NE.toList as) ([a'] <> NE.toList as') - in mconcat <$> traverse (uncurry unify) pairs - (MTRecord ann as Nothing, MTRecord ann' bs Nothing) -> - unifyRecords (ann, as) (ann', bs) - (MTRecord ann as (Just restA), MTRecord ann' bs (Just restB)) -> - unifyRecordRows (ann, as, restA) (ann', bs, restB) - (MTRecord ann as Nothing, MTRecord ann' bs (Just rest)) -> - unifyRecordWithRow (ann, as) (ann', bs, rest) - (MTRecord ann as (Just rest), MTRecord ann' bs Nothing) -> - unifyRecordWithRow (ann', bs) (ann, as, rest) - (MTTypeApp _ a b, MTTypeApp _ a' b') -> - unifyPairs (a, b) (a', b') - (MTArray _ a, MTArray _ b) -> unify a b - (MTVar ann u, t) -> varBind ann u t - (t, MTVar ann u) -> varBind ann u t - (a, b) -> - throwError $ UnificationError a b - -getRecordItemType :: - (MonadError TypeError m) => - Annotation -> - Name -> - Map Name MonoType -> - m MonoType -getRecordItemType ann name map' = - case M.lookup name map' of - Just found -> pure found - _ -> throwError (MissingRecordTypeMember ann name map') diff --git a/compiler/src/Language/Mimsa/Types/Error.hs b/compiler/src/Language/Mimsa/Types/Error.hs deleted file mode 100644 index 7e7e3697..00000000 --- a/compiler/src/Language/Mimsa/Types/Error.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS -Wno-orphans #-} - -module Language.Mimsa.Types.Error - ( Error (..), - InterpreterError (..), - ResolverError (..), - TypeErrorF (..), - TypeError, - StoreError (..), - PatternMatchErrorF (..), - PatternMatchError, - BackendError (..), - ProjectError (..), - ModuleError (..), - FileType (..), - CodegenError (..), - errorToDiagnostic, - ) -where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import qualified Error.Diagnose as Diag -import Error.Diagnose.Compat.Megaparsec -import Language.Mimsa.Backend.BackendError -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.DisplayError -import Language.Mimsa.Types.Error.CodegenError -import Language.Mimsa.Types.Error.InterpreterError -import Language.Mimsa.Types.Error.ModuleError -import Language.Mimsa.Types.Error.PatternMatchError -import Language.Mimsa.Types.Error.ProjectError -import Language.Mimsa.Types.Error.ResolverError -import Language.Mimsa.Types.Error.StoreError -import Language.Mimsa.Types.Error.TypeError -import Text.Megaparsec - -instance HasHints Void msg where - hints _ = mempty - -data Error ann - = TypeErr Text TypeError - | ResolverErr ResolverError - | InterpreterErr (InterpreterError Name ann) -- this hardcoded Variable is bad - | StoreErr StoreError - | BackendErr (BackendError ann) - | ProjectErr ProjectError - | CodegenErr CodegenError - | ModuleErr ModuleError - | ParseError Text (ParseErrorBundle Text Void) - deriving stock (Eq, Show) - -instance (Show ann, Printer ann) => Printer (Error ann) where - prettyPrint (TypeErr input typeErr) = displayError input typeErr - prettyPrint (ResolverErr a) = prettyPrint a - prettyPrint (InterpreterErr a) = prettyPrint a - prettyPrint (StoreErr a) = prettyPrint a - prettyPrint (BackendErr a) = prettyPrint a - prettyPrint (ProjectErr a) = prettyPrint a - prettyPrint (CodegenErr a) = prettyPrint a - prettyPrint (ModuleErr a) = prettyPrint a - prettyPrint (ParseError _input errorBundle) = T.pack (errorBundlePretty errorBundle) - -errorToDiagnostic :: Error Annotation -> Diag.Diagnostic Text -errorToDiagnostic (ParseError input bundle) = - let filename = "" - diag = errorDiagnosticFromBundle Nothing "Parse error on input" Nothing bundle - in -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec - Diag.addFile diag filename (T.unpack input) -errorToDiagnostic (TypeErr input typeErr) = - typeErrorDiagnostic input typeErr -errorToDiagnostic (ModuleErr modErr) = - moduleErrorDiagnostic modErr -errorToDiagnostic e = - let report = - Diag.Err - Nothing - (prettyPrint e) - [] - [] - in Diag.addReport Diag.def report diff --git a/compiler/src/Language/Mimsa/Types/Error/CodegenError.hs b/compiler/src/Language/Mimsa/Types/Error/CodegenError.hs deleted file mode 100644 index 8610be24..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/CodegenError.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.CodegenError where - -import Language.Mimsa.Core -import Prettyprinter - -data CodegenError - = TypeShouldHaveAtLeastOneVariable - | TypeShouldHaveNoVariables - | ExpectedNonEmptyMap - | NoConstructorMatches - | TooManyConstructorMatches - | CannotUseNonFunctorValue - | UnknownCodegenError -- for Monoid - | Multiple CodegenError CodegenError - | CouldNotFindVarsInType - | RecursingOverAnotherType - | MultipleFunctorVariablesInApplicativeArg - | NewtypeShouldOnlyHaveOneArgument - | ConstructorShouldHaveNoArgs TyCon - deriving stock (Eq, Show) - -instance Semigroup CodegenError where - a <> b = Multiple a b - -instance Monoid CodegenError where - mempty = UnknownCodegenError - -instance Printer CodegenError where - prettyDoc TypeShouldHaveAtLeastOneVariable = "Type should have at least one type variable" - prettyDoc TypeShouldHaveNoVariables = "Type should have no variables" - prettyDoc ExpectedNonEmptyMap = "Expected non-empty map" - prettyDoc NoConstructorMatches = "No constructor matches" - prettyDoc TooManyConstructorMatches = "Too many constructor matches" - prettyDoc CannotUseNonFunctorValue = "Cannot use non-functor value" - prettyDoc UnknownCodegenError = "UnknownCodegenError" - prettyDoc CouldNotFindVarsInType = "Could not find vars in type" - prettyDoc RecursingOverAnotherType = "Cannot recurse over another data type" - prettyDoc MultipleFunctorVariablesInApplicativeArg = "Multiple functor variables in first applicative argument" - prettyDoc NewtypeShouldOnlyHaveOneArgument = "Newtype should only have one type argument" - prettyDoc (ConstructorShouldHaveNoArgs tyCon) = "Constructor" <+> prettyDoc tyCon <+> "should have no arguments" - prettyDoc (Multiple a b) = prettyDoc a <> line <> prettyDoc b diff --git a/compiler/src/Language/Mimsa/Types/Error/InterpreterError.hs b/compiler/src/Language/Mimsa/Types/Error/InterpreterError.hs deleted file mode 100644 index 0b827114..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/InterpreterError.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.InterpreterError (InterpreterError (..)) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import GHC.Natural -import Language.Mimsa.Core -import Language.Mimsa.Types.Interpreter.Stack -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Typechecker.Unique - -type InterpretExpr var ann = Expr (var, Unique) (ExprData var ann) - -data InterpreterError var ann - = UnknownInterpreterError - | CouldNotFindVar (Map var (InterpretExpr var ann)) var - | CouldNotFindInfix (Map InfixOp (InterpretExpr var ann)) InfixOp - | CouldNotFindGlobal (Map ExprHash (InterpretExpr var ann)) ExprHash - | AdditionWithNonNumber (InterpretExpr var ann) - | SubtractionWithNonNumber (InterpretExpr var ann) - | ComparisonWithNonNumber Operator (InterpretExpr var ann) - | StringConcatenationFailure (InterpretExpr var ann) (InterpretExpr var ann) - | ArrayConcatenationFailure (InterpretExpr var ann) (InterpretExpr var ann) - | PredicateForIfMustBeABoolean (InterpretExpr var ann) - | CannotDestructureAsRecord (InterpretExpr var ann) Name - | CannotDestructureAsTuple (InterpretExpr var ann) Natural - | CannotFindMemberInRecord (Map Name (InterpretExpr var ann)) Name - | CannotFindMemberInTuple [InterpretExpr var ann] Natural - | PatternMatchFailure (InterpretExpr var ann) - deriving stock (Eq, Ord, Show) - -instance Semigroup (InterpreterError var ann) where - a <> _ = a - -instance Monoid (InterpreterError var ann) where - mempty = UnknownInterpreterError - -instance (Show ann, Show var, Printer ann, Printer var) => Printer (InterpreterError var ann) where - prettyPrint (CouldNotFindVar items name) = - "Could not find var " <> prettyPrint name <> " in " <> itemList - where - itemList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys items) <> " ]" - prettyPrint (CouldNotFindInfix items infixOp) = - "Could not find infix " <> prettyPrint infixOp <> " in " <> itemList - where - itemList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys items) <> " ]" - prettyPrint (CouldNotFindGlobal items name) = - "Could not find global " <> prettyPrint name <> " in " <> itemList - where - itemList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys items) <> " ]" - prettyPrint UnknownInterpreterError = "Unknown interpreter 2 error" - prettyPrint (AdditionWithNonNumber a) = - "Addition expected number but got this: " <> prettyPrint a - prettyPrint (SubtractionWithNonNumber a) = - "Subtraction expected number but got this: " <> prettyPrint a - prettyPrint (ComparisonWithNonNumber op a) = - "Operator " <> prettyPrint op <> " expected number but got this: " <> prettyPrint a - prettyPrint (StringConcatenationFailure a b) = - "Concatenation expected string + string but got this: " <> prettyPrint a <> " and " <> prettyPrint b - prettyPrint (ArrayConcatenationFailure a b) = - "Concatenation expected array + array but got this: " <> prettyPrint a <> " and " <> prettyPrint b - prettyPrint (PredicateForIfMustBeABoolean expr) = - "Expected a boolean as a predicate. Cannot use: " <> prettyPrint expr - prettyPrint (CannotDestructureAsRecord expr name) = - "Expected a record with a member " <> prettyPrint name <> ". Cannot destructure: " <> prettyPrint expr - prettyPrint (CannotDestructureAsTuple expr index) = - "Expected a tuple with an index at " <> prettyPrint index <> ". Cannot destructure: " <> prettyPrint expr - prettyPrint (CannotFindMemberInRecord items name) = - "Could not find member " <> prettyPrint name <> " in " <> itemList - where - itemList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys items) <> " ]" - prettyPrint (CannotFindMemberInTuple items index) = - "Could not find index " <> prettyPrint index <> " in " <> itemList - where - itemList = "[ " <> prettyPrint items <> " ]" - prettyPrint (PatternMatchFailure expr') = - "Could not pattern match on value " <> prettyPrint expr' diff --git a/compiler/src/Language/Mimsa/Types/Error/ModuleError.hs b/compiler/src/Language/Mimsa/Types/Error/ModuleError.hs deleted file mode 100644 index 3c80c4ab..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/ModuleError.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.ModuleError (ModuleError (..), moduleErrorDiagnostic) where - -import Data.Set (Set) -import Data.Text (Text) -import qualified Error.Diagnose as Diag -import Language.Mimsa.Core -import Language.Mimsa.Types.Error.TypeError - -data ModuleError - = DuplicateDefinition DefIdentifier - | DuplicateTypeName TypeName - | DuplicateConstructor TyCon - | DefinitionConflictsWithImport DefIdentifier ModuleHash - | TypeConflictsWithImport TypeName ModuleHash - | CannotFindValues (Set DefIdentifier) - | CannotFindTypes (Set TypeName) - | CannotFindConstructors (Set TyCon) - | DefDoesNotTypeCheck Text DefIdentifier TypeError - | NamedImportNotFound (Set ModuleName) ModuleName - | MissingModule ModuleHash - | MissingModuleDep DefIdentifier ModuleHash - | MissingModuleTypeDep TypeName ModuleHash - | DefMissingReturnType DefIdentifier - | DefMissingTypeAnnotation DefIdentifier Name - | EmptyTestName (Expr Name ()) - deriving stock (Eq, Ord, Show) - -instance Printer ModuleError where - prettyPrint (DuplicateDefinition name) = - "Duplicate definition: " <> prettyPrint name - prettyPrint (DuplicateTypeName tyName) = - "Duplicate type name: " <> prettyPrint tyName - prettyPrint (DuplicateConstructor tyCon) = - "Duplicate constructor name: " <> prettyPrint tyCon - prettyPrint (CannotFindValues names) = - "Cannot find values: " <> prettyPrint names - prettyPrint (CannotFindTypes names) = - "Cannot find types: " <> prettyPrint names - prettyPrint (CannotFindConstructors names) = - "Cannot find constructors: " <> prettyPrint names - prettyPrint (DefDoesNotTypeCheck _ name typeErr) = - prettyPrint name <> " had a typechecking error: " <> prettyPrint typeErr - prettyPrint (MissingModule mHash) = - "Could not find module for " <> prettyPrint mHash - prettyPrint (DefinitionConflictsWithImport name mHash) = - "Cannot define " <> prettyPrint name <> " as it is already defined in import " <> prettyPrint mHash - prettyPrint (TypeConflictsWithImport typeName mHash) = - "Cannot define type " <> prettyPrint typeName <> " as it is already defined in import " <> prettyPrint mHash - prettyPrint (MissingModuleDep name mHash) = - "Cannot find dep " <> prettyPrint name <> " in module " <> prettyPrint mHash - prettyPrint (MissingModuleTypeDep typeName mHash) = - "Cannot find type " <> prettyPrint typeName <> " in module " <> prettyPrint mHash - prettyPrint (DefMissingReturnType defName) = - "Definition " <> prettyPrint defName <> " was expected to have a return type but it is missing" - prettyPrint (DefMissingTypeAnnotation defName name) = - "Argument " <> prettyPrint name <> " in " <> prettyPrint defName <> " was expected to have a type annotation but it does not." - prettyPrint (EmptyTestName expr) = - "Test name must be non-empty for expression " <> prettyPrint expr - prettyPrint (NamedImportNotFound haystack needle) = - "Could not find import for " <> prettyPrint needle <> " in " <> prettyPrint haystack - -moduleErrorDiagnostic :: ModuleError -> Diag.Diagnostic Text -moduleErrorDiagnostic (DefDoesNotTypeCheck input _ typeErr) = typeErrorDiagnostic input typeErr -moduleErrorDiagnostic other = - let report = - Diag.Err - Nothing - (prettyPrint other) - [] - [] - in Diag.addReport Diag.def report diff --git a/compiler/src/Language/Mimsa/Types/Error/PatternMatchError.hs b/compiler/src/Language/Mimsa/Types/Error/PatternMatchError.hs deleted file mode 100644 index c78bedf4..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/PatternMatchError.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Mimsa.Types.Error.PatternMatchError - ( PatternMatchErrorF (..), - PatternMatchError, - renderPatternMatchError, - ) -where - -import Data.Set (Set) -import qualified Data.Text as T -import Language.Mimsa.Core -import Prettyprinter -import Text.Megaparsec - -data PatternMatchErrorF var ann - = -- | No patterns provided - EmptyPatternMatch ann - | -- | "Just 1 2" or "Nothing 3", for instance - -- | ann, offending tyCon, expected, actual - ConstructorArgumentLengthMismatch ann TyCon Int Int - | -- | Cases not covered in pattern matches - -- | ann, [missing patterns] - MissingPatterns ann [Pattern var ann] - | -- | Unnecessary cases covered by previous matches - RedundantPatterns ann [Pattern var ann] - | -- | Multiple instances of the same variable - DuplicateVariableUse ann (Set var) - deriving stock (Eq, Ord, Show, Foldable) - -type PatternMatchError = PatternMatchErrorF Name Annotation - ------- - -instance Semigroup (PatternMatchErrorF var ann) where - a <> _ = a - -instance - ( Printer ann, - Printer var, - Printer (Pattern var ann) - ) => - Printer (PatternMatchErrorF var ann) - where - prettyDoc = vsep . renderPatternMatchError - -instance ShowErrorComponent PatternMatchError where - showErrorComponent = T.unpack . prettyPrint - errorComponentLen pmErr = let (_, len) = getErrorPos pmErr in len - -type Start = Int - -type Length = Int - --- | Single combined error area for Megaparsec -fromAnnotation :: Annotation -> (Start, Length) -fromAnnotation (Location a b) = (a, b - a) -fromAnnotation _ = (0, 0) - -getErrorPos :: PatternMatchError -> (Start, Length) -getErrorPos = fromAnnotation . mconcat . getAllAnnotations - -getAllAnnotations :: PatternMatchError -> [Annotation] -getAllAnnotations = foldMap pure - ------ - -renderPatternMatchError :: - (Printer var, Printer (Pattern var ann)) => - PatternMatchErrorF var ann -> - [Doc a] -renderPatternMatchError (EmptyPatternMatch _) = - ["Pattern match needs at least one pattern to match"] -renderPatternMatchError - ( ConstructorArgumentLengthMismatch - _ - tyCon - expected - actual - ) = - [ "Constructor argument length mismatch. " - <> prettyDoc tyCon - <> " expected " - <> prettyDoc expected - <> " but got " - <> prettyDoc actual - ] -renderPatternMatchError (MissingPatterns _ missing) = - ["Pattern match is not exhaustive. These patterns are missing:"] - <> (prettyDoc <$> missing) -renderPatternMatchError (RedundantPatterns _ redundant) = - ["Pattern match has unreachable patterns, you should remove them"] <> (prettyDoc <$> redundant) -renderPatternMatchError (DuplicateVariableUse _ vars) = - [ "Pattern match variables must be unique.", - "Variables " <> prettyDoc vars <> " are used multiple times" - ] diff --git a/compiler/src/Language/Mimsa/Types/Error/ProjectError.hs b/compiler/src/Language/Mimsa/Types/Error/ProjectError.hs deleted file mode 100644 index 3136b2dc..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/ProjectError.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.ProjectError (ProjectError (..)) where - -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import Language.Mimsa.Core - --- | things that could happen -data ProjectError - = CantUpgradeNoDependencies - | CantUpgradeAlreadyUpToDate - | CannotFindModuleByName ModuleName (Set ModuleName) - deriving stock (Eq, Ord, Show) - -instance Printer ProjectError where - prettyPrint CantUpgradeAlreadyUpToDate = - "Cannot upgrade, dependencies are already up to date" - prettyPrint CantUpgradeNoDependencies = - "Cannot upgrade, expression has no dependencies" - prettyPrint (CannotFindModuleByName needle haystack) = - "Could not find a module called " - <> prettyPrint needle - <> " in project. Found " - <> T.intercalate ", " (prettyPrint <$> S.toList haystack) - <> "." diff --git a/compiler/src/Language/Mimsa/Types/Error/ResolverError.hs b/compiler/src/Language/Mimsa/Types/Error/ResolverError.hs deleted file mode 100644 index a7bf2d56..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/ResolverError.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.ResolverError where - -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.Bindings (Bindings (Bindings)) -import Language.Mimsa.Types.Store.TypeBindings - ( TypeBindings (TypeBindings), - ) - -data ResolverError - = MissingBinding Name Bindings - | MissingType TyCon TypeBindings - deriving stock (Eq, Ord, Show) - -instance Printer ResolverError where - prettyPrint (MissingBinding name (Bindings bindings')) = "A binding for " <> prettyPrint name <> " could not be found in " <> bindingsList - where - bindingsList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys bindings') <> " ]" - prettyPrint (MissingType cName (TypeBindings bindings')) = "A binding for type " <> prettyPrint cName <> " could not be found in " <> bindingsList - where - bindingsList = "[ " <> T.intercalate ", " (prettyPrint <$> M.keys bindings') <> " ]" diff --git a/compiler/src/Language/Mimsa/Types/Error/StoreError.hs b/compiler/src/Language/Mimsa/Types/Error/StoreError.hs deleted file mode 100644 index 4eb59890..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/StoreError.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Error.StoreError (StoreError (..), FileType (..)) where - -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Store - -data FileType = ProjectFile | StoreExprFile | ModuleFile - deriving stock (Eq, Ord, Show) - -instance Printer FileType where - prettyPrint ProjectFile = "project" - prettyPrint StoreExprFile = "store expression" - prettyPrint ModuleFile = "module" - -data StoreError - = ExpressionDoesNotMatchHash ExprHash ExprHash - | CouldNotReadFilePath FileType FilePath - | CouldNotWriteFilePath FileType FilePath - | CouldNotDecodeJson ExprHash - | CouldNotDecodeFile FilePath - | CouldNotDecodeByteString - | CouldNotFindExprHashForBindings [(Maybe ModuleName, Name)] - | CouldNotFindExprHashForInfixes [InfixOp] - | CouldNotFindExprHashForTypeBindings [TyCon] - | CouldNotFindExprHashForTypeNameBindings [TypeName] - | CouldNotFindBinding Name - | CouldNotFindStoreExpression ExprHash - | CouldNotFindModule ModuleHash - | UnknownStoreError - deriving stock (Eq, Ord, Show) - -instance Printer StoreError where - prettyPrint (ExpressionDoesNotMatchHash a b) = - "Expression hashes does not match expected: " - <> prettyPrint a - <> " !== " - <> prettyPrint b - prettyPrint (CouldNotReadFilePath fileType path) = - "Could not read " <> prettyPrint fileType <> " file at path " <> T.pack path - prettyPrint (CouldNotWriteFilePath fileType path) = - "Could not write " <> prettyPrint fileType <> " file at path " <> T.pack path - prettyPrint (CouldNotDecodeJson hash') = - "Could not decode JSON for hash " <> prettyPrint hash' - prettyPrint CouldNotDecodeByteString = - "Could not decode JSON for bytestring" - prettyPrint (CouldNotDecodeFile path) = - "Could not decode JSON for file " <> T.pack path - prettyPrint (CouldNotFindExprHashForBindings missing) = - "Could not find expressions in the store for the following: " - <> T.intercalate "," (prettyPrint <$> missing) - prettyPrint (CouldNotFindExprHashForInfixes missing) = - "Could not find expressions in the store for the following: " - <> T.intercalate "," (prettyPrint <$> missing) - prettyPrint (CouldNotFindExprHashForTypeBindings missing) = - "Could not find type expressions in the store for the following: " - <> T.intercalate "," (prettyPrint <$> missing) - prettyPrint (CouldNotFindExprHashForTypeNameBindings missing) = - "Could not find type name expressions in the store for the following: " - <> T.intercalate "," (prettyPrint <$> missing) - prettyPrint (CouldNotFindBinding name) = - "Could not find binding " <> prettyPrint name - prettyPrint (CouldNotFindStoreExpression exprHash) = - "Could not find store expression for hash " <> prettyPrint exprHash - prettyPrint (CouldNotFindModule modHash) = - "Could not find module for hash " <> prettyPrint modHash - prettyPrint UnknownStoreError = - "Unknown store error" - -instance Semigroup StoreError where - _ <> b = b - -instance Monoid StoreError where - mempty = UnknownStoreError diff --git a/compiler/src/Language/Mimsa/Types/Error/TypeError.hs b/compiler/src/Language/Mimsa/Types/Error/TypeError.hs deleted file mode 100644 index 7a0a73cb..00000000 --- a/compiler/src/Language/Mimsa/Types/Error/TypeError.hs +++ /dev/null @@ -1,438 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Mimsa.Types.Error.TypeError - ( TypeErrorF (..), - TypeError, - getErrorPos, - getAllAnnotations, - typeErrorDiagnostic, - ) -where - -import Data.Foldable (fold) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Error.Diagnose as Diag -import GHC.Natural -import Language.Mimsa.Core -import Language.Mimsa.Project.SourceSpan -import Language.Mimsa.Types.Error.PatternMatchError (PatternMatchErrorF (..)) -import Language.Mimsa.Types.Project.SourceSpan -import Language.Mimsa.Types.Typechecker.Environment (Environment (getDataTypes)) -import Language.Mimsa.Types.Typechecker.FoundPath -import Prettyprinter -import Text.Megaparsec - -data TypeErrorF var ann - = UnknownTypeError - | FailsOccursCheck TypeIdentifier (Type ann) - | UnificationError (Type ann) (Type ann) - | MissingRecordMember ann var (Set var) - | MissingRecordTypeMember ann var (Map Name (Type ann)) - | MissingTupleTypeMember ann Natural [Type ann] - | NoFunctionEquality (Type ann) (Type ann) - | CannotMatchRecord Environment ann (Type ann) - | CannotMatchTuple Environment ann (Type ann) - | TypeConstructorNotInScope Environment ann (Maybe ModuleName) TyCon - | TypeVariablesNotInDataType ann TypeName (Set var) (Set var) - | ConflictingConstructors ann TyCon - | RecordKeyMismatch (Set Name) - | DuplicateTypeDeclaration ann TypeName - | IncompletePatternMatch ann [TyCon] - | MixedUpPatterns [TyCon] - | TypedHoles (Map Name (Type ann, Set FoundPath)) - | CouldNotFindInfixOperator ann InfixOp (Set InfixOp) - | CannotUseBuiltInTypeAsConstructor ann TyCon - | InternalConstructorUsedOutsidePatternMatch ann TyCon - | PatternMatchErr (PatternMatchErrorF var ann) - | NameNotFoundInScope ann (Set (var, Maybe ModuleName)) (Maybe ModuleName) var - | VariableNotFound ann (Set TypeIdentifier) var - | IfPredicateIsNotBoolean ann (Type ann) - | FunctionArgumentMismatch ann (Type ann) (Type ann) - | ApplicationToNonFunction ann (Type ann) - | UnscopedTypeVarFound ann TypeIdentifier - | KindMismatchInDataDeclaration ann (Maybe ModuleName) TypeName Int Int - deriving stock (Eq, Ord, Show, Foldable) - -type TypeError = TypeErrorF Name Annotation - ------- - -instance Semigroup (TypeErrorF var ann) where - a <> _ = a - -instance Monoid (TypeErrorF var ann) where - mempty = UnknownTypeError - -instance - (Printer ann, Show ann, Printer var, Printer (Pattern var ann)) => - Printer (TypeErrorF var ann) - where - prettyDoc = vsep . renderTypeError - -instance ShowErrorComponent (TypeErrorF Name Annotation) where - showErrorComponent = T.unpack . prettyPrint - errorComponentLen typeErr = let (_, len) = getErrorPos typeErr in len - -type Start = Int - -type Length = Int - --- megaparsec accepts one single error range -fromAnnotation :: Annotation -> (Start, Length) -fromAnnotation (Location a b) = (a, b - a) -fromAnnotation _ = (0, 0) - --- get overall error position for Megaparsec -getErrorPos :: TypeError -> (Start, Length) -getErrorPos = fromAnnotation . mconcat . getAllAnnotations - --- use the derived Foldable instance to get all annotations in an error -getAllAnnotations :: TypeError -> [Annotation] -getAllAnnotations = foldMap pure - ------- - -showKeys :: (p -> Doc ann) -> Map p a -> [Doc ann] -showKeys renderP record = dquotes . renderP <$> M.keys record - -showSet :: (a -> Doc ann) -> Set a -> [Doc ann] -showSet renderA set = renderA <$> S.toList set - -showMap :: (k -> Doc ann) -> (a -> Doc ann) -> Map k a -> [Doc ann] -showMap renderK renderA map' = - (\(k, a) -> renderK k <+> ":" <+> renderA a) - <$> M.toList map' - ------- - ------ - -renderTypeError :: (Printer ann, Printer var, Printer (Pattern var ann)) => TypeErrorF var ann -> [Doc a] -renderTypeError UnknownTypeError = - ["Unknown type error"] -renderTypeError (FailsOccursCheck var mt) = - [ prettyDoc var <+> "appears inside" <+> prettyDoc mt <+> "." - ] -renderTypeError (UnificationError a b) = - [ "Unification error", - "Cannot match" <+> prettyDoc a <+> "and" <+> prettyDoc b - ] -renderTypeError (IfPredicateIsNotBoolean _ mt) = - ["Predicate for an if expression should be a boolean. This has type" <+> prettyDoc mt] -renderTypeError (FunctionArgumentMismatch _ expected actual) = - [ "Incorrect function argument. Expected " - <> prettyDoc expected - <> ", got " - <> prettyDoc actual - ] -renderTypeError (ApplicationToNonFunction _ mt) = - ["Cannot apply to non-function. Expected Function, got " <> prettyDoc mt] -renderTypeError (CouldNotFindInfixOperator _ op allOps) = - [ "Could not find infix operator " <> prettyDoc op, - "The following are available:" - ] - <> showSet prettyDoc allOps -renderTypeError (MissingRecordMember _ name members) = - [ "Cannot find" <+> prettyDoc name <> ".", - "The following are available:" - ] - <> showSet prettyDoc members -renderTypeError (MissingRecordTypeMember _ name types) = - [ "Cannot find" <+> dquotes (prettyDoc name) <> ". The following record items are available:" - ] - <> showKeys prettyDoc types -renderTypeError (MissingTupleTypeMember _ index types) = - [ "Cannot find index " <+> dquotes (prettyDoc index) <> ". The following items are available:" - ] - <> (prettyDoc <$> types) -renderTypeError (CannotMatchRecord env _ mt) = - [ "Cannot match type" <+> prettyDoc mt <+> "to record.", - "The following vars are available:", - pretty (show env) - ] -renderTypeError (CannotMatchTuple env _ mt) = - [ "Cannot match type" <+> prettyDoc mt <+> "to tuple.", - "The following vars are available:", - pretty (show env) - ] -renderTypeError (TypeConstructorNotInScope env _ modName constructor) = - let prettyName = case modName of - Just mod' -> prettyDoc mod' <> "." <> prettyDoc constructor - _ -> prettyDoc constructor - in [ "Type constructor for" - <+> prettyName - <+> "not found in scope.", - "The following are available:" - ] - <> printDataTypes env -renderTypeError (ConflictingConstructors _ constructor) = - ["Multiple constructors found matching" <+> prettyDoc constructor] -renderTypeError (DuplicateTypeDeclaration _ constructor) = - ["Cannot redeclare existing type name" <+> prettyDoc constructor] -renderTypeError (RecordKeyMismatch keys) = - [ "Record key mismatch", - "The following keys were expected to be in both records and were not:" - ] - <> showSet prettyDoc keys -renderTypeError (TypeVariablesNotInDataType _ann constructor names as) = - [ "Type variables" - <+> mconcat (showSet prettyDoc names) - <+> "could not be in found in type vars for" - <+> prettyDoc constructor, - "The following type variables were found:" - ] - <> showSet prettyDoc as -renderTypeError (IncompletePatternMatch _ names) = - [ "Incomplete pattern match.", - "Missing constructors:" - ] - <> (prettyDoc <$> names) -renderTypeError (MixedUpPatterns names) = - [ "Mixed up patterns in same match.", - "Constructors:" - ] - <> (prettyDoc <$> names) -renderTypeError (NoFunctionEquality a b) = - ["Cannot use == on functions", prettyDoc a, prettyDoc b] -renderTypeError (TypedHoles map') = - ["Typed holes found:"] <> showMap renderHoleName renderSuggestion map' - where - renderHoleName n = "?" <> prettyDoc n - renderSuggestion (mt, suggestions) = - prettyDoc mt <+> renderMatches suggestions - renderMatches s = - if S.null s - then "" - else line <> indent 2 ("Suggestions:" <+> list (prettyDoc <$> S.toList s)) -renderTypeError (CannotUseBuiltInTypeAsConstructor _ name) = - ["Cannot use built-in type as constructor name:" <+> prettyDoc name] -renderTypeError (InternalConstructorUsedOutsidePatternMatch _ tyCon) = - ["Internal type constructor" <+> prettyDoc tyCon <+> "cannot be used outside of a pattern match"] -renderTypeError (PatternMatchErr pmErr) = - [prettyDoc pmErr] -renderTypeError (NameNotFoundInScope _ available mModName name) = - case mModName of - Just modName -> - ["Could not find" <+> prettyDoc modName <> "." <> prettyDoc name <+> itemList] - Nothing -> - ["Could not find " <+> prettyDoc name <+> "in" <+> itemList] - where - itemList = "[" <+> pretty (T.intercalate ", " (prettyPrint <$> S.toList available)) <+> "]" -renderTypeError (VariableNotFound _ available name) = - ["Could not find var" <+> prettyDoc name <+> "in scope" <+> itemList] - where - itemList = - "[" - <+> pretty - ( T.intercalate - ", " - (prettyPrint <$> S.toList available) - ) - <+> "]" -renderTypeError (UnscopedTypeVarFound _ typeVar) = - [ "Unscoped type var found: " <> prettyDoc typeVar, - "This is an implementation error, please complain on Github or write a mean tweet" - ] -renderTypeError (KindMismatchInDataDeclaration _ modName typeName expectedArgs actualArgs) = - let nameo = case modName of - Just m -> prettyDoc m <> "." <> prettyDoc typeName - _ -> prettyDoc typeName - in ["Kind mismatch " <> nameo <> " expected " <> pretty expectedArgs <> " but got " <> pretty actualArgs] - -printDataTypes :: Environment -> [Doc style] -printDataTypes env = mconcat $ snd <$> M.toList (printDt <$> getDataTypes env) - where - printDt :: DataType -> [Doc style] - printDt (DataType tyName tyVars constructors) = - [prettyDoc tyName] - <> printTyVars tyVars - <> zipWith (<>) (":" : repeat "|") (printCons <$> M.toList constructors) - printTyVars as = prettyDoc <$> as - printCons (consName, args) = - fold - ( [ prettyDoc - consName - ] - <> (prettyDoc <$> args) - ) - -positionFromAnnotation :: - String -> - Text -> - Annotation -> - Maybe Diag.Position -positionFromAnnotation path input ann = - let toPos ss = - Diag.Position - (ssRowStart ss, ssColStart ss) - (ssRowEnd ss, ssColEnd ss) - path - in toPos <$> sourceSpan input ann - -typeErrorDiagnostic :: Text -> TypeError -> Diag.Diagnostic Text -typeErrorDiagnostic input e = - let filename = "" - diag = Diag.addFile Diag.def filename (T.unpack input) - in case e of - (UnificationError a b) -> - let report = - Diag.Err - Nothing - ( "Unification error! Expected matching types but found " - <> prettyPrint a - <> " and " - <> prettyPrint b - <> "." - ) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - (getAnnotationForType a) - <*> pure - ( Diag.This ("This has type " <> prettyPrint a) - ), - (,) - <$> positionFromAnnotation - filename - input - (getAnnotationForType b) - <*> pure (Diag.Where ("This has type " <> prettyPrint b)) - ] - ) - ["These two values should be of the same type"] - in Diag.addReport diag report - (IfPredicateIsNotBoolean ann mt) -> - let report = - Diag.Err - Nothing - ("Predicate for an if expression should be a Boolean. This has type " <> prettyPrint mt) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - (getAnnotationForType mt) - <*> pure - ( Diag.This ("This has type " <> prettyPrint mt <> " but should have type Boolean") - ), - (,) - <$> positionFromAnnotation - filename - input - ann - <*> pure (Diag.Where "error in this expression") - ] - ) - ["Change the predicate to be a Boolean type (True or False)"] - in Diag.addReport diag report - (MissingRecordTypeMember ann missing _types) -> - let report = - Diag.Err - Nothing - (prettyPrint e) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - ann - <*> pure - ( Diag.Where - ( "Should contain a member called " - <> prettyPrint missing - ) - ) - ] - ) - [] - in Diag.addReport diag report - (DuplicateTypeDeclaration ann _constructor) -> - let report = - Diag.Err - Nothing - (prettyPrint e) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - ann - <*> pure - (Diag.Where "Is a duplicate") - ] - ) - [] - in Diag.addReport diag report - (FunctionArgumentMismatch fnAnn expected actual) -> - let report = - Diag.Err - Nothing - ( "Function called with incorrect argument type. Expected " - <> prettyPrint expected - <> " but got " - <> prettyPrint actual - <> "." - ) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - (getAnnotationForType actual) - <*> pure - ( Diag.This ("Passed a " <> prettyPrint actual) - ), - (,) - <$> positionFromAnnotation - filename - input - fnAnn - <*> pure (Diag.Where $ "Expects a " <> prettyPrint expected) - ] - ) - [Diag.Note ("Pass a value of type " <> prettyPrint expected <> " to the function")] - in Diag.addReport diag report - (ApplicationToNonFunction _ mt) -> - let report = - Diag.Err - Nothing - ("Cannot apply value to non-function. Expected a function, got " <> prettyPrint mt) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - (getAnnotationForType mt) - <*> pure - ( Diag.This ("This should be a function, but instead has type " <> prettyPrint mt) - ) - ] - ) - [] - in Diag.addReport diag report - other -> - let positions = - mapMaybe - (positionFromAnnotation filename input) - (getAllAnnotations other) - report = - Diag.Err - Nothing - (prettyPrint other) - ((,Diag.Where "") <$> positions) - [] - in Diag.addReport diag report diff --git a/compiler/src/Language/Mimsa/Types/Interpreter/Stack.hs b/compiler/src/Language/Mimsa/Types/Interpreter/Stack.hs deleted file mode 100644 index 643ddb81..00000000 --- a/compiler/src/Language/Mimsa/Types/Interpreter/Stack.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Interpreter.Stack (StackFrame (..), ExprData (..)) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Typechecker.Unique - -data StackFrame var ann = StackFrame - { sfVariables :: Map var (Expr (var, Unique) (ExprData var ann)), - sfInfix :: Map InfixOp (Expr (var, Unique) (ExprData var ann)) - } - deriving stock (Eq, Ord, Show) - -instance (Ord var) => Semigroup (StackFrame var ann) where - (StackFrame varA infixA) <> (StackFrame varB infixB) = - StackFrame (varA <> varB) (infixA <> infixB) - -instance (Ord var) => Monoid (StackFrame var ann) where - mempty = StackFrame mempty mempty - -instance (Printer var) => Printer (StackFrame var ann) where - prettyPrint (StackFrame sfVars sfInf) = - "{ vars: [" - <> T.intercalate "," (prettyPrint <$> M.keys sfVars) - <> "], infix: [" - <> T.intercalate "," (prettyPrint <$> M.keys sfInf) - <> "] }" - --- carried around in each node when interpreting -data ExprData var ann = ExprData - { edStackFrame :: StackFrame var ann, - edIsRecursive :: Bool, - edAnnotation :: ann - } - deriving stock (Eq, Ord, Show) - -instance (Ord var, Semigroup ann) => Semigroup (ExprData var ann) where - (ExprData sfA isRecA annA) <> (ExprData sfB isRecB annB) = ExprData (sfA <> sfB) (isRecA || isRecB) (annA <> annB) - -instance (Ord var, Monoid ann) => Monoid (ExprData var ann) where - mempty = ExprData mempty False mempty diff --git a/compiler/src/Language/Mimsa/Types/Project.hs b/compiler/src/Language/Mimsa/Types/Project.hs deleted file mode 100644 index 2716500d..00000000 --- a/compiler/src/Language/Mimsa/Types/Project.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Language.Mimsa.Types.Project - ( module Language.Mimsa.Types.Project.Project, - module Language.Mimsa.Types.Project.Usage, - module Language.Mimsa.Types.Project.VersionedMap, - module Language.Mimsa.Types.Project.ProjectHash, - module Language.Mimsa.Types.Project.Versioned, - module Language.Mimsa.Types.Project.SaveProject, - module Language.Mimsa.Types.Project.SourceSpan, - ) -where - -import Language.Mimsa.Types.Project.Project -import Language.Mimsa.Types.Project.ProjectHash -import Language.Mimsa.Types.Project.SaveProject -import Language.Mimsa.Types.Project.SourceSpan -import Language.Mimsa.Types.Project.Usage -import Language.Mimsa.Types.Project.Versioned -import Language.Mimsa.Types.Project.VersionedMap diff --git a/compiler/src/Language/Mimsa/Types/Project/Project.hs b/compiler/src/Language/Mimsa/Types/Project/Project.hs deleted file mode 100644 index a89f0c85..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/Project.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Types.Project.Project where - -import Data.Map.Strict (Map) -import GHC.Generics (Generic) -import Language.Mimsa.Core -import Language.Mimsa.Types.Project.Versioned -import Language.Mimsa.Types.Store (Store) - --- our environment contains whichever hash/expr pairs we have flapping about --- and a list of mappings of names to those pieces -data Project ann = Project - { prjStore :: Store ann, - prjModules :: VersionedModules, - prjModuleStore :: Map ModuleHash (Module ann) - } - deriving stock - ( Eq, - Ord, - Show, - Functor, - Generic - ) - -instance Semigroup (Project a) where - Project a a1 a2 <> Project b b1 b2 = - Project (a <> b) (a1 <> b1) (a2 <> b2) - -instance Monoid (Project a) where - mempty = Project mempty mempty mempty - -------------- diff --git a/compiler/src/Language/Mimsa/Types/Project/ProjectHash.hs b/compiler/src/Language/Mimsa/Types/Project/ProjectHash.hs deleted file mode 100644 index 92c15f03..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/ProjectHash.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Types.Project.ProjectHash where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core - --- because of the size of the ints --- and JS's limitations in the browser --- we JSON encode these as strings -newtype ProjectHash = ProjectHash Text - deriving stock (Eq, Ord, Generic) - deriving newtype (ToParamSchema, ToSchema) - deriving newtype - ( JSON.FromJSON, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance Show ProjectHash where - show (ProjectHash a) = T.unpack a - -instance Printer ProjectHash where - prettyPrint (ProjectHash a) = a diff --git a/compiler/src/Language/Mimsa/Types/Project/SaveProject.hs b/compiler/src/Language/Mimsa/Types/Project/SaveProject.hs deleted file mode 100644 index a8ca555f..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/SaveProject.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Mimsa.Types.Project.SaveProject where - -import Control.Monad (mzero) -import Data.Aeson -import qualified Data.Aeson as JSON -import GHC.Generics (Generic) -import Language.Mimsa.Types.Project.Versioned - -data SaveProject = SaveProject - { projectVersion :: Int, - projectModules :: VersionedModules - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON) - -instance JSON.FromJSON SaveProject where - parseJSON (JSON.Object o) = do - version <- o .: "projectVersion" - modules <- o .:? "projectModules" - - mods <- case modules of - Just as -> JSON.parseJSON as - Nothing -> pure mempty - - SaveProject - <$> JSON.parseJSON version - <*> pure mods - parseJSON _ = mzero diff --git a/compiler/src/Language/Mimsa/Types/Project/SourceItem.hs b/compiler/src/Language/Mimsa/Types/Project/SourceItem.hs deleted file mode 100644 index 8eed43b6..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/SourceItem.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Mimsa.Types.Project.SourceItem where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import Data.Text (Text) -import GHC.Generics -import Language.Mimsa.Types.Project - --- SourceItem is any interesting thing in the response, with a location -data SourceItem = SourceItem - { siLabel :: Text, - siSourceSpan :: SourceSpan - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, ToSchema) diff --git a/compiler/src/Language/Mimsa/Types/Project/SourceSpan.hs b/compiler/src/Language/Mimsa/Types/Project/SourceSpan.hs deleted file mode 100644 index e55252af..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/SourceSpan.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Types.Project.SourceSpan (SourceSpan (..)) where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import GHC.Generics - -data SourceSpan = SourceSpan - { ssRowStart :: Int, - ssRowEnd :: Int, - ssColStart :: Int, - ssColEnd :: Int - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, ToSchema) diff --git a/compiler/src/Language/Mimsa/Types/Project/Usage.hs b/compiler/src/Language/Mimsa/Types/Project/Usage.hs deleted file mode 100644 index f1d2601b..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/Usage.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Project.Usage where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash - -data Usage - = Transient Name ExprHash - | Direct Name ExprHash - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON) - -instance Printer Usage where - prettyPrint (Transient name _) = - "Transient dependency of " - <> prettyPrint name - prettyPrint (Direct name _) = - "Direct dependency of " - <> prettyPrint name - ----------- diff --git a/compiler/src/Language/Mimsa/Types/Project/Versioned.hs b/compiler/src/Language/Mimsa/Types/Project/Versioned.hs deleted file mode 100644 index 70939e04..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/Versioned.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Language.Mimsa.Types.Project.Versioned (VersionedBindings, VersionedTypeBindings, VersionedModules) where - -import Language.Mimsa.Core -import Language.Mimsa.Types.Project.VersionedMap (VersionedMap) -import Language.Mimsa.Types.Store (ExprHash) - -type VersionedBindings = VersionedMap Name ExprHash - -type VersionedTypeBindings = VersionedMap TyCon ExprHash - -type VersionedModules = VersionedMap ModuleName ModuleHash diff --git a/compiler/src/Language/Mimsa/Types/Project/VersionedMap.hs b/compiler/src/Language/Mimsa/Types/Project/VersionedMap.hs deleted file mode 100644 index 41759949..00000000 --- a/compiler/src/Language/Mimsa/Types/Project/VersionedMap.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Types.Project.VersionedMap where - -import qualified Data.Aeson as JSON -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M - ------- --- A versioned Map is a Map whose contents are a unique nonempty list --- When adding a new item, it goes at the end, removing previous occurances ------- - -newtype VersionedMap k a = VersionedMap {getVersionedMap :: Map k (NonEmpty a)} - deriving newtype (Eq, Ord, Show, Monoid) - deriving newtype (JSON.ToJSON, JSON.FromJSON) - -instance (Ord k, Eq a) => Semigroup (VersionedMap k a) where - (VersionedMap a) <> (VersionedMap b) = - VersionedMap (M.unionWith combineUnique a b) - --- we don't want duplicates in list --- nub keeps first instance, we want last instance, hence the reversing -combineUnique :: (Eq a) => NonEmpty a -> NonEmpty a -> NonEmpty a -combineUnique as bs = - let as' = NE.toList as - bs' = NE.toList bs - in NE.fromList . reverse . nub . reverse $ as' <> bs' - --- remove an item from a versioned map -delete :: (Ord k) => k -> VersionedMap k a -> VersionedMap k a -delete key = VersionedMap . M.delete key . getVersionedMap diff --git a/compiler/src/Language/Mimsa/Types/Store.hs b/compiler/src/Language/Mimsa/Types/Store.hs deleted file mode 100644 index acf1c65f..00000000 --- a/compiler/src/Language/Mimsa/Types/Store.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Language.Mimsa.Types.Store - ( module Language.Mimsa.Types.Store.Store, - module Language.Mimsa.Types.Store.ExprHash, - module Language.Mimsa.Types.Store.StoreExpression, - module Language.Mimsa.Types.Store.Bindings, - module Language.Mimsa.Types.Store.TypeBindings, - module Language.Mimsa.Types.Store.ResolvedDeps, - ) -where - -import Language.Mimsa.Types.Store.Bindings -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Store.ResolvedDeps -import Language.Mimsa.Types.Store.Store -import Language.Mimsa.Types.Store.StoreExpression -import Language.Mimsa.Types.Store.TypeBindings diff --git a/compiler/src/Language/Mimsa/Types/Store/Bindings.hs b/compiler/src/Language/Mimsa/Types/Store/Bindings.hs deleted file mode 100644 index f9796e17..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/Bindings.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Store.Bindings where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash - --- a list of names to hashes -newtype Bindings = Bindings {getBindings :: Map Name ExprHash} - deriving newtype - ( Eq, - Ord, - Show, - Semigroup, - Monoid, - JSON.FromJSON, - JSON.ToJSON - ) - -instance Printer Bindings where - prettyPrint (Bindings b) = - "{ " <> T.intercalate ", " (prettyPrint <$> M.keys b) <> " }" diff --git a/compiler/src/Language/Mimsa/Types/Store/ExprHash.hs b/compiler/src/Language/Mimsa/Types/Store/ExprHash.hs deleted file mode 100644 index 381d5e08..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/ExprHash.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Types.Store.ExprHash where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core - --- because of the size of the ints --- and JS's limitations in the browser --- we JSON encode these as strings -newtype ExprHash = ExprHash Text - deriving stock (Eq, Ord, Generic) - deriving newtype (ToParamSchema, ToSchema) - deriving newtype - ( JSON.FromJSON, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance Show ExprHash where - show (ExprHash a) = T.unpack a - -instance Printer ExprHash where - prettyPrint (ExprHash a) = a diff --git a/compiler/src/Language/Mimsa/Types/Store/ResolvedDeps.hs b/compiler/src/Language/Mimsa/Types/Store/ResolvedDeps.hs deleted file mode 100644 index 0fb13bc9..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/ResolvedDeps.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Types.Store.ResolvedDeps where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Store.StoreExpression -import Prettyprinter - -newtype ResolvedDeps a = ResolvedDeps - { getResolvedDeps :: - Map - (Maybe ModuleName, Name) - (ExprHash, StoreExpression a) - } - deriving newtype (Semigroup, Monoid) - -hasNoDeps :: ResolvedDeps a -> Bool -hasNoDeps (ResolvedDeps m) = M.size m == 0 - -instance Printer (ResolvedDeps a) where - prettyDoc (ResolvedDeps deps) = - encloseSep - lbrace - rbrace - comma - (prettyDoc <$> M.keys deps) diff --git a/compiler/src/Language/Mimsa/Types/Store/RootPath.hs b/compiler/src/Language/Mimsa/Types/Store/RootPath.hs deleted file mode 100644 index 94fe05d1..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/RootPath.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Language.Mimsa.Types.Store.RootPath - ( RootPath (..), - ) -where - -newtype RootPath = RootPath String - deriving newtype (Eq, Ord, Show) diff --git a/compiler/src/Language/Mimsa/Types/Store/Store.hs b/compiler/src/Language/Mimsa/Types/Store/Store.hs deleted file mode 100644 index 094accf3..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/Store.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Store.Store where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash -import Language.Mimsa.Types.Store.StoreExpression - --- store is where we keep the big map of hashes to expresions -newtype Store ann = Store {getStore :: Map ExprHash (StoreExpression ann)} - deriving newtype - ( Eq, - Ord, - Show, - Semigroup, - Monoid, - JSON.ToJSON, - JSON.FromJSON - ) - deriving stock (Functor) - -instance Printer (Store ann) where - prettyPrint (Store store) = T.intercalate ", " (prettyPrint <$> M.keys store) diff --git a/compiler/src/Language/Mimsa/Types/Store/StoreExpression.hs b/compiler/src/Language/Mimsa/Types/Store/StoreExpression.hs deleted file mode 100644 index 055d46a9..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/StoreExpression.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Types.Store.StoreExpression where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import GHC.Generics -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash - --- a storeExpression contains the AST Expr --- and a map of names to hashes with further functions inside -data StoreExpression ann - = StoreExpression - { seExpr :: Expr Name ann, - seBindings :: Map (Maybe ModuleName, Name) ExprHash, - seTypeBindings :: Map (Maybe ModuleName, TyCon) ExprHash, - seInfixes :: Map InfixOp ExprHash, - seTypes :: Map (Maybe ModuleName, TypeName) ExprHash - } - | StoreDataType - { seDataType :: DataType, - seTypes :: Map (Maybe ModuleName, TypeName) ExprHash - } - deriving stock - ( Eq, - Ord, - Show, - Generic, - Functor - ) - deriving anyclass - ( JSON.ToJSON, - JSON.FromJSON - ) - -storeExpression :: StoreExpression ann -> Maybe (Expr Name ann) -storeExpression (StoreExpression se _ _ _ _) = Just se -storeExpression _ = Nothing - -storeBindings :: StoreExpression ann -> Map (Maybe ModuleName, Name) ExprHash -storeBindings (StoreExpression _ bindings _ _ _) = bindings -storeBindings _ = mempty - -storeTypeBindings :: StoreExpression ann -> Map (Maybe ModuleName, TyCon) ExprHash -storeTypeBindings (StoreExpression _ _ typeBindings _ _) = typeBindings -storeTypeBindings _ = mempty - -storeInfixes :: StoreExpression ann -> Map InfixOp ExprHash -storeInfixes (StoreExpression _ _ _ infixes _) = infixes -storeInfixes _ = mempty - -storeTypes :: StoreExpression ann -> Map (Maybe ModuleName, TypeName) ExprHash -storeTypes (StoreExpression _ _ _ _ types) = types -storeTypes (StoreDataType _ types) = types - -instance Printer (StoreExpression ann) where - prettyPrint (StoreExpression expr _ _ _ _) = prettyPrint expr - prettyPrint (StoreDataType dt _) = prettyPrint dt diff --git a/compiler/src/Language/Mimsa/Types/Store/TypeBindings.hs b/compiler/src/Language/Mimsa/Types/Store/TypeBindings.hs deleted file mode 100644 index 70c07d29..00000000 --- a/compiler/src/Language/Mimsa/Types/Store/TypeBindings.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Store.TypeBindings where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash (ExprHash) - --- a list of names to hashes -newtype TypeBindings = TypeBindings - { getTypeBindings :: - Map TyCon ExprHash - } - deriving newtype - ( Eq, - Ord, - Show, - Semigroup, - Monoid, - JSON.FromJSON, - JSON.ToJSON - ) - -instance Printer TypeBindings where - prettyPrint (TypeBindings b) = "{ " <> T.intercalate ", " (prettyPrint <$> M.keys b) <> " }" diff --git a/compiler/src/Language/Mimsa/Types/Tests.hs b/compiler/src/Language/Mimsa/Types/Tests.hs deleted file mode 100644 index 2c09e677..00000000 --- a/compiler/src/Language/Mimsa/Types/Tests.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Tests - ( Test (..), - UnitTest (..), - TestName (..), - UnitTestSuccess (..), - PropertyTest (..), - PropertyTestResult (..), - TestResult (..), - ModuleTestResult (..), - ModuleTestResults (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core -import Language.Mimsa.Types.Store -import Prettyprinter - -newtype UnitTestSuccess = UnitTestSuccess Bool - deriving newtype - ( Eq, - Ord, - Show, - JSON.ToJSON, - JSON.FromJSON - ) - -data PropertyTestResult ann - = PropertyTestSuccess - | PropertyTestFailures (Set (Expr Name ann)) - deriving stock - ( Eq, - Ord, - Show, - Generic - ) - deriving anyclass - ( JSON.ToJSON, - JSON.FromJSON - ) - -data Test = UTest UnitTest | PTest PropertyTest - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance Printer Test where - prettyPrint (PTest pt) = prettyPrint pt - prettyPrint (UTest ut) = prettyPrint ut - -data PropertyTest = PropertyTest - { ptName :: TestName, - ptExprHash :: ExprHash - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance Printer PropertyTest where - prettyPrint test = - prettyPrint (ptName test) - -data UnitTest = UnitTest - { utName :: TestName, - utSuccess :: UnitTestSuccess, - utExprHash :: ExprHash - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance Printer UnitTest where - prettyPrint test = - let tickOrCross = case utSuccess test of - (UnitTestSuccess True) -> "+++ PASS +++" - _ -> "--- FAIL ---" - in tickOrCross <> " " <> prettyPrint (utName test) - -data TestResult ann - = -- | unit test is run once and contains its result - UTestResult UnitTest - | -- | property test is effectful and run when returning results - PTestResult PropertyTest (PropertyTestResult ann) - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance Printer (TestResult ann) where - prettyPrint (UTestResult ut) = prettyPrint ut - prettyPrint (PTestResult pt ptRes) = - let tickOrCross = case ptRes of - PropertyTestSuccess -> "+++ PASS +++" - _ -> "--- FAIL ---" - failures = case ptRes of - PropertyTestSuccess -> "" - PropertyTestFailures es -> - "\nFailing inputs:\n" <> T.intercalate "\n" ((<>) " - " . prettyPrint <$> S.toList es) - in tickOrCross <> " " <> prettyPrint pt <> failures - -newtype ModuleTestResults = ModuleTestResults {getModuleTests :: Map TestName ModuleTestResult} - deriving newtype (Eq, Ord, Show) - -instance Printer ModuleTestResults where - prettyDoc (ModuleTestResults results) | M.null results = "" - prettyDoc results = - case partitionModuleTestResults results of - ([], successes) -> "๐Ÿ‘" <+> pretty (length successes) <+> "tests passed" - (fails, successes) -> - let printFail testName = "๐Ÿ’ฉ" <+> prettyDoc testName <> line - printSuccess testName = "๐Ÿ‘" <+> prettyDoc testName <> line - successCount = pretty (length successes) <> "\\" <> pretty (length successes + length fails) <+> "tests passed" - in successCount <> line <> foldMap printFail fails <> foldMap printSuccess successes - --- | split the test results into a list of successes and failures --- when we come to include property tests this will need to show --- failed cases too -partitionModuleTestResults :: ModuleTestResults -> ([TestName], [TestName]) -partitionModuleTestResults (ModuleTestResults results) = - partitionEithers $ - ( \(testName, result) -> case result of - ModuleTestPassed -> Right testName - ModuleTestFailed -> Left testName - ) - <$> M.toList results - -data ModuleTestResult - = ModuleTestPassed - | ModuleTestFailed - deriving stock (Eq, Ord, Show) - -instance Printer ModuleTestResult where - prettyPrint ModuleTestPassed = "+" - prettyPrint ModuleTestFailed = "-" diff --git a/compiler/src/Language/Mimsa/Types/Typechecker.hs b/compiler/src/Language/Mimsa/Types/Typechecker.hs deleted file mode 100644 index 28f9228d..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Language.Mimsa.Types.Typechecker - ( module Language.Mimsa.Types.Typechecker.Scheme, - module Language.Mimsa.Types.Typechecker.Environment, - module Language.Mimsa.Types.Typechecker.Constraint, - module Language.Mimsa.Types.Typechecker.TypeConstructor, - module Language.Mimsa.Types.Typechecker.FoundPath, - ) -where - -import Language.Mimsa.Types.Typechecker.Constraint -import Language.Mimsa.Types.Typechecker.Environment -import Language.Mimsa.Types.Typechecker.FoundPath -import Language.Mimsa.Types.Typechecker.Scheme -import Language.Mimsa.Types.Typechecker.TypeConstructor diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/Constraint.hs b/compiler/src/Language/Mimsa/Types/Typechecker/Constraint.hs deleted file mode 100644 index b1344cdf..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/Constraint.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.Constraint (Constraint (..)) where - -import Language.Mimsa.Core - -data Constraint - = ShouldEqual MonoType MonoType - deriving stock (Eq, Ord, Show) - -instance Printer Constraint where - prettyPrint (ShouldEqual a b) = - prettyPrint a <> " == " <> prettyPrint b diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/Environment.hs b/compiler/src/Language/Mimsa/Types/Typechecker/Environment.hs deleted file mode 100644 index a2a76c3f..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/Environment.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.Environment where - -import Data.Map.Strict (Map) -import Language.Mimsa.Core -import Language.Mimsa.Types.Typechecker.Scheme (Scheme) -import Prettyprinter - --- everything we need in typechecking environment -data Environment = Environment - { getSchemes :: Map TypeIdentifier Scheme, - getDataTypes :: Map (Maybe ModuleName, TypeName) DataType, - getInfix :: Map InfixOp Scheme, - getTypeVarsInScope :: Map TyVar Int, -- used for scoping type variables - getNamespacedSchemes :: Map ModuleHash (Map Name Scheme) -- Name should probably be DefIdentifier or something so we can do Infix in future - } - deriving stock (Eq, Ord, Show) - -instance Semigroup Environment where - (Environment a b c d e) <> (Environment a' b' c' d' e') = - Environment (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') - -instance Monoid Environment where - mempty = Environment mempty mempty mempty mempty mempty - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Int -> Doc style -> Doc style -indentMulti i doc = flatAlt (indent i doc) doc - -instance Printer Environment where - prettyDoc (Environment typeSchemes dataTypes infixes tyVars externals) = - "[" - <> indentMulti - 2 - ( line - <> "typeSchemes:" - <> indentMulti 2 (prettyDoc typeSchemes) - <> comma - <> line - <> "dataTypes:" - <> indentMulti 2 (prettyDoc dataTypes) - <> comma - <> line - <> "infixes:" - <> indentMulti 2 (prettyDoc infixes) - <> comma - <> line - <> "tyVars:" - <> indentMulti 2 (prettyDoc tyVars) - <> comma - <> line - <> "externals:" - <> indentMulti 2 (prettyDoc externals) - ) - <> line - <> "]" diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/FoundPath.hs b/compiler/src/Language/Mimsa/Types/Typechecker/FoundPath.hs deleted file mode 100644 index b6d17c99..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/FoundPath.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.FoundPath (FoundPath (..), appendNameToFoundPath) where - -import qualified Data.List.NonEmpty as NE -import Data.String -import qualified Data.Text as T -import Language.Mimsa.Core - --- | path to found item, ie ["state","map"] -newtype FoundPath = FoundPath (NE.NonEmpty Name) - deriving stock (Eq, Ord, Show) - -instance IsString FoundPath where - fromString as = - let textAs = T.pack as - in case NE.nonEmpty (T.splitOn "." (T.pack as)) of - Just path -> FoundPath (Name <$> path) - Nothing -> FoundPath (NE.singleton (Name textAs)) - -instance Printer FoundPath where - prettyPrint (FoundPath as) = T.intercalate "." (prettyPrint <$> NE.toList as) - -appendNameToFoundPath :: Name -> FoundPath -> FoundPath -appendNameToFoundPath a (FoundPath as) = - FoundPath (as <> NE.singleton a) diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/Scheme.hs b/compiler/src/Language/Mimsa/Types/Typechecker/Scheme.hs deleted file mode 100644 index 09b8eb6c..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/Scheme.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.Scheme where - -import qualified Data.Text as T -import Language.Mimsa.Core - -data Scheme = Scheme [TypeIdentifier] MonoType - deriving stock (Eq, Ord, Show) - -instance Printer Scheme where - prettyPrint (Scheme vars mt) = varText <> prettyPrint mt - where - varText = case vars of - [] -> "" - a -> "[" <> T.intercalate ", " (prettyPrint <$> a) <> "] " diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/Substitutions.hs b/compiler/src/Language/Mimsa/Types/Typechecker/Substitutions.hs deleted file mode 100644 index 9bd589a7..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/Substitutions.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.Substitutions - ( Substitutions (..), - applySubst, - ) -where - -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.FlattenRow - ---- - -newtype Substitutions = Substitutions - { getSubstitutions :: - Map TypeIdentifier MonoType - } - deriving stock (Eq, Ord, Show) - -instance Semigroup Substitutions where - (Substitutions s1) <> (Substitutions s2) = - Substitutions $ M.union (M.map (applySubst (Substitutions s1)) s2) s1 - -instance Monoid Substitutions where - mempty = Substitutions mempty - -instance Printer Substitutions where - prettyPrint (Substitutions s1) = "\n " <> T.intercalate "\n " (printRow <$> M.toList s1) - where - printRow (var, mt) = prettyPrint var <> ": " <> prettyPrint mt - ---- - -class Substitutable a where - applySubst :: Substitutions -> a -> a - -substLookup :: ann -> Substitutions -> TypeIdentifier -> Maybe (Type ann) -substLookup ann subst i = - let replaceAnn mt = mt $> ann - in replaceAnn <$> M.lookup i (getSubstitutions subst) - -instance Substitutable (Type ann) where - applySubst subst ty = case flattenRow ty of - MTVar ann var -> - fromMaybe - (MTVar ann var) - (substLookup ann subst var) - other -> mapType (applySubst subst) other - -instance (Substitutable a) => Substitutable (Map k a) where - applySubst subst as = applySubst subst <$> as - -instance Substitutable (Expr var MonoType) where - applySubst subst elabExpr = - applySubst subst <$> elabExpr diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/TypeConstructor.hs b/compiler/src/Language/Mimsa/Types/Typechecker/TypeConstructor.hs deleted file mode 100644 index d8d28fc3..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/TypeConstructor.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Types.Typechecker.TypeConstructor where - -import qualified Data.Text as T -import Language.Mimsa.Core - -data TypeConstructor = TypeConstructor - { tcModName :: Maybe ModuleName, - tcConsName :: TypeName, - tcTypeVars :: [MonoType], - tcConsTypes :: [MonoType] - } - deriving stock (Show) - -instance Printer TypeConstructor where - prettyPrint (TypeConstructor modName consName tyTypeVars consTypes) = - prefix <> prettyPrint consName <> " [" <> vars <> "] " <> cons - where - prefix = case modName of - Just m -> prettyPrint m <> "." - _ -> mempty - vars = T.intercalate ", " (prettyPrint <$> tyTypeVars) - cons = T.intercalate " " (prettyPrint <$> consTypes) diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/UniVar.hs b/compiler/src/Language/Mimsa/Types/Typechecker/UniVar.hs deleted file mode 100644 index 23007622..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/UniVar.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Types.Typechecker.UniVar where - -import GHC.Generics -import Language.Mimsa.Core -import Prettyprinter - -newtype UniVar = UniVar Int - deriving stock (Eq, Ord, Generic) - deriving newtype (Show, Num) - -instance Printer UniVar where - prettyDoc (UniVar a) = pretty a diff --git a/compiler/src/Language/Mimsa/Types/Typechecker/Unique.hs b/compiler/src/Language/Mimsa/Types/Typechecker/Unique.hs deleted file mode 100644 index 5f0c26b4..00000000 --- a/compiler/src/Language/Mimsa/Types/Typechecker/Unique.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Language.Mimsa.Types.Typechecker.Unique (Unique (..), getExprHash) where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.ExprHash - -data Unique - = Unique Int - | Dependency ExprHash - | ModuleDep ModuleHash - | Local - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON) - -getExprHash :: Unique -> Maybe ExprHash -getExprHash (Dependency hash) = Just hash -getExprHash _ = Nothing diff --git a/compiler/static/modules/Array.mimsa b/compiler/static/modules/Array.mimsa deleted file mode 100644 index f576779e..00000000 --- a/compiler/static/modules/Array.mimsa +++ /dev/null @@ -1,23 +0,0 @@ - -export def reduce = - let arrayReduce f default as = - match as with [] -> default - | [a, ...rest] -> arrayReduce f (f a default) rest; - arrayReduce - -export def reverse = reduce (\all -> \a -> [ all ] <> a) [] - -export def fmap f = reduce (\a -> \all -> all <> [ f a ]) [] - -export def map = fmap - -export def filter pred = - reduce (\a -> \all -> if pred a then all <> [ a ] else all) [] - -export def find pred = - reduce (\item -> \total -> - match total with - (Maybe.Just found) -> (Maybe.Just found) - | _ -> (if (pred item) then (Maybe.Just item) else Maybe.Nothing)) - Maybe.Nothing - diff --git a/compiler/static/modules/Either.mimsa b/compiler/static/modules/Either.mimsa deleted file mode 100644 index 98dfd768..00000000 --- a/compiler/static/modules/Either.mimsa +++ /dev/null @@ -1,5 +0,0 @@ -export type Either e a = Left e | Right a - -export def fmap f value = match value with - Right a -> Right (f a) - | Left e -> Left e diff --git a/compiler/static/modules/Maybe.mimsa b/compiler/static/modules/Maybe.mimsa deleted file mode 100644 index b3e76afe..00000000 --- a/compiler/static/modules/Maybe.mimsa +++ /dev/null @@ -1,11 +0,0 @@ -export type Maybe a = Just a | Nothing - -export def fromMaybe (val: Maybe a) (fallback: a): a = - match val with - Just a -> a - | _ -> fallback - -export def fmap (f: a -> b) (maybeA: Maybe a): Maybe b - = match maybeA with - Just a -> Just (f a) - | _ -> Nothing diff --git a/compiler/static/modules/Monoid.mimsa b/compiler/static/modules/Monoid.mimsa deleted file mode 100644 index 48a0807e..00000000 --- a/compiler/static/modules/Monoid.mimsa +++ /dev/null @@ -1,37 +0,0 @@ - -export def maybe innerM = { - mappend: \a -> \b -> match (a,b) with - (Maybe.Just iA, Maybe.Just iB) -> Maybe.Just (innerM.mappend iA iB) - | (Maybe.Just iA, Maybe.Nothing) -> (Maybe.Just iA) - | (Maybe.Nothing, Maybe.Just iB) -> (Maybe.Just iB) - | _ -> Maybe.Nothing, - mempty: Maybe.Nothing - } - -export def concat monoid = - Array.reduce (monoid.mappend) monoid.mempty - -export def foldMap monoid f = - Array.reduce (\a -> \total -> monoid.mappend total (f a)) monoid.mempty - -export def any = { mappend: Prelude.or, mempty: False } - -export def all = { mappend: Prelude.and, mempty: True } - -export def sum = { mappend: \a -> \b -> a + b, mempty: 0 } - -export def first = { mappend: \a -> \b -> - match (a, b) with - (Maybe.Just a, _) -> (Maybe.Just a) - | (_, b) -> b, - mempty: Maybe.Nothing - } - - export def last = { mappend: \a -> \b -> - match (a, b) with - (_, Maybe.Just b) -> (Maybe.Just b) - | (a, _) -> a, - mempty: Maybe.Nothing - } - - diff --git a/compiler/static/modules/NonEmptyArray.mimsa b/compiler/static/modules/NonEmptyArray.mimsa deleted file mode 100644 index abf9e3fa..00000000 --- a/compiler/static/modules/NonEmptyArray.mimsa +++ /dev/null @@ -1,6 +0,0 @@ -export type NonEmptyArray a = NonEmptyArray a [a] - -export def fmap f ne = - let (NonEmptyArray a as) = ne; - NonEmptyArray (f a) (Array.fmap f as) - diff --git a/compiler/static/modules/Parser.mimsa b/compiler/static/modules/Parser.mimsa deleted file mode 100644 index c5bf05de..00000000 --- a/compiler/static/modules/Parser.mimsa +++ /dev/null @@ -1,59 +0,0 @@ -export type Parser a = Parser (String -> Maybe.Maybe (a, String)) - -export def run parser str = - match parser with (Parser p) -> - match p str with (Maybe.Just (a, _)) -> (Maybe.Just a) | _ -> (Maybe.Nothing) - -export def fmap f parser = - Parser (\str -> match parser with (Parser p) -> - (match p str with - (Maybe.Just (a, rest)) -> (Maybe.Just ((f a,rest))) - | _ -> (Maybe.Nothing))) - -export def ap parserF parserA = - let (Parser pF) = parserF; - let (Parser pA) = parserA; - Parser (\input -> match (pF input) with - Maybe.Just (f, input2) -> ( - match (pA input2) with - Maybe.Just (a, input3) -> Maybe.Just (f a, input3) - | _ -> Maybe.Nothing) - | _ -> Maybe.Nothing) - -export def bind f parser = - Parser (\input -> let (Parser firstP) = parser; match (firstP input) with (Maybe.Just (a, input2)) -> let (Parser secondP) = (f a); (secondP input2) | _ -> Maybe.Nothing) - -export def anyChar = - Parser (\s -> match s with ch ++ rest -> (Maybe.Just ((ch, rest))) | _ -> (Maybe.Nothing)) - -export def pred predicate p = - Parser (\s -> let (Parser inner) = p; match inner s with (Maybe.Just (a, rest)) -> (if predicate a then (Maybe.Just ((a, rest))) else (Maybe.Nothing)) | _ -> (Maybe.Nothing)) - -export def alt = - let runParse p input = let (Parser pp) = p in (pp input); \p1 -> \p2 -> Parser (\input -> match (runParse p1 input) with (Maybe.Just a) -> (Maybe.Just a) | (Maybe.Nothing) -> (runParse p2 input)) - -export def char chr = pred (\c -> c == chr) anyChar - -export def many parser = - let (Parser innerP) = parser; - (Parser (\input -> let go items i = match (innerP i) with (Maybe.Just (a, i2)) -> (go (items <> [ a ]) i2) | (Maybe.Nothing) -> (Maybe.Just ((items, i))); go [] input)) - -export def left p1 p2 = ap (fmap (\a -> \b -> a) p1) p2 - -export def right p1 p2 = ap (fmap (\a -> \b -> b) p1) p2 - -export def some p = ap (fmap NonEmptyArray.NonEmptyArray p) (many p) - -infix <|> = alt - -export def whitespace = - char " " <|> char "\n" <|> char "\r" - -export def space0 = fmap (Prelude.const Prelude.Unit) (many whitespace) - -export def space1 = fmap (Prelude.const Prelude.Unit) (some whitespace) - -export def sepBy sepP p = - let pairP = right sepP p; ap (fmap NonEmptyArray.NonEmptyArray p) (many pairP) - -export def fail = Parser (Prelude.const Maybe.Nothing) diff --git a/compiler/static/modules/Prelude.mimsa b/compiler/static/modules/Prelude.mimsa deleted file mode 100644 index 6fac2eb2..00000000 --- a/compiler/static/modules/Prelude.mimsa +++ /dev/null @@ -1,40 +0,0 @@ -export def id a = a - -export def compose f g a = f (g a) - -export def not a = if a then False else True - -export def and a b = if a then b else False - -export def or a b = if a then True else b - -export def fst pair = let (a,_) = pair in a - -export def snd pair = let (_,b) = pair in b - -export def const a b = a - -export type Unit = Unit - -test "id does nothing" = id True == True - -test "fst and snd work as expected" = - let pair = (1,2); - let newPair = (fst pair, snd pair); - newPair == pair - -test "const True 1 equals True" = const True 1 - -test "and True True equals True" = - and True True - -test "or False True equals True" - = or False True - -test "not False equals True" - = not False - -test "composing increment twice adds two" - = let increment a = a + 1; - let incrementTwice = compose increment increment; - incrementTwice 40 == 42 diff --git a/compiler/static/modules/Reader.mimsa b/compiler/static/modules/Reader.mimsa deleted file mode 100644 index 3c107160..00000000 --- a/compiler/static/modules/Reader.mimsa +++ /dev/null @@ -1,21 +0,0 @@ - -export type Reader r a = Reader (r -> a) - -export def run reader r = - let (Reader ra) = reader in (ra r) - -export def ask = Reader (Prelude.id) - -export def local envF reader = - Reader (\r -> run reader (envF r)) - -export def ap readerF readerA = - let (Reader rToF) = readerF; - let (Reader rToA) = readerA; - (Reader (\r -> rToF r (rToA r))) - -export def monoid innerM = - { mappend: \rA -> \rB -> Reader (\r -> innerM.append (run rA r) (run rB r)), - mempty: Reader (\r -> innerM.empty) - } - diff --git a/compiler/static/modules/State.mimsa b/compiler/static/modules/State.mimsa deleted file mode 100644 index 8da4cd0b..00000000 --- a/compiler/static/modules/State.mimsa +++ /dev/null @@ -1,28 +0,0 @@ -export type State s a = State (s -> (a, s)) - -export def get = State (\s -> (s, s)) - -export def put s = - State (Prelude.const (Prelude.Unit, s)) - -export def pure a = State (\s -> (a, s)) - -export def fmap (f: a -> b) (state: State s a): State s b = - match state with (State sas) -> - State (\s -> - match sas s with (a, s) -> (f a, s) - ) - -export def ap (stateF: State s (a -> b)) (stateA: State s a): State s b = - State (\s -> match stateF with (State sfs) -> let fs = sfs s; match fs with (f, ss) -> match stateA with (State sas) -> let as = sas ss; match as with (a, sss) -> (f a, sss)) - -export def bind f state = State (\s -> match state with (State sas) -> match (sas s) with (a, ss) -> match f a with (State sbs) -> sbs ss) - -export def run state s = match state with (State sas) -> sas s - -export def exec state = Prelude.compose Prelude.snd (run state) - -export def eval state = Prelude.compose Prelude.fst (run state) - -export def liftA2 f stateA stateB = ap (fmap f stateA) stateB - diff --git a/compiler/static/modules/String.mimsa b/compiler/static/modules/String.mimsa deleted file mode 100644 index e14eec06..00000000 --- a/compiler/static/modules/String.mimsa +++ /dev/null @@ -1,18 +0,0 @@ -export def reduce = - let stringReduce = \f -> \default -> \str -> match str with "" -> default | head ++ tail -> stringReduce f (f default head) tail; stringReduce - -export def fmap f = - reduce (\total -> \a -> total ++ f a) "" - -export def filter pred = - reduce (\all -> \a -> if pred a then all ++ a else all) "" - -export def split char str = - Array.reverse (reduce (\as -> \a -> if (a == char) then [ "" ] <> as else match as with [] -> [] | [current, ...rest] -> [ current ++ a ] <> rest) [""] str) - -def mempty = "" - -def mappend a b = a ++ b - -export def monoid = { mempty, mappend } - diff --git a/compiler/static/modules/These.mimsa b/compiler/static/modules/These.mimsa deleted file mode 100644 index 1d0edc20..00000000 --- a/compiler/static/modules/These.mimsa +++ /dev/null @@ -1,2 +0,0 @@ -export type These a b = This a | That b | These a b - diff --git a/compiler/static/modules/Tree.mimsa b/compiler/static/modules/Tree.mimsa deleted file mode 100644 index 5a61ee1f..00000000 --- a/compiler/static/modules/Tree.mimsa +++ /dev/null @@ -1,16 +0,0 @@ -export type Tree a = Branch (Tree a) a (Tree a) | Leaf a - -export def fmap f = - let map innerTree = - match innerTree with - (Branch left a right) -> Branch (map left) (f a) (map right) - | (Leaf a) -> Leaf (f a) - in map - -export def invert = - let invertTree innerTree = - match innerTree with - (Branch left a right) -> Branch (invertTree right) a (invertTree left) - | (Leaf a) -> Leaf a - in invertTree - diff --git a/compiler/static/test/failing-test.ts b/compiler/static/test/failing-test.ts deleted file mode 100644 index d4055c23..00000000 --- a/compiler/static/test/failing-test.ts +++ /dev/null @@ -1,8 +0,0 @@ -// this file should not typecheck -type Horse = { - horseName: string -} - -const a: Horse = { horseName: 100 } - -console.log('i am a test') diff --git a/compiler/static/test/test.js b/compiler/static/test/test.js deleted file mode 100644 index 496a8d3d..00000000 --- a/compiler/static/test/test.js +++ /dev/null @@ -1 +0,0 @@ -console.log('i am a test') diff --git a/compiler/static/test/test.ts b/compiler/static/test/test.ts deleted file mode 100644 index adc90b25..00000000 --- a/compiler/static/test/test.ts +++ /dev/null @@ -1,5 +0,0 @@ -type Horse = { - horseName: string -} - -console.log('i am a test') diff --git a/compiler/test/Spec.hs b/compiler/test/Spec.hs deleted file mode 100644 index 62d8be38..00000000 --- a/compiler/test/Spec.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Main - ( main, - ) -where - -import qualified Test.Actions.BindModule -import qualified Test.Actions.Build -import qualified Test.Actions.Compile -import qualified Test.Actions.Evaluate -import qualified Test.Backend.ESModulesJSEndToEnd -import qualified Test.Backend.RunNode -import qualified Test.Backend.TypescriptEndToEnd -import qualified Test.Backend.Wasm -import Test.Hspec -import qualified Test.Modules.Check -import qualified Test.Modules.Repl -import qualified Test.Modules.Test -import qualified Test.Modules.ToStoreExprs -import qualified Test.Modules.Uses -import qualified Test.Project.NormaliseType -import qualified Test.Project.SourceSpan -import qualified Test.Project.Stdlib -import qualified Test.RenderErrors -import qualified Test.Serialisation -import qualified Test.Tests.Properties -import qualified Test.Transform.BetaReduce -import qualified Test.Transform.EtaReduce -import qualified Test.Transform.FindUnused -import qualified Test.Transform.FindUses -import qualified Test.Transform.FlattenLets -import qualified Test.Transform.FloatDown -import qualified Test.Transform.FloatUp -import qualified Test.Transform.Inliner -import qualified Test.Transform.SimplifyPatterns -import qualified Test.Typechecker.DataTypes -import qualified Test.Typechecker.Elaborate -import qualified Test.Typechecker.Exhaustiveness -import qualified Test.Typechecker.NumberVars -import qualified Test.Typechecker.ScopeTypeVar -import qualified Test.Typechecker.Substitutions -import qualified Test.Typechecker.Typecheck -import qualified Test.Typechecker.Unify - -main :: IO () -main = - hspec $ do - Test.Actions.BindModule.spec - Test.Actions.Build.spec - Test.Actions.Compile.spec - Test.Actions.Evaluate.spec - Test.Backend.ESModulesJSEndToEnd.spec - Test.Backend.RunNode.spec - Test.Backend.TypescriptEndToEnd.spec - Test.Backend.Wasm.spec - Test.Modules.Check.spec - Test.Modules.Repl.spec - Test.Modules.Test.spec - Test.Modules.ToStoreExprs.spec - Test.Modules.Uses.spec - Test.Project.NormaliseType.spec - Test.Project.SourceSpan.spec - Test.Project.Stdlib.spec - Test.RenderErrors.spec - Test.Serialisation.spec - Test.Tests.Properties.spec - Test.Transform.BetaReduce.spec - Test.Transform.EtaReduce.spec - Test.Transform.FindUnused.spec - Test.Transform.FindUses.spec - Test.Transform.FlattenLets.spec - Test.Transform.FloatDown.spec - Test.Transform.FloatUp.spec - Test.Transform.Inliner.spec - Test.Transform.SimplifyPatterns.spec - Test.Typechecker.DataTypes.spec - Test.Typechecker.Elaborate.spec - Test.Typechecker.Exhaustiveness.spec - Test.Typechecker.NumberVars.spec - Test.Typechecker.ScopeTypeVar.spec - Test.Typechecker.Substitutions.spec - Test.Typechecker.Typecheck.spec - Test.Typechecker.Unify.spec diff --git a/compiler/test/Test/Actions/BindModule.hs b/compiler/test/Test/Actions/BindModule.hs deleted file mode 100644 index da346c48..00000000 --- a/compiler/test/Test/Actions/BindModule.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Actions.BindModule - ( spec, - ) -where - -import Data.Either (isLeft, isRight) -import qualified Data.Set as S -import qualified Language.Mimsa.Actions.Modules.Bind as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Types.Project -import Test.Data.Prelude -import Test.Data.Project -import Test.Hspec -import Test.Utils.Helpers - -newModules :: Project ann -> Project ann -> Int -newModules old new = - let countModules = length . prjModuleStore - in countModules new - countModules old - -spec :: Spec -spec = do - describe "BindModule" $ do - describe "addBindingToModule" $ do - it "Adds a new function to Prelude that does not typecheck" $ do - let action = do - (_hash, mod') <- Actions.bindModule prelude "Prelude" (prettyPrint prelude) - let input = "def idTrue = fst True" - modItem = unsafeParseModuleItem input - Actions.addBindingToModule mempty mod' modItem - Actions.run testStdlib action `shouldSatisfy` isLeft - - it "Adds a new function to Prelude that is good typecheck" $ do - let action = do - (_hash, mod') <- Actions.bindModule prelude "Prelude" (prettyPrint prelude) - let input = "def useId = fst (True, 1)" - modItem = unsafeParseModuleItem input - (newModule, _) <- Actions.addBindingToModule mempty mod' modItem - Actions.bindModule (getAnnotationForType <$> newModule) "Repl" (prettyPrint newModule) - let (newProject, _outcomes, _) = fromRight $ Actions.run testStdlib action - newModules testStdlib newProject - `shouldBe` 2 - - it "Adds a new function to a new module that uses the Prelude" $ do - let action = do - -- add the Prelude - (preludeHash', _mod') <- Actions.bindModule prelude "Prelude" (prettyPrint prelude) - -- import Prelude - let importExpr = unsafeParseModuleItem $ "import MyPrelude from " <> prettyPrint preludeHash' - (mod2, _) <- Actions.addBindingToModule mempty mempty importExpr - -- use Prelude - let expr = unsafeParseModuleItem "def useFst = MyPrelude.fst (1,2)" - (mod3, _) <- Actions.addBindingToModule mempty mod2 expr - -- store the updated thing - Actions.bindModule (getAnnotationForType <$> mod3) "Repl" (prettyPrint mod3) - let (newProject, _outcomes, _) = fromRight $ Actions.run testStdlib action - -- we've added two modules here - newModules testStdlib newProject - `shouldBe` 2 - - describe "bindModule" $ do - it "Adds a fresh new module to prjModules and to Store" $ do - case Actions.run testStdlib (Actions.bindModule prelude "Prelude" (prettyPrint prelude)) of - Left _ -> expectationFailure "Should not have failed" - Right (newProject, outcomes, _) -> do - -- one more item in module store - newModules testStdlib newProject - `shouldBe` 1 - -- one more binding - lookupModuleName - newProject - "Prelude" - `shouldSatisfy` isRight - -- one new store expression - S.size (Actions.modulesFromOutcomes outcomes) - `shouldBe` 1 diff --git a/compiler/test/Test/Actions/Build.hs b/compiler/test/Test/Actions/Build.hs deleted file mode 100644 index f9954a68..00000000 --- a/compiler/test/Test/Actions/Build.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Actions.Build - ( spec, - ) -where - -import Control.Monad.IO.Class -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Helpers.Build as Actions -import Test.Hspec - -job :: Actions.Job IO Int Text [Text] -job deps input = - pure ([input] <> mconcat (M.elems deps)) - -spec :: Spec -spec = do - describe "Build" $ do - it "Empty state is a no-op" $ do - let state = Actions.State mempty mempty - newState <- liftIO $ Actions.doJobs job state - newState `shouldBe` state - it "Run job on single item" $ do - let inputs = M.singleton 1 (Actions.Plan mempty "Hello") - let state = Actions.State inputs mempty - newState <- liftIO $ Actions.doJobs job state - let expectedOutputs = M.singleton 1 ["Hello"] - Actions.stOutputs newState `shouldBe` expectedOutputs - it "Run job with a dep" $ do - let inputs = - M.fromList - [ (1, Actions.Plan mempty "Hello"), - (2, Actions.Plan (S.singleton 1) "Egg"), - (3, Actions.Plan (S.singleton 1) "Horse"), - (4, Actions.Plan (S.fromList [1, 3]) "Dog") - ] - let state = Actions.State inputs mempty - let run = Actions.doJobs job - newState <- liftIO $ run state - let expectedOutputs = - M.fromList - [ (1, ["Hello"]), - (2, ["Egg", "Hello"]), - (3, ["Horse", "Hello"]), - (4, ["Dog", "Hello", "Horse", "Hello"]) - ] - Actions.stOutputs newState `shouldBe` expectedOutputs - it "If all work is done, just return it" $ do - let inputs = - M.fromList - [ (1, Actions.Plan mempty "Hello"), - (2, Actions.Plan (S.singleton 1) "Egg"), - (3, Actions.Plan (S.singleton 1) "Horse") - ] - let outputs = - M.fromList - [ (1, ["Hello!"]), - (2, ["Egg!", "Hello!"]), - (3, ["Horse!", "Hello!"]) - ] - let state = Actions.State inputs outputs - let run = Actions.doJobs job - newState <- liftIO $ run state - Actions.stOutputs newState `shouldBe` outputs - it "If outputs already exist, uses them instead of calculating" $ do - let inputs = - M.fromList - [ (1, Actions.Plan mempty "Hello"), - (2, Actions.Plan (S.singleton 1) "Egg"), - (3, Actions.Plan (S.singleton 1) "Horse"), - (4, Actions.Plan (S.fromList [1, 3]) "Dog") - ] - let outputs = - M.fromList - [ (1, ["Hello!"]), - (2, ["Egg!", "Hello!"]), - (3, ["Horse!", "Hello!"]) - ] - let state = Actions.State inputs outputs - let run = Actions.doJobs job - newState <- liftIO $ run state - let expectedOutputs = - outputs - <> M.fromList - [ (4, ["Dog", "Hello!", "Horse!", "Hello!"]) - ] - Actions.stOutputs newState `shouldBe` expectedOutputs - it "Detects missing deps" $ do - let inputs = - M.fromList - [ ( 1, - Actions.Plan (S.singleton (100 :: Int)) ("100 doesn't exist" :: String) - ), - (2, Actions.Plan (S.fromList [101, 1]) "101 doesn't exist either") - ] - outputs = mempty - state = Actions.State inputs outputs - Actions.getMissing state `shouldBe` S.fromList [100, 101] diff --git a/compiler/test/Test/Actions/Compile.hs b/compiler/test/Test/Actions/Compile.hs deleted file mode 100644 index 6daaf745..00000000 --- a/compiler/test/Test/Actions/Compile.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Actions.Compile - ( spec, - ) -where - -import Data.Either (isRight) -import Data.Foldable -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Compile as Actions -import qualified Language.Mimsa.Actions.Helpers.LookupExpression as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Project -import Test.Hspec - -spec :: Spec -spec = do - describe "Compile" $ do - it "Compiles entire project" $ do - let action = do - _ <- Actions.compileProject Typescript - pure () - Actions.run stdlib action `shouldSatisfy` isRight - - describe "Can compile each top-level module" $ do - let compileModule (modName, modHash) = - it ("Compiles module " <> T.unpack (prettyPrint modName) <> " from stdlib") $ do - let action = - Actions.lookupModule modHash - >>= Actions.compileModule Typescript - Actions.run stdlib action - `shouldSatisfy` isRight - let moduleNames = M.toList . getCurrentModules . prjModules $ stdlib - in traverse_ compileModule moduleNames diff --git a/compiler/test/Test/Actions/Evaluate.hs b/compiler/test/Test/Actions/Evaluate.hs deleted file mode 100644 index 9339755b..00000000 --- a/compiler/test/Test/Actions/Evaluate.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Actions.Evaluate - ( spec, - ) -where - -import Data.Either (isRight) -import qualified Language.Mimsa.Actions.Modules.Bind as Actions -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Test.Data.Project -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "Evaluate" $ do - it "Should use the passed in module as context" $ do - let action = do - -- add a definition to an empty module - let expr = unsafeParseModuleItem "def dog = True" - (newMod, _) <- Actions.addBindingToModule mempty mempty expr - -- evaluate using that module - Actions.evaluateModule (unsafeParseExpr' "dog") (getAnnotationForType <$> newMod) - Actions.run testStdlib action `shouldSatisfy` isRight diff --git a/compiler/test/Test/Backend/ESModulesJSEndToEnd.hs b/compiler/test/Test/Backend/ESModulesJSEndToEnd.hs deleted file mode 100644 index f63527a1..00000000 --- a/compiler/test/Test/Backend/ESModulesJSEndToEnd.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.ESModulesJSEndToEnd - ( spec, - ) -where - --- these are the backend tests that invoke the whole idea of a project - -import Control.Monad.Except -import Data.Bifunctor -import Data.Foldable -import Data.Functor -import Data.Hashable -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Backend.Javascript.Printer as JS -import Language.Mimsa.Backend.Types -import Language.Mimsa.Backend.Typescript.FromExpr -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Test.Backend.RunNode hiding (spec) -import Test.Data.Project -import Test.Hspec -import Test.Utils.Compilation -import Test.Utils.Helpers -import Test.Utils.Serialisation - -testFromInputText :: Text -> Either Text Text -testFromInputText input = - case evaluateText testStdlib input of - Left e -> throwError (prettyPrint e) - Right typedExpr -> do - let readerState = TSReaderState mempty mempty - startState = TSCodegenState mempty mempty mempty - first prettyPrint (JS.printModule . fst <$> fromExpr readerState startState typedExpr) - --- test that we have a valid ESModulesJS module by saving it and running it -testESModulesJSInNode :: Text -> IO String -testESModulesJSInNode ts = do - -- write file - tsPath <- createOutputFolder "ESModulesJS" - let tsFilename = tsPath <> show (hash ts) <> ".mjs" - -- cache output - cachePath <- createOutputFolder "ESModulesJS-result" - let cacheFilename = cachePath <> show (hash ts) <> ".json" - -- create output - let tsOutput = ts <> "\nconsole.log(main)" - writeFile tsFilename (T.unpack tsOutput) - (ec, err) <- withCache cacheFilename (runScriptFromFile tsFilename) - if ec then pure err else fail err - --- test that we have a valid ESModulesJS module by saving it and running it -testESModulesJSFileInNode :: FilePath -> IO String -testESModulesJSFileInNode tsFilename = do - -- create output - (ec, err) <- runScriptFromFile tsFilename - if ec then pure err else fail err - -testIt :: (Text, Text, String) -> Spec -testIt (expr, expectedTS, expectedValue) = - it (T.unpack expr) $ do - case testFromInputText expr of - Left e -> fail (T.unpack e) - Right ts -> do - ts `shouldBe` expectedTS - val <- testESModulesJSInNode ts - val `shouldBe` expectedValue - -fullTestIt :: (Text, String) -> Spec -fullTestIt (input, expectedValue) = - it (T.unpack input) $ do - let unsafeParse = ($> mempty) . unsafeParseExpr - expr = unsafeParse input - (filename, contentHash) <- testProjectCompile "CompileJSProject" ESModulesJS expr - cachePath <- createOutputFolder "CompileJSProject-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - - result <- withCache cacheFilename (testESModulesJSFileInNode filename) - result `shouldBe` expectedValue - -testModule :: (Text, String) -> Spec -testModule (input, expectedValue) = - it (T.unpack input) $ do - (filename, contentHash) <- testModuleCompile "CompileJSModuleProject" ESModulesJS input - cachePath <- createOutputFolder "CompileJSModuleProject-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - - result <- withCache cacheFilename (testESModulesJSFileInNode filename) - result `shouldBe` expectedValue - --- | input, output ejs, nodeJS output -testCases :: [(Text, Text, String)] -testCases = - [ ("True", "export const main = true", "true"), - ("False", "export const main = false", "false"), - ("123", "export const main = 123", "123"), - ("\"Poo\"", "export const main = `Poo`", "Poo"), - ( "\\a -> a", - "export const main = (a) => a", - "[Function: main]" - ), - ( "if True then 1 else 2", - "export const main = true ? 1 : 2", - "1" - ), - ( "let a = \"dog\" in 123", - "const a = `dog`; export const main = 123", - "123" - ), - ( "let a = \"dog\" in let b = \"horse\" in 123", - "const a = `dog`; \nconst b = `horse`; export const main = 123", - "123" - ), - ( "{ a: 123, b: \"horse\" }", - "export const main = { a: 123, b: `horse` }", - "{ a: 123, b: 'horse' }" - ), - ( "\\a -> let b = 123 in a", - "export const main = (a) => { const b = 123; return a; }", - "[Function: main]" - ), - ("(1,2)", "export const main = [1,2]", "[ 1, 2 ]"), - ("2 + 2", "export const main = 2 + 2", "4"), - ("10 - 2", "export const main = 10 - 2", "8"), - ( "\"dog\" ++ \"log\"", - "export const main = `dog` + `log`", - "doglog" - ), - ( "{ fn: (\\a -> let d = 1 in a) }", - "export const main = { fn: (a) => { const d = 1; return a; } }", - "{ fn: [Function: fn] }" - ), - ( "[1,2] <> [3,4]", - "export const main = [...[1,2],...[3,4]]", - "[ 1, 2, 3, 4 ]" - ), - ( "let (a, b) = (1,2) in a", - "const [a,b] = [1,2]; export const main = a", - "1" - ), - ( "let { dog: a, cat: b } = { dog: 1, cat: 2} in (a,b)", - "const { cat: b, dog: a } = { cat: 2, dog: 1 }; export const main = [a,b]", - "[ 1, 2 ]" - ) - ] - --- | input, nodeJS output -fullTestCases :: [(Text, String)] -fullTestCases = - [ ("True", "true"), - ("False", "false"), - ("123", "123"), - ("\"Poo\"", "Poo"), - ("let id a = a; id", "[Function: main]"), - ( "\\a -> a", - "[Function: main]" - ), - ( "let id a = a; id 1", - "1" - ), - ( "if True then 1 else 2", - "1" - ), - ( "let a = \"dog\" in 123", - "123" - ), - ( "let a = \"dog\" in let b = \"horse\" in 123", - "123" - ), - ( "{ a: 123, b: \"horse\" }", - "{ a: 123, b: 'horse' }" - ), - ( "let aPair = (1,2); let (a,b) = aPair in a", - "1" - ), - ( "\\a -> let b = 123 in a", - "[Function: main]" - ), - ("(1,2)", "[ 1, 2 ]"), - ("let aRecord = { a: 1 }; aRecord.a", "1"), - ( "Maybe.Just", - "[Function: Just]" - ), - ( "Maybe.Just 1", - "{ type: 'Just', vars: [ 1 ] }" - ), - ( "Maybe.Nothing", - "{ type: 'Nothing', vars: [] }" - ), - ( "These.These", - "[Function: These]" - ), - ("True == True", "true"), - ("2 + 2", "4"), - ("10 - 2", "8"), - ( "\"dog\" ++ \"log\"", - "doglog" - ), - ( "{ fn: (\\a -> let d = 1 in a) }", - "{ fn: [Function: fn] }" - ), - ( "[1,2] <> [3,4]", - "[ 1, 2, 3, 4 ]" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> a | _ -> False", - "true" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> Maybe.Just a | _ -> Maybe.Nothing", - "{ type: 'Just', vars: [ true ] }" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> let b = 1; Maybe.Just a | _ -> Maybe.Nothing", - "{ type: 'Just', vars: [ true ] }" - ), - ( "let (a, b) = (1,2) in a", - "1" - ), - ( "let { dog: a, cat: b } = { dog: 1, cat: 2} in (a,b)", - "[ 1, 2 ]" - ), - ("let str = \"hey\" in match (Maybe.Just str) with (Maybe.Just a) -> a | _ -> \"\"", "hey"), - ("\"hello world\"", "hello world"), - ("let id a = a; id \"hello again\"", "hello again"), - ( "Either.Right 101", - "{ type: 'Right', vars: [ 101 ] }" - ), - ("let const = True; 1", "1"), - ("2 > 1", "true"), - ("1 > 2", "false"), - ("1 >= 1", "true"), - ("0 >= 1", "false"), - ("1 < 2", "true"), - ("2 < 1", "false"), - ("2 <= 2", "true"), - ("3 <= 2", "false"), - ("\"\nHello\n\"", "\nHello\n") - ] - -spec :: Spec -spec = do - describe "ESModulesJS" $ do - describe "from parsed input" $ do - traverse_ testIt testCases - - it "simple expression" $ do - testFromInputText "\\a -> a + 100" - `shouldBe` Right "export const main = (a) => a + 100" - - it "pattern matching array spreads" $ do - testFromInputText "\\a -> match a with [a1,...as] -> [as] | [] -> []" - `shouldBe` Right "export const main = (a) => { const match = (value) => { if (value.length >= 1) { const [a1,...as] = value; return [as]; }; if (value.length === 0) { return []; }; throw new Error(\"Pattern match error\"); }; return match(a); }" - - describe "Entire compilation" $ do - traverse_ fullTestIt fullTestCases - - describe "Compile `main` function from modules and run them in Node" $ do - let moduleTestCases = - [ ( joinLines - [ "export def main = 1 + 2" - ], - "3" - ), - ( joinLines - [ "def adding a b = a + b", - "infix +++ = adding", - "export def main = 1 +++ 2" - ], - "3" - ), - ( joinLines - [ "export type Identity a = Identity a", - "def runIdentity a = let (Identity inner) = a in inner", - "export def main = runIdentity (Identity True)" - ], - "true" - ), - ( joinLines - [ "export type Either e a = Left e | Right a", - "def useEither val = match val with Right a -> a | _ -> False", - "def shouldHaveEitherAsDep val = useEither val", - "export def main = shouldHaveEitherAsDep (Right True)" - ], - "true" - ) - ] - in traverse_ testModule moduleTestCases - - -- Unique variable errors here, maybe more than we want to chew off rn? - describe "Compile and open entire project" $ do - xit "Compiles entire project" $ do - (filename, contentHash) <- testWholeProjectCompile "CompileJSProjectWhole" stdlib ESModulesJS - cachePath <- createOutputFolder "CompileJSProjectWhole-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - - result <- withCache cacheFilename (testESModulesJSFileInNode filename) - result `shouldSatisfy` const True diff --git a/compiler/test/Test/Backend/RunNode.hs b/compiler/test/Test/Backend/RunNode.hs deleted file mode 100644 index e7665f3c..00000000 --- a/compiler/test/Test/Backend/RunNode.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.RunNode - ( spec, - runScriptFromFile, - runTypescriptFromFile, - lbsToString, - withCache, - ) -where - -import Control.Exception -import Control.Monad.IO.Class -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import System.Exit -import System.Process.Typed -import Test.Hspec - -runProcessFromFile :: (MonadIO m) => String -> [String] -> String -> m (Bool, String) -runProcessFromFile binaryName args filename = do - let allArgs = args <> [filename] - result <- liftIO $ try $ readProcess (proc binaryName allArgs) - case result of - Right (ExitSuccess, success, _) -> - pure (exitCodeToBool ExitSuccess, binNewline success) - Right (ExitFailure exitCode, _, failure) -> - pure (exitCodeToBool (ExitFailure exitCode), binNewline failure) - Left e -> pure (False, show (e :: IOException)) - --- | Pass a filepath to a JS file for Node to execute. --- Required as ES modules don't work with the `-p` flag -runScriptFromFile :: (MonadIO m) => String -> m (Bool, String) -runScriptFromFile = runProcessFromFile "node" [] - --- | Pass a filepath to a TS file for `ts-node` to execute. -runTypescriptFromFile :: (MonadIO m) => String -> m (Bool, String) -runTypescriptFromFile = - runProcessFromFile - "ts-node" - [ "--compiler-options={\"lib\":[\"dom\",\"dom.iterable\",\"es6\"],\"module\":\"commonjs\"}" - ] - -exitCodeToBool :: ExitCode -> Bool -exitCodeToBool ExitSuccess = True -exitCodeToBool _ = False - -cacheResult :: (MonadIO m, JSON.ToJSON a) => String -> a -> m () -cacheResult filename result = do - let json = JSON.encode result - liftIO $ LBS.writeFile filename json - --- load previously -loadCacheResult :: (MonadIO m, JSON.FromJSON a) => String -> m (Maybe a) -loadCacheResult filename = do - res <- liftIO $ try $ LBS.readFile filename - case (res :: Either IOError LBS.ByteString) of - Right json -> do - pure $ JSON.decode json - Left _ -> pure Nothing - --- | Wrap a test in caching -withCache :: - (MonadIO m, JSON.FromJSON a, JSON.ToJSON a) => - String -> - m a -> - m a -withCache cachePath action = do - cached <- loadCacheResult cachePath - case cached of - Just res -> pure res - Nothing -> do - res <- action - cacheResult cachePath res - pure res - -lbsToString :: LBS.ByteString -> String -lbsToString = T.unpack . decodeUtf8 . LBS.toStrict - -binNewline :: LBS.ByteString -> String -binNewline = init . lbsToString - --- | this test is very slow, only switch on when checking node tests work in --- local environment -spec :: Spec -spec = do - describe "RunNode" $ do - describe "runScriptFromFile" $ do - it "Succeeds with printed value" $ do - (ec, bs) <- runScriptFromFile "compiler/static/test/test.js" - ec `shouldBe` True - bs `shouldBe` "i am a test" - - describe "runTypescriptFromFile" $ do - it "Succeeds with printed value" $ do - (ec, bs) <- runTypescriptFromFile "compiler/static/test/test.ts" - ec `shouldBe` True - bs `shouldBe` "i am a test" - - it "Fails with badly-typed file" $ do - (ec, _) <- runTypescriptFromFile "compiler/static/test/failing-test.ts" - ec `shouldBe` False diff --git a/compiler/test/Test/Backend/TypescriptEndToEnd.hs b/compiler/test/Test/Backend/TypescriptEndToEnd.hs deleted file mode 100644 index 03360f38..00000000 --- a/compiler/test/Test/Backend/TypescriptEndToEnd.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.TypescriptEndToEnd - ( spec, - ) -where - --- these are the backend tests that invoke the whole idea of a project - -import Control.Monad.Except -import Data.Bifunctor -import Data.Foldable -import Data.Functor -import Data.Hashable -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Backend.Types -import Language.Mimsa.Backend.Typescript.FromExpr -import Language.Mimsa.Backend.Typescript.Monad -import Language.Mimsa.Backend.Typescript.Printer -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Test.Backend.RunNode hiding (spec) -import Test.Hspec -import Test.Utils.Compilation -import Test.Utils.Helpers -import Test.Utils.Serialisation - -testFromInputText :: Text -> Either Text Text -testFromInputText input = - case evaluateText stdlib input of - Left e -> throwError (prettyPrint e) - Right typedExpr -> do - let readerState = TSReaderState mempty mempty - startState = TSCodegenState mempty mempty mempty - first - prettyPrint - (printModule . fst <$> fromExpr readerState startState typedExpr) - --- test that we have a valid Typescript module by saving it and running it -testTypescriptInNode :: Text -> IO String -testTypescriptInNode ts = do - -- write file - tsPath <- createOutputFolder "Typescript" - let tsFilename = tsPath <> show (hash ts) <> ".ts" - -- cache output - cachePath <- createOutputFolder "Typescript-result" - let cacheFilename = cachePath <> show (hash ts) <> ".json" - -- create output - let tsOutput = ts <> "\nconsole.log(main)" - writeFile tsFilename (T.unpack tsOutput) - (ec, err) <- withCache cacheFilename (runTypescriptFromFile tsFilename) - if ec then pure err else fail err - --- test that we have a valid Typescript module by saving it and running it -testTypescriptFileInNode :: FilePath -> IO String -testTypescriptFileInNode tsFilename = do - -- create output - (ec, err) <- runTypescriptFromFile tsFilename - if ec then pure err else fail err - -testIt :: (Text, Text, String) -> Spec -testIt (expr, expectedTS, expectedValue) = - it (T.unpack expr) $ do - case testFromInputText expr of - Left e -> fail (T.unpack e) - Right ts -> do - ts `shouldBe` expectedTS - val <- testTypescriptInNode ts - val `shouldBe` expectedValue - -fullTestIt :: (Text, String) -> Spec -fullTestIt (input, expectedValue) = - it (T.unpack input) $ do - let unsafeParse = ($> mempty) . unsafeParseExpr - expr = unsafeParse input - (filename, contentHash) <- testProjectCompile "CompileTSProject" Typescript expr - cachePath <- createOutputFolder "CompileTSProject-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - - result <- withCache cacheFilename (testTypescriptFileInNode filename) - result `shouldBe` expectedValue - -testModule :: (Text, String) -> Spec -testModule (input, expectedValue) = - it (T.unpack input) $ do - (filename, contentHash) <- testModuleCompile "CompileTSModuleProject" Typescript input - cachePath <- createOutputFolder "CompileTSModuleProject-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - print filename - result <- withCache cacheFilename (testTypescriptFileInNode filename) - result `shouldBe` expectedValue - --- | input, output TS, nodeJS output -testCases :: [(Text, Text, String)] -testCases = - [ ("True", "export const main = true", "true"), - ("False", "export const main = false", "false"), - ("123", "export const main = 123", "123"), - ("\"Poo\"", "export const main = `Poo`", "Poo"), - ( "if True then 1 else 2", - "export const main = true ? 1 : 2", - "1" - ), - ( "let a = \"dog\" in 123", - "const a = `dog`; export const main = 123", - "123" - ), - ( "let a = \"dog\" in let b = \"horse\" in 123", - "const a = `dog`; \nconst b = `horse`; export const main = 123", - "123" - ), - ( "{ a: 123, b: \"horse\" }", - "export const main = { a: 123, b: `horse` }", - "{ a: 123, b: 'horse' }" - ), - ("(1,2)", "export const main = [1,2] as const", "[ 1, 2 ]"), - ("\\a -> let (b,c) = a in b", "export const main = (a: readonly [C,D]) => { const [b,c] = a; return b; }", "[Function: main]"), - ("2 + 2", "export const main = 2 + 2", "4"), - ("10 - 2", "export const main = 10 - 2", "8"), - ( "\"dog\" ++ \"log\"", - "export const main = `dog` + `log`", - "doglog" - ), - ( "{ fun: (\\a -> let d = 1 in a) }", - "export const main = { fun: (a: B) => { const d = 1; return a; } }", - "{ fun: [Function: fun] }" - ), - ( "[1,2] <> [3,4]", - "export const main = [...[1,2],...[3,4]]", - "[ 1, 2, 3, 4 ]" - ), - ( "let (a, b) = (1,2) in a", - "const [a,b] = [1,2] as const; export const main = a", - "1" - ), - ( "let { dog: a, cat: b } = { dog: 1, cat: 2} in (a,b)", - "const { cat: b, dog: a } = { cat: 2, dog: 1 }; export const main = [a,b] as const", - "[ 1, 2 ]" - ) - ] - --- | input, nodeJS output -fullTestCases :: [(Text, String)] -fullTestCases = - [ ("True", "true"), - ("False", "false"), - ("123", "123"), - ("\"Poo\"", "Poo"), - ( "\\a -> a", - "[Function: main]" - ), - ( "let id a = a; id 1", - "1" - ), - ( "if True then 1 else 2", - "1" - ), - ( "let a = \"dog\" in 123", - "123" - ), - ( "let a = \"dog\" in let b = \"horse\" in 123", - "123" - ), - ( "{ a: 123, b: \"horse\" }", - "{ a: 123, b: 'horse' }" - ), - ( "let aPair = (1,2); let (a,b) = aPair in a", - "1" - ), - ( "\\a -> let b = 123 in a", - "[Function: main]" - ), - ("(1,2)", "[ 1, 2 ]"), - ( "Maybe.Just", - "[Function: Just]" - ), - ( "Maybe.Just 1", - "{ type: 'Just', vars: [ 1 ] }" - ), - ( "Maybe.Nothing", - "{ type: 'Nothing', vars: [] }" - ), - ("True == True", "true"), - ("2 + 2", "4"), - ("10 - 2", "8"), - ( "\"dog\" ++ \"log\"", - "doglog" - ), - ( "{ fn: (\\a -> let d = 1 in a) }", - "{ fn: [Function: fn] }" - ), - ( "[1,2] <> [3,4]", - "[ 1, 2, 3, 4 ]" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> a | _ -> False", - "true" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> Maybe.Just a | _ -> Maybe.Nothing", - "{ type: 'Just', vars: [ true ] }" - ), - ( "match Maybe.Just True with (Maybe.Just a) -> let b = 1; Maybe.Just a | _ -> Maybe.Nothing", - "{ type: 'Just', vars: [ true ] }" - ), - ( "let (a, b) = (1,2) in a", - "1" - ), - ( "let { dog: a, cat: b } = { dog: 1, cat: 2} in (a,b)", - "[ 1, 2 ]" - ), - ("let str = \"hey\" in match (Maybe.Just str) with (Maybe.Just a) -> a | _ -> \"\"", "hey"), - ("\"hello world\"", "hello world"), - ("Either.Right 101", "{ type: 'Right', vars: [ 101 ] }"), - ("let stringReduce a = 100 in stringReduce", "[Function: main]"), - ("let const = True; 1", "1"), - ("2 > 1", "true"), - ("1 > 2", "false"), - ("1 >= 1", "true"), - ("0 >= 1", "false"), - ("1 < 2", "true"), - ("2 < 1", "false"), - ("2 <= 2", "true"), - ("3 <= 2", "false"), - ("let and a b = if a then b else False; let a = 1; let b = 3; let c = 6; and False True", "false"), - ("\"\nHello\n\"", "\nHello\n"), - ("match Either.Right 1 with Either.Right a -> a | _ -> 0", "1") - ] - -spec :: Spec -spec = do - describe "Typescript" $ do - describe "from parsed input" $ do - traverse_ testIt testCases - - it "simple expression" $ do - testFromInputText "{ dog: \\a -> a + 100 }" - `shouldBe` Right "export const main = { dog: (a: number) => a + 100 }" - - -- what the fuck - it "pattern matching array spreads" $ do - testFromInputText "\\a -> match a with [a1,...as] -> [as] | [] -> []" - `shouldBe` Right "export const main = (a: D[]) => { const match = (value: D[]): D[][] => { if (value.length >= 1) { const [a1,...as] = value; return [as]; }; if (value.length === 0) { return []; }; throw new Error(\"Pattern match error\"); }; return match(a); }" - - describe "Entire compilation" $ do - traverse_ fullTestIt fullTestCases - - describe "Compile `main` function from modules and run them in Node" $ do - let moduleTestCases = - [ ( joinLines - [ "export def main = 1 + 2" - ], - "3" - ), - ( joinLines - [ "def adding a b = a + b", - "infix +++ = adding", - "export def main = 1 +++ 2" - ], - "3" - ), - ( joinLines - [ "export type Identity a = Identity a", - "def runIdentity a = let (Identity inner) = a in inner", - "export def main = runIdentity (Identity True)" - ], - "true" - ), - ( joinLines - [ "export type Either e a = Left e | Right a", - "def useEither val = match val with Right a -> a | _ -> False", - "def shouldHaveEitherAsDep val = useEither val", - "export def main = shouldHaveEitherAsDep (Right True)" - ], - "true" - ) - ] - in traverse_ testModule moduleTestCases - - describe "Compile and open entire project" $ do - xit "Compiles entire project" $ do - (filename, contentHash) <- testWholeProjectCompile "CompileTSProjectWhole" stdlib Typescript - cachePath <- createOutputFolder "CompileTSProjectWhole-result" - let cacheFilename = cachePath <> show contentHash <> ".json" - - result <- withCache cacheFilename (testTypescriptFileInNode filename) - result `shouldSatisfy` const True diff --git a/compiler/test/Test/Backend/Wasm.hs b/compiler/test/Test/Backend/Wasm.hs deleted file mode 100644 index 2dbdc76e..00000000 --- a/compiler/test/Test/Backend/Wasm.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Backend.Wasm - ( spec, - ) -where - -import Data.Bifunctor -import Data.Text (Text) -import Language.Mimsa.Backend.Wasm.Compile -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Typechecker.Typecheck -import qualified Language.Wasm as Wasm -import qualified Language.Wasm.Interpreter as Wasm -import Test.Hspec -import Test.Utils.Helpers - -runWasm :: Wasm.Module -> IO (Maybe [Wasm.Value]) -runWasm wasmModule = do - case Wasm.validate wasmModule of - Right validModule -> do - (result, store) <- Wasm.instantiate Wasm.emptyStore mempty validModule - case result of - Right moduleInstance -> - Wasm.invokeExport store moduleInstance "test" mempty - Left e -> error e - Left e -> do - print wasmModule - error $ "invalid module: " <> show e - -typecheck' :: - (Monoid ann) => - Expr Name Annotation -> - Expr Name (Type ann) -typecheck' expr = do - let numberedExpr = fromRight (addNumbersToStoreExpression expr mempty) - let result = - fmap (\(_, _, a, _) -> first fst a) - . typecheck mempty mempty - $ numberedExpr - (fmap . fmap) (const mempty) (fromRight result) - -wasmTest :: Text -> IO (Maybe [Wasm.Value]) -wasmTest input = - let expr = typecheck' $ unsafeParseExpr' input - in runWasm (compileRaw expr) - -spec :: Spec -spec = do - describe "Wasm" $ do - describe "Number literals" $ do - it "int literal 1" $ do - result <- wasmTest "1" - result `shouldBe` Just [Wasm.VI32 1] - it "int literal 42" $ do - result <- wasmTest "42" - result `shouldBe` Just [Wasm.VI32 42] - describe "Boolean literals" $ do - it "true" $ do - result <- wasmTest "True" - result `shouldBe` Just [Wasm.VI32 1] - it "false" $ do - result <- wasmTest "False" - result `shouldBe` Just [Wasm.VI32 0] - describe "If expression" $ do - it "true branch" $ do - result <- wasmTest "if True then 42 else 5" - result `shouldBe` Just [Wasm.VI32 42] - it "false branch" $ do - result <- wasmTest "if False then 42 else 5" - result `shouldBe` Just [Wasm.VI32 5] - it "using infix op" $ do - result <- wasmTest "if 4 == 5 then 42 else 5" - result `shouldBe` Just [Wasm.VI32 5] - describe "Infix ops" $ do - it "1 + 1 == 2" $ do - result <- wasmTest "1 + 1" - result `shouldBe` Just [Wasm.VI32 2] - it "10 - 9" $ do - result <- wasmTest "10 - 9" - result `shouldBe` Just [Wasm.VI32 1] - it "1 == 1" $ do - result <- wasmTest "1 == 1" - result `shouldBe` Just [Wasm.VI32 1] - it "1 == 2" $ do - result <- wasmTest "1 == 2" - result `shouldBe` Just [Wasm.VI32 0] - it "1 < 2" $ do - result <- wasmTest "1 < 2" - result `shouldBe` Just [Wasm.VI32 1] - it "1 > 2" $ do - result <- wasmTest "1 > 2" - result `shouldBe` Just [Wasm.VI32 0] - it "1 >= 1" $ do - result <- wasmTest "1 >= 1" - result `shouldBe` Just [Wasm.VI32 1] - it "1 <= 1" $ do - result <- wasmTest "1 <= 1" - result `shouldBe` Just [Wasm.VI32 1] - it "1 + 2 + 3 + 4 + 5" $ do - result <- wasmTest "1 + 2 + 3 + 4 + 5" - result `shouldBe` Just [Wasm.VI32 15] - describe "Function" $ do - xit "let inc = \\a -> a + 1; inc 1" $ do - result <- wasmTest "let inc = \\a -> a + 1; inc 1" - result `shouldBe` Just [Wasm.VI32 2] - describe "Variables" $ do - it "let a = 1 in a + 1" $ do - result <- wasmTest "let a = 1 in a + 1" - result `shouldBe` Just [Wasm.VI32 2] - it "let a = 1; let b = 2; a + b" $ do - result <- wasmTest "let a = 1; let b = 2; a + b" - result `shouldBe` Just [Wasm.VI32 3] - it "let a = 1; let b = 2; let c = 3; a + b - c" $ do - result <- wasmTest "let a = 1; let b = 2; let c = 3; a + b - c" - result `shouldBe` Just [Wasm.VI32 0] diff --git a/compiler/test/Test/Codegen/Shared.hs b/compiler/test/Test/Codegen/Shared.hs deleted file mode 100644 index 2fe910cb..00000000 --- a/compiler/test/Test/Codegen/Shared.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Codegen.Shared - ( unsafeParse, - dtVoid, - dtTrafficLights, - dtWrappedString, - dtIdentity, - dtMaybe, - dtEither, - dtPair, - dtMonoPair, - dtThese, - dtList, - dtDoubleList, - dtTree, - dtReader, - dtMatchedPair, - dtConsoleF, - dtEnv, - ) -where - -import Data.Functor -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Test.Utils.Helpers - --- | has no constructors, we can do nothing with this -dtVoid :: DataType -dtVoid = DataType "Void" mempty mempty - --- | an enum, we can go to and from a string -dtTrafficLights :: DataType -dtTrafficLights = - DataType - "TrafficLights" - mempty - ( M.fromList - [ ("Red", mempty), - ("Yellow", mempty), - ("Green", mempty) - ] - ) - --- | A newtype around a string --- | we can wrap and unwrap maybe? -dtWrappedString :: DataType -dtWrappedString = - DataType - "WrappedString" - mempty - (M.singleton "Wrapped" [dataTypeWithVars mempty Nothing "String" mempty]) - --- | Identity monad -dtIdentity :: DataType -dtIdentity = - DataType - "Identity" - ["a"] - (M.singleton "Identity" [MTVar mempty (tvNamed "a")]) - --- | Maybe monad -dtMaybe :: DataType -dtMaybe = - DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [MTVar mempty (tvNamed "a")]), - ("Nothing", []) - ] - ) - --- | Either monad -dtEither :: DataType -dtEither = - DataType - "Either" - ["e", "a"] - ( M.fromList - [ ("Right", [MTVar mempty (tvNamed "a")]), - ("Left", [MTVar mempty (tvNamed "e")]) - ] - ) - --- | These monad -dtThese :: DataType -dtThese = - DataType - "These" - ["a", "b"] - ( M.fromList - [ ("This", [MTVar mempty (tvNamed "a")]), - ("That", [MTVar mempty (tvNamed "b")]), - ( "These", - [ MTVar mempty (tvNamed "a"), - MTVar - mempty - (tvNamed "b") - ] - ) - ] - ) - --- | List monad -dtList :: DataType -dtList = - DataType - "List" - ["a"] - ( M.fromList - [ ( "Cons", - [ MTVar mempty (tvNamed "a"), - dataTypeWithVars mempty Nothing "List" [MTVar mempty (tvNamed "a")] - ] - ), - ("Nil", []) - ] - ) - --- | List but with more type params so we can recurse around more complicated --- types -dtDoubleList :: DataType -dtDoubleList = - DataType - "DoubleList" - ["a", "b"] - ( M.fromList - [ ( "DoubleCons", - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b"), - dataTypeWithVars - mempty - Nothing - "DoubleList" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b") - ] - ] - ), - ("DoubleNil", []) - ] - ) - -dtTree :: DataType -dtTree = - DataType - "Tree" - ["a"] - ( M.fromList - [ ("Leaf", [MTVar mempty (tvNamed "a")]), - ( "Branch", - [ dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")], - dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")] - ] - ) - ] - ) - -dtReader :: DataType -dtReader = - DataType - "Reader" - ["r", "a"] - ( M.singleton - "Reader" - [ MTFunction - mempty - (MTVar mempty (tvNamed "r")) - (MTVar mempty (tvNamed "a")) - ] - ) - -dtMatchedPair :: DataType -dtMatchedPair = - DataType - "MatchedPair" - ["a"] - ( M.singleton - "MatchedPair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "a") - ] - ) - -dtConsoleF :: DataType -dtConsoleF = - DataType - "ConsoleF" - ["next"] - ( M.fromList - [ ( "Write", - [ dataTypeWithVars mempty Nothing "String" [], - MTVar mempty (tvNamed "next") - ] - ), - ( "Read", - [ MTFunction - mempty - (dataTypeWithVars mempty Nothing "String" []) - (MTVar mempty (tvNamed "next")) - ] - ) - ] - ) - -dtPair :: DataType -dtPair = - DataType - "Pair" - ["a", "b"] - ( M.singleton - "Pair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b") - ] - ) - -dtMonoPair :: DataType -dtMonoPair = - DataType - "MonoPair" - ["a"] - ( M.singleton - "MonoPair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "a") - ] - ) - -dtEnv :: DataType -dtEnv = - DataType - "Env" - ["w", "a"] - ( M.singleton - "Env" - [ MTVar mempty (tvNamed "w"), - MTVar mempty (tvNamed "a") - ] - ) - -unsafeParse :: Text -> Expr Name () -unsafeParse t = case parseExprAndFormatError t of - Right a -> a $> mempty - Left e -> error (T.unpack e) diff --git a/compiler/test/Test/Data/Prelude.hs b/compiler/test/Test/Data/Prelude.hs deleted file mode 100644 index 990e186e..00000000 --- a/compiler/test/Test/Data/Prelude.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Data.Prelude (prelude, preludeHash) where - --- hard coded basic Prelude module used for tests - -import Data.Functor -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Modules.HashModule -import Test.Utils.Helpers - -preludeHash :: ModuleHash -preludeHash = snd (serializeModule prelude) - -prelude :: Module Annotation -prelude = - Module - { moExpressions = exprs, - moDataTypes = dts, - moExpressionExports = S.fromList [DIName "fst", DIInfix (InfixOp "<|>")], - moExpressionImports = mempty, - moDataTypeExports = S.singleton "Either", - moDataTypeImports = mempty, - moNamedImports = mempty - } - where - exprs = - M.fromList - [ ( DIName "fst", - unsafeParseExpr "\\pair -> let (a,_) = pair in a" $> mempty - ), - ( DIInfix (InfixOp "<|>"), - unsafeParseExpr "\\eA -> \\eB -> match eA with Right a -> Right a | Left e -> eB" $> mempty - ) - ] - dts = - M.fromList - [ ( "Either", - DataType - "Either" - ["e", "a"] - ( M.fromList - [ ("Left", [MTVar mempty (TVName "e")]), - ("Right", [MTVar mempty (TVName "a")]) - ] - ) - ) - ] diff --git a/compiler/test/Test/Data/Project.hs b/compiler/test/Test/Data/Project.hs deleted file mode 100644 index ed6dae71..00000000 --- a/compiler/test/Test/Data/Project.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Test.Data.Project - ( testStdlib, - ) -where - -import Data.Functor -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project - --- check removing annotation doesn't break stuff -testStdlib :: Project Annotation -testStdlib = case buildTestStdlib of - Right stdLib' -> (stdLib' $> ()) $> mempty - Left e -> - error (T.unpack $ prettyPrint e) - -buildTestStdlib :: Either (Error Annotation) (Project Annotation) -buildTestStdlib = - Actions.run mempty action >>= \(proj, _, _) -> pure proj - where - action = pure () diff --git a/compiler/test/Test/Modules/Check.hs b/compiler/test/Test/Modules/Check.hs deleted file mode 100644 index 0dab3624..00000000 --- a/compiler/test/Test/Modules/Check.hs +++ /dev/null @@ -1,528 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.Check - ( spec, - ) -where - -import Control.Monad.IO.Class -import Data.Either (isLeft, isRight) -import Data.Functor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.Mimsa.Actions.Modules.Check as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Check -import Language.Mimsa.Modules.FromParts -import Language.Mimsa.Types.Error -import Test.Data.Prelude -import Test.Hspec -import Test.Utils.Helpers - -modulesPath :: FilePath -modulesPath = "compiler/test/modules/" - -exprAndTypeFromParts' :: - (Monoid ann) => - [DefPart ann] -> - Expr Name ann -> - Either (Error Annotation) (Expr Name ann) -exprAndTypeFromParts' = - exprAndTypeFromParts (DIName "test") - -testModules :: Map ModuleHash (Module Annotation) -testModules = M.singleton preludeHash prelude - -checkModule' :: Text -> Either (Error Annotation) (Module ()) -checkModule' t = do - let action = do - (a, _) <- Actions.checkModule testModules t - (b, _) <- Actions.checkModule testModules (prettyPrint a) - if (a $> ()) /= (b $> ()) - then - error $ - "Does not match!\n\n" - <> show a - <> "\n\n" - <> show b - <> "\n\nWhen re-parsing\n\n" - <> show (prettyPrint a) - else - let tyA = getModuleType a - tyB = getModuleType b - in if (tyA $> ()) == (tyB $> ()) - then pure (a $> mempty) - else - error $ - "Types are different:\n\n" - <> T.unpack (prettyPrint tyA) - <> "\n\n" - <> T.unpack (prettyPrint tyB) - getResult <$> Actions.run mempty action - -getResult :: (a, b, c) -> c -getResult (_, _, c) = c - -checkModuleType :: Text -> Either (Error Annotation) (Module (Type Annotation)) -checkModuleType t = - fst . getResult - <$> Actions.run - mempty - ( Actions.checkModule testModules t - ) - -spec :: Spec -spec = do - describe "modules" $ do - describe "CheckModule" $ do - it "1 parses correctly" $ do - let filePath = modulesPath <> "1.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents `shouldSatisfy` isRight - it "2 errors because duplicate definitions" $ do - let filePath = modulesPath <> "2.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldBe` Left (ModuleErr (DuplicateDefinition (DIName "duplicate"))) - it "3 errors because duplicate type name" $ do - let filePath = modulesPath <> "3.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldBe` Left (ModuleErr (DuplicateTypeName "Maybe")) - -- to implement - it "4 errors because duplicate constructor" $ do - let filePath = modulesPath <> "4.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldBe` Left (ModuleErr (DuplicateConstructor "Nothing")) - it "5 errors because it refers to an non-existent value" $ do - let filePath = modulesPath <> "5.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldBe` Left (ModuleErr (CannotFindValues (S.singleton (DIName "eatEgg")))) - it "6 errors because it doesn't typecheck" $ do - let filePath = modulesPath <> "6.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldSatisfy` \case - Left (ModuleErr (DefDoesNotTypeCheck _ (DIName "doesntTypecheck") _)) -> True - _ -> False - it "7 errors because annotation means it doesn't typecheck" $ do - let filePath = modulesPath <> "7.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldSatisfy` \case - Left (ModuleErr (DefDoesNotTypeCheck _ (DIName "doesntTypecheckBecauseAnnotation") _)) -> True - _ -> False - it "8 is broken because of partial type annotation" $ do - let filePath = modulesPath <> "8.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldSatisfy` isLeft - it "9 fails to typecheck because we cannot have polymorphic id function with a set input type" $ do - let filePath = modulesPath <> "9.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldSatisfy` isLeft - it "10 contains an infix function and typechecks" $ do - let filePath = modulesPath <> "10.mimsa" - fileContents <- liftIO $ T.readFile filePath - checkModule' fileContents - `shouldSatisfy` isRight - - describe "exprAndTypeFromParts" $ do - it "No args" $ do - let expr = unsafeParseExpr "100" - exprAndTypeFromParts' mempty expr `shouldBe` Right expr - it "Single non-typed arg" $ do - let expr = unsafeParseExpr "100" - parts = [DefArg (Identifier () "a")] - exprAndTypeFromParts' parts expr - `shouldBe` Right (MyLambda mempty (Identifier mempty "a") expr) - - it "Two non-typed args" $ do - let expr = unsafeParseExpr "100" - parts = [DefArg (Identifier () "a"), DefArg (Identifier () "b")] - exprAndTypeFromParts' parts expr - `shouldBe` Right - ( MyLambda - mempty - (Identifier mempty "a") - (MyLambda mempty (Identifier mempty "b") expr) - ) - it "Typed arg and return type" $ do - let expr = unsafeParseExpr "True" - parts = - [ DefTypedArg (Identifier () "str") mtString, - DefTypedArg (Identifier () "int") mtInt, - DefType mtBool - ] - exprAndTypeFromParts' parts expr - `shouldBe` Right - ( MyAnnotation - mempty - (mtFun mtString (mtFun mtInt mtBool)) - ( MyLambda - mempty - (Identifier mempty "str") - (MyLambda mempty (Identifier mempty "int") expr) - ) - ) - - it "Errors on typed arg but no return type" $ do - let expr = unsafeParseExpr "True" - parts = - [ DefTypedArg (Identifier () "str") mtString, - DefTypedArg (Identifier () "int") mtInt - ] - exprAndTypeFromParts' parts expr - `shouldSatisfy` isLeft - - describe "Examples" $ do - it "Empty file" $ - checkModule' "" `shouldBe` Right mempty - describe "definitions" $ do - it "Single constant" $ - let expectedExpr = unsafeParseExpr "100" $> mempty - exprs = M.singleton (DIName "noSig") expectedExpr - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def noSig = 100" - `shouldBe` Right expectedModule - it "Two constants" $ - let exprs = - M.fromList - [ (DIName "one", unsafeParseExpr "1" $> mempty), - (DIName "two", unsafeParseExpr "2" $> mempty) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def one = 1\ndef two = 2" - `shouldBe` Right expectedModule - it "id Function" $ - let exprs = - M.fromList - [ (DIName "id", unsafeParseExpr "\\a -> a" $> mempty) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def id a = a" - `shouldBe` Right expectedModule - it "const Function" $ - let exprs = - M.fromList - [ (DIName "const", unsafeParseExpr "\\a -> \\b -> a" $> mempty) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def const a b = a" - `shouldBe` Right expectedModule - it "multiple Functions" $ - let exprs = - M.fromList - [ (DIName "id", unsafeParseExpr "\\a -> a" $> mempty), - (DIName "const", unsafeParseExpr "\\a -> \\b -> a" $> mempty) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def id a = a\ndef const a b = a" - `shouldBe` Right expectedModule - describe "datatype definitions" $ do - it "single datatype definition" $ - let dts = - M.fromList - [ ( "Maybe", - DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [mtVar "a"]), - ("Nothing", mempty) - ] - ) - ) - ] - expectedModule = mempty {moDataTypes = dts} - in checkModule' "type Maybe a = Just a | Nothing" - `shouldBe` Right expectedModule - it "single datatype definition with definition after" $ - let dts = - M.fromList - [ ( "Maybe", - DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [mtVar "a"]), - ("Nothing", mempty) - ] - ) - ) - ] - exprs = M.fromList [(DIName "a", unsafeParseExpr "1" $> mempty)] - expectedModule = mempty {moDataTypes = dts, moExpressions = exprs} - in checkModule' "type Maybe a = Just a | Nothing\ndef a = 1" - `shouldBe` Right expectedModule - describe "exports" $ do - it "export id function" $ do - let exprs = - M.fromList - [(DIName "id", unsafeParseExpr "\\a -> a" $> mempty)] - exports = S.singleton (DIName "id") - expectedModule = mempty {moExpressions = exprs, moExpressionExports = exports} - checkModule' "export def id a = a" - `shouldBe` Right expectedModule - - describe "definitions with types" $ do - it "function with full signature" $ - let exprs = - M.fromList - [ ( DIName "const", - MyAnnotation - mempty - (unsafeParseMonoType "String -> Int -> String" $> mempty) - (unsafeParseExpr "\\a -> \\b -> a" $> mempty) - ) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def const (a: String) (b: Int) : String = a" - `shouldBe` Right expectedModule - it "function with signature where not all args have names" $ - let exprs = - M.fromList - [ ( DIName "returnFunc", - MyAnnotation - mempty - (unsafeParseMonoType "String -> Int -> String" $> mempty) - (unsafeParseExpr "\\a -> \\b -> a" $> mempty) - ) - ] - expectedModule = mempty {moExpressions = exprs} - in checkModule' "def returnFunc (a: String) : Int -> String = \\b -> a" - `shouldBe` Right expectedModule - - it "function where signature has partial types" $ - checkModule' "def const (a: String) b : a = a" - `shouldBe` Left (ModuleErr (DefMissingTypeAnnotation (DIName "const") "b")) - - it "function where signature has incomplete type annotations explodes" $ - checkModule' "def const (a: String) b = a" - `shouldBe` Left (ModuleErr (DefMissingReturnType (DIName "const"))) - - it "multiple functions with signatures" $ - let exprs = - M.fromList - [ ( DIName "fmap", - MyAnnotation - mempty - (unsafeParseMonoType "(a -> b) -> Maybe a -> Maybe b" $> mempty) - ( unsafeParseExpr "\\f -> \\maybeA -> match maybeA with Just a -> Just (f a) | Nothing -> Nothing" $> mempty - ) - ), - ( DIName "inc", - unsafeParseExpr "\\a -> a + 1" $> mempty - ) - ] - dts = - M.fromList - [ ( "Maybe", - DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [mtVar "a"]), - ("Nothing", mempty) - ] - ) - ) - ] - - expectedModule = - mempty - { moExpressions = exprs, - moDataTypes = dts - } - in checkModule' "type Maybe a = Just a | Nothing\ndef fmap (f: a -> b) (maybeA: Maybe a): Maybe b = match maybeA with Just a -> Just (f a) | Nothing -> Nothing\n\n\ndef inc a = a + 1" - `shouldBe` Right expectedModule - - describe "check types" $ do - it "broken type declaration" $ - checkModuleType - ( joinLines - ["type Maybe a = Just b | Nothing"] - ) - `shouldSatisfy` isLeft - - it "one type uses another correctly" $ - checkModuleType - ( joinLines - [ "type Maybe a = Just a | Nothing", - "type Parser a = Parser (String -> Maybe (String, a))" - ] - ) - `shouldSatisfy` isRight - - -- need to implement kind checking in datatype declarations - xit "one type uses another incorrectly and fails" $ - checkModuleType - ( joinLines - [ "type Maybe a = Just a | Nothing", - "type Parser a = Parser (String -> Maybe Int (String, a))" - ] - ) - `shouldSatisfy` isLeft - - describe "tests" $ do - it "Accepts a trivial test" $ - checkModuleType - (joinLines ["test \"2 equals 2\" = 2 == 2"]) - `shouldSatisfy` isRight - - it "Does not accept a test with an empty name" $ - checkModuleType - (joinLines ["test \"\" = 2 == 2"]) - `shouldSatisfy` isLeft - - it "Does not accept a duplicated test name" $ - checkModuleType - ( joinLines - [ "test \"test\" = 2 == 2", - "test \"test\" = 2 + 2 == 4" - ] - ) - `shouldSatisfy` isLeft - - it "Accepts a trivial test that refers to another expression" $ - checkModuleType - ( joinLines - [ "test \"id 2 equals 2\" = id 2 == 2", - "def id a = a" - ] - ) - `shouldSatisfy` isRight - - describe "imports" $ do - it "uses fst from Prelude" $ - getModuleType - <$> checkModuleType - ( joinLines - [ "import * from " <> prettyPrint preludeHash, - "export def useFst = fst (1,2)" - ] - ) - `shouldSatisfy` isRight - it "uses fst from Prelude but it shouldn't typecheck" $ - checkModuleType - ( joinLines - [ "import * from " <> prettyPrint preludeHash, - "def useFst = fst True" - ] - ) - `shouldSatisfy` isLeft - it "errors when locally defining fst" $ - checkModuleType - ( joinLines - [ "import * from " <> prettyPrint preludeHash, - "def fst pair = let (a,_) = pair in a" - ] - ) - `shouldBe` Left (ModuleErr $ DefinitionConflictsWithImport (DIName "fst") preludeHash) - it "uses Either from Prelude" $ - checkModuleType - ( joinLines - [ "import * from " <> prettyPrint preludeHash, - "def withEither val = match val with Right a -> [a,a] | Left _ -> []" - ] - ) - `shouldSatisfy` isRight - - it "uses Either and <|> from Prelude" $ - checkModuleType - ( joinLines - [ "import * from " <> prettyPrint preludeHash, - "def nice = Left 1 <|> Right True" - ] - ) - `shouldSatisfy` isRight - it "errors when locally defining Either" $ - checkModuleType - ( joinLines - [ "type Either b c = Left b | Right c", - "import * from " <> prettyPrint preludeHash - ] - ) - `shouldBe` Left (ModuleErr $ DuplicateTypeName "Either") - - it "Errors when adding a duplicate Right constructor" $ - checkModule' - ( joinLines - [ "type Result e a = Failure e | Right a", - "type Either e a = Left e | Right a" - ] - ) - `shouldSatisfy` isLeft - - it "Imports parse and pretty print" $ - checkModule' - ( joinLines - [ "type Maybe a = Just a | Nothing", - "import * from " <> prettyPrint preludeHash - ] - ) - `shouldSatisfy` isRight - - it "Parses namespaced import" $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash - ] - ) - `shouldSatisfy` isRight - - it ("Uses fst from Prelude with named import: " <> T.unpack (prettyPrint preludeHash)) $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash, - "def withFst = Prelude.fst (True, 1)" - ] - ) - `shouldSatisfy` isRight - - it ("Uses Right and Left from Prelude with named import: " <> T.unpack (prettyPrint preludeHash)) $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash, - "def useEither eA = match eA with Prelude.Right a -> [a] | Prelude.Left _ -> []" - ] - ) - `shouldSatisfy` isRight - - it ("Uses Either type from Prelude with named import: " <> T.unpack (prettyPrint preludeHash)) $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash, - "def useEither (eA: Prelude.Either e String): String = match eA with Prelude.Right a -> a | Prelude.Left _ -> \"\"" - ] - ) - `shouldSatisfy` isRight - - it "Uses Either type from Prelude without specifying namespace fails" $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash, - "def useEither (eA: Either e String): String = match eA with Right a -> a | _ -> \"\"" - ] - ) - `shouldSatisfy` isLeft - - it "Locally defined Either does not mess with namespace imported Either" $ - checkModuleType - ( joinLines - [ "import Prelude from " <> prettyPrint preludeHash, - "type Either e a = Left e | Right a", - "def convert (val: Either e a): Prelude.Either e a = ", - " match val with Right a -> Prelude.Right a | Left e -> Prelude.Left e" - ] - ) - `shouldSatisfy` isRight diff --git a/compiler/test/Test/Modules/Repl.hs b/compiler/test/Test/Modules/Repl.hs deleted file mode 100644 index 74df2488..00000000 --- a/compiler/test/Test/Modules/Repl.hs +++ /dev/null @@ -1,1352 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Modules.Repl - ( spec, - ) -where - --- testing doing repl things but in the modules world - -import Data.Either (isLeft, isRight) -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Helpers.Parse as Actions -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib (buildStdlib) -import Language.Mimsa.Typechecker.NormaliseTypes -import Language.Mimsa.Types.Project -import Test.Hspec -import Test.Utils.Helpers - -stdlib :: Project Annotation -stdlib = fromRight buildStdlib - -evalWithDefs :: - Maybe Text -> - Text -> - IO (Either Text (Type (), Expr Name ())) -evalWithDefs inputParts input = do - let action = do - mod' <- case inputParts of - Just input' -> Actions.parseModule input' - Nothing -> pure mempty - expr <- Actions.parseExpr input - (mt, interpretedExpr, _) <- - Actions.evaluateModule expr mod' - pure (mt, interpretedExpr) - case Actions.run stdlib action of - Right (_, _, (mt, endExpr)) -> do - pure (Right (normaliseType (toEmptyType mt), toEmptyAnn endExpr)) - Left e -> pure (Left (prettyPrint e)) - -eval :: - Text -> - IO (Either Text (Type (), Expr Name ())) -eval = evalWithDefs Nothing - --- remove annotations for comparison -toEmptyAnn :: Expr a b -> Expr a () -toEmptyAnn = toEmptyAnnotation - -toEmptyType :: Type a -> Type () -toEmptyType a = a $> () - -defs :: [Text] -> Text -defs = T.intercalate "\n" - -spec :: Spec -spec = - describe "Modules repl" $ do - describe "End to end parsing to evaluation" $ do - it "No functions" $ do - result <- eval "100" - result `shouldBe` Right (MTPrim mempty MTInt, int 100) - - it "No dependencies" $ do - result <- eval "let id a = a in id 100" - result `shouldBe` Right (MTPrim mempty MTInt, int 100) - - it "Use Prelude.fst" $ do - result <- eval "let x = ((1,2)) in Prelude.fst x" - result - `shouldBe` Right - (MTPrim mempty MTInt, int 1) - - it "Access value inside record" $ do - result <- eval "let good = ({ dog: True }) in good.dog" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Run function from record" $ do - result <- eval "let record = ({ id: (\\i -> i) }) in record.id" - result - `shouldBe` Right - ( MTFunction mempty (unknown 1) (unknown 1), - MyLambda mempty (Identifier mempty "i") (MyVar mempty Nothing "i") - ) - - it "Use polymorphic function from inside record" $ do - result <- eval "let prelude = ({ id: (\\i -> i) }) in prelude.id 1" - result - `shouldBe` Right - ( MTPrim mempty MTInt, - int 1 - ) - - it "Calls function from doubly nested record" $ do - result <- eval "let bigPrelude = ({ prelude: { id: (\\i -> i) } }) in bigPrelude.prelude.id 1" - result - `shouldBe` Right - ( MTPrim mempty MTInt, - int 1 - ) - - it "compose incrementInt" $ do - result <- eval "let incrementInt a = a + 1; let compose = (\\f -> \\g -> \\a -> f (g a)) in let blah = compose incrementInt incrementInt in blah 67" - result `shouldBe` Right (MTPrim mempty MTInt, int 69) - - it "Use id function twice" $ do - result <- eval "let reuse = ({ first: Prelude.id 1, second: Prelude.id 2 }) in reuse.first" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "Define and use id function" $ do - result <- eval "let id = \\a -> a in id 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "Use id function twice with different types" $ do - result <- eval "let reuse = ({ first: Prelude.id True, second: Prelude.id 2 }) in reuse.first" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Use id function with different types (2)" $ do - result <- eval "let reuse = ({ first: Prelude.id, second: Prelude.id 2 }) in reuse.first True" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "reuses polymorphic function" $ do - result <- eval "let reuse = ({ first: Prelude.const 1, second: Prelude.const True }) in reuse.first 100" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "reuses polymorphic function 2" $ do - result <- eval "let reuse = ({ first: Prelude.const True, second: Prelude.const 2 }) in reuse.second 100" - result `shouldBe` Right (MTPrim mempty MTInt, int 2) - - it "reuses polymorphic function defined here" $ do - result <- eval "let id2 a = a; (id2 1, id2 True)" - result `shouldSatisfy` isRight - - it "Use a function" $ do - result <- eval "let addInt a b = a + b; addInt 1 2" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - - it "(\\a -> a) 1" $ do - result <- eval "(\\a -> a) 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "(\\b -> (\\a -> b)) 0 1" $ do - result <- eval "(\\b -> (\\a -> b)) 0 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 0) - - it "Nested function application" $ do - result <- eval "let addInt a b = a + b; addInt 1 (addInt (addInt 2 4) 5)" - result `shouldBe` Right (MTPrim mempty MTInt, int 12) - - it "type LeBool = Vrai | Faux in Vrai" $ do - result <- evalWithDefs (Just "type LeBool = Vrai | Faux") "Vrai" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "LeBool" [], - MyConstructor mempty Nothing "Vrai" - ) - - it "type Nat = Zero | Suc Nat in Suc Zero" $ do - result <- evalWithDefs (Just "type Nat = Zero | Suc Nat") "Suc Zero" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Nat" [], - MyApp - mempty - (MyConstructor mempty Nothing "Suc") - (MyConstructor mempty Nothing "Zero") - ) - - it "type Nat = Zero | Suc Nat in Suc (Suc Zero)" $ do - result <- evalWithDefs (Just "type Nat = Zero | Suc Nat") "Suc (Suc Zero)" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Nat" [], - MyApp - mempty - (MyConstructor mempty Nothing "Suc") - ( MyApp - mempty - (MyConstructor mempty Nothing "Suc") - (MyConstructor mempty Nothing "Zero") - ) - ) - - it "type Nat = Zero | Suc Nat in Suc 1" $ do - result <- evalWithDefs (Just "type Nat = Zero | Suc Nat") "Suc 1" - result - `shouldSatisfy` isLeft - - it "type Nat = Zero | Suc Nat in Suc Dog" $ do - result <- evalWithDefs (Just "type Nat = Zero | Suc Nat") "Suc Dog" - result - `shouldSatisfy` isLeft - - it "type Nat = Zero | Suc Nat in Suc" $ do - result <- evalWithDefs (Just "type Nat = Zero | Suc Nat") "Suc" - result - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "Nat" []) - (dataTypeWithVars mempty Nothing "Nat" []), - MyConstructor mempty Nothing "Suc" - ) - - it "type OhNat = Zero | Suc OhNat String in Suc" $ do - result <- evalWithDefs (Just "type OhNat = Zero | Suc OhNat String") "Suc" - result - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "OhNat" []) - ( MTFunction - mempty - (MTPrim mempty MTString) - (dataTypeWithVars mempty Nothing "OhNat" []) - ), - MyConstructor mempty Nothing "Suc" - ) - it "type Pet = Cat String | Dog String in Cat \"mimsa\"" $ do - result <- evalWithDefs (Just "type Pet = Cat String | Dog String") "Cat \"mimsa\"" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Pet" [], - MyApp - mempty - (MyConstructor mempty Nothing "Cat") - (str' "mimsa") - ) - it "type Void in 1" $ do - result <- evalWithDefs (Just "type Void") "1" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - it "type String = Should | Error in Error" $ do - result <- evalWithDefs (Just "type String = Should | Error") "Error" - result `shouldSatisfy` isLeft - it "type LongBoy = Stuff String Int String in Stuff \"yes\"" $ do - result <- - evalWithDefs - (Just "type LongBoy = Stuff String Int String") - "Stuff \"yes\"" - result - `shouldBe` Right - ( MTFunction - mempty - (MTPrim mempty MTInt) - ( MTFunction - mempty - (MTPrim mempty MTString) - (dataTypeWithVars mempty Nothing "LongBoy" []) - ), - MyApp - mempty - (MyConstructor mempty Nothing "Stuff") - (str' "yes") - ) - it "type Tree = Leaf Int | Branch Tree Tree in Branch (Leaf 1) (Leaf 2)" $ do - result <- - evalWithDefs - (Just "type Tree = Leaf Int | Branch Tree Tree") - "Branch (Leaf 1) (Leaf 2)" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Tree" [], - MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Branch") - (MyApp mempty (MyConstructor mempty Nothing "Leaf") (int 1)) - ) - (MyApp mempty (MyConstructor mempty Nothing "Leaf") (int 2)) - ) - it "type Maybe a = Just a | Nothing in Just" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "Just" - result - `shouldBe` Right - ( MTFunction - mempty - (MTVar mempty (TVUnificationVar 1)) - (dataTypeWithVars mempty Nothing "Maybe" [MTVar mempty (TVUnificationVar 1)]), - MyConstructor mempty Nothing "Just" - ) - it "type Maybe a = Just a | Nothing in Nothing" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "Nothing" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Maybe" [MTVar mempty (TVUnificationVar 1)], - MyConstructor mempty Nothing "Nothing" - ) - it "type Maybe a = Just a | Nothing in Just 1" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "Just 1" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Maybe" [MTPrim mempty MTInt], - MyApp - mempty - (MyConstructor mempty Nothing "Just") - (int 1) - ) - - it "use Maybe with eq" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "let eq a b = a == b; match Just 1 with (Just a) -> eq 100 a | Nothing -> False" - result - `shouldBe` Right - (MTPrim mempty MTBool, bool False) - - it "type Maybe a = Just a | Nothing in match Just 1 with (Just a) -> True | Nothing -> 1" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "match Just 1 with (Just a) -> True | Nothing -> 1" - result `shouldSatisfy` isLeft - - it "unfolding Maybe more" $ do - result <- - evalWithDefs - (Just "type Maybe a = Just a | Nothing") - "let eq a b = a == b; match Just 1 with (Just a) -> eq 100 a | _ -> False" - result - `shouldBe` Right - (MTPrim mempty MTBool, bool False) - - it "Extracts values with pattern match" $ do - result <- evalWithDefs (Just "type Stuff = Thing String Int") "match Thing \"Hello\" 1 with (Thing name num) -> name" - result - `shouldBe` Right - (MTPrim mempty MTString, str' "Hello") - - it "Pattern matching on result" $ do - result <- - evalWithDefs - (Just "type Result e a = Failure e | Success a") - "match Failure \"oh no\" with (Success a) -> \"oh yes\" | (Failure e) -> e" - result - `shouldBe` Right - (MTPrim mempty MTString, str' "oh no") - - it "Pattern matching datatype with type vars and concrete types" $ do - result <- evalWithDefs (Just "type Blap a = Boop a Int") "match Boop True 100 with (Boop a b) -> a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Identifies broken pattern match" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "match Nothing with Nothing False" - result `shouldSatisfy` isLeft - - it "type Thing = Thing String in let a = Thing \"string\" in match a with (Thing s) -> s" $ do - result <- evalWithDefs (Just "type Thing = Thing String") "let a = Thing \"string\" in match a with (Thing s) -> s" - result `shouldBe` Right (MTPrim mempty MTString, str' "string") - - it "type Pair a b = Pair a b in match Pair \"dog\" 1 with Pair \a -> a" $ do - result <- evalWithDefs (Just "type Pair a b = Pair a b") "match Pair \"dog\" 1 with Pair \a -> a" - result `shouldSatisfy` isLeft - - it "type Tree a = Leaf a | Branch (Tree a) (Tree a) in Leaf 1" $ do - result <- evalWithDefs (Just "type Tree a = Leaf a | Branch (Tree a) (Tree a)") "Leaf 1" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Tree" [MTPrim mempty MTInt], - MyApp - mempty - (MyConstructor mempty Nothing "Leaf") - (int 1) - ) - it "type Tree a = Leaf a | Branch (Tree a) (Tree b) in Leaf 1" $ do - result <- - evalWithDefs - (Just "type Tree a = Leaf a | Branch (Tree a) (Tree b)") - "Leaf 1" - result - `shouldSatisfy` isLeft - - it "type Tree a = Leaf a | Branch (Tree a) (Tree b) in Branch (Leaf 1) (Leaf True)" $ do - result <- evalWithDefs (Just "type Tree a = Leaf a | Branch (Tree a) (Tree b)") "Branch (Leaf 1) (Leaf True)" - result - `shouldSatisfy` isLeft - - it "type Tree a = Empty | Branch (Tree a) a (Tree a) in Branch (Empty) 1 (Empty)" $ do - result <- evalWithDefs (Just "type Tree a = Empty | Branch (Tree a) a (Tree a)") "Branch (Empty) 1 (Empty)" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Tree" [MTPrim mempty MTInt], - MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Branch") - (MyConstructor mempty Nothing "Empty") - ) - (int 1) - ) - (MyConstructor mempty Nothing "Empty") - ) - - it "unwrapping Maybe" $ do - result <- evalWithDefs (Just "type Maybe a = Just a | Nothing") "match Just True with Just \\a -> a | Nothing \"what\"" - result `shouldSatisfy` isLeft - - it "unwrap for Either" $ do - result <- evalWithDefs (Just "type Either e a = Left e | Right a") "\\f -> \\g -> \\either -> match either with (Left e) -> g e | (Right a) -> (f a)" - result `shouldSatisfy` isRight - {- - it "type Maybe a = Just a | Nothing in \\maybe -> match maybe with Just \\a -> a | Nothing \"poo\"" $ do - result <- eval "type Maybe a = Just a | Nothing in \\maybe -> match maybe with Just \\a -> a | Nothing \"poo\"" - fst <$> result - `shouldBe` Right - ( MTFunction (dataTypeWithVars ( "Maybe") []) (MTPrim MTString) - ) - - -} - it "type Array a = Empty | Item a (Array a) in match (Item 1 (Item 2 Empty)) with Empty -> Empty | (Item a rest) -> rest" $ do - result <- evalWithDefs (Just "type Array a = Empty | Item a (Array a)") "match (Item 1 (Item 2 Empty)) with Empty -> Empty | (Item a rest) -> rest" - result - `shouldBe` Right - ( dataTypeWithVars mempty Nothing "Array" [MTPrim mempty MTInt], - MyApp - mempty - ( MyApp - mempty - ( MyConstructor - mempty - Nothing - "Item" - ) - (int 2) - ) - (MyConstructor mempty Nothing "Empty") - ) - - it "Recursive function works" $ do - result <- eval "let eq a b = a == b; let addInt a b = a + b; let loop = (\\a -> if eq 10 a then a else loop (addInt a 1)) in loop 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 10) - - it "Recursively converts Nat to integer" $ do - result <- - evalWithDefs - (Just "type Nat = Zero | Suc Nat") - "let incrementInt a = a + 1; let loop = (\\as -> match as with Zero -> 0 | (Suc as2) -> incrementInt (loop as2)) in loop (Suc (Suc (Suc Zero)))" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - - it "Recursively converts bigger Nat to integer" $ do - result <- - evalWithDefs - (Just "type Nat = Zero | Suc Nat") - "let incrementInt a = a + 1; let loop = (\\as -> \\b -> match as with Zero -> b | (Suc as2) -> incrementInt (loop as2 b)) in loop (Suc (Suc (Suc Zero))) 10" - result `shouldBe` Right (MTPrim mempty MTInt, int 13) - {- - it "type Arr a = Empty | Item a (Arr a) in let reduceA = (\\b -> \\as -> match as with Empty -> b | (Item a rest) -> reduceA(addInt(b)(a))(rest)) in reduceA(0)(Item 3 Empty)" $ do - result <- eval "type Arr a = Empty | Item a (Arr a) in let reduceA = (\\b -> \\as -> match as with Empty -> b | (Item a rest) -> reduceA(addInt(b)(a))(rest)) in reduceA(0)(Item 3 Empty)" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - -} - - it "Array reduce function" $ do - result <- - evalWithDefs - (Just "type Array a = Empty | Item a (Array a)") - "let addInt a b = a + b; let reduceA = (\\f -> \\b -> \\as -> match as with Empty -> b | (Item a rest) -> reduceA f (f b a) rest) in reduceA addInt 0 Empty" - result `shouldBe` Right (MTPrim mempty MTInt, int 0) - - it "Array reduce function 2" $ do - result <- evalWithDefs (Just "type Array a = Empty | Item a (Array a)") "let addInt a b = a + b; let reduceA = (\\f -> \\b -> \\as -> match as with Empty -> b | (Item a rest) -> reduceA f (f b a) rest) in reduceA addInt 0 (Item 3 Empty)" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - - it "type Tlee a = Non | Tlee (Maybe b) in {}" $ do - result <- evalWithDefs (Just "type Tlee a = Non | Tlee (Maybe b)") "{}" - result `shouldSatisfy` isLeft - - it "Use Maybe module" $ do - result <- eval "let some = \\a -> Maybe.Just a in if True then some 1 else Maybe.Nothing" - result - `shouldBe` Right - ( dataTypeWithVars mempty (Just "Maybe") "Maybe" [MTPrim mempty MTInt], - MyApp - mempty - (MyConstructor mempty (Just "Maybe") "Just") - (int 1) - ) - - it "Pattern match fails using Maybe" $ do - result <- eval "\\a -> match a with (Maybe.Just as) -> True | Maybe.Nothing -> 100" - fst <$> result - `shouldSatisfy` isLeft - - it "Pattern match succeeds using Maybe" $ do - result <- eval "\\a -> match a with (Maybe.Just as) -> as | Maybe.Nothing -> 100" - fst <$> result - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty (Just "Maybe") "Maybe" [MTPrim mempty MTInt]) - (MTPrim mempty MTInt) - ) - - it "fromMaybe should fail typecheck when default does not match inner value" $ do - result <- eval "let fromMaybe = \\defVal -> (\\maybe -> match maybe with (Maybe.Just a) -> a | Maybe.Nothing -> defVal) in fromMaybe \"Horse\" (Maybe.Just 1)" - result `shouldSatisfy` isLeft - - it "fromMaybe works when types match up" $ do - result <- eval "let fromMaybe = \\defVal -> (\\maybe -> match maybe with (Maybe.Just a) -> a | Maybe.Nothing -> defVal) in fromMaybe \"Horse\" (Maybe.Just \"Dog\")" - result `shouldBe` Right (MTPrim mempty MTString, str' "Dog") - - it "String and bool fail to equals" $ do - result <- eval "True == \"dog\"" - result `shouldSatisfy` isLeft - - it "Errors when attempting function equality" $ do - -- no function equality - result <- eval "(\\a -> a) == (\\b -> b)" - result `shouldSatisfy` isLeft - - it "True == False" $ do - result <- eval "True == False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "True == True" $ do - result <- eval "True == True" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Equality with constructors" $ do - result <- eval "(Maybe.Just 1) == Maybe.Just 2" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Equality as a function" $ do - result <- eval "let eq1 = (\\a -> a == 1) in eq1 1" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "1 + 1" $ do - result <- eval "1 + 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 2) - - it "True + 1" $ do - result <- eval "True + 1" - result `shouldSatisfy` isLeft - - it "10 - 1" $ do - result <- eval "10 - 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 9) - - it "True - 1" $ do - result <- eval "True - 1" - result `shouldSatisfy` isLeft - - it "1 + 1 + 1 + 1" $ do - result <- eval "1 + 1 + 1 + 1" - result `shouldBe` Right (MTPrim mempty MTInt, int 4) - - it "\"dog\" ++ \"log\"" $ do - result <- eval "\"dog\" ++ \"log\"" - result `shouldBe` Right (MTPrim mempty MTString, str' "doglog") - - it "\"dog\" ++ 123" $ do - result <- eval "\"dog\" ++ 123" - result `shouldSatisfy` isLeft - - it "passes record to function" $ do - result <- eval "let f = (\\a -> if True then a.num else a.num2) in f {num: 1, num2: 2}" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "if True then { one: 1 } else { two: 2 }" $ do - result <- eval "if True then { one: 1 } else { two: 2 }" - result `shouldSatisfy` isLeft - - it "if True then { one: 1 } else { one: 2 }" $ do - result <- eval "if True then { one: 1 } else { one: 2 }" - result `shouldSatisfy` isRight - - it "let a = { one: 1 }; let one = a.one; let two = a.two; a" $ do - result <- eval "let a = { one: 1 }; let one = a.one; let two = a.two; a" - result `shouldSatisfy` isLeft - - it "\\a -> let one = a.one; let two = a.two; a" $ do - result <- eval "\\a -> let one = a.one; let two = a.two; a" - result - `shouldSatisfy` isRight - - it "passes inferred record value to a function" $ do - result <- eval "let useRecord = (\\a -> let one = a.one; let two = a.two; one + two) in useRecord {one: 1}" - result `shouldSatisfy` \case - (Left err) -> not $ T.isInfixOf "InterpreterError" err - _ -> False - - it "passes inferred value to another function" $ do - result <- eval "let useRecord = (\\a -> let one = a.one; let two = a.two; one + two) in useRecord {two: 2}" - result `shouldSatisfy` \case - (Left err) -> not $ T.isInfixOf "InterpreterError" err - _ -> False - - it "passes complete record value to function" $ do - result <- eval "let useRecord = (\\a -> let one = a.one; let two = a.two; one + two) in useRecord {one: 1, two: 2}" - result `shouldSatisfy` isRight - - it "if ?missingFn then 1 else 2" $ do - result <- eval "if ?missingFn then 1 else 2" - result `shouldSatisfy` \case - (Left msg) -> - T.isInfixOf "Typed holes found" msg - && T.isInfixOf "?missingFn" msg - && T.isInfixOf "Boolean" msg - (Right _) -> False - - it "typed holes found in map function" $ do - result <- eval "let map = \\f -> \\a -> f a in map ?flappy 1" - result `shouldSatisfy` \case - (Left msg) -> - T.isInfixOf "Typed holes found" msg - (Right _) -> False - - it "compose function" $ do - result <- eval "let compose = \\f -> \\g -> \\a -> f (g a); compose" - result `shouldSatisfy` isRight - - it "Just (1 == 1)" $ do - result <- eval "Maybe.Just (1 == 1)" - snd <$> result - `shouldBe` Right - ( MyApp - mempty - (MyConstructor mempty (Just "Maybe") "Just") - (bool True) - ) - it "\\a -> if (100 == a.int) then 100 else 0" $ do - result <- eval "\\a -> if (100 == a.int) then 100 else 0" - result `shouldSatisfy` isRight - - it "\\a -> if (a.one == a.two) then 100 else 0" $ do - result <- eval "\\a -> if (a.one == a.two) then 100 else 0" - result `shouldSatisfy` isRight - - it "type Reader r a = Reader (r -> a) in Reader (\\r -> r + 100)" $ do - result <- evalWithDefs (Just "type Reader r a = Reader (r -> a)") "Reader (\\r -> r + 100)" - result - `shouldBe` Right - ( dataTypeWithVars - mempty - Nothing - "Reader" - [MTPrim mempty MTInt, MTPrim mempty MTInt], - MyApp - mempty - (MyConstructor mempty Nothing "Reader") - ( MyLambda - mempty - (Identifier mempty "r") - ( MyInfix - mempty - Add - (MyVar mempty Nothing "r") - (int 100) - ) - ) - ) - - it "Match State monad" $ do - result <- eval "\\state -> \\s -> match state with (State.State sas) -> sas s" - result `shouldSatisfy` isRight - - it "Bind with State monad" $ do - result <- eval "let storeName a = State.fmap (Prelude.const a) (State.put a); let a = State.pure \"dog\"; let b = State.bind storeName a; State.run b \"\"" - result `shouldSatisfy` isRight - - it "Stops boolean and Maybe being used together" $ do - result <- eval "\\some -> match some with (Maybe.Just a) -> Maybe.Just (a == 1) | _ -> some" - result `shouldSatisfy` isLeft - - -- need a new way of stopping this looping - -- perhaps static analysis for silly cases - -- and a timeout when used as an endpoint? - xit "Interpreter is stopped before it loops infinitely" $ do - result <- eval "let forever = \\a -> forever a in forever True" - result `shouldSatisfy` \case - Left msg -> "interpreter aborted" `T.isInfixOf` msg - _ -> False - - -- built-ins should not be used as type constructors - it "type Justthing = String in True" $ do - result <- evalWithDefs (Just "type Justthing = String") "True" - result `shouldSatisfy` isLeft - - it "Define Pair" $ do - result <- evalWithDefs (Just "type Pair a b = Pair (a,b)") "True" - result `shouldSatisfy` isRight - - it "type Record a = Record { name: String, other: a } in True" $ do - result <- evalWithDefs (Just "type Record a = Record { name: String, other: a }") "True" - result `shouldSatisfy` isRight - - it "type State s a = State (s -> (a,s)) in True" $ do - result <- evalWithDefs (Just "type State s a = State (s -> (a,s))") "True" - result `shouldSatisfy` isRight - - -- simplest swaps test - it "\\a -> 1" $ do - result <- eval "\\a -> 1" - case result of - Left _ -> error "Was not supposed to fail" - Right (_, expr') -> T.unpack (prettyPrint expr') `shouldContain` "a" - - it "filter function for strings" $ do - result <- eval "let filter = \\pred -> \\str -> let fn = (\\s -> match s with a ++ as -> let rest = fn as; if pred a then a ++ rest else rest | _ -> \"\") in fn str; filter (\\a -> a == \"o\") \"woo\"" - result - `shouldBe` Right - ( MTPrim mempty MTString, - MyLiteral mempty (MyString "oo") - ) - - it "Parse any character" $ do - result <- eval "Parser.run Parser.anyChar \"dog\"" - result `shouldSatisfy` isRight - - it "Parser.fmap works correctly" $ do - result <- eval "let repeat = Parser.fmap (\\a -> a ++ a) Parser.anyChar in Parser.run repeat \"dog\"" - snd <$> result - `shouldBe` Right - ( MyApp - mempty - (MyConstructor mempty (Just "Maybe") "Just") - (MyLiteral mempty (MyString "dd")) - ) - - it "Parser.bind works correctly" $ do - result <- eval "let parser = Parser.bind (\\a -> if a == \"d\" then Parser.anyChar else Parser.fail) Parser.anyChar; Parser.run parser \"dog\"" - snd <$> result - `shouldBe` Right - ( MyApp - mempty - (MyConstructor mempty (Just "Maybe") "Just") - (MyLiteral mempty (MyString "o")) - ) - - it "Parser.bind fails correctly" $ do - result <- eval "let parser = Parser.bind (\\a -> if a == \"d\" then Parser.anyChar else Parser.fail) Parser.anyChar; Parser.run parser \"log\"" - snd <$> result - `shouldBe` Right - (MyConstructor mempty (Just "Maybe") "Nothing") - - it "Parser.ap formats correctly" $ do - result <- eval "\\parserF -> \\parserA -> let (Parser.Parser pF) = parserF; let (Parser.Parser pA) = parserA; Parser.Parser (\\input -> match (pF input) with Maybe.Just (f, input2) -> (match (pA input2) with Maybe.Just (a, input3) -> Maybe.Just (f a, input3) | _ -> Maybe.Nothing) | _ -> Maybe.Nothing)" - result `shouldSatisfy` isRight - - it "Array literal" $ do - result <- eval "[1,2,3]" - result - `shouldBe` Right - ( MTArray mempty (MTPrim mempty MTInt), - MyArray mempty [int 1, int 2, int 3] - ) - - it "[1,True,3]" $ do - result <- eval "[1,True,3]" - result - `shouldSatisfy` isLeft - - describe "Native array" $ do - it "[1] <> [2]" $ do - result <- eval "[1] <> [2]" - result - `shouldBe` Right - ( MTArray mempty (MTPrim mempty MTInt), - MyArray mempty [int 1, int 2] - ) - - it "[1] <> [True]" $ do - result <- eval "[1] <> [True]" - result `shouldSatisfy` isLeft - - it "[1] <> \"2\"" $ do - result <- eval "[1] <> \"2\"" - result - `shouldSatisfy` isLeft - - it "\"1\" <> [2]" $ do - result <- eval "\"1\" <> [2]" - result - `shouldSatisfy` isLeft - - it "Array.fmap increments ints inside" $ do - result <- eval "Array.fmap (\\a -> a + 1) [1,2,3]" - result - `shouldBe` Right - ( MTArray mempty (MTPrim mempty MTInt), - MyArray mempty [int 2, int 3, int 4] - ) - - describe "Let pattern" $ do - it "Matches a wildcard" $ do - result <- eval "let _ = False in True" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a value" $ do - result <- eval "let a = True in a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a pair" $ do - result <- eval "let (a,b) = (True,False) in a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a record" $ do - result <- eval "let { dog: a } = { dog: True } in a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Does not match a constructor with other cases" $ do - result <- eval "let (Maybe.Just a) = Maybe.Just True in a" - result `shouldSatisfy` isLeft - - it "Matches a one case constructor" $ do - result <- evalWithDefs (Just "type Ident a = Ident a") "let (Ident a) = Ident True in a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a nested one case constructor" $ do - result <- evalWithDefs (Just "type Ident a = Ident a") "let (Ident (Ident a)) = Ident (Ident True) in a" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Does not matches a pair that is not complete" $ do - result <- eval "let (a,True) = (True,False) in a" - result `shouldSatisfy` isLeft - - it "Adds constructors to required types for StoreExpression" $ do - result <- eval "let (Parser.Parser parser) = Parser.pred (\\d -> d == \"d\") Parser.anyChar in parser \"dog\"" - result `shouldSatisfy` isRight - - describe "Pattern matching" $ do - it "Matches a wildcard" $ do - result <- eval "match 1 with _ -> True" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a variable" $ do - result <- eval "match 1 with a -> a" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "Deconstructs a pair" $ do - result <- eval "match (1,True) with (a,b) -> b" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches an int literal" $ do - result <- eval "match (1, True) with (1, a) -> a | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a string literal" $ do - result <- eval "match \"dog\" with \"dog\" -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches two string literals" $ do - result <- eval "match \"dog\" with \"dog\" -> True | \"log\" -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches a record" $ do - result <- eval "match { dog: 1 } with { dog: a } -> a" - result `shouldBe` Right (MTPrim mempty MTInt, int 1) - - it "Matches a constructor with no args" $ do - result <- eval "match Maybe.Nothing with Maybe.Nothing -> False | _ -> True" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Matches a constructor with args" $ do - result <- eval "match Maybe.Just 1 with (Maybe.Just _) -> True | Maybe.Nothing -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches These correctly" $ do - result <- eval "match These.This 1 with (These.These _ _) -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Fallbacks to correct catchall" $ do - result <- eval "match Maybe.Just 1 with (Maybe.Just _) -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Typechecks Either correctly" $ do - result <- eval "match Either.Right 100 with (Either.Left \"log\") -> False | (Either.Right 100) -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Does not have a swap error" $ do - result <- eval "\\a -> match (Either.Left a) with (Either.Left e) -> e | _ -> False" - result `shouldSatisfy` isRight - - it "Pulls Left into scope from Project" $ do - result <- eval "\\a -> match a with (Either.Left e) -> e | _ -> False" - result `shouldSatisfy` isRight - - it "Parses constructor application in expr" $ do - result <- eval "match Maybe.Just 1 with (Maybe.Just a) -> Maybe.Just a | _ -> Maybe.Nothing" - result `shouldSatisfy` isRight - - -- pattern matching is wacked - xit "Parses and pretty prints more complex matches" $ do - result <- eval "\\mf -> \\ma -> match (mf, ma) with (Either.Right f, Either.Right a) -> Either.Right (f a) | (Either.Left e, _) -> Either.Left e | (_, Either.Left e) -> Either.Left e" - result `shouldSatisfy` isRight - - it "Matches array with non-empty match" $ do - result <- eval "match [1] with [_] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Matches empty array with empty case" $ do - result <- eval "match [] with [_] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Should not match when input array is longer than pattern" $ do - result <- eval "match [1,2] with [_] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Should match when input is long but we have a SpreadWildcard at the end" $ do - result <- eval "match [1,2,3] with [1,2,...] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Shouldn't match when input is too short with SpreadWildcard at the end" $ do - result <- eval "match [1] with [1,2,...] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Binds empty remainder with array to SpreadValue" $ do - result <- eval "match [1] with [1,...a] -> a | _ -> [0]" - result - `shouldBe` Right - ( MTArray mempty (MTPrim mempty MTInt), - MyArray mempty mempty - ) - it "Binds remainder with array to SpreadValue" $ do - result <- eval "match [1,2,3] with [1,...a] -> a | _ -> []" - result - `shouldBe` Right - ( MTArray mempty (MTPrim mempty MTInt), - MyArray mempty [int 2, int 3] - ) - - it "Errors if we bind the same variable twice" $ do - result <- eval "match (1,2) with (a,a) -> a" - result `shouldSatisfy` isLeft - - it "Uses a constructor inside an array" $ do - result <- eval "match [] with [Maybe.Just 1] -> True | _ -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Generates more nuanced exhaustiveness checks when using spread operatpr" $ do - result <- eval "match [] with [] -> True | [_] -> False | [_,...] -> False" - result - `shouldBe` Right - (MTPrim mempty MTBool, bool True) - - it "Matches an empty string" $ do - result <- eval "match \"\" with _ ++ _ -> True | \"\" -> False" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Matches an non-empty string" $ do - result <- eval "match \"dog\" with a ++ b -> (a,b) | \"\" -> (\"\", \"\")" - result - `shouldBe` Right - ( MTTuple mempty (MTPrim mempty MTString) (NE.singleton $ MTPrim mempty MTString), - MyTuple mempty (MyLiteral mempty (MyString "d")) (NE.singleton $ MyLiteral mempty (MyString "og")) - ) - - it "Fix empty pattern match obscuring bindings" $ do - result <- eval "\\a -> match Maybe.Nothing with (Maybe.Nothing) -> a | _ -> a" - result `shouldSatisfy` isRight - - describe "Error with List type" $ do - it "Is fine with no shadowed variables" $ do - let input = - mconcat - [ "\\a -> \\b -> match (a, b) with ", - "(Cons aa restA, Nil) -> (Cons aa restA)", - " | (Nil, Cons bb restB) -> (Cons bb restB)", - " | _ -> (Nil)" - ] - result <- evalWithDefs (Just "type List a = Cons a (List a) | Nil") input - result `shouldSatisfy` isRight - - it "Is fine with shadowed variables" $ do - let input = - mconcat - [ " \\a -> \\b -> match (a, b) with ", - "(Cons a restA, Nil) -> (Cons a restA)", - " | (Nil, Cons b restB) -> (Cons b restB)", - " | _ -> a" - ] - result <- evalWithDefs (Just "type List a = Cons a (List a) | Nil") input - result `shouldSatisfy` isRight - - describe "Too many generics in stringReduce" $ do - it "simpler type" $ do - let input = "\\a -> match a with head ++ tail -> head | _ -> \"\"" - result <- eval input - fst <$> result `shouldBe` Right (MTFunction () (MTPrim () MTString) (MTPrim () MTString)) - - it "type of function" $ do - let input = "String.reduce" - result <- eval input - fst <$> result - `shouldBe` Right - ( MTFunction - () - ( MTFunction - () - (MTVar () (TVUnificationVar 1)) - (MTFunction () (MTPrim () MTString) (MTVar () (TVUnificationVar 1))) - ) - ( MTFunction - () - (MTVar () (TVUnificationVar 1)) - (MTFunction () (MTPrim () MTString) (MTVar () (TVUnificationVar 1))) - ) - ) - - describe "Monoid losing types" $ do - it "Monoid.maybe with String.monoid" $ do - result <- eval "let monoid = Monoid.maybe String.monoid in monoid.mappend (Maybe.Just \"1\") Maybe.Nothing" - fst <$> result - `shouldBe` Right - ( dataTypeWithVars mempty (Just "Maybe") "Maybe" [MTPrim mempty MTString] - ) - it "Monoid.sum with Monoid.maybe" $ do - result <- eval "let monoid = Monoid.maybe Monoid.sum; monoid.mappend (Maybe.Just 1) Maybe.Nothing" - fst <$> result - `shouldBe` Right - ( dataTypeWithVars mempty (Just "Maybe") "Maybe" [MTPrim mempty MTInt] - ) - - describe "Tree interpreter error" $ do - let leaf = MyApp mempty (MyConstructor mempty Nothing "Leaf") - branch l a = - MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Branch") - l - ) - a - ) - it "Constructs a Tree" $ do - result <- eval "Tree.Leaf 1" - result `shouldSatisfy` isRight - - it "Reverses a leaf" $ do - result <- eval "Tree.invert (Tree.Leaf 1)" - snd <$> result - `shouldBe` Right (leaf (int 1)) - - it "Maps a tree" $ do - result <- eval "Tree.fmap (Prelude.const True) (Tree.Branch (Tree.Leaf 1) 2 (Tree.Leaf 3))" - result `shouldSatisfy` isRight - - it "Reverses a branch" $ do - result <- eval "Tree.invert (Tree.Branch (Tree.Leaf 1) 2 (Tree.Leaf 3))" - snd <$> result - `shouldBe` Right (branch (leaf (int 3)) (int 2) (leaf (int 1))) - - it "Reverses a small tree correctly" $ do - result <- eval "Tree.invert (Tree.Branch (Tree.Leaf 1) 2 (Tree.Branch (Tree.Leaf 3) 4 (Tree.Leaf 5)))" - snd <$> result - `shouldBe` Right (branch (branch (leaf (int 5)) (int 4) (leaf (int 3))) (int 2) (leaf (int 1))) - - it "Reversing a tree twice is identity" $ do - result <- eval "let tree = Tree.Branch (Tree.Leaf 1) 2 (Tree.Branch (Tree.Leaf 3) 4 (Tree.Leaf 5)); Tree.invert (Tree.invert tree) == tree" - snd <$> result - `shouldBe` Right (bool True) - - describe "delays arity check for infix operators" $ do - it "is fine" $ do - result <- - evalWithDefs - ( Just $ - defs - [ "def flip f a b = f b a", - "def and a b = if a then b else False", - "infix <<>> = flip and" - ] - ) - "True <<>> False" - result `shouldSatisfy` isRight - - describe "let with type annotation" $ do - it "should not parse without brackets" $ do - result <- eval "let a: Boolean = True in a" - result `shouldSatisfy` isLeft - - it "should typecheck" $ do - result <- eval "let (a: Boolean) = True in a" - result `shouldSatisfy` isRight - - it "should typecheck (with brackets)" $ do - result <- eval "let (a: Boolean) = True in a" - result `shouldSatisfy` isRight - - it "should not typecheck" $ do - result <- eval "let (a: Int) = True in a" - result `shouldSatisfy` isLeft - - it "should break with non-existent type" $ do - result <- eval "let (a: FooBar) = True in a" - result `shouldSatisfy` isLeft - - it "cannot assign concrete value to polymorphic type" $ do - result <- eval "let (a: anyA) = True in a" - result `shouldSatisfy` isLeft - - describe "regressions" $ do - it "should destructure record correctly" $ do - result <- eval "let { b: b } = { a: 5, b: 100 } in b" - result `shouldBe` Right (MTPrim mempty MTInt, int 100) - it "should show pattern match exhaustiveness error" $ do - result <- eval "let matcher a = match a with [] -> True; matcher [1]" - result `shouldSatisfy` textErrorContains "Pattern match is not exhaustive" - - describe "lambda with type annotation" $ do - it "should not parse without brackets" $ do - result <- eval "\\a -> a + 1 : Int -> Int" - result `shouldSatisfy` isLeft - - it "should parse without space" $ do - result <- eval "(\\a -> a + 1 : Int -> Int)" - result `shouldSatisfy` isRight - - it "should typecheck" $ do - result <- eval "(\\a -> a + 1 : Int -> Int)" - result `shouldSatisfy` isRight - - it "should typecheck (and print properly)" $ do - result <- eval "(\\a -> a : Maybe.Maybe a -> Maybe.Maybe a)" - result `shouldSatisfy` isRight - - it "should not typecheck if boolean and int do not match" $ do - result <- eval "(\\a -> a + 1 : Boolean -> Int)" - result `shouldSatisfy` isLeft - - it "should not typecheck if unifying int with 'a'" $ do - result <- eval "\\(abc: a) -> abc + 1" - result `shouldSatisfy` isLeft - - it "should unify named type variables with themselves" $ do - result <- eval "(\\abc -> \\defVal -> abc == defVal : a -> a -> Boolean)" - result `shouldSatisfy` isRight - - it "should not unify named type variables with one another" $ do - result <- eval "(\\abc -> \\defVal -> abc == defVal: a -> b -> Boolean)" - result `shouldSatisfy` isLeft - - it "should typecheck when id has a specific type" $ do - result <- eval "let (identity: a -> a) abc = abc; identity True" - fst <$> result `shouldBe` Right (MTPrim mempty MTBool) - - it "each type variable is unique to the scope it's introduced in" $ do - result <- eval "let (id1: a -> (a,a)) a = (a,a); let (id2: a -> a) b = b; id1 (id2 True)" - result `shouldSatisfy` isRight - - it "annotation does not match" $ do - result <- eval "let (f: a -> String -> a) a b = if True then a else b" - result `shouldSatisfy` isLeft - - it "annotation does not match (1)" $ do - result <- eval "(\\a -> \\b -> if True then a else b : String -> a -> String) \"Hi\" \"Lo\"" - result `shouldSatisfy` isLeft - - it "annotation does not match (2)" $ do - result <- eval "(\\a -> \\b -> if True then a else b : a -> String -> a) \"Hi\" \"Lo\"" - result `shouldSatisfy` isLeft - - it "annotation does not match (3)" $ do - result <- eval "(\\a -> a : a -> String) \"Hi\"" - result `shouldSatisfy` isLeft - - it "annotation does not match (4)" $ do - result <- eval "(\\a -> a : String -> a) \"Hi\"" - result `shouldSatisfy` isLeft - - describe "check if" $ do - it "spots mismatched predicate type" $ do - result <- eval "let (a: Int) = if 1 then 2 else 3; a" - result `shouldSatisfy` textErrorContains "Predicate for an if expression" - - describe "check app" $ do - it "spots function argument does not match with annotated function" $ do - result <- eval "(\\a -> a: Int -> Int) True" - result `shouldSatisfy` textErrorContains "Incorrect function argument" - - it "spots function argument does not match" $ do - result <- eval "(\\a -> a + 1) True" - result `shouldSatisfy` textErrorContains "Incorrect function argument" - - it "spots function argument does not match when it is used with a variable" $ do - result <- eval "let f a = a + 1; f True" - result `shouldSatisfy` textErrorContains "Incorrect function argument" - - describe "optimisations" $ do - it "should do all optimisations in one pass" $ do - result <- eval "\\opts -> let d = \"dog\"; match [\"a\", \"b\"] with [a, b, c] -> (Maybe.Just ((a, d))) | _ -> (Maybe.Nothing)" - result `shouldSatisfy` isRight - - describe "operators" $ do - it "Bind <<< to compose" $ do - result <- evalWithDefs (Just "infix <<< = Prelude.compose") "True" - -- binding to a two arity function is A++ - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - -- we don't seem to be checking this infix op's type - xit "Bind incrementInt to <<<" $ do - result <- - evalWithDefs - ( Just $ - defs - [ "def incrementInt a = a + 1", - "infix <<< = incrementInt" - ] - ) - "True" - -- we can only bind to a two arity function - result `shouldSatisfy` isLeft - - it "define +++ as infix and use it" $ do - result <- - evalWithDefs - (Just $ defs ["def addInt a b = a + b", "infix +++ = addInt"]) - "1 +++ 2" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - - it "multiple uses of infix with same type" $ do - result <- - evalWithDefs - (Just $ defs ["def incrementInt a = a + 1", "def apply a f = f a", "infix |> = apply"]) - "1 |> incrementInt |> incrementInt" - result `shouldBe` Right (MTPrim mempty MTInt, int 3) - - it "multiple uses of infix with same type 2" $ do - result <- - evalWithDefs - (Just $ defs ["def incrementInt a = a + 1", "def isOne a = a == 1", "def apply a f = f a", "infix |> = apply"]) - "1 |> incrementInt |> isOne" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "multiple uses of infix with different types" $ do - result <- - evalWithDefs - ( Just $ - defs - [ "def incrementInt a = a + 1", - "def apply a f = f a", - "infix |> = apply" - ] - ) - "1 |> incrementInt |> State.pure" - result `shouldSatisfy` isRight - - it "Can't override a built-in infix op" $ do - result <- evalWithDefs (Just $ defs ["def addInt a b = a + b", "infix == = addInt"]) "True" - -- can't overwrite built in infix operators - result `shouldSatisfy` isLeft - - it "Binds addInt to +++" $ do - result <- evalWithDefs (Just $ defs ["def addInt a b = a + b", "infix +++ = addInt"]) "1 +++ True" - -- function typechecking should still work - result `shouldSatisfy` isLeft - - it "Greater than 1" $ do - result <- eval "10 > 1" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Greater than 2" $ do - result <- eval "1 > 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Greater than 3" $ do - result <- eval "True < 1" - result `shouldSatisfy` isLeft - - it "Greater than or equal to 1" $ do - result <- eval "10 >= 1" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Greater than or equal to 2" $ do - result <- eval "10 >= 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Greater than or equal to 3" $ do - result <- eval "9 >= 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Less than 1" $ do - result <- eval "1 < 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Less than 2" $ do - result <- eval "10 < 1" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - it "Less than or equal to 1" $ do - result <- eval "1 <= 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Less than or equal to 2" $ do - result <- eval "10 <= 10" - result `shouldBe` Right (MTPrim mempty MTBool, bool True) - - it "Less than or equal to 3" $ do - result <- eval "10 <= 9" - result `shouldBe` Right (MTPrim mempty MTBool, bool False) - - describe "Tuple access" $ do - it "Can't index below 1" $ do - result <- eval "(1,2,3).0" - result `shouldSatisfy` isLeft - - it "Can't index past length" $ do - result <- eval "(1,2,3).4" - result `shouldSatisfy` isLeft - - it "First item works" $ do - result <- eval "(10,True,\"dog\").1" - result `shouldBe` Right (MTPrim mempty MTInt, int 10) - - it "Third item works" $ do - result <- eval "(10,True,\"dog\").3" - result `shouldBe` Right (MTPrim mempty MTString, str "dog") - - it "Access from var works" $ do - result <- eval "let tup = (10,True,\"dog\") in tup.3" - result `shouldBe` Right (MTPrim mempty MTString, str "dog") - - it "Nested access from var works" $ do - result <- eval "let tup = (10,True,(1,2,\"dog\")) in tup.3.3" - result `shouldBe` Right (MTPrim mempty MTString, str "dog") - - describe "Big stuff that breaks interpreter" $ do - it "Uses Parser.char" $ do - let expr = "Parser.char" - result <- eval expr - result `shouldSatisfy` isRight - - it "Parses using a lexeme" $ do - let expr = - mconcat - [ "let lexeme p = Parser.left p Parser.space0; ", - "let bracketL = lexeme (Parser.char \"[\"); ", - "Parser.run bracketL \"[ \"" - ] - result <- eval expr - result `shouldSatisfy` isRight - - it "Parses a JSON array" $ do - let expr = - mconcat - [ "let lexeme p = Parser.left p Parser.space0; ", - "let bracketL = lexeme (Parser.char \"[\"); ", - "let bracketR = lexeme (Parser.char \"]\"); ", - "let comma = lexeme (Parser.char \",\"); ", - "let inner = lexeme (Parser.char \"d\"); ", - "let bigP = Parser.right bracketL (Parser.left (Parser.sepBy comma inner) bracketR); ", - "Parser.run bigP \"[d,d,d,d]\"" - ] - result <- eval expr - result `shouldSatisfy` isRight diff --git a/compiler/test/Test/Modules/Test.hs b/compiler/test/Test/Modules/Test.hs deleted file mode 100644 index 7536b456..00000000 --- a/compiler/test/Test/Modules/Test.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.Test - ( spec, - ) -where - -import Data.Either (isLeft) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Modules.Check as Actions -import qualified Language.Mimsa.Actions.Modules.RunTests as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Tests -import Test.Hspec -import Test.Utils.Helpers - -runTests :: Text -> Either (Error Annotation) ModuleTestResults -runTests t = do - let action = do - (modA, _tyA) <- Actions.checkModule (prjModuleStore stdlib) t - Actions.runModuleTests modA - (_, _, a) <- Actions.run stdlib action - pure a - -spec :: Spec -spec = do - describe "Modules tests" $ do - it "Trivial passing unit test" $ - runTests - (joinLines ["test \"2 equals 2\" = 2 == 2"]) - `shouldBe` Right (ModuleTestResults (M.singleton (TestName "2 equals 2") ModuleTestPassed)) - - it "Trivial failing unit test" $ - runTests - (joinLines ["test \"2 equals 3\" = 2 == 3"]) - `shouldBe` Right (ModuleTestResults (M.singleton (TestName "2 equals 3") ModuleTestFailed)) - - it "A test that does not typecheck with Boolean fails" $ - runTests - (joinLines ["test \"2 equals 2\" = 2"]) - `shouldSatisfy` isLeft - - it "Passing unit test using module functions" $ - runTests - ( joinLines - [ "test \"identity 2 equals 2\" = id 2 == 2", - "def id a = a" - ] - ) - `shouldBe` Right (ModuleTestResults (M.singleton (TestName "identity 2 equals 2") ModuleTestPassed)) - - it "Runs a trivial test that refers to a Prelude expression" $ do - let preludeHash = fromJust (M.lookup "Prelude" (getCurrentModules $ prjModules stdlib)) - in runTests - ( joinLines - [ "test \"Prelude.id 2 equals 2\" = Prelude.id 2 == 2", - "import Prelude from " <> prettyPrint preludeHash - ] - ) - `shouldBe` Right (ModuleTestResults (M.singleton (TestName "Prelude.id 2 equals 2") ModuleTestPassed)) diff --git a/compiler/test/Test/Modules/ToStoreExprs.hs b/compiler/test/Test/Modules/ToStoreExprs.hs deleted file mode 100644 index 3482bd5b..00000000 --- a/compiler/test/Test/Modules/ToStoreExprs.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.ToStoreExprs - ( spec, - ) -where - -import Data.Functor -import qualified Data.Map.Strict as M -import Language.Mimsa.Core hiding (parseModule) -import Language.Mimsa.Modules.HashModule -import Language.Mimsa.Modules.Parse -import Language.Mimsa.Modules.ToStoreExprs -import Language.Mimsa.Modules.Typecheck -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store -import Test.Hspec -import Test.Utils.Helpers - -toStoreExpressions' :: Module Annotation -> CompiledModule Annotation -toStoreExpressions' mod' = - let action :: Either (Error Annotation) (CompiledModule Annotation) - action = do - tcMods <- typecheckAllModules mempty (prettyPrint mod') mod' - case M.lookup (snd $ serializeModule mod') tcMods of - Just tcMod -> (fmap . fmap) getAnnotationForType (toStoreExpressions tcMods tcMod) - Nothing -> error "Could not find the module we just typechecked" - in fromRight action - -spec :: Spec -spec = do - describe "Compile modules" $ do - it "Empty module, no outputs" $ do - toStoreExpressions' mempty - `shouldBe` CompiledModule - { cmStore = mempty, - cmExprs = mempty - } - it "Single expression, single output with no deps" $ do - let expr = unsafeParseExpr "\\a -> a" $> mempty - storeExpr = StoreExpression expr mempty mempty mempty mempty - hash = getStoreExpressionHash storeExpr - inputModule = - mempty - { moExpressions = M.singleton (DIName "id") expr - } - expected = - CompiledModule - { cmStore = Store $ M.singleton hash storeExpr, - cmExprs = M.singleton (DIName "id") hash - } - toStoreExpressions' inputModule `shouldBe` expected - it "Two expressions, one depends on the other" $ do - let exprA = unsafeParseExpr "\\a -> a" $> mempty - storeExprA = StoreExpression exprA mempty mempty mempty mempty - hashA = getStoreExpressionHash storeExprA - - exprB = unsafeParseExpr "id 100" $> mempty - storeExprB = StoreExpression exprB (M.singleton (Nothing, "id") hashA) mempty mempty mempty - hashB = getStoreExpressionHash storeExprB - - inputModule = - mempty - { moExpressions = - M.fromList - [ (DIName "id", exprA), - (DIName "useId", exprB) - ] - } - expected = - CompiledModule - { cmStore = - Store $ - M.fromList - [ (hashA, storeExprA), - (hashB, storeExprB) - ], - cmExprs = - M.fromList - [ (DIName "id", hashA), - (DIName "useId", hashB) - ] - } - toStoreExpressions' inputModule `shouldBe` expected - - it "Two expressions, one type, second expression uses type indirectly and should have it as a dep" $ do - let lookupInCompiled name compiled = - fromJust $ M.lookup (DIName name) (cmExprs compiled) >>= \hash -> M.lookup hash (getStore (cmStore compiled)) - - let inputModule = - fromRight $ - parseModule mempty $ - joinLines - [ "export type Either e a = Left e | Right a", - "def useEither val = match val with Right a -> a | _ -> False", - "def shouldHaveEitherAsDep val = useEither val" - ] - output = toStoreExpressions' inputModule - -- three output items - cmStore output `shouldSatisfy` \(Store a) -> M.size a == 3 - -- main one has Either as dep - let shouldHaveEither = lookupInCompiled "shouldHaveEitherAsDep" output - storeTypes shouldHaveEither `shouldSatisfy` \a -> M.size a == 1 diff --git a/compiler/test/Test/Modules/Uses.hs b/compiler/test/Test/Modules/Uses.hs deleted file mode 100644 index 7913898f..00000000 --- a/compiler/test/Test/Modules/Uses.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.Uses - ( spec, - ) -where - -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Modules.Uses -import Test.Hspec - -spec :: Spec -spec = do - describe "Uses" $ do - describe "extractUsesTyped" $ do - it "Finds no types" $ do - let entities = extractUsesTyped (MyLiteral (MTPrim () MTInt) (MyInt 1)) - entities `shouldSatisfy` S.null - - it "Finds one type" $ do - let entities = extractUsesTyped (MyVar (MTConstructor () Nothing "Unit") Nothing "a") - entities `shouldBe` S.fromList [EName "a", EType "Unit"] - - it "Finds one type in type app" $ do - let entities = extractUsesTyped (MyVar (MTTypeApp () (MTConstructor () Nothing "Maybe") (MTPrim () MTInt)) Nothing "a") - entities `shouldBe` S.fromList [EName "a", EType "Maybe"] - - it "Finds one namespaced type" $ do - let entities = extractUsesTyped (MyVar (MTConstructor () (Just "Prelude") "Unit") Nothing "a") - entities `shouldBe` S.fromList [EName "a", ENamespacedType "Prelude" "Unit"] - - it "Finds Either" $ do - let expr :: Expr Name (Type ()) - expr = - MyLambda - { expAnn = - MTFunction - { typAnn = (), - typArg = - MTTypeApp {typAnn = (), typFunc = MTTypeApp {typAnn = (), typFunc = MTConstructor {typAnn = (), typModuleName = Nothing, typTypeName = "Either"}, typArg = MTVar {typAnn = (), typIdent = TVUnificationVar {tiUniVar = 3}}}, typArg = MTPrim {typAnn = (), typPrim = MTBool}}, - typRes = MTPrim {typAnn = (), typPrim = MTBool} - }, - expBinder = Identifier {idAnn = MTTypeApp {typAnn = (), typFunc = MTTypeApp {typAnn = (), typFunc = MTConstructor {typAnn = (), typModuleName = Nothing, typTypeName = "Either"}, typArg = MTVar {typAnn = (), typIdent = TVUnificationVar {tiUniVar = 3}}}, typArg = MTPrim {typAnn = (), typPrim = MTBool}}, idVar = "val"}, - expBody = - MyApp - { expAnn = MTPrim {typAnn = (), typPrim = MTBool}, - expFunc = - MyVar - { expAnn = - MTFunction - { typAnn = (), - typArg = - MTTypeApp - { typAnn = (), - typFunc = - MTTypeApp - { typAnn = (), - typFunc = - MTConstructor {typAnn = (), typModuleName = Nothing, typTypeName = "Either"}, - typArg = MTVar {typAnn = (), typIdent = TVUnificationVar {tiUniVar = 3}} - }, - typArg = - MTPrim {typAnn = (), typPrim = MTBool} - }, - typRes = MTPrim {typAnn = (), typPrim = MTBool} - }, - expModuleName = Nothing, - expVar = "useEither" - }, - expArg = MyVar {expAnn = MTTypeApp {typAnn = (), typFunc = MTTypeApp {typAnn = (), typFunc = MTConstructor {typAnn = (), typModuleName = Nothing, typTypeName = "Either"}, typArg = MTVar {typAnn = (), typIdent = TVUnificationVar {tiUniVar = 3}}}, typArg = MTPrim {typAnn = (), typPrim = MTBool}}, expModuleName = Nothing, expVar = "val"} - } - } - extractUsesTyped expr `shouldBe` S.fromList [EType "Either", EName "useEither"] diff --git a/compiler/test/Test/Project/NormaliseType.hs b/compiler/test/Test/Project/NormaliseType.hs deleted file mode 100644 index 59090347..00000000 --- a/compiler/test/Test/Project/NormaliseType.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Project.NormaliseType - ( spec, - ) -where - -import Data.Coerce -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.NormaliseTypes -import Test.Hspec - -mkVar :: Int -> MonoType -mkVar i = MTVar mempty (TVUnificationVar i) - -mkNameVar :: Text -> MonoType -mkNameVar n = MTVar mempty (TVName (coerce n)) - -normaliseType' :: MonoType -> MonoType -normaliseType' = normaliseType - -spec :: Spec -spec = - describe "Normalise type" $ do - it "Literals are the same" $ - normaliseType' (MTPrim mempty MTInt) - `shouldBe` MTPrim mempty MTInt - it "Unification var starts at 1" $ - normaliseType' (mkVar 10) - `shouldBe` mkVar 1 - it "The same vars should get the same numbers " $ - normaliseType' (MTTuple mempty (mkVar 10) (NE.singleton $ mkVar 10)) - `shouldBe` MTTuple mempty (mkVar 1) (NE.singleton $ mkVar 1) - it "We increase the value we return as we go" $ - normaliseType' (MTTuple mempty (mkVar 10) (NE.singleton $ mkVar 8)) - `shouldBe` MTTuple mempty (mkVar 1) (NE.singleton $ mkVar 2) - it "Repeating an earlier value does not break it" $ - normaliseType' - ( MTTuple - mempty - (mkVar 10) - (NE.singleton $ MTTuple mempty (mkVar 8) (NE.singleton $ mkVar 10)) - ) - `shouldBe` MTTuple - mempty - (mkVar 1) - ( NE.singleton $ - MTTuple - mempty - (mkVar 2) - (NE.singleton $ mkVar 1) - ) - it "Normalises named variables too" $ - normaliseType' - ( MTFunction - mempty - (mkNameVar "a") - (MTFunction mempty (mkNameVar "b") (mkNameVar "a")) - ) - `shouldBe` MTFunction - mempty - (mkVar 1) - ( MTFunction - mempty - (mkVar 2) - (mkVar 1) - ) diff --git a/compiler/test/Test/Project/SourceSpan.hs b/compiler/test/Test/Project/SourceSpan.hs deleted file mode 100644 index 348ba73d..00000000 --- a/compiler/test/Test/Project/SourceSpan.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Project.SourceSpan (spec) where - -import Language.Mimsa.Core -import Language.Mimsa.Project.SourceSpan -import Language.Mimsa.Types.Project.SourceSpan -import Test.Hspec - -spec :: Spec -spec = - describe "SourceSpan" $ do - it "Simple" $ - sourceSpan "dog" (Location 0 2) - `shouldBe` Just - ( SourceSpan - { ssRowStart = 1, - ssRowEnd = 1, - ssColStart = 1, - ssColEnd = 3 - } - ) - it "Second line" $ - sourceSpan "dog\nlog" (Location 4 6) - `shouldBe` Just - ( SourceSpan - { ssRowStart = 2, - ssRowEnd = 2, - ssColStart = 1, - ssColEnd = 3 - } - ) - it "Across lines" $ - sourceSpan "a\ngood\ndog" (Location 2 9) - `shouldBe` Just - ( SourceSpan - { ssRowStart = 2, - ssRowEnd = 3, - ssColStart = 1, - ssColEnd = 3 - } - ) diff --git a/compiler/test/Test/Project/Stdlib.hs b/compiler/test/Test/Project/Stdlib.hs deleted file mode 100644 index 0dbd9fa6..00000000 --- a/compiler/test/Test/Project/Stdlib.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Project.Stdlib - ( spec, - ) -where - -import Control.Monad.IO.Class -import Data.Either -import Data.Foldable -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Helpers.LookupExpression as Actions -import qualified Language.Mimsa.Actions.Modules.Check as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Project -import Test.Hspec - -moduleTypechecksSuccessfully :: - Project Annotation -> - (ModuleName, ModuleHash) -> - Spec -moduleTypechecksSuccessfully project (modName, modHash) = - it ("Typechecks module " <> T.unpack (prettyPrint modName) <> " from stdlib") $ do - let action = do - thisMod <- Actions.lookupModule modHash - Actions.checkModule (prjModuleStore project) (prettyPrint thisMod) - Actions.run project action `shouldSatisfy` isRight - -spec :: Spec -spec = do - describe "Stdlib" $ do - it "Builds" $ do - buildStdlib `shouldSatisfy` isRight - - describe "Can typecheck each top-level module" $ do - case buildStdlib of - Right prj -> - let moduleNames = M.toList . getCurrentModules . prjModules $ prj - in traverse_ (moduleTypechecksSuccessfully prj) moduleNames - Left e -> - it "could not create stdlib" $ do - liftIO (putStrLn (T.unpack (prettyPrint e))) - False `shouldBe` True diff --git a/compiler/test/Test/RenderErrors.hs b/compiler/test/Test/RenderErrors.hs deleted file mode 100644 index d60445a2..00000000 --- a/compiler/test/Test/RenderErrors.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.RenderErrors (spec) where - --- this prints out loads of errors so we can look at them and decide if they --- look bad - -import Control.Monad.IO.Class -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Error.Diagnose hiding (Annotation) -import qualified Language.Mimsa.Actions.Helpers.Parse as Actions -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib (buildStdlib) -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Test.Hspec - -stdlib :: Project Annotation -stdlib = case buildStdlib of - Right a -> a - _ -> error "Error building stdlib in error printing tests" - -printError :: - Project Annotation -> - Text -> - Expectation -printError env input = do - let action = do - expr <- Actions.parseExpr input - (mt, interpretedExpr, _) <- Actions.evaluateModule expr mempty - pure (mt, interpretedExpr) - case Actions.run env action of - Right (_, _, result) -> do - liftIO $ - putStrLn - ("Expected error, got " <> T.unpack (prettyPrint result)) - False `shouldBe` True - Left err' -> do - let diag = errorToDiagnostic err' - liftIO (T.putStrLn "\n---") - liftIO (T.putStrLn input) - liftIO $ printDiagnostic stderr True True 4 defaultStyle diag - liftIO (T.putStrLn "---\n") - True `shouldBe` True - -spec :: Spec -spec = - describe "Error printing" $ do - describe "Store errors" $ do - it "Cannot find dependency" $ do - printError stdlib "mysteryFunction (1,2)" - describe "Type errors" $ do - it "Non-boolean in If predicate" $ do - printError stdlib "if 1 then True else False" - it "Non-boolean in If predicate with annotation" $ do - printError stdlib "let (a: Boolean) = if 1 then True else False; 1" - it "Non-boolean from function in if predicate" $ do - printError stdlib "let f a = if a then 1 else 2; f 1" - it "Non-matching if branches" $ do - printError stdlib "if True then 1 else False" - it "Patterns do not match input" $ do - printError stdlib "match Just True with Right a -> a | _ -> False" - it "Pattern match branches have different types" $ do - printError stdlib "match Just True with Just a -> a | _ -> 100" - it "Defines a type twice" $ do - printError stdlib "type Dog = Dog; type Dog = Log; True" - it "Pattern match with no matches" $ do - printError stdlib "match True with" - it "Type constructor uses variable not found in type" $ do - printError stdlib "type Maybe a = Just b; True" - it "Uses built-in type as constructor in type definition" $ do - printError stdlib "type Dog = String Int; True" - it "Annotated function called with wrong type argument" $ do - printError stdlib "let (f: Int -> Boolean) i = True; f False" - it "Inferred function called with wrong type argument" $ do - printError stdlib "let f i = i + 1; f False" - it "Applied a value to non-function" $ do - printError stdlib "let f = 1; f True" - it "Applied wrong value to lambda" $ do - printError stdlib "(\\a -> a + 1) True" - it "Applies two args to single arity func" $ do - printError stdlib "let f a = a + 1; f 1 True" diff --git a/compiler/test/Test/Serialisation.hs b/compiler/test/Test/Serialisation.hs deleted file mode 100644 index 0d94a81c..00000000 --- a/compiler/test/Test/Serialisation.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Serialisation - ( spec, - ) -where - -import Data.Either (partitionEithers) -import Language.Mimsa.Types.Project -import Test.Hspec -import Test.Utils.Serialisation - -catEithers :: [Either e a] -> [a] -catEithers as = snd $ partitionEithers as - -spec :: Spec -spec = - describe "Serialisation" $ do - it "StoreExpression JSON" $ do - files <- getAllFilesInDir "StoreExpr" "json" - loaded <- traverse loadStoreExpression files - length (catEithers loaded) `shouldBe` length loaded - - it "Project JSON" $ do - files <- getAllFilesInDir "SaveProject" "json" - loaded <- traverse (loadJSON @SaveProject) files - length (catEithers loaded) `shouldBe` length loaded diff --git a/compiler/test/Test/Tests/Properties.hs b/compiler/test/Test/Tests/Properties.hs deleted file mode 100644 index dc2f3b9a..00000000 --- a/compiler/test/Test/Tests/Properties.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Tests.Properties - ( spec, - ) -where - -import Control.Monad.IO.Class -import Data.Either (isLeft, isRight) -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Store.ResolveDataTypes -import Language.Mimsa.Tests.Generate -import Language.Mimsa.Tests.Helpers -import Language.Mimsa.Typechecker.CreateEnv -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Typechecker.Typecheck -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store -import Test.Data.Project -import Test.Hspec -import Test.Utils.Helpers - -getStoreExprs :: Project Annotation -> [StoreExpression Annotation] -getStoreExprs = - M.elems - . getStore - . prjStore - -itTypeChecks :: MonoType -> Expr Name Annotation -> Either TypeError () -itTypeChecks mt expr = do - let numberedExpr = - fromRight - ( addNumbersToStoreExpression - expr - mempty - ) - let elabbed = - fmap (\(_, _, a, _) -> a) - . typecheck - mempty - ( createEnv - mempty - (createTypeMap $ getStoreExprs testStdlib) - mempty - mempty - ) - $ numberedExpr - generatedMt <- getTypeFromAnn <$> elabbed - unifies mt generatedMt - -itGenerates :: MonoType -> Expectation -itGenerates mt = do - samples <- liftIO $ generateFromMonoType @() (createTypeMap $ getStoreExprs testStdlib) mt - let success = traverse (itTypeChecks mt) (fmap ($> mempty) samples) - success `shouldSatisfy` isRight - -spec :: Spec -spec = do - -- skipping as these tests need types found in the stdlib - -- will need it to learn to use modules - xdescribe "Properties" $ do - describe "Test the testing" $ do - it "typechecking check works" $ do - itTypeChecks (MTPrim mempty MTInt) (MyLiteral mempty (MyInt 100)) - `shouldSatisfy` isRight - it "typechecking fail works" $ do - itTypeChecks (MTPrim mempty MTBool) (MyLiteral mempty (MyInt 100)) - `shouldSatisfy` isLeft - describe "isRecursive" $ do - it "unit is not recursive" $ do - isRecursive "Unit" [] `shouldBe` False - it "maybe is not recursive 2" $ do - isRecursive "Maybe" [MTPrim mempty MTInt] `shouldBe` False - it "list is recursive" $ do - isRecursive - "List" - [ MTTypeApp mempty (MTConstructor mempty Nothing "List") (MTPrim mempty MTInt) - ] - `shouldBe` True - - describe "Test generators" $ do - it "Bool" $ do - itGenerates mtBool - it "Int" $ do - itGenerates mtInt - it "String" $ do - itGenerates mtString - it "Array of ints" $ do - itGenerates (MTArray mempty mtInt) - it "Pair of int and string" $ do - itGenerates (MTTuple mempty mtInt (NE.singleton mtString)) - it "Records" $ do - let record = MTRecord mempty (M.fromList [("dog", mtInt), ("cat", mtBool)]) Nothing - itGenerates record - it "Functions" $ do - itGenerates (MTFunction mempty mtBool mtInt) - it "Nested functions" $ do - itGenerates (MTFunction mempty mtString (MTFunction mempty mtBool mtInt)) - it "Constructor" $ do - itGenerates (MTConstructor mempty Nothing "TrafficLight") - it "Constructor with var" $ do - itGenerates (MTTypeApp mempty (MTConstructor mempty Nothing "Maybe") mtInt) - it "Constructor with nested vars" $ do - itGenerates (MTTypeApp mempty (MTConstructor mempty Nothing "Tree") mtBool) diff --git a/compiler/test/Test/Transform/BetaReduce.hs b/compiler/test/Test/Transform/BetaReduce.hs deleted file mode 100644 index d534d9e9..00000000 --- a/compiler/test/Test/Transform/BetaReduce.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.BetaReduce - ( spec, - ) -where - -import Language.Mimsa.Transform.BetaReduce -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "BetaReduce" $ do - it "Does nothing when no pattern match" $ do - let expr = unsafeParseExpr "let a = True in 1" - betaReduce expr `shouldBe` expr - it "Turns app lambda val in let val" $ do - let expr = unsafeParseExpr "(\\x -> x + 2) 3" - expected = unsafeParseExpr "let x = 3 in x + 2" - betaReduce expr `shouldBe` expected - it "Turns app lambda val in let val without type signature" $ do - let expr = unsafeParseExpr "(\\x -> x : a -> a) 3" - expected = unsafeParseExpr "let x = 3 in x" - betaReduce expr `shouldBe` expected - it "Removes redundant if statement" $ do - let expr = unsafeParseExpr "if True then 1 else 2" - expected = unsafeParseExpr "1" - betaReduce expr `shouldBe` expected - it "Removes redundant if statement (2)" $ do - let expr = unsafeParseExpr "if False then 1 else 2" - expected = unsafeParseExpr "2" - betaReduce expr `shouldBe` expected - it "Removes record-and-record-get" $ do - let expr = unsafeParseExpr "{ dog: True }.dog" - expected = unsafeParseExpr "True" - betaReduce expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/EtaReduce.hs b/compiler/test/Test/Transform/EtaReduce.hs deleted file mode 100644 index 3f0ea891..00000000 --- a/compiler/test/Test/Transform/EtaReduce.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.EtaReduce - ( spec, - ) -where - -import Language.Mimsa.Transform.EtaReduce -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "EtaReduce" $ do - it "Does nothing when no function" $ do - let expr = unsafeParseExpr "let a = True in 1" - etaReduce expr `shouldBe` expr - - it "Doesn't mess things up" $ do - let expr = unsafeParseExpr "\\a -> const a 1" - etaReduce expr `shouldBe` expr - - it "Doesn't mess things up 2" $ do - let expr = unsafeParseExpr "\\a -> \\b -> const b a" - etaReduce expr `shouldBe` expr - - it "Removes unnecessary lambda on single arity function" $ do - let expr = unsafeParseExpr "\\a -> id a" - expected = unsafeParseExpr "id" - etaReduce expr `shouldBe` expected - - it "Removes unnecessary lambda on two arity function" $ do - let expr = unsafeParseExpr "\\a -> const 1 a" - expected = unsafeParseExpr "const 1" - etaReduce expr `shouldBe` expected - - it "Removes two unnecessary lambdas on two arity function" $ do - let expr = unsafeParseExpr "\\a -> \\b -> const a b" - expected = unsafeParseExpr "const" - etaReduce expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/FindUnused.hs b/compiler/test/Test/Transform/FindUnused.hs deleted file mode 100644 index f1158b74..00000000 --- a/compiler/test/Test/Transform/FindUnused.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Transform.FindUnused - ( spec, - ) -where - -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUnused -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "FindUnused" $ - do - it "Nothing in literal" $ do - findUnused @Annotation @Name (bool True) - `shouldBe` mempty - it "Finds `a` in simple Let assignment" $ do - findUnused @Annotation @Name - (MyLet mempty (Identifier mempty "a") (bool True) (bool True)) - `shouldBe` S.singleton ("a", mempty) - it "Does not find `a` when it is returned later from Let" $ do - findUnused @Annotation @Name - (MyLet mempty (Identifier mempty "a") (bool True) (MyVar mempty Nothing "a")) - `shouldBe` mempty - it "Finds `a` in a pattern match" $ do - findUnused @Annotation @Name - (MyPatternMatch mempty (bool True) [(PVar mempty "a", bool True)]) - `shouldBe` S.singleton ("a", mempty) - it "Finds `a` in a let pattern match" $ do - findUnused @Annotation @Name - (MyLetPattern mempty (PVar mempty "a") (bool True) (bool True)) - `shouldBe` S.singleton ("a", mempty) - - it "Does not find `a` when it is used in a pattern match" $ do - findUnused @Annotation @Name - (MyPatternMatch mempty (bool True) [(PVar mempty "a", MyVar mempty Nothing "a")]) - `shouldBe` mempty - - describe "removeUnused" $ do - it "No change in literal" $ do - let expr = bool True - removeUnused @Annotation @Name expr - `shouldBe` expr - it "Remove Let with `a` in simple Let assignment" $ do - let expr = MyLet mempty (Identifier mempty "a") (bool True) (bool True) - removeUnused @Annotation @Name expr - `shouldBe` bool True - it "Turns `a` in pattern match to PWildcard" $ do - let expr = MyPatternMatch mempty (bool True) [(PVar mempty "a", bool True)] - expected = MyPatternMatch mempty (bool True) [(PWildcard mempty, bool True)] - removeUnused @Annotation @Name expr - `shouldBe` expected - it "Turns `a` in let pattern match to PWildcard" $ do - let expr = MyLetPattern mempty (PVar mempty "a") (bool True) (bool True) - expected = MyLetPattern mempty (PWildcard mempty) (bool True) (bool True) - removeUnused @Annotation @Name expr - `shouldBe` expected - it "Removes let behind a lambda" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - (MyLet mempty (Identifier mempty "b") (bool True) (MyVar mempty Nothing "a")) - expected = MyLambda mempty (Identifier mempty "a") (MyVar mempty Nothing "a") - removeUnused @Annotation @Name expr - `shouldBe` expected - it "Removes from broken thing" $ do - let expr = unsafeParseExpr "let fold f total either = match either with (Left e) -> total | (Right a1) -> (f total a1); fold" - expected = unsafeParseExpr "let fold f total either = match either with (Left _) -> total | (Right a1) -> (f total a1); fold" - removeUnused expr `shouldBe` expected - it "Removes from second broken thing" $ do - let expr = unsafeParseExpr "let d = \"dog\"; \\opts -> match [ \"a\", \"b\" ] with [a, b, c] -> (Just ((a, d))) | _ -> (Nothing)" - expected = unsafeParseExpr "let d = \"dog\"; \\opts -> match [ \"a\", \"b\" ] with [a, _, _] -> (Just ((a, d))) | _ -> (Nothing)" - removeUnused expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/FindUses.hs b/compiler/test/Test/Transform/FindUses.hs deleted file mode 100644 index 45207fc2..00000000 --- a/compiler/test/Test/Transform/FindUses.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Transform.FindUses - ( spec, - ) -where - -import qualified Data.Map.Strict as M -import Data.Monoid -import Language.Mimsa.Core -import Language.Mimsa.Transform.FindUses -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "FindUses" $ do - it "Nothing in literal" $ do - findUses @Name @Annotation (bool True) - `shouldBe` mempty - it "One in var uses" $ do - findUses (unsafeParseExpr "let a = 1 in a") - `shouldBe` Uses (M.singleton (Nothing, "a") (Sum 1)) - it "Does not find uses of a var in it's own recursive def" $ do - findUses (unsafeParseExpr "let a b = if b == 0 then 0 else a (b - 1) in a") - `shouldBe` Uses (M.fromList [((Nothing, "a"), Sum 1), ((Nothing, "b"), Sum 2)]) diff --git a/compiler/test/Test/Transform/FlattenLets.hs b/compiler/test/Test/Transform/FlattenLets.hs deleted file mode 100644 index f319cf4d..00000000 --- a/compiler/test/Test/Transform/FlattenLets.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.FlattenLets - ( spec, - ) -where - -import Language.Mimsa.Core -import Language.Mimsa.Transform.FlattenLets -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "FlattenLets" $ do - describe "Remove nested lets" $ do - it "Does nothing when no nested lets" $ do - let expr = unsafeParseExpr "let a = True in 1" - flattenLets expr `shouldBe` expr - it "Flattens a let" $ do - let expr = unsafeParseExpr "let a = (let b = 1 in True) in a + 1" - expected = unsafeParseExpr "let b = 1; let a = True; a + 1" - flattenLets expr `shouldBe` expected - it "Flattens many lets" $ do - let expr = unsafeParseExpr "let a = (let b = (let c = 1 in c) in True) in a + 1" - expected = unsafeParseExpr "let c = 1; let b = c; let a = True; a + 1" - flattenLets expr `shouldBe` expected - describe "Simple let patterns become Let again" $ do - it "Turns a simple let pattern into let" $ do - let expr = MyLetPattern () (PVar mempty ("a" :: String)) (int 1) (MyVar mempty Nothing "a") - expected = MyLet mempty (Identifier mempty "a") (int 1) (MyVar mempty Nothing "a") - flattenLets expr `shouldBe` expected - describe "Single match pattern matches become let patterns" $ do - it "Leaves a multiple pattern match alone" $ do - let expr = unsafeParseExpr "match [1,2,3] with [] -> True | other -> False" - flattenLets expr `shouldBe` expr - it "Converts a single match into a Let Pattern" $ do - let expr = unsafeParseExpr "match (Identity 1) with (Identity a) -> a" - expected = unsafeParseExpr "let (Identity a) = Identity 1 in a" - flattenLets expr `shouldBe` expected - describe "Remove unbound let" $ do - it "Removes let pattern with wildcard" $ do - let expr = unsafeParseExpr "let _ = 1 in 2" - expected = unsafeParseExpr "2" - flattenLets expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/FloatDown.hs b/compiler/test/Test/Transform/FloatDown.hs deleted file mode 100644 index 876f5efb..00000000 --- a/compiler/test/Test/Transform/FloatDown.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.FloatDown - ( spec, - ) -where - -import Language.Mimsa.Transform.FloatDown -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "FloatDown" $ do - it "Does nothing when no pattern match" $ do - let expr = unsafeParseExpr "let a = True in 1" - floatDown expr `shouldBe` expr - it "Pushes a let into each pattern branch" $ do - let expr = unsafeParseExpr "let a = 1 in match True with True -> 1 | False -> 2" - expected = unsafeParseExpr "match True with True -> let a = 1 in 1 | False -> let a = 1 in 2" - floatDown expr `shouldBe` expected - it "Does not pushes a let when it matches on the let value" $ do - let expr = unsafeParseExpr "let a = 1 in match a with True -> 1 | False -> 2" - floatDown expr `shouldBe` expr - it "Pushes multiple lets into each pattern branch" $ do - let expr = unsafeParseExpr "let a = 1; let b = a + 1 in match True with True -> 1 | False -> 2" - expected = unsafeParseExpr "match True with True -> let a = 1; let b = a + 1 in 1 | False -> let a = 1; let b = a + 1 in 2" - floatDown expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/FloatUp.hs b/compiler/test/Test/Transform/FloatUp.hs deleted file mode 100644 index 645893dc..00000000 --- a/compiler/test/Test/Transform/FloatUp.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.FloatUp - ( spec, - ) -where - -import Language.Mimsa.Transform.FloatUp -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "FloatUp" $ do - it "Does nothing when no pattern match" $ do - let expr = unsafeParseExpr "let a = True in 1" - floatUp expr `shouldBe` expr - it "Does nothing when let uses lambda variable" $ do - let expr = unsafeParseExpr "\\b -> let a = b + 1; a + b" - floatUp expr `shouldBe` expr - it "Pushes a let above a lambda" $ do - let expr = unsafeParseExpr "\\b -> let a = 1; a + b" - expected = unsafeParseExpr "let a = 1; \\b -> a + b" - floatUp expr `shouldBe` expected - it "Pushes a let up once but not twice" $ do - let expr = unsafeParseExpr "\\a -> \\c -> let b = a + 1; a + b + c" - expected = unsafeParseExpr "\\a -> let b = a + 1; \\c -> a + b + c" - floatUp expr `shouldBe` expected - it "Pushes a let up twice" $ do - let expr = unsafeParseExpr "\\b -> \\c -> let a = 1; a + b + c" - expected = unsafeParseExpr "let a = 1; \\b -> \\c -> a + b + c" - floatUp expr `shouldBe` expected diff --git a/compiler/test/Test/Transform/Inliner.hs b/compiler/test/Test/Transform/Inliner.hs deleted file mode 100644 index e6785d79..00000000 --- a/compiler/test/Test/Transform/Inliner.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.Inliner - ( spec, - ) -where - -import Data.Maybe -import Language.Mimsa.Transform.Inliner -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "Inliner" $ do - describe "howTrivial" $ do - it "Yes to number literal" $ do - howTrivial (unsafeParseExpr "1") - `shouldSatisfy` isJust - it "Yes to string literal" $ do - howTrivial (unsafeParseExpr "\"dog\"") - `shouldSatisfy` isJust - it "Yes to bool literal" $ do - howTrivial (unsafeParseExpr "True") - `shouldSatisfy` isJust - it "Yes to number array literal" $ - do - howTrivial (unsafeParseExpr "[1,2,3]") - `shouldSatisfy` isJust - it "Yes to record full of literals" $ do - howTrivial (unsafeParseExpr "{ a: 1, b: True, c: \"dog\", d: [1,2,3] }") - `shouldSatisfy` isJust - it "Yes to var" $ do - howTrivial (unsafeParseExpr "b") - `shouldSatisfy` isJust - it "No to function" $ do - howTrivial (unsafeParseExpr "\\a -> True") - `shouldBe` Nothing - describe "inlineInternal" $ do - let inlineInternal' = inlineInternal (InlineState mempty) - it "Does nothing when no vars" $ do - let expr = unsafeParseExpr "True" - inlineInternal' expr - `shouldBe` expr - it "Inlines simple literal that is used once" $ do - let expr = unsafeParseExpr "let a = 1 in a" - expected = unsafeParseExpr "let a = 1 in 1" - inlineInternal' expr - `shouldBe` expected - it "Inline function when it is used once" $ do - let expr = unsafeParseExpr "let a = \\b -> 1 in a" - expected = unsafeParseExpr "let a = \\b -> 1 in \\b -> 1" - inlineInternal' expr - `shouldBe` expected - it "Does not inlines trivial item into function if it used more than once" $ do - let expr = unsafeParseExpr "let a = 1 in \\f -> g True a a" - inlineInternal' expr - `shouldBe` expr - -- disabled doing this for now as it broke some shit - xit "Inlines trivial item into function" $ do - let expr = unsafeParseExpr "let a = 1 in \\f -> g True a" - expected = unsafeParseExpr "let a = 1 in \\f -> g True 1" - inlineInternal' expr - `shouldBe` expected - it "Function with type annotation" $ do - let expr = unsafeParseExpr "let (identity: a -> a) abc = abc; identity True" - expected = unsafeParseExpr "let (identity: a -> a) abc = abc; (\\abc -> abc : a -> a) True" - inlineInternal' expr - `shouldBe` expected - it "Does not inline recursive definition" $ do - let expr = unsafeParseExpr "let flip as = if as then False else flip as in flip False" - inlineInternal' expr - `shouldBe` expr diff --git a/compiler/test/Test/Transform/SimplifyPatterns.hs b/compiler/test/Test/Transform/SimplifyPatterns.hs deleted file mode 100644 index 326de3ca..00000000 --- a/compiler/test/Test/Transform/SimplifyPatterns.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Transform.SimplifyPatterns - ( spec, - ) -where - -import Language.Mimsa.Transform.SimplifyPatterns -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "SimplifyPatterns" $ do - describe "Pattern match" $ do - it "Does nothing when no constructor in expr" $ do - let expr = unsafeParseExpr "match a with (Just b) -> True | Nothing -> False" - simplifyPatterns expr `shouldBe` expr - it "Removes constructors and useless patterns" $ do - let expr = unsafeParseExpr "match Just a with (Just b) -> True | Nothing -> False" - expected = unsafeParseExpr "match a with b -> True" - simplifyPatterns expr `shouldBe` expected - -- if we had variable length tuples this could be OK though - it "Does not work with constructors with more than two args" $ do - let expr = unsafeParseExpr "match Triple 1 2 3 with (Triple a b c) -> True | _ -> False" - simplifyPatterns expr `shouldBe` expr - it "Converts two arg constructor to use tuple" $ do - let expr = unsafeParseExpr "match These 1 2 with (These a b) -> True | (This a) -> False | (That b) -> False" - expected = unsafeParseExpr "match (1, 2) with (a, b) -> True" - simplifyPatterns expr `shouldBe` expected diff --git a/compiler/test/Test/Typechecker/DataTypes.hs b/compiler/test/Test/Typechecker/DataTypes.hs deleted file mode 100644 index a21d1bfb..00000000 --- a/compiler/test/Test/Typechecker/DataTypes.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.DataTypes - ( spec, - ) -where - -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.State.Strict -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.DataTypes -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Error -import Test.Codegen.Shared -import Test.Hspec -import Test.Utils.Helpers - -runTC :: - ExceptT TypeError (StateT TypecheckState Identity) a -> - Either TypeError a -runTC action = - fst either' - where - defaultState = - TypecheckState 1 mempty - either' = - runState - (runExceptT action) - defaultState - -testInferDataConstructor :: TyCon -> Either TypeError MonoType -testInferDataConstructor tyCon = runTC $ do - env1 <- storeDataDeclaration mempty mempty dtMaybe - env2 <- storeDataDeclaration env1 mempty dtEither - inferDataConstructor env2 mempty Nothing tyCon - -spec :: Spec -spec = do - describe "Datatypes" $ do - it "varsFromDataType" $ do - varsFromDataType (MTPrim () MTInt) `shouldBe` Nothing - varsFromDataType (MTConstructor () Nothing "Dog") `shouldBe` Just (Nothing, "Dog", mempty) - varsFromDataType (MTTypeApp () (MTConstructor () Nothing "Dog") (MTPrim () MTInt)) - `shouldBe` Just (Nothing, "Dog", [MTPrim () MTInt]) - varsFromDataType - ( MTTypeApp - () - (MTTypeApp () (MTConstructor () Nothing "Dog") (MTPrim () MTInt)) - (MTPrim () MTBool) - ) - `shouldBe` Just (Nothing, "Dog", [MTPrim () MTInt, MTPrim () MTBool]) - - it "Instantiates Maybe" $ do - testInferDataConstructor "Nothing" - `shouldBe` Right (MTTypeApp mempty (MTConstructor mempty Nothing "Maybe") (unknown 1)) - testInferDataConstructor "Just" - `shouldBe` Right - ( MTFunction - mempty - (unknown 1) - ( MTTypeApp mempty (MTConstructor mempty Nothing "Maybe") (unknown 1) - ) - ) - - it "Instantiates Either" $ do - testInferDataConstructor "Left" - `shouldBe` Right - ( MTFunction - mempty - (unknown 1) - ( MTTypeApp - mempty - ( MTTypeApp - mempty - (MTConstructor mempty Nothing "Either") - (unknown 1) - ) - (unknown 2) - ) - ) - testInferDataConstructor "Right" - `shouldBe` Right - ( MTFunction - mempty - (unknown 2) - ( MTTypeApp - mempty - ( MTTypeApp - mempty - (MTConstructor mempty Nothing "Either") - (unknown 1) - ) - (unknown 2) - ) - ) diff --git a/compiler/test/Test/Typechecker/Elaborate.hs b/compiler/test/Test/Typechecker/Elaborate.hs deleted file mode 100644 index 6de61e3b..00000000 --- a/compiler/test/Test/Typechecker/Elaborate.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.Elaborate - ( spec, - ) -where - -import Data.Bifunctor -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Typechecker.Typecheck -import Test.Hspec -import Test.Utils.Helpers - -startElaborate :: - Expr Name Annotation -> - Expr Name MonoType -> - IO () -startElaborate expr expected = do - let numberedExpr = fromRight (addNumbersToStoreExpression expr mempty) - let result = - fmap (\(_, _, a, _) -> first fst a) - . typecheck mempty mempty - $ numberedExpr - (fmap . fmap) recoverAnn result `shouldBe` Right expr - result `shouldBe` Right expected - -spec :: Spec -spec = do - describe "Elaborate" $ do - describe "basic cases" $ do - it "infers int" $ do - let expr = int 1 - expected = MyLiteral (MTPrim mempty MTInt) (MyInt 1) - startElaborate expr expected - - it "infers bool" $ do - let expr = MyLiteral (Location 1 4) (MyBool True) - expected = MyLiteral (MTPrim (Location 1 4) MTBool) (MyBool True) - startElaborate expr expected - - it "infers string" $ do - let expr = - MyLiteral - (Location 1 10) - (MyString (StringType "hello")) - expected = - MyLiteral - (MTPrim (Location 1 10) MTString) - ( MyString - (StringType "hello") - ) - startElaborate expr expected - - it "infers let and var" $ do - let expr = - MyLet - (Location 1 2) - (Identifier (Location 7 8) "a") - (MyLiteral (Location 3 4) (MyInt 1)) - (MyVar (Location 5 6) Nothing "a") - expected = - MyLet - (MTPrim (Location 1 2) MTInt) - (Identifier (MTPrim (Location 7 8) MTInt) "a") - (MyLiteral (MTPrim (Location 3 4) MTInt) (MyInt 1)) - (MyVar (MTPrim (Location 5 6) MTInt) Nothing "a") - startElaborate expr expected - - it "infers let binding" $ do - let expr = - MyLet - (Location 1 2) - (Identifier (Location 7 8) "x") - (MyLiteral (Location 3 4) (MyInt 42)) - (MyLiteral (Location 5 6) (MyBool True)) - expected = - MyLet - (MTPrim (Location 1 2) MTBool) - (Identifier (MTPrim (Location 7 8) MTInt) "x") - (MyLiteral (MTPrim (Location 3 4) MTInt) (MyInt 42)) - (MyLiteral (MTPrim (Location 5 6) MTBool) (MyBool True)) - startElaborate expr expected - - it "infers let binding with usage" $ do - let expr = - MyLet - mempty - (Identifier mempty "x") - (int 42) - (MyVar mempty Nothing "x") - expected = - MyLet - (MTPrim mempty MTInt) - (Identifier (MTPrim mempty MTInt) "x") - (MyLiteral (MTPrim mempty MTInt) (MyInt 42)) - ( MyVar (MTPrim mempty MTInt) Nothing "x" - ) - startElaborate expr expected - - it "infers let binding with recursion 0" $ do - let expr = - MyLet - mempty - (Identifier mempty "dec") - ( MyLambda - mempty - (Identifier mempty "bool") - ( MyIf - mempty - (MyVar mempty Nothing "bool") - (bool True) - ( MyApp - mempty - (MyVar mempty Nothing "dec") - (bool False) - ) - ) - ) - (MyVar mempty Nothing "dec") - expected = - MyLet - (MTFunction mempty mtBool mtBool) - (Identifier (MTFunction mempty mtBool mtBool) "dec") - ( MyLambda - (MTFunction mempty mtBool mtBool) - (Identifier mtBool "bool") - ( MyIf - mtBool - (MyVar mtBool Nothing "bool") - (MyLiteral mtBool (MyBool True)) - ( MyApp - mtBool - ( MyVar - (MTFunction mempty mtBool mtBool) - Nothing - "dec" - ) - (MyLiteral mtBool (MyBool False)) - ) - ) - ) - (MyVar (MTFunction mempty mtBool mtBool) Nothing "dec") - startElaborate expr expected - - it "infers let binding with recursion 1" $ do - let expr = - MyLet - mempty - (Identifier mempty "dec") - ( MyLambda - mempty - (Identifier mempty "bool") - ( MyIf - mempty - (MyVar mempty Nothing "bool") - (bool True) - ( MyApp - mempty - (MyVar mempty Nothing "dec") - (bool False) - ) - ) - ) - (MyApp mempty (MyVar mempty Nothing "dec") (bool False)) - expected = - MyLet - mtBool - (Identifier (MTFunction mempty mtBool mtBool) "dec") - ( MyLambda - (MTFunction mempty mtBool mtBool) - (Identifier mtBool "bool") - ( MyIf - mtBool - (MyVar mtBool Nothing "bool") - (MyLiteral mtBool (MyBool True)) - ( MyApp - mtBool - (MyVar (MTFunction mempty mtBool mtBool) Nothing "dec") - (MyLiteral mtBool (MyBool False)) - ) - ) - ) - ( MyApp - mtBool - ( MyVar - (MTFunction mempty mtBool mtBool) - Nothing - "dec" - ) - (MyLiteral mtBool (MyBool False)) - ) - startElaborate expr expected diff --git a/compiler/test/Test/Typechecker/Exhaustiveness.hs b/compiler/test/Test/Typechecker/Exhaustiveness.hs deleted file mode 100644 index 71852f35..00000000 --- a/compiler/test/Test/Typechecker/Exhaustiveness.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.Exhaustiveness - ( spec, - ) -where - -import Control.Monad.Except -import Control.Monad.Identity -import Data.Either -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Exhaustiveness -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Test.Codegen.Shared -import Test.Hspec - -type PatternM = ExceptT TypeError Identity - -runPatternM :: - PatternM a -> - Either TypeError a -runPatternM value = - runIdentity (runExceptT value) - -exhaustiveCheck :: - [Pattern Name Annotation] -> - Either TypeError [Pattern Name Annotation] -exhaustiveCheck = runPatternM . isExhaustive testEnv - -redundantCasesCheck :: - [Pattern Name Annotation] -> - Either TypeError [Pattern Name Annotation] -redundantCasesCheck = runPatternM . redundantCases testEnv - -noDuplicatesCheck :: - Pattern Name Annotation -> - Either TypeError () -noDuplicatesCheck = runPatternM . noDuplicateVariables - -testEnv :: Environment -testEnv = mempty {getDataTypes = dts} - where - dts = - M.fromList - [ ((Nothing, "Maybe"), dtMaybe), - ((Nothing, "Either"), dtEither), - ((Nothing, "These"), dtThese) - ] - -spec :: Spec -spec = do - describe "Smaller list versions" $ do - it "Empty is empty" $ do - smallerListVersions [] `shouldBe` ([] :: [[Int]]) - it "1 list is the same" $ do - smallerListVersions [[1]] `shouldBe` ([[1]] :: [[Int]]) - it "2 list adds a 1 list" $ do - smallerListVersions [[1, 2]] `shouldBe` ([[2], [1, 2]] :: [[Int]]) - it "3 list adds a 2 and a 1 list" $ do - smallerListVersions [[1, 2, 3]] `shouldBe` ([[3], [2, 3], [1, 2, 3]] :: [[Int]]) - - describe "Exhaustiveness" $ - do - it "Wildcard is fine" $ do - exhaustiveCheck [PWildcard mempty] `shouldBe` Right [] - it "Var alone is fine" $ do - exhaustiveCheck [PVar mempty "a"] `shouldBe` Right [] - it "Both True and False is fine" $ do - exhaustiveCheck - [ PLit mempty (MyBool False), - PLit - mempty - ( MyBool True - ) - ] - `shouldBe` Right [] - it "Just True return Lit False" $ do - exhaustiveCheck - [PLit mempty (MyBool False)] - `shouldBe` Right - [ PLit - mempty - ( MyBool True - ) - ] - it "Just False return Lit True" $ do - exhaustiveCheck - [PLit mempty (MyBool True)] - `shouldBe` Right - [ PLit - mempty - ( MyBool False - ) - ] - it "Int literal returns Wildcard" $ do - exhaustiveCheck [PLit mempty (MyInt 1)] - `shouldBe` Right [PWildcard mempty] - it "String literal returns Wildcard" $ do - exhaustiveCheck [PLit mempty (MyString "hello")] - `shouldBe` Right [PWildcard mempty] - it "Int then var is exhaustive" $ do - exhaustiveCheck - [ PLit mempty (MyInt 1), - PVar mempty "otherwise" - ] - `shouldBe` Right mempty - - it "Pair of vars is fine" $ do - exhaustiveCheck - [ PTuple - mempty - (PWildcard mempty) - (NE.singleton $ PWildcard mempty) - ] - `shouldBe` Right [] - - it "Pair of False is returned" $ - do - let true = PLit mempty (MyBool True) - false = PLit mempty (MyBool False) - exhaustiveCheck - [ PTuple mempty true (NE.singleton true), - PTuple mempty false (NE.singleton true), - PTuple mempty true (NE.singleton false) - ] - `shouldBe` Right [PTuple mempty false (NE.singleton false)] - - it "3 tuple of wildcards is exhaustive" $ do - let wildcard = PWildcard mempty - exhaustiveCheck [PTuple mempty wildcard (NE.fromList [wildcard, wildcard])] - `shouldBe` Right mempty - - it "3 tuple of ones are not exhaustive" $ do - let one = PLit mempty (MyInt 1) - wildcard = PWildcard mempty - exhaustiveCheck [PTuple mempty one (NE.fromList [one, one])] - `shouldBe` Right [PTuple mempty wildcard (NE.fromList [wildcard, wildcard])] - - it "First in 3-tuples is non-exhaustive" $ do - let one = PLit mempty (MyInt 1) - wildcard = PWildcard mempty - exhaustiveCheck - [ PTuple - mempty - one - ( NE.fromList [wildcard, wildcard] - ) - ] - `shouldBe` Right - [ PTuple - mempty - wildcard - ( NE.fromList [wildcard, wildcard] - ) - ] - - it "Third in a 3-tuple is non-exhaustive" $ do - let true = PLit mempty (MyBool True) - false = PLit mempty (MyBool False) - wildcard = PWildcard mempty - exhaustiveCheck - [ PTuple - mempty - wildcard - ( NE.fromList [wildcard, true] - ) - ] - `shouldBe` Right - [ PTuple - mempty - wildcard - ( NE.fromList [wildcard, false] - ) - ] - - -- its not but cba fixing now, making it over rather than under safe - xit "Pair with var is exhaustive" $ do - let true = PLit mempty (MyBool True) - false = PLit mempty (MyBool False) - exhaustiveCheck - [ PTuple mempty true (NE.singleton true), - PTuple mempty false (NE.singleton true), - PTuple mempty (PVar mempty "dog") (NE.singleton false) - ] - `shouldBe` Right [] - - -- same as above - xit "A pair with complete coverage of Right and Left is exhaustive" $ do - let leftE = PConstructor mempty Nothing "Left" [PVar mempty "e"] - rightF = PConstructor mempty Nothing "Right" [PVar mempty "f"] - rightA = PConstructor mempty Nothing "Right" [PVar mempty "a"] - wildcard = PWildcard mempty - exhaustiveCheck - [ PTuple mempty rightF (NE.singleton rightA), - PTuple mempty leftE (NE.singleton wildcard), - PTuple mempty wildcard (NE.singleton leftE) - ] - `shouldBe` Right mempty - - it "Record with two False values is returned" $ do - let true = PLit mempty (MyBool True) - false = PLit mempty (MyBool False) - exhaustiveCheck - [ PRecord mempty (M.fromList [("a", true), ("b", true)]), - PRecord mempty (M.fromList [("a", false), ("b", true)]), - PRecord mempty (M.fromList [("a", true), ("b", false)]) - ] - `shouldBe` Right [PRecord mempty (M.fromList [("a", false), ("b", false)])] - it "A pair annihilates empty" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "Just" [PTuple mempty (PWildcard mempty) (NE.singleton $ PWildcard mempty)], - PConstructor mempty Nothing "Nothing" mempty - ] - `shouldBe` Right mempty - it "A record annihilates empty" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "Just" [PRecord mempty mempty], - PConstructor mempty Nothing "Nothing" mempty - ] - `shouldBe` Right mempty - it "Constructor returns unused constructor" $ do - exhaustiveCheck - [PConstructor mempty Nothing "Just" [PWildcard mempty]] - `shouldBe` Right [PConstructor mempty Nothing "Nothing" []] - it "Constructor returns unused items inside it" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "Just" [PLit mempty (MyBool True)], - PConstructor mempty Nothing "Nothing" mempty - ] - `shouldBe` Right - [ PConstructor - mempty - Nothing - "Just" - [ PLit - mempty - (MyBool False) - ], - PConstructor - mempty - Nothing - "Just" - [ PWildcard mempty - ] - ] - it "Constructor returns multiple unused constructors" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "This" [PWildcard mempty] - ] - `shouldBe` Right - [ PConstructor mempty Nothing "That" [PWildcard mempty], - PConstructor mempty Nothing "These" [PWildcard mempty, PWildcard mempty] - ] - it "Nested constructors" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "Just" [PConstructor mempty Nothing "Nothing" mempty], - PConstructor mempty Nothing "Just" [PWildcard mempty] - ] - `shouldBe` Right - [ PConstructor mempty Nothing "Nothing" [] - ] - it "A var is equivalent to a wildcard" $ do - exhaustiveCheck - [ PConstructor mempty Nothing "Just" [PVar mempty "a"], - PConstructor mempty Nothing "Nothing" mempty - ] - `shouldBe` Right [] - it "Multiple int literals" $ do - exhaustiveCheck [PLit mempty (MyInt 1), PLit mempty (MyInt 2)] - `shouldBe` Right [PWildcard mempty] - it "NoSpread Array produces wildcard" $ do - exhaustiveCheck [PArray mempty [PLit mempty (MyInt 1)] NoSpread] - `shouldBe` Right - [ PArray mempty [PWildcard mempty] (SpreadWildcard mempty), -- one or more - PArray mempty [] NoSpread -- empty - ] - it "Spread Array produces all other sized spread cases" $ do - exhaustiveCheck [PArray mempty [PLit mempty (MyInt 1)] (SpreadValue mempty "a")] - `shouldBe` Right - [ PArray mempty [PWildcard mempty] (SpreadWildcard mempty), -- one or more - PArray mempty [] NoSpread -- empty - ] - it "Larger Spread Array produces all other sized spread cases" $ do - exhaustiveCheck [PArray mempty [PLit mempty (MyInt 1), PLit mempty (MyInt 2)] (SpreadValue mempty "a")] - `shouldBe` Right - [ PArray mempty [PWildcard mempty] (SpreadWildcard mempty), -- one or more - PArray mempty [PWildcard mempty, PWildcard mempty] (SpreadWildcard mempty), -- two or more - PArray mempty [] NoSpread -- empty - ] - it "NoSpread empty array produces wildcard" $ do - exhaustiveCheck [PArray mempty mempty NoSpread] - `shouldBe` Right [PArray mempty [PWildcard mempty] (SpreadWildcard mempty)] - - it "A string match produces empty string" $ do - exhaustiveCheck [PString mempty (StrWildcard mempty) (StrWildcard mempty)] - `shouldBe` Right [PLit mempty (MyString "")] - describe "Redundant cases" $ do - it "Returns none" $ do - redundantCasesCheck [PWildcard mempty] `shouldBe` Right mempty - it "Returns anything after a wildcard (1)" $ do - redundantCasesCheck - [ PWildcard mempty, - PLit mempty (MyBool True) - ] - `shouldBe` Right - [ PLit mempty (MyBool True) - ] - it "Returns anything after a wildcard (2)" $ do - redundantCasesCheck - [ PWildcard mempty, - PLit mempty (MyBool True), - PLit mempty (MyBool False) - ] - `shouldBe` Right - [ PLit mempty (MyBool True), - PLit mempty (MyBool False) - ] - it "Works with constructors" $ do - redundantCasesCheck - [ PConstructor mempty Nothing "Just" [PWildcard mempty], - PConstructor mempty Nothing "Just" [PLit mempty (MyInt 1)], - PConstructor mempty Nothing "Nothing" mempty - ] - `shouldBe` Right - [ PConstructor - mempty - Nothing - "Just" - [PLit mempty (MyInt 1)] - ] - it "Multiple ints make wildcard necessary" $ do - redundantCasesCheck - [PLit mempty (MyInt 1), PLit mempty (MyInt 2), PWildcard mempty] - `shouldBe` Right [] - describe "noDuplicateVariables" $ do - it "Is fine with wildcard" $ do - noDuplicatesCheck (PWildcard mempty) `shouldSatisfy` isRight - it "Is fine with lit" $ do - noDuplicatesCheck (PLit mempty (MyBool True)) `shouldSatisfy` isRight - it "Is fine with single var" $ do - noDuplicatesCheck (PVar mempty "a") `shouldSatisfy` isRight - it "Is fine with a pair of different vars" $ do - noDuplicatesCheck - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - `shouldSatisfy` isRight - it "Hates a pair of the same var" $ do - noDuplicatesCheck - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "a") - ) - `shouldSatisfy` isLeft - it "Is fine with a record of uniques" $ do - noDuplicatesCheck - ( PRecord - mempty - ( M.fromList - [ ("dog", PVar mempty "a"), - ("log", PVar mempty "b") - ] - ) - ) - `shouldSatisfy` isRight - it "Is not fine with a record with dupes" $ do - noDuplicatesCheck - ( PRecord - mempty - ( M.fromList - [ ("dog", PVar mempty "a"), - ("log", PVar mempty "a") - ] - ) - ) - `shouldSatisfy` isLeft - it "Is fine with an array with no dupes" $ do - noDuplicatesCheck - ( PArray - mempty - [ PVar mempty "a", - PVar mempty "b" - ] - NoSpread - ) - `shouldSatisfy` isRight - it "Is not fine with an array with dupes" $ do - noDuplicatesCheck - ( PArray - mempty - [ PVar mempty "a", - PVar mempty "a" - ] - NoSpread - ) - `shouldSatisfy` isLeft - it "Is not fine with an array with dupes with the spread" $ do - noDuplicatesCheck - ( PArray - mempty - [ PVar mempty "a", - PVar mempty "b" - ] - (SpreadValue mempty "a") - ) - `shouldSatisfy` isLeft - it "Is fine with a constructor with no dupes" $ do - noDuplicatesCheck - ( PConstructor - mempty - Nothing - "Dog" - [ PVar mempty "a", - PVar mempty "b" - ] - ) - `shouldSatisfy` isRight - it "Is not fine with a constructor with dupes" $ do - noDuplicatesCheck - ( PConstructor - mempty - Nothing - "Dog" - [ PVar mempty "a", - PVar mempty "b", - PConstructor - mempty - Nothing - "Dog" - [ PVar mempty "c", - PVar mempty "a" - ] - ] - ) - `shouldSatisfy` isLeft diff --git a/compiler/test/Test/Typechecker/NumberVars.hs b/compiler/test/Test/Typechecker/NumberVars.hs deleted file mode 100644 index 8ba60003..00000000 --- a/compiler/test/Test/Typechecker/NumberVars.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.Typechecker.NumberVars - ( spec, - ) -where - -import Data.Either -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Types.Error.TypeError -import Language.Mimsa.Types.Store -import Language.Mimsa.Types.Typechecker.Unique -import Test.Hspec -import Test.Utils.Helpers - -testAddNumbers :: - Expr Name () -> - Map (Maybe ModuleName, Name) ExprHash -> - Either (TypeErrorF Name ()) (Expr (Name, Unique) ()) -testAddNumbers = addNumbersToStoreExpression - -testAddToExpr :: - Expr Name () -> - Either (TypeErrorF Name ()) (Expr (Name, Unique) ()) -testAddToExpr = addNumbersToExpression mempty mempty mapMods - where - mapMods = M.singleton "Prelude" (ModuleHash "123", S.singleton "id") - -spec :: Spec -spec = do - describe "NumberVars" $ do - describe "Expression" $ do - it "Normal var" $ do - let expr = - MyLambda - mempty - (Identifier mempty "x") - (MyVar mempty Nothing "x") - expected = - MyLambda - mempty - (Identifier mempty ("x", Unique 0)) - ( MyVar mempty Nothing ("x", Unique 0) - ) - testAddToExpr expr `shouldBe` Right expected - - it "Namespaced var" $ do - let expr = MyVar mempty (Just "Prelude") "id" - expected = - MyVar - mempty - (Just "Prelude") - ("id", ModuleDep (ModuleHash "123")) - testAddToExpr expr `shouldBe` Right expected - - describe "StoreExpression" $ do - it "Lambda vars are turned into numbers" $ - do - let expr = - MyLambda - mempty - (Identifier mempty "x") - ( MyTuple - mempty - (MyVar mempty Nothing "x") - (NE.singleton $ MyLambda mempty (Identifier mempty "x") (MyVar mempty Nothing "x")) - ) - expected = - MyLambda - mempty - (Identifier mempty ("x", Unique 0)) - ( MyTuple - mempty - (MyVar mempty Nothing ("x", Unique 0)) - ( NE.singleton $ - MyLambda - mempty - ( Identifier mempty ("x", Unique 1) - ) - (MyVar mempty Nothing ("x", Unique 1)) - ) - ) - ans = testAddNumbers expr mempty - ans `shouldBe` Right expected - - it "Pattern match entries work" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyPatternMatch - mempty - (int 1) - [ (PLit mempty (MyInt 1), MyVar mempty Nothing "a"), - (PWildcard mempty, MyVar mempty Nothing "a") - ] - ) - expected = - MyLambda - mempty - (Identifier mempty ("a", Unique 0)) - ( MyPatternMatch - mempty - (MyLiteral mempty (MyInt 1)) - [ (PLit mempty (MyInt 1), MyVar mempty Nothing ("a", Unique 0)), - (PWildcard mempty, MyVar mempty Nothing ("a", Unique 0)) - ] - ) - - ans = testAddNumbers expr mempty - ans `shouldBe` Right expected - - it "Scoping variables in pattern matches works" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyPatternMatch - mempty - (int 1) - [ (PWildcard mempty, MyVar mempty Nothing "a"), - (PVar mempty "a", MyVar mempty Nothing "a"), - (PWildcard mempty, MyVar mempty Nothing "a") - ] - ) - expected = - MyLambda - mempty - (Identifier mempty ("a", Unique 0)) - ( MyPatternMatch - mempty - (int 1) - [ (PWildcard mempty, MyVar mempty Nothing ("a", Unique 0)), - (PVar mempty ("a", Unique 1), MyVar mempty Nothing ("a", Unique 1)), - (PWildcard mempty, MyVar mempty Nothing ("a", Unique 0)) - ] - ) - ans = testAddNumbers expr mempty - ans `shouldBe` Right expected - - it "Scoping variables in let patterns works" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyLetPattern - mempty - (PVar mempty "a") - (int 1) - (MyVar mempty Nothing "a") - ) - expected = - MyLambda - mempty - (Identifier mempty ("a", Unique 0)) - ( MyLetPattern - mempty - (PVar mempty ("a", Unique 1)) - (int 1) - (MyVar mempty Nothing ("a", Unique 1)) - ) - - ans = testAddNumbers expr mempty - ans `shouldBe` Right expected - - it "Does not explode with a namespaced dep" $ do - let expr = - MyVar mempty (Just "Prelude") "what" - valueDeps = M.singleton (Just "Prelude", "what") (ExprHash "13") - ans = testAddNumbers expr valueDeps - ans `shouldSatisfy` isRight - - it "Fails if can't find outside dep" $ do - let expr = - MyVar mempty Nothing "what" - ans = testAddNumbers expr mempty - ans `shouldBe` Left (NameNotFoundInScope mempty mempty Nothing "what") - - it "Outside deps are assigned a number" $ do - let hash = ExprHash "123" - let expr = - MyApp mempty (MyVar mempty Nothing "id") (MyVar mempty Nothing "id") - expected = - MyApp - mempty - (MyVar mempty Nothing ("id", Dependency hash)) - (MyVar mempty Nothing ("id", Dependency hash)) - bindings = M.singleton (Nothing, "id") hash - ans = testAddNumbers expr bindings - ans `shouldBe` Right expected diff --git a/compiler/test/Test/Typechecker/ScopeTypeVar.hs b/compiler/test/Test/Typechecker/ScopeTypeVar.hs deleted file mode 100644 index f16240b7..00000000 --- a/compiler/test/Test/Typechecker/ScopeTypeVar.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.ScopeTypeVar - ( spec, - ) -where - -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.State.Strict -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.ScopeTypeVar -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Test.Hspec - -runTC :: - ExceptT TypeError (StateT TypecheckState Identity) a -> - Either TypeError a -runTC action = - fst either' - where - defaultState = - TypecheckState 1 mempty - either' = - runState - (runExceptT action) - defaultState - -spec :: Spec -spec = do - describe "ScopeTypeVar" $ do - it "Empty set changes value" $ do - let mt = MTVar mempty (TVName "a") - let result = - runTC - ( freshNamedType - mempty - mt - ) - snd <$> result `shouldBe` Right (MTVar mempty (TVScopedVar 1 "a")) - it "Empty set changes to same value" $ do - let mt = - MTTuple - mempty - (MTVar mempty (TVName "a")) - (NE.singleton $ MTVar mempty (TVName "a")) - - let result = - runTC - ( freshNamedType - mempty - mt - ) - let expected = - MTTuple - mempty - (MTVar mempty (TVScopedVar 1 "a")) - (NE.singleton $ MTVar mempty (TVScopedVar 1 "a")) - - snd <$> result `shouldBe` Right expected - - it "If set contains name leave it" $ do - let mt = MTVar mempty (TVName "a") - let result = - runTC - ( freshNamedType - ( Environment mempty mempty mempty (M.singleton "a" 1) mempty - ) - mt - ) - snd <$> result `shouldBe` Right (MTVar mempty (TVScopedVar 1 "a")) diff --git a/compiler/test/Test/Typechecker/Substitutions.hs b/compiler/test/Test/Typechecker/Substitutions.hs deleted file mode 100644 index a50185ae..00000000 --- a/compiler/test/Test/Typechecker/Substitutions.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.Substitutions - ( spec, - ) -where - -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Types.Typechecker.Substitutions -import Test.Hspec -import Test.Utils.Helpers - -spec :: Spec -spec = do - describe "Substitutions" $ do - describe "Preserve the original annotations" $ do - it "Empty is no-op" $ do - let mt = MTPrim (Location 1 2) MTInt - subs = mempty - applySubst subs mt `shouldBe` mt - it "Single substitution preserves type" $ do - let mt = MTVar (Location 1 3) (tvNamed "a") - subs = Substitutions $ M.singleton (tvNamed "a") (MTPrim (Location 100 123) MTString) - result = applySubst subs mt - getAnnotationForType result `shouldBe` getAnnotationForType mt diff --git a/compiler/test/Test/Typechecker/Typecheck.hs b/compiler/test/Test/Typechecker/Typecheck.hs deleted file mode 100644 index a5c70747..00000000 --- a/compiler/test/Test/Typechecker/Typecheck.hs +++ /dev/null @@ -1,1304 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typechecker.Typecheck - ( spec, - ) -where - -import Data.Bifunctor -import Data.Either (isLeft) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.Elaborate -import Language.Mimsa.Typechecker.NormaliseTypes -import Language.Mimsa.Typechecker.NumberVars -import Language.Mimsa.Typechecker.Typecheck -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker -import Test.Codegen.Shared - ( dtEither, - dtMaybe, - dtPair, - dtThese, - ) -import Test.Hspec -import Test.Utils.Helpers - -identity :: (Monoid ann) => Expr Name ann -identity = - MyLambda - mempty - (Identifier mempty "x") - (MyVar mempty Nothing "x") - -startInference :: Expr Name Annotation -> Either TypeError MonoType -> IO () -startInference = startInferenceWithDataTypes [] - -dtToMap :: DataType -> Map (Maybe ModuleName, TypeName) DataType -dtToMap dt@(DataType tn _ _) = M.singleton (Nothing, tn) dt - -startInferenceWithDataTypes :: [DataType] -> Expr Name Annotation -> Either TypeError MonoType -> IO () -startInferenceWithDataTypes dts expr expected = do - let numberedExpr = - fromRight $ - addNumbersToStoreExpression - expr - mempty - let env = mempty {getDataTypes = mconcat (dtToMap <$> dts)} - let elabbed = - fmap (\(_, _, a, _) -> first fst a) - . typecheck mempty env - $ numberedExpr - normaliseType . getTypeFromAnn <$> elabbed `shouldBe` expected - case elabbed of - Right elabExpr -> recoverAnn <$> elabExpr `shouldBe` expr - _ -> pure () -- can't compare - -testInfer :: Expr Name Annotation -> Either TypeError MonoType -testInfer expr = do - numberedExpr <- - addNumbersToStoreExpression - expr - mempty - let elabbed = - fmap (\(_, _, a, _) -> a) - . typecheck mempty mempty - $ numberedExpr - getTypeFromAnn <$> elabbed - -spec :: Spec -spec = do - describe "Typecheck" $ do - describe "basic cases" $ do - it "infers int" $ do - let expr = int 1 - startInference expr (Right (MTPrim mempty MTInt)) - it "infers bool" $ do - let expr = bool True - startInference expr (Right (MTPrim mempty MTBool)) - it "infers string" $ do - let expr = str (StringType "hello") - startInference expr $ Right (MTPrim mempty MTString) - it "infers let binding" $ do - let expr = - MyLet - mempty - (Identifier mempty "x") - (int 42) - (bool True) - startInference expr $ Right (MTPrim mempty MTBool) - it "infers let binding with usage" $ do - let expr = - MyLet - mempty - (Identifier mempty "x") - (int 42) - (MyVar mempty Nothing "x") - startInference expr $ Right (MTPrim mempty MTInt) - it "regressions" $ do - let expr = unsafeParseExpr' "{ fun: (\\a -> let d = 1 in a) }" - startInference expr $ - Right - ( MTRecord - mempty - ( M.singleton - "fun" - ( MTFunction - mempty - (MTVar mempty (TVUnificationVar 1)) - (MTVar mempty (TVUnificationVar 1)) - ) - ) - Nothing - ) - - describe "annotations" $ do - it "annotation that is ok" $ do - let expr = - MyAnnotation mempty (MTPrim mempty MTInt) (int 1) - startInference expr (Right (MTPrim mempty MTInt)) - it "annotation that is not ok" $ do - let expr = - MyAnnotation mempty (MTPrim mempty MTInt) (bool True) - startInference expr (Left (UnificationError mtBool mtInt)) - it "annotation with function" $ - do - let expr = - MyAnnotation - mempty - (MTFunction mempty (MTPrim mempty MTBool) (MTPrim mempty MTInt)) - (MyLambda mempty (Identifier mempty "a") (int 1)) - startInference - expr - ( Right - (MTFunction mempty (MTPrim mempty MTBool) (MTPrim mempty MTInt)) - ) - it "annotation with nested function makes both params the same type" $ do - let expr = - MyAnnotation - mempty - ( MTFunction - mempty - (MTVar mempty (TVName "a")) - ( MTFunction - mempty - (MTVar mempty (TVName "a")) - (MTPrim mempty MTInt) - ) - ) - ( MyLambda - mempty - (Identifier mempty "a") - ( MyLambda - mempty - (Identifier mempty "b") - (int 1) - ) - ) - startInference - expr - ( Right - ( MTFunction - mempty - (unknown 1) - ( MTFunction - mempty - (unknown 1) - (MTPrim mempty MTInt) - ) - ) - ) - it "Let annotation matches value" $ do - let expr = - MyLet - mempty - (Identifier mempty "a") - (MyAnnotation mempty mtString (MyLiteral mempty (MyString "dog"))) - (MyLiteral mempty (MyBool True)) - startInference expr $ - Right mtBool - - it "Let annotation does not match value" $ do - let expr = - MyLet - mempty - (Identifier mempty "a") - (MyAnnotation mempty mtInt (MyLiteral mempty (MyString "dog"))) - (MyLiteral mempty (MyBool True)) - startInference expr $ - Left (UnificationError mtString mtInt) - - it "Lambda annotation matches makes id monomorphic" $ do - let expr = - MyAnnotation - mempty - (MTFunction mempty mtString mtString) - ( MyLambda - mempty - (Identifier mempty "a") - (MyVar mempty Nothing "a") - ) - startInference expr $ - Right $ - MTFunction mempty mtString mtString - - it "Lambda annotation does not match lambda body" $ do - let expr = - MyAnnotation - mempty - (MTFunction mempty mtString mtInt) - ( MyLambda - mempty - (Identifier mempty "a") - (MyInfix mempty Add (MyVar mempty Nothing "a") (int 1)) - ) - startInference expr $ - Left (UnificationError mtString mtInt) - - it "Applies concrete value to annotated polymorphic function after let generalisation" $ do - let expr = - MyLet - mempty - (Identifier mempty "f") - ( MyAnnotation - mempty - (MTFunction mempty (MTVar mempty (TVName "a")) (MTVar mempty (TVName "a"))) - (MyLambda mempty (Identifier mempty "a") (MyVar mempty Nothing "a")) - ) - ( MyApp - mempty - (MyVar mempty Nothing "f") - (bool True) - ) - startInference expr $ - Right mtBool - it "infers let binding with recursion 0" $ do - let expr = - MyLet - mempty - (Identifier mempty "dec") - ( MyLambda - mempty - (Identifier mempty "bool") - ( MyIf - mempty - (MyVar mempty Nothing "bool") - (bool True) - ( MyApp - mempty - (MyVar mempty Nothing "dec") - (bool False) - ) - ) - ) - (MyVar mempty Nothing "dec") - startInference expr $ Right (MTFunction mempty (MTPrim mempty MTBool) (MTPrim mempty MTBool)) - - it "infers let binding with recursion 1" $ do - let expr = - MyLet - mempty - (Identifier mempty "dec") - ( MyLambda - mempty - (Identifier mempty "bool") - ( MyIf - mempty - (MyVar mempty Nothing "bool") - (bool True) - ( MyApp - mempty - (MyVar mempty Nothing "dec") - (bool False) - ) - ) - ) - (MyApp mempty (MyVar mempty Nothing "dec") (bool False)) - startInference expr $ Right (MTPrim mempty MTBool) - - it "infers let binding with recursion 2 (flipped if cases)" $ do - let expr = - MyLet - mempty - (Identifier mempty "dec") - ( MyLambda - mempty - (Identifier mempty "bool") - ( MyIf - mempty - (MyVar mempty Nothing "bool") - ( MyApp - mempty - (MyVar mempty Nothing "dec") - (bool False) - ) - (bool True) - ) - ) - (MyApp mempty (MyVar mempty Nothing "dec") (bool False)) - startInference expr $ Right (MTPrim mempty MTBool) - - it "infers multiple let bindings" $ do - let expr = - MyLet - mempty - (Identifier mempty "x") - (bool True) - ( MyLet - mempty - (Identifier mempty "y") - (int 42) - (MyVar mempty Nothing "x") - ) - startInference expr $ Right (MTPrim mempty MTBool) - - it "infers shadowed let bindings" $ do - let expr = - MyLet - mempty - (Identifier mempty "x") - (bool True) - ( MyLet - mempty - (Identifier mempty "x") - (int 42) - (MyVar mempty Nothing "x") - ) - startInference expr $ Right (MTPrim mempty MTInt) - - it "infers const lambda" $ do - let expr = MyLambda mempty (Identifier mempty "x") (bool True) - startInference expr $ - Right (MTFunction mempty (unknown 1) (MTPrim mempty MTBool)) - - it "infers identity" $ do - let expr = identity - startInference expr $ Right (MTFunction mempty (unknown 1) (unknown 1)) - - it "infers const function" $ do - let expr = - MyLambda - mempty - (Identifier mempty "x") - (MyLambda mempty (Identifier mempty "y") (MyVar mempty Nothing "x")) - startInference expr $ - Right - ( MTFunction - mempty - (unknown 1) - (MTFunction mempty (unknown 2) (unknown 1)) - ) - - it "infers const applied with boolean" $ do - let expr = - MyApp - mempty - ( MyLambda - mempty - (Identifier mempty "x") - (bool True) - ) - (int 1) - startInference expr $ Right (MTPrim mempty MTBool) - it "infers identity with int passed to it" $ do - let expr = - MyApp - mempty - identity - (int 1) - startInference expr $ Right (MTPrim mempty MTInt) - it "passing int to an if statement in a lambda fails" $ do - let expr = - MyApp - mempty - ( MyLambda - mempty - (Identifier mempty "x") - (MyIf mempty (MyVar mempty Nothing "x") (int 10) (int 10)) - ) - (int 100) - startInference expr $ - Left - ( FunctionArgumentMismatch - mempty - (MTPrim mempty MTBool) - (MTPrim mempty MTInt) - ) - it "fails occurs check" $ do - let expr = - MyLambda - mempty - (Identifier mempty "x") - ( MyApp - mempty - (MyVar mempty Nothing "x") - (MyVar mempty Nothing "x") - ) - startInference expr $ - Left - ( FailsOccursCheck - (tvNum 1) - ( MTFunction - mempty - (MTVar mempty (tvNum 1)) - (MTVar mempty (tvNum 2)) - ) - ) - it "infers pair" $ do - let expr = MyTuple mempty (int 1) (NE.singleton $ bool True) - startInference expr $ - Right - (MTTuple mempty (MTPrim mempty MTInt) (NE.singleton $ MTPrim mempty MTBool)) - it "infers and destructures pair" $ do - let expr = - MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyTuple mempty (int 1) (NE.singleton $ bool True)) - (MyVar mempty Nothing "a") - startInference expr $ Right (MTPrim mempty MTInt) - it "infers destructured pair in a lambda" $ do - let expr = - MyLambda - mempty - (Identifier mempty "x") - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyVar mempty Nothing "x") - (MyVar mempty Nothing "a") - ) - startInference expr $ - Right - (MTFunction mempty (MTTuple mempty (unknown 1) (NE.singleton $ unknown 2)) (unknown 1)) - it "infers empty record" $ do - let expr = - MyRecord - mempty - mempty - startInference expr $ - Right - ( MTRecord mempty mempty Nothing - ) - it "infers record with two ints in it" $ do - let expr = - MyRecord - mempty - ( M.fromList - [ ("dog", int 1), - ("cat", int 2) - ] - ) - startInference expr $ - Right - ( MTRecord - mempty - ( M.fromList - [ ("dog", MTPrim mempty MTInt), - ("cat", MTPrim mempty MTInt) - ] - ) - Nothing - ) - it "Infers a record literal from a lambda" $ do - let expr = - MyLambda - mempty - (Identifier mempty "i") - ( MyIf - mempty - ( MyRecordAccess - mempty - (MyVar mempty Nothing "i") - "dog" - ) - (int 1) - (int 2) - ) - startInference expr $ - Right - ( MTFunction - mempty - ( MTRecord - mempty - ( M.singleton - "dog" - (MTPrim mempty MTBool) - ) - (Just $ unknown 1) - ) - (MTPrim mempty MTInt) - ) - it "Infers partial record from lambda" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyInfix - mempty - Add - ( MyRecordAccess - mempty - (MyVar mempty Nothing "a") - "int" - ) - (int 1) - ) - startInference expr $ - Right - ( MTFunction - mempty - ( MTRecord - mempty - (M.singleton "int" (MTPrim mempty MTInt)) - (Just $ unknown 1) - ) - (MTPrim mempty MTInt) - ) - - it "Uses a polymorphic function twice with conflicting types" $ do - let expr = - MyLet - mempty - (Identifier mempty "id") - (MyLambda mempty (Identifier mempty "var") (MyVar mempty Nothing "var")) - ( MyTuple - mempty - (MyApp mempty (MyVar mempty Nothing "id") (int 1)) - (NE.singleton $ MyApp mempty (MyVar mempty Nothing "id") (bool True)) - ) - let expected = Right (MTTuple mempty (MTPrim mempty MTInt) (NE.singleton $ MTPrim mempty MTBool)) - startInference expr expected - - it "Simple let pattern with tuple" $ do - let expr = - MyLet - mempty - (Identifier mempty "pair") - (MyTuple mempty (int 1) (NE.singleton $ bool True)) - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyVar mempty Nothing "pair") - (MyVar mempty Nothing "a") - ) - - let expected = Right (MTPrim mempty MTInt) - startInference expr expected - - it "Simplified Tuple destructuring" $ do - let expr = - MyLambda - mempty - (Identifier mempty "tuple") - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyVar mempty Nothing "tuple") - (MyVar mempty Nothing "a") - ) - - let expected = - Right - ( MTFunction - mempty - (MTTuple mempty (unknown 1) (NE.singleton $ unknown 2)) - (unknown 1) - ) - startInference expr expected - - it "Tuple destructuring (pattern match)" $ do - let expr = - MyLet - mempty - (Identifier mempty "fst") - ( MyLambda - mempty - (Identifier mempty "tuple") - ( MyPatternMatch - mempty - (MyVar mempty Nothing "tuple") - [ ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b"), - MyVar mempty Nothing "a" - ) - ] - ) - ) - ( MyLet - mempty - (Identifier mempty "pair") - (MyTuple mempty (int 1) (NE.singleton $ bool True)) - ( MyApp - mempty - (MyVar mempty Nothing "fst") - (MyVar mempty Nothing "pair") - ) - ) - let expected = Right (MTPrim mempty MTInt) - startInference expr expected - - it "Tuple destructuring" $ do - let expr = - MyLet - mempty - (Identifier mempty "fst") - ( MyLambda - mempty - (Identifier mempty "tuple") - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyVar mempty Nothing "tuple") - (MyVar mempty Nothing "a") - ) - ) - ( MyLet - mempty - (Identifier mempty "pair") - (MyTuple mempty (int 1) (NE.singleton $ bool True)) - (MyApp mempty (MyVar mempty Nothing "fst") (MyVar mempty Nothing "pair")) - ) - let expected = Right (MTPrim mempty MTInt) - startInference expr expected - - it "We can use identity with two different datatypes in one expression" $ do - let lambda = - MyLambda - mempty - (Identifier mempty "a") - ( MyIf - mempty - (MyApp mempty identity (MyVar mempty Nothing "a")) - (MyApp mempty identity (int 1)) - (MyApp mempty identity (int 2)) - ) - let expr = MyApp mempty lambda (bool True) - startInference lambda $ - Right - ( MTFunction - mempty - (MTPrim mempty MTBool) - (MTPrim mempty MTInt) - ) - startInference expr $ Right (MTPrim mempty MTInt) - it "Conflict RecordRows throw an error" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyTuple - mempty - ( MyInfix - mempty - Add - (int 1) - (MyRecordAccess mempty (MyVar mempty Nothing "a") "prop") - ) - ( NE.singleton $ - MyInfix - mempty - StringConcat - (str "!") - (MyRecordAccess mempty (MyVar mempty Nothing "a") "prop") - ) - ) - testInfer expr `shouldSatisfy` isLeft - describe "Pattern matching" $ do - it "Returns an EmptyPatternMatch error when no patterns supplied" $ do - let expr = MyPatternMatch mempty (int 1) mempty - startInference expr $ Left (PatternMatchErr $ EmptyPatternMatch mempty) - it "Detects an integer does not match a boolean literal" $ do - let expr = - MyPatternMatch - mempty - (int 1) - [ (PLit mempty (MyBool True), int 1), - (PLit mempty (MyBool False), int 2) - ] - testInfer expr `shouldSatisfy` isLeft - it "Matches a boolean literal" $ do - let expr = - MyPatternMatch - mempty - (bool True) - [ (PLit mempty (MyBool True), int 1), - (PLit mempty (MyBool False), int 2) - ] - startInference expr $ - Right (MTPrim mempty MTInt) - it "Detects patterns don't unify" $ do - let expr = - MyPatternMatch - mempty - (bool True) - [ (PLit mempty (MyBool True), int 1), - (PLit mempty (MyInt 1), int 2) - ] - testInfer expr - `shouldSatisfy` isLeft - it "Detects output exprs don't unify" $ do - let expr = - MyPatternMatch - mempty - (bool True) - [ (PLit mempty (MyBool True), int 1), - (PLit mempty (MyBool False), bool True) - ] - testInfer expr - `shouldSatisfy` isLeft - it "Matches a boolean with a variable" $ do - let expr = - MyPatternMatch - mempty - (int 1) - [(PVar mempty "dog", bool True)] - startInference expr $ - Right (MTPrim mempty MTBool) - it "Matches with a variable and uses that variable" $ do - let expr = - MyPatternMatch - mempty - (int 1) - [ ( PVar mempty "dog", - MyVar mempty Nothing "dog" - ) - ] - startInference expr $ - Right (MTPrim mempty MTInt) - it "Matches with a wildcard expression" $ do - let expr = - MyPatternMatch - mempty - (int 1) - [ ( PWildcard mempty, - bool True - ) - ] - startInference expr $ - Right (MTPrim mempty MTBool) - - it "Matches pattern match values to branch return types" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyPatternMatch - mempty - (MyVar mempty Nothing "a") - [ ( PConstructor mempty Nothing "Just" [PVar mempty "as"], - MyVar mempty Nothing "as" - ), - ( PWildcard mempty, - int 100 - ) - ] - ) - - startInferenceWithDataTypes [dtMaybe] expr $ - Right - (MTFunction mempty (dataTypeWithVars mempty Nothing "Maybe" [MTPrim mempty MTInt]) (MTPrim mempty MTInt)) - - it "Errors when number of args does not match for Just" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Just") (int 1)) - [ ( PConstructor mempty Nothing "Just" [], - bool True - ), - ( PConstructor mempty Nothing "Nothing" [], - bool False - ), - (PConstructor mempty Nothing "Just" [PWildcard mempty], bool False) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Left (PatternMatchErr $ ConstructorArgumentLengthMismatch mempty "Just" 1 0) - it "Matches wildcard inside datatype" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Just") (int 1)) - [ ( PConstructor mempty Nothing "Just" [PWildcard mempty], - bool True - ), - ( PConstructor mempty Nothing "Nothing" [], - bool False - ) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Right (MTPrim mempty MTBool) - it "Matches value inside datatype" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Just") (int 1)) - [ ( PConstructor mempty Nothing "Just" [PVar mempty "a"], - MyVar mempty Nothing "a" - ), - ( PConstructor mempty Nothing "Nothing" [], - int 0 - ) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Right (MTPrim mempty MTInt) - - it "Matches value inside more complex datatype" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "That") (int 1)) - [ ( PConstructor mempty Nothing "This" [PWildcard mempty], - int 0 - ), - ( PConstructor mempty Nothing "That" [PVar mempty "b"], - MyVar mempty Nothing "b" - ), - ( PConstructor mempty Nothing "These" [PWildcard mempty, PVar mempty "b"], - MyVar mempty Nothing "b" - ) - ] - - startInferenceWithDataTypes [dtThese] expr $ - Right (MTPrim mempty MTInt) - - it "Matches nested datatype" $ do - let val = - MyApp - mempty - (MyConstructor mempty Nothing "Just") - ( MyApp mempty (MyConstructor mempty Nothing "Just") (bool True) - ) - let expr = - MyPatternMatch - mempty - val - [ ( PConstructor - mempty - Nothing - "Just" - [ PConstructor - mempty - Nothing - "Just" - [PVar mempty "bool"] - ], - MyVar mempty Nothing "bool" - ), - (PWildcard mempty, bool False) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Right (MTPrim mempty MTBool) - - it "Matches pair" $ do - let expr = - MyPatternMatch - mempty - (MyTuple mempty (int 1) (NE.singleton $ int 2)) - [ ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b"), - MyInfix - mempty - Add - (MyVar mempty Nothing "a") - (MyVar mempty Nothing "b") - ) - ] - startInference expr $ - Right (MTPrim mempty MTInt) - - it "Infers Left type variable in Either from pattern" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Left") (int 1)) - [ ( PConstructor mempty Nothing "Left" [PVar mempty "e"], - MyApp mempty (MyConstructor mempty Nothing "Left") (MyVar mempty Nothing "e") - ), - ( PConstructor mempty Nothing "Right" [PLit mempty (MyInt 1)], - MyApp mempty (MyConstructor mempty Nothing "Right") (int 1) - ), - ( PConstructor mempty Nothing "Right" [PVar mempty "a"], - MyApp mempty (MyConstructor mempty Nothing "Right") (MyVar mempty Nothing "a") - ) - ] - - startInferenceWithDataTypes [dtEither] expr $ - Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTInt, - MTPrim mempty MTInt - ] - ) - it "Infers Right type variable in Either from pattern" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Right") (bool True)) - [ ( PConstructor mempty Nothing "Left" [PLit mempty (MyInt 1)], - MyApp mempty (MyConstructor mempty Nothing "Left") (int 1) - ), - ( PConstructor mempty Nothing "Left" [PVar mempty "e"], - MyApp mempty (MyConstructor mempty Nothing "Left") (MyVar mempty Nothing "e") - ), - ( PConstructor mempty Nothing "Right" [PVar mempty "a"], - MyApp mempty (MyConstructor mempty Nothing "Right") (MyVar mempty Nothing "a") - ) - ] - - startInferenceWithDataTypes [dtEither] expr $ - Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTInt, - MTPrim mempty MTBool - ] - ) - - it "Simpler Either example" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Right") (bool True)) - [ ( PConstructor mempty Nothing "Left" [PWildcard mempty], - MyApp mempty (MyConstructor mempty Nothing "Left") (int 1) - ), - ( PVar mempty "all", - MyVar mempty Nothing "all" - ) - ] - - startInferenceWithDataTypes [dtEither] expr $ - Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTInt, - MTPrim mempty MTBool - ] - ) - it "Simpler Either example 2" $ do - let expr = - MyPatternMatch - mempty - (MyApp mempty (MyConstructor mempty Nothing "Left") (bool True)) - [ ( PConstructor mempty Nothing "Right" [PWildcard mempty], - MyApp mempty (MyConstructor mempty Nothing "Right") (int 1) - ), - ( PVar mempty "all", - MyVar mempty Nothing "all" - ) - ] - - startInferenceWithDataTypes [dtEither] expr $ - Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTBool, - MTPrim mempty MTInt - ] - ) - it "Getting types from pair" $ do - let matchExpr = - MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Pair") - (bool True) - ) - (int 1) - - let expr = - MyPatternMatch - mempty - matchExpr - [ ( PConstructor mempty Nothing "Pair" [PVar mempty "a", PVar mempty "b"], - MyTuple mempty (MyVar mempty Nothing "a") (NE.singleton $ MyVar mempty Nothing "b") - ) - ] - - startInferenceWithDataTypes [dtPair] expr $ - Right - ( MTTuple - mempty - (MTPrim mempty MTBool) - ( NE.singleton $ MTPrim mempty MTInt - ) - ) - - it "Fails when record does not match pattern" $ do - let expr = - MyPatternMatch - mempty - (MyRecord mempty (M.singleton "dog" (int 1))) - [ ( PRecord - mempty - ( M.singleton - "log" - (PWildcard mempty) - ), - bool True - ) - ] - testInfer expr - `shouldSatisfy` isLeft - it "Succeeds when record partially matches pattern" $ do - let expr = - MyPatternMatch - mempty - (MyRecord mempty (M.fromList [("dog", int 1), ("cat", bool True)])) - [ ( PRecord - mempty - ( M.singleton - "dog" - (PVar mempty "a") - ), - MyVar mempty Nothing "a" - ) - ] - startInference expr $ - Right (MTPrim mempty MTInt) - it "Succeeds when record entirely matches pattern" $ do - let expr = - MyPatternMatch - mempty - (MyRecord mempty (M.fromList [("dog", int 1), ("cat", int 2)])) - [ ( PRecord - mempty - ( M.fromList - [ ( "dog", - PVar - mempty - "a" - ), - ("cat", PVar mempty "b") - ] - ), - MyInfix - mempty - Add - (MyVar mempty Nothing "a") - (MyVar mempty Nothing "b") - ) - ] - startInference expr $ - Right (MTPrim mempty MTInt) - it "Spots a missing pattern" $ do - let expr = - MyPatternMatch - mempty - (MyConstructor mempty Nothing "Nothing") - [ ( PConstructor mempty Nothing "Just" [PWildcard mempty], - bool False - ) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Left - ( PatternMatchErr - (MissingPatterns mempty [PConstructor mempty Nothing "Nothing" mempty]) - ) - it "Does substitutions correctly when pattern matching on a variable from a lambda" $ do - let expr = - MyLambda - mempty - (Identifier mempty "a") - ( MyPatternMatch - mempty - (MyVar mempty Nothing "a") - [ (PConstructor mempty Nothing "Just" [PVar mempty "as"], MyVar mempty Nothing "as"), - (PConstructor mempty Nothing "Nothing" [], MyLiteral mempty (MyInt 100)) - ] - ) - - mtMaybeInt = dataTypeWithVars mempty Nothing "Maybe" [mtInt] - startInferenceWithDataTypes [dtMaybe] expr $ - Right (MTFunction mempty mtMaybeInt mtInt) - it "Does substitutions correctly when pattern matching on a variable from a lambda with application" $ do - let fn = - MyLambda - mempty - (Identifier mempty "a") - ( MyLambda - mempty - (Identifier mempty "b") - ( MyPatternMatch - mempty - (bool True) - [ (PLit mempty (MyBool True), MyVar mempty Nothing "a"), - (PWildcard mempty, MyVar mempty Nothing "b") - ] - ) - ) - expr = MyApp mempty (MyApp mempty fn (MyLiteral mempty (MyInt 1))) (MyLiteral mempty (MyBool True)) - startInference expr $ - Left (FunctionArgumentMismatch mempty (MTPrim mempty MTInt) (MTPrim mempty MTBool)) - it "Does substitutions correctly when pattern matching on a variable inside a constructor from a lambda with application" $ do - let fn = - MyLambda - mempty - (Identifier mempty "maybeA") - ( MyLambda - mempty - (Identifier mempty "b") - ( MyPatternMatch - mempty - (MyVar mempty Nothing "maybeA") - [ ( PConstructor mempty Nothing "Just" [PVar mempty "a"], - MyVar mempty Nothing "a" - ), - (PWildcard mempty, MyVar mempty Nothing "b") - ] - ) - ) - maybeExpr = - MyApp - mempty - (MyConstructor mempty Nothing "Just") - (MyLiteral mempty (MyInt 1)) - expr = - MyApp - mempty - (MyApp mempty fn maybeExpr) - ( MyLiteral mempty (MyBool True) - ) - - startInferenceWithDataTypes [dtMaybe] expr $ - Left (FunctionArgumentMismatch mempty (MTPrim mempty MTInt) (MTPrim mempty MTBool)) - - it "Spots a redundant pattern" $ do - let expr = - MyPatternMatch - mempty - (MyConstructor mempty Nothing "Nothing") - [ ( PConstructor mempty Nothing "Just" [PWildcard mempty], - bool False - ), - (PConstructor mempty Nothing "Nothing" mempty, bool True), - (PConstructor mempty Nothing "Nothing" mempty, bool True) - ] - - startInferenceWithDataTypes [dtMaybe] expr $ - Left - ( PatternMatchErr - (RedundantPatterns mempty [PConstructor mempty Nothing "Nothing" mempty]) - ) - describe "Variables as constructors" $ do - it "Let variable as constructor" $ do - let expr = - MyLet - mempty - (Identifier mempty "f") - (MyConstructor mempty Nothing "Just") - (MyApp mempty (MyVar mempty Nothing "f") (int 1)) - - startInferenceWithDataTypes [dtMaybe] expr $ - Right - ( MTTypeApp - mempty - (MTConstructor mempty Nothing "Maybe") - (MTPrim mempty MTInt) - ) - it "Typed hole suggestions in scope item" $ do - let expr = - MyLet - mempty - (Identifier mempty "this") - (bool True) - (MyIf mempty (MyTypedHole mempty "what") (int 1) (int 2)) - startInference expr $ - Left - ( TypedHoles - ( M.singleton - "what" - (MTPrim mempty MTBool, S.singleton "this") - ) - ) - - it "No typed hole suggestions in scope item" $ do - let expr = - MyLet - mempty - (Identifier mempty "this") - (int 1) - (MyIf mempty (MyTypedHole mempty "what") (int 1) (int 2)) - startInference expr $ - Left - ( TypedHoles - ( M.singleton - "what" - (MTPrim mempty MTBool, mempty) - ) - ) - - it "Suggests a polymorphic value, specialised to fit" $ do - let expr = - MyLambda - mempty - (Identifier mempty "this") - (MyIf mempty (MyTypedHole mempty "what") (int 1) (int 2)) - startInference expr $ Left (TypedHoles (M.singleton "what" (MTPrim mempty MTBool, S.singleton "this"))) - - describe "type annotations" $ do - -- needs type annotations to make this make sense - xit "Lambda variable as constructor" $ do - let funcType = - MTFunction - mempty - (MTVar mempty (TVName "f")) - ( MTTypeApp - mempty - (MTVar mempty (TVName "f")) - (MTPrim mempty MTInt) - ) - let expr = - MyAnnotation - mempty - funcType - ( MyLambda - mempty - (Identifier mempty "f") - (MyApp mempty (MyVar mempty Nothing "f") (int 1)) - ) - - startInferenceWithDataTypes [dtMaybe] expr $ - Right funcType - -- needs type annotations - xit "Lambda variable as constructor (multiple application)" $ do - let expr = - MyLambda - mempty - (Identifier mempty "f") - (MyApp mempty (MyApp mempty (MyVar mempty Nothing "f") (int 1)) (bool True)) - - startInferenceWithDataTypes [dtMaybe] expr $ - Right - ( MTFunction - mempty - ( MTFunction - mempty - (MTPrim mempty MTInt) - ( MTFunction - mempty - (MTPrim mempty MTBool) - ( MTTypeApp - mempty - ( MTTypeApp - mempty - (unknown 2) - (MTPrim mempty MTInt) - ) - (MTPrim mempty MTBool) - ) - ) - ) - ( MTTypeApp - mempty - ( MTTypeApp - mempty - (unknown 2) - (MTPrim mempty MTInt) - ) - (MTPrim mempty MTBool) - ) - ) diff --git a/compiler/test/Test/Typechecker/Unify.hs b/compiler/test/Test/Typechecker/Unify.hs deleted file mode 100644 index 4dba166a..00000000 --- a/compiler/test/Test/Typechecker/Unify.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.Typechecker.Unify - ( spec, - ) -where - -import Control.Monad.Except -import Control.Monad.State.Strict (runState) -import Data.Either (isLeft, isRight) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core -import Language.Mimsa.Typechecker.TcMonad -import Language.Mimsa.Typechecker.Unify -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Typechecker.Substitutions -import Test.Hspec -import Test.Utils.Helpers - -runUnifier :: (MonoType, MonoType) -> Either TypeError Substitutions -runUnifier (a, b) = - fst either' - where - defaultState = - TypecheckState 1 mempty - either' = - runState - (runExceptT (unify a b)) - defaultState - -spec :: Spec -spec = - describe "Unify" $ do - it "Two same things teach us nothing" $ - runUnifier (MTPrim mempty MTInt, MTPrim mempty MTInt) - `shouldBe` Right mempty - - it "Combines a known with an unknown" $ - runUnifier (MTVar mempty (TVUnificationVar 1), MTPrim mempty MTInt) - `shouldBe` Right (Substitutions $ M.singleton (TVUnificationVar 1) (MTPrim mempty MTInt)) - - it "Combines a named var with a matching named var" $ - runUnifier (MTVar mempty (TVName "a"), MTVar mempty (TVName "a")) - `shouldSatisfy` isRight - - it "Does not combines a named var with a unification variable" $ - runUnifier (MTVar mempty (TVName "a"), MTVar mempty (TVUnificationVar 1)) - `shouldSatisfy` isLeft - - it "Combines a named/numbered var with a unification variable" $ - runUnifier (MTVar mempty (TVScopedVar 1 "a"), MTVar mempty (TVUnificationVar 1)) - `shouldSatisfy` isRight - - it "Does not combine a named var with a different named var" $ - runUnifier (MTVar mempty (TVName "a"), MTVar mempty (TVName "b")) - `shouldSatisfy` isLeft - - it "Does not combine a named var with a concrete type" $ - runUnifier (MTVar mempty (TVName "a"), MTPrim mempty MTString) - `shouldSatisfy` isLeft - - it "Combines a var with the same var" $ - runUnifier (MTVar mempty (TVScopedVar 1 "a"), MTVar mempty (TVScopedVar 1 "a")) - `shouldSatisfy` isRight - - it "Does not combines a var with the same var" $ - runUnifier (MTVar mempty (TVScopedVar 2 "a"), MTVar mempty (TVScopedVar 1 "a")) - `shouldSatisfy` isLeft - - it "Does not combines a var with a different var" $ - runUnifier (MTVar mempty (TVScopedVar 2 "b"), MTVar mempty (TVScopedVar 1 "a")) - `shouldSatisfy` isLeft - - it "Does not unify a concrete type with a named var" $ - runUnifier (MTVar mempty (TVName "a"), MTPrim mempty MTInt) - `shouldSatisfy` isLeft - - it "Does not unify a concrete type with a numbered var" $ - runUnifier (MTVar mempty (TVScopedVar 1 "a"), MTPrim mempty MTBool) - `shouldSatisfy` isLeft - - it "Combines two half pairs" $ - runUnifier - ( MTTuple mempty (MTVar mempty (TVUnificationVar 1)) (NE.singleton $ MTPrim mempty MTInt), - MTTuple mempty (MTPrim mempty MTBool) (NE.singleton $ MTVar mempty (TVUnificationVar 2)) - ) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 1, MTPrim mempty MTBool), - (TVUnificationVar 2, MTPrim mempty MTInt) - ] - ) - - describe "Constructors" $ do - it "Combines a Maybe" $ do - runUnifier - ( MTTypeApp mempty (MTConstructor mempty Nothing "Maybe") (MTVar mempty $ TVUnificationVar 1), - MTTypeApp mempty (MTConstructor mempty Nothing "Maybe") (MTPrim mempty MTInt) - ) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 1, MTPrim mempty MTInt) - ] - ) - - it "Combines an Either" $ do - runUnifier - ( MTTypeApp mempty (MTTypeApp mempty (MTConstructor mempty Nothing "Either") (MTVar mempty $ TVUnificationVar 1)) (MTPrim mempty MTBool), - MTTypeApp mempty (MTTypeApp mempty (MTConstructor mempty Nothing "Either") (MTPrim mempty MTInt)) (MTVar mempty $ TVUnificationVar 2) - ) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 1, MTPrim mempty MTInt), - (TVUnificationVar 2, MTPrim mempty MTBool) - ] - ) - - describe "Records" $ do - it "Combines two half records" $ - runUnifier - ( MTRecord - mempty - ( M.fromList - [ ("one", MTPrim mempty MTInt), - ("two", MTVar mempty (TVUnificationVar 1)) - ] - ) - Nothing, - MTRecord - mempty - ( M.fromList - [ ("one", MTVar mempty (TVUnificationVar 2)), - ("two", MTPrim mempty MTBool) - ] - ) - Nothing - ) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 1, MTPrim mempty MTBool), - (TVUnificationVar 2, MTPrim mempty MTInt) - ] - ) - - it "Two conflicting RecordRows errors" $ do - let leftItems = M.singleton "a" (MTPrim mempty MTInt) - rightItems = M.singleton "a" (MTPrim mempty MTString) - runUnifier - ( MTRecord mempty leftItems (Just $ unknown 1), - MTRecord mempty rightItems (Just $ unknown 2) - ) - `shouldSatisfy` isLeft - it "Combines Record with matching RecordRow" $ do - let items = M.fromList [("a", MTPrim mempty MTInt), ("b", MTPrim mempty MTString)] - runUnifier (MTRecord mempty items (Just $ unknown 3), MTRecord mempty items Nothing) - `shouldBe` Right mempty - it "Combines Record with RecordRow with less items" $ do - let recordItems = M.fromList [("a", MTPrim mempty MTInt), ("b", MTPrim mempty MTString)] - rowItems = M.fromList [("a", MTPrim mempty MTInt)] - runUnifier (MTRecord mempty rowItems (Just $ unknown 3), MTRecord mempty recordItems Nothing) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 3, MTRecord mempty (M.singleton "b" $ MTPrim mempty MTString) (Just $ unknown 1)) - ] - ) - it "Combines Record with less items with RecordRow" $ do - let rowItems = M.fromList [("a", MTPrim mempty MTInt), ("b", MTPrim mempty MTString)] - recordItems = M.fromList [("a", MTPrim mempty MTInt)] - runUnifier (MTRecord mempty rowItems (Just $ unknown 3), MTRecord mempty recordItems Nothing) - `shouldSatisfy` isLeft - it "Combines Record with less items with nested RecordRow" $ do - let rowOne = M.singleton "a" (MTPrim mempty MTInt) - rowTwo = M.singleton "b" (MTPrim mempty MTString) - recordItems = M.fromList [("a", MTPrim mempty MTInt)] - runUnifier (MTRecord mempty rowOne (Just $ MTRecord mempty rowTwo (Just $ unknown 3)), MTRecord mempty recordItems Nothing) - `shouldSatisfy` isLeft - - it "Combines two RecordRows with different items" $ do - let leftItems = M.singleton "a" (MTPrim mempty MTInt) - rightItems = M.singleton "b" (MTPrim mempty MTString) - runUnifier - ( MTRecord mempty leftItems (Just $ unknown 2), - MTRecord mempty rightItems (Just $ unknown 3) - ) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ (TVUnificationVar 2, MTRecord mempty rightItems (Just $ unknown 1)), - (TVUnificationVar 3, MTRecord mempty leftItems (Just $ unknown 1)) - ] - ) - it "Combines two RecordRows with some matching items" $ do - let leftItems = - M.fromList - [ ("same", MTPrim mempty MTInt), - ("a", MTPrim mempty MTString) - ] - rightItems = - M.fromList - [ ("same", MTPrim mempty MTInt), - ("b", MTPrim mempty MTBool) - ] - runUnifier (MTRecord mempty leftItems (Just $ unknown 10), MTRecord mempty rightItems (Just $ unknown 11)) - `shouldBe` Right - ( Substitutions $ - M.fromList - [ ( TVUnificationVar 10, - MTRecord - mempty - ( M.singleton - "b" - (MTPrim mempty MTBool) - ) - (Just $ unknown 1) - ), - ( TVUnificationVar 11, - MTRecord - mempty - ( M.singleton - "a" - (MTPrim mempty MTString) - ) - (Just $ unknown 1) - ) - ] - ) diff --git a/compiler/test/Test/Utils/Compilation.hs b/compiler/test/Test/Utils/Compilation.hs deleted file mode 100644 index af560537..00000000 --- a/compiler/test/Test/Utils/Compilation.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Utils.Compilation - ( testProjectCompile, - testModuleCompile, - testWholeProjectCompile, - ) -where - -import Control.Monad.IO.Class (liftIO) -import Data.Foldable -import Data.Hashable -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.Mimsa.Actions.Compile as Actions -import qualified Language.Mimsa.Actions.Modules.Check as Actions -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Modules.Imports as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import qualified Language.Mimsa.Actions.Types as Actions -import Language.Mimsa.Backend.Output -import Language.Mimsa.Backend.Shared -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store -import Test.Data.Project -import Test.Utils.Helpers -import Test.Utils.Serialisation - --- | evaluate an expression, then compile into a temp folder and return the --- main filename -testProjectCompile :: - String -> - Backend -> - Expr Name Annotation -> - IO (FilePath, Int) -testProjectCompile folderPrefix be expr = do - let action = do - (_, _, newModule) <- Actions.evaluateModule expr mempty - (_, exprMap, _) <- Actions.compileModule be newModule - let exprName = case Actions.evalId of - DIName name -> name - _ -> error "broken evalId" - case M.lookup exprName exprMap of - Just eh -> pure eh - Nothing -> error "could not find outputted exprHash to compile" - let (_newProject_, outcomes, seHash) = - fromRight (Actions.run stdlib action) - - writeFiles be folderPrefix seHash outcomes - --- | compile a module into a temp folder and return the main filename -testModuleCompile :: - String -> - Backend -> - T.Text -> - IO (FilePath, Int) -testModuleCompile folderPrefix be input = do - let action = do - -- parse a module from text - (parsedModule, _) <- Actions.checkModule mempty input - -- turn into TS / JS etc - (moduleHash, _, _) <- Actions.compileModule be (getAnnotationForType <$> parsedModule) - pure moduleHash - let (_newProject_, outcomes, modHash) = - fromRight (Actions.run testStdlib action) - - writeModuleFiles be folderPrefix modHash outcomes - --- | compile a project into a temp folder and return the main filename -testWholeProjectCompile :: - String -> - Project Annotation -> - Backend -> - IO (FilePath, Int) -testWholeProjectCompile folderName project be = do - let action = do - _ <- Actions.compileProject be - pure () - let (_newProject_, outcomes, _) = - fromRight (Actions.run project action) - - -- clean up old rubbish - deleteOutputFolder folderName - - -- re-create path - tsPath <- createOutputFolder folderName - - -- write all files to temp folder - traverse_ - ( \(_, filename, Actions.SaveContents content) -> do - let savePath = tsPath <> show filename - liftIO $ T.writeFile savePath content - ) - (Actions.writeFilesFromOutcomes outcomes) - - -- hash of generated content for caching test results - let allFilesHash = hash (Actions.writeFilesFromOutcomes outcomes) - - let actualIndexPath = tsPath <> "/" <> T.unpack (projectIndexFilename be) - - pure (actualIndexPath, allFilesHash) - -writeModuleFiles :: Backend -> String -> ModuleHash -> [Actions.ActionOutcome] -> IO (FilePath, Int) -writeModuleFiles be folderPrefix modHash outcomes = do - let folderName = folderPrefix <> "/compile-test-" <> show modHash - - -- clean up old rubbish - deleteOutputFolder folderName - - -- re-create path - tsPath <- createOutputFolder folderName - - -- write all files to temp folder - traverse_ - ( \(_, filename, Actions.SaveContents content) -> do - let savePath = tsPath <> show filename - liftIO $ T.writeFile savePath content - ) - (Actions.writeFilesFromOutcomes outcomes) - - -- hash of generated content for caching test results - let allFilesHash = hash (Actions.writeFilesFromOutcomes outcomes) - - -- make a new index file that imports the outcome and logs it - let actualIndex = - "import { main } from './" - <> moduleImport be modHash - <> "';\nconsole.log(main)" - - -- get filename of index file - let actualIndexPath = tsPath <> T.unpack (projectIndexFilename be) - - -- write actual index - liftIO (T.writeFile actualIndexPath actualIndex) - - pure (actualIndexPath, allFilesHash) - -writeFiles :: Backend -> String -> ExprHash -> [Actions.ActionOutcome] -> IO (FilePath, Int) -writeFiles be folderPrefix seHash outcomes = do - let folderName = folderPrefix <> "/compile-test-" <> show seHash - - -- clean up old rubbish - deleteOutputFolder folderName - - -- re-create path - tsPath <- createOutputFolder folderName - - -- write all files to temp folder - traverse_ - ( \(_, filename, Actions.SaveContents content) -> do - let savePath = tsPath <> show filename - liftIO $ T.writeFile savePath content - ) - (Actions.writeFilesFromOutcomes outcomes) - - -- hash of generated content for caching test results - let allFilesHash = hash (Actions.writeFilesFromOutcomes outcomes) - - -- make a new index file that imports the outcome and logs it - let actualIndex = - "import { main } from './" - <> storeExprFilename be seHash - <> "';\nconsole.log(main)" - - -- get filename of index file - let actualIndexPath = tsPath <> T.unpack (projectIndexFilename be) - - -- write actual index - liftIO (T.writeFile actualIndexPath actualIndex) - - pure (actualIndexPath, allFilesHash) diff --git a/compiler/test/Test/Utils/Helpers.hs b/compiler/test/Test/Utils/Helpers.hs deleted file mode 100644 index 039f7fa1..00000000 --- a/compiler/test/Test/Utils/Helpers.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Utils.Helpers (joinLines, fromRight, fromLeft, fromJust, mkStoreExpression, unsafeParseExpr', int, bool, unknown, str', textErrorContains, str, evaluateText, unsafeParseExpr, mtBool, mtString, mtVar, mtInt, unsafeParseDataType, tvNamed, tvNum, typeName, unsafeParseModuleItem, mtFun, unsafeParseMonoType) where - -import Data.Functor -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Helpers.Parse as Actions -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store - -joinLines :: [Text] -> Text -joinLines = T.intercalate "\n" - -fromRight :: (Printer e) => Either e a -> a -fromRight either' = case either' of - Left e -> error (T.unpack $ prettyPrint e) - Right a -> a - -fromLeft :: Either e a -> e -fromLeft either' = case either' of - Left e -> e - Right _ -> error "Expected a Left!" - -fromJust :: Maybe a -> a -fromJust maybe' = case maybe' of - Just a -> a - _ -> error "Expected a Just" - --- | make a StoreExpression with no deps -mkStoreExpression :: Expr Name ann -> StoreExpression ann -mkStoreExpression expr = StoreExpression expr mempty mempty mempty mempty - -unsafeParseExpr' :: (Monoid ann) => Text -> Expr Name ann -unsafeParseExpr' t = case parseExpr t of - Right a -> a $> mempty - Left _ -> - error $ - "Error parsing expr for Prettier tests:" - <> T.unpack t - -unsafeParseDataType :: Text -> DataType -unsafeParseDataType t = case parseTypeDecl t of - Right a -> a - Left _ -> error $ "could not parse data type: " <> T.unpack t - -unsafeParseExpr :: Text -> Expr Name () -unsafeParseExpr = unsafeParseExpr' - -unsafeParseModuleItem :: (Monoid ann) => Text -> ModuleItem ann -unsafeParseModuleItem t = case parseAndFormat moduleParser t of - Right [item] -> item $> mempty - Right _many -> error "ModuleItem parser succeeded but did not have 1 item" - Left e -> error $ "Error parsing ModuleItem for tests: " <> T.unpack (prettyPrint e) - -unsafeParseMonoType :: Text -> Type () -unsafeParseMonoType t = case parseMonoType t of - Right a -> a $> () - Left _ -> - error $ - "Error parsing monotype for Prettier tests:" - <> T.unpack t - -textErrorContains :: Text -> Either Text a -> Bool -textErrorContains s res = case res of - Left e -> s `T.isInfixOf` e - _ -> False - -bool :: (Monoid ann) => Bool -> Expr a ann -bool a = MyLiteral mempty (MyBool a) - -int :: (Monoid ann) => Int -> Expr a ann -int a = MyLiteral mempty (MyInt a) - -str :: (Monoid ann) => StringType -> Expr a ann -str a = MyLiteral mempty (MyString a) - -str' :: (Monoid ann) => Text -> Expr a ann -str' = str . StringType - --- -unknown :: (Monoid ann) => Int -> Type ann -unknown = MTVar mempty . TVUnificationVar - -typeName :: (Monoid ann) => Text -> Type ann -typeName = MTVar mempty . TVName . mkTyVar - ---- - -tvNum :: Int -> TypeIdentifier -tvNum = TVUnificationVar - -tvNamed :: Text -> TypeIdentifier -tvNamed t = TVName $ mkTyVar t - ----- - -mtInt :: (Monoid ann) => Type ann -mtInt = MTPrim mempty MTInt - -mtBool :: (Monoid ann) => Type ann -mtBool = MTPrim mempty MTBool - -mtString :: (Monoid ann) => Type ann -mtString = MTPrim mempty MTString - -mtVar :: (Monoid ann) => Text -> Type ann -mtVar n = MTVar mempty (tvNamed n) - -mtFun :: (Monoid ann) => Type ann -> Type ann -> Type ann -mtFun = MTFunction mempty - ----- - --- | given some text, parse and typecheck it -evaluateText :: - Project Annotation -> - Text -> - Either (Error Annotation) (Expr Name MonoType) -evaluateText project input = do - let action = do - expr <- Actions.parseExpr input - Actions.typecheckExpression expr mempty - (_, _, typedExpr) <- - Actions.run - project - action - pure typedExpr diff --git a/compiler/test/Test/Utils/Serialisation.hs b/compiler/test/Test/Utils/Serialisation.hs deleted file mode 100644 index e3aa58c8..00000000 --- a/compiler/test/Test/Utils/Serialisation.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Utils.Serialisation - ( getAllFilesInDir, - loadJSON, - saveJSON, - savePretty, - loadRegression, - saveRegression, - createOutputFolder, - deleteOutputFolder, - loadStoreExpression, - saveStoreExpression, - ) -where - -import Control.Exception (try) -import qualified Data.Aeson as JSON -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BS -import Data.Functor -import Data.List (isInfixOf) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Text.Lazy (fromStrict) -import Data.Text.Lazy.Encoding -import Language.Mimsa.Core -import Language.Mimsa.Store -import Language.Mimsa.Types.Store -import System.Directory - -saveRootPath :: String -saveRootPath = "./compiler/test/golden" - -createOutputFolder :: FilePath -> IO FilePath -createOutputFolder folder = do - let fullPath = saveRootPath <> "/" <> folder - createDirectoryIfMissing True fullPath - pure (fullPath <> "/") - -deleteOutputFolder :: FilePath -> IO () -deleteOutputFolder folder = do - let fullPath = saveRootPath <> "/" <> folder - removePathForcibly fullPath - -getAllFilesInDir :: FilePath -> String -> IO [String] -getAllFilesInDir folder ext = do - path <- createOutputFolder folder - files <- listDirectory path - pure $ - filter - (isInfixOf ext) - ((path <>) <$> files) - --- if file does not already exist, convert it to ByteString and save it -saveRegression :: - String -> - (a -> ByteString) -> - a -> - IO () -saveRegression savePath convert a = do - exists <- doesFileExist savePath - if exists - then pure () - else do - putStrLn $ "Writing " <> savePath <> "..." - BS.writeFile savePath (convert a) - --- attempt to load and decode from file -loadRegression :: - String -> - (ByteString -> Either Text a) -> - IO (Either Text a) -loadRegression loadPath decode = do - file <- try $ BS.readFile loadPath - case file of - Right a -> case decode a of - Right ok -> pure (Right ok) - Left e -> do - putStrLn $ loadPath <> ": " - T.putStrLn e - pure (Left e) - Left (_ :: IOError) -> - pure (Left $ "Error loading file: " <> T.pack loadPath) - -saveJSON :: - (JSON.ToJSON a) => - String -> - a -> - IO () -saveJSON filename = saveRegression filename JSON.encode - -loadJSON :: - (JSON.FromJSON a) => - String -> - IO (Either Text a) -loadJSON filename = - loadRegression - filename - ( \a -> case JSON.decode a of - Just a' -> Right a' - Nothing -> Left "JSON decode failed" - ) - -saveStoreExpression :: String -> StoreExpression ann -> IO () -saveStoreExpression filename = - saveRegression filename (fst . serialiseStoreExpression) - -loadStoreExpression :: String -> IO (Either Text (StoreExpression ())) -loadStoreExpression filename = - loadRegression - filename - ( \a -> case deserialiseStoreExpression a of - Just a' -> pure (a' $> ()) - Nothing -> Left "Decoding Store Expression failed" - ) - -savePretty :: - (Printer a) => - String -> - a -> - IO () -savePretty filename = - saveRegression - filename - (encodeUtf8 . fromStrict . prettyPrint) diff --git a/compiler/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json b/compiler/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json deleted file mode 100644 index eb62daa5..00000000 --- a/compiler/test/golden/SaveProject/1e3db6bbe43f768b8445530974851e87140a9c47df381d7f7a5a20a7a62f7e3a.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["6efce297c2d4351e9a7efe9843a834ba2898dbacb3f18472eca94b66e8a20353"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json b/compiler/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json deleted file mode 100644 index 24eace25..00000000 --- a/compiler/test/golden/SaveProject/2be54e49da619543433213f310799d3f65d1a5725b76bb1c4825da0d303bad2e.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["89ec42d372033b7a5d322f418c1c773b2cb72a25c3ee1fa00c0a6a16ca0dad92"],"aRecord":["67c91729b64f5e925ff20a372d655b09c22c8fe825692f49e44ee01b0571c7fe"],"addInt":["50d596f035ef2298486dfe76fce2eb559aa9790444b8fe198b1aa18fb8098f00"],"and":["dda72ee0b169eca331a8e82c7e2ea5e9eec65423a697fbd6c0c550f0658fa602"],"anyChar":["506016edce16d305a382b50895ba565b36591c777af422deab19d836a633992b"],"apState":["ccd75a4b14bbaac07de81f51ead2677e45e42f0e806a35cb5fb29363c6874df5"],"bindParser":["06c44f8b06787e06c9937a619acbd87b6cc30c0228fe13c0727b68da574e7bc0"],"bindState":["491e3832b8573dd503ce8ae77a33fe10e26230cd005391520115582431672268"],"compose":["e080b6add324eb92cbef140e85bff5adc3278371ae13b6ebcd954f941fecec69","21d6bf82bd841b80647b19055fcfff02e8f2a195bc97d0801388ee2d15911754"],"cons":["d9d8d53a5eb27950e916f5bc716e28fd80148de11437477af86439f87fecae22"],"const":["065947481f020264ce041ba551f5534fa49a7d81a5b2836b74069635ac7134a8"],"constFalse":["6887c73fa2acc5014df704ae64b0789fa13a631ece9829772d0b2f973892a657"],"constTrue":["3cbfc22aec69a1f929939a6e95db2562c2d7aef97817b76747f239153e44e69f"],"either":["2b50845346ae7befaad7d06ed4cbea233e01b2365d168792f0de0914d468c353"],"eq":["7865e0a2b8d0e86ff3c1538fbbab1e2b7637fb725068837106678b6c992955c4"],"eqTen":["ae67718536e7366d3e44624f024c5a2ade5396fc224fec2531c793d2820bbb48"],"evalState":["d618faa423396f0bb3a79ae01dd1940f51f4eb3a9c83daab2082e797deca8d39"],"execState":["9b5c8e929db9e174f1ce1394e835df1d8cc6cf1a7ff906c52f8ed4fe74cddba7"],"failParser":["fa5edee30d30af98e23ea1bffd2214cb652510fea5d0159cae92557de4ffe378"],"fmapMaybe":["22266c91dc63819a66db32fdcba6f8779d30ee789317a97b08f69bfa45516363"],"fmapParser":["cd42896cef20904082efe867f8704fef86d93e45036d3f6037b4d43fb579cc91"],"fmapState":["b3e0ec45ae5d3a6fa1962886e9531ceac3626bd3d9227498dd482fb926b41031"],"fst":["f978339d21f76522684de9dfe0cc33a1375356e813aae7e36169fb5ff7477067"],"fstPair":["140640e279b2ab46a2cd4f7c0c6f43974c23d4336f0c818c3f26934cf6a832fe"],"id":["6bcbfacffa7df2141fdaab499b254937055614a413d00bbaca98998028dabad4"],"ident":["47863facbb14b341c179244839967614be2682bb8999b8246107a48bd7928cb8"],"incrementInt":["41632fd3b67d33aa652e4057598b592deaf890763869aa88cd10fc17338d6845"],"int":["09cd4349c6c00d40e14689ad994bfb71a4512728bc12a71a10d3b152e9e0bba8"],"invertTree":["f128ac2dc2cd03b663886a45c92a993bfae3b18cb35695cd47a0e834056d891b"],"invertTreeTwice":["21acd81c00a43b6b3ce53b7bf9075de96c78fc6d8a570c96e48ea39444e3edba"],"liftA2State":["99110470e13a475f5968feb06acf7f4157667f28848b928bb79a66f76985369d"],"list":["07310ce985594d4b40df473d66f3a7b0dc6e245ce8fbd7f409ec02fcae961ce7"],"mapArray":["af09b9118c81903f2f1d1452ab9a2d8d2b8764115467c8f74a362e22d4b7b93a"],"maybeMonoid":["e720c445e6c1ca3efd534925c3d617ee11d62e96d321ec2a9ef78716edec1231"],"monoPair":["8dfd7bec63258df923500c9945740b2e6bef48120ef989c85ee27b7c4cc6e3c2"],"nil":["5488e660b1ca97664bafb058886a2dc02e182976fb244f56f4e8175fe1f7c68b"],"not":["eeb4c3a7f5a8dff2bf11d64864d39fafeadef96bd3d2cf8c6786b462c3e839db"],"pair":["b792651c6b6f38ee27bbc8bb471b4c9b9712ca89820625609c9d52a1a62bba77"],"parser":["d0c809ccb07f8a0e6242f19caf922734c00c5e382e247da40ed16dbc950fe899"],"predParser":["5b84e032adbb016f2b1fc5836936a0a4354b457c8373a97460098fea5366ca8f"],"pureState":["e9828be4d35ef15b9391b05c46830d82a6512506930e36273e82cc0466323e36"],"runParser":["d7f6ff73646c63539b4282a98cf9b432dcd5504900a3a1b5580d5055f25d197f"],"runState":["52f8cc7edcb587683bf83846d4afecb42444ba4ff38886c4e49308871eed0e11"],"snd":["27b0c6ec1fa2ae2b61809756a138cece632f47b2c46377065c32e81f0276ce8d"],"sndPair":["8b4e660d07a0f0fcd0b7b7f32d8d884a2b4480d75a8f5bd90e6411acae9ad1ae"],"state":["47e1c8e33c8646c744c513a752c4beda810f713176b426d2eee1a36ca7c94ba0"],"storeName":["8e9c28a29597c9fff7e8c520771e9d52c155a87a532cc3136291133f553f3851"],"stringMonoid":["019a523b2c4757f5949f06c9b961addcbad359c73945739ccc5f8ab606816da1"],"stringReduce":["68a148f7fc27644880c28c3fc48fc615e2cf0f52085ccc68f579962b9cfd0753"],"subtractInt":["c88909ec5c5c953982dae03632f48e6b5484168da1b3c2f822c212ed7f580b3c"],"sumMonoid":["7f9473b31145d179d7b24606e07d3d0d6e4e2de502f8d71440d6eea98714017f"],"testStateUsages":["f909477d250128aeed4e3996ea20bfd13b0036b28f1a380a5518ae30427d67bb"],"trafficLight":["29cfc3f9d88ccdfc1a42affc423abe2647a39b1aa0e95827ea0edb4975ee57b0"],"tree":["8b91340817fc53dd09a94c5ab008badb547d602917d0a7d07df405bf9335c02d"],"typePerson":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"typeState":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"typeThese":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Cons":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Either":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"Green":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Ident":["eaea1fa57623e4b29172d982c3fb03d5048391668504c0129ae3081497d9d2f6"],"Just":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Leaf":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Left":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"List":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Maybe":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"MonoPair":["bb6f10ce0fead888d2f2d85defc08e21919ee06c01503a769b8b7286865ae920"],"Monoid":["1d49dac60d3b201147ddad2493dd67e98be499e801db0897f86f5de37666422b"],"Nil":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Nothing":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Pair":["19817d3943f7ef924625ccb655e5492adf0168f29238edec61a0310eb999bc2c"],"Parser":["56c450b3dadc5621e7fc54162257f50aa3b0091c22fba1efce0d97935d60484f"],"Person":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"Red":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Right":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"State":["63469d9155ce6dcd64bfab0e3e40ec9d43f54905c7f236e3a3c568636d145697"],"That":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"These":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"This":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"TrafficLight":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Tree":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Yellow":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json b/compiler/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json deleted file mode 100644 index 025c9c9d..00000000 --- a/compiler/test/golden/SaveProject/2d4aede0f90ea2b7256d39bfc99868a14960ab8a88c160c99155de48495a9719.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"either":["e8dc919cf8b9bdcd8d6f28412ab099b4ede573c094b472284e9a0fa6ae9c341a"],"eitherAp":["2ffab3dd4460746288febd5b751fc94f6aae8371cdb2575b823e054840854728"],"eitherFmap":["b5008f7c34747cde95b7ed126ee49b0d6b5a5707aad77bec78b976224b061801"],"eitherPure":["c2d95f4066c787cbf265d8c9224afc234816256dcb6a3eaaa4ec264cf119e6fe"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json b/compiler/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json deleted file mode 100644 index 2b9cc2ec..00000000 --- a/compiler/test/golden/SaveProject/35b6226a9ed6f1ef007b656836db57d56146f1741754d625cc773126bab2bcec.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["083684fc6b7cb4d27b88a7863f67479e53b48a5f7674c468eef04b853e9433f5"],"apState":["5aa3c8c5b588c82e3fb2a485d8be1aa3ebc2d3e929ce260160da198f549ee36d"],"bindParser":["12f48a641846bc9fde215f4395602452f5765624b08d2c9bd1e3e8d7bb50d9b8"],"bindState":["bcc003d3140ecd5166b99e1cc7fddce3e05238d3d2567691b9400b42d5978ce8"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["a14881a7387acb9039631e994483db537509e46ae9f42cab84b47e39335a202f"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["3ccd9283de2206222b8cd95b47247dc7d7f1673a4c0f2e2bc664696ded151092"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["15f7b24a87ffe1b581fe010e63c8747761e05f2cf0ede98c4968a23a24f15901"],"fmapMaybe":["35e9d187aa7430499de7e4b67e7b5ea400b0f5446325fc7a3a16cbb78ee6d25e"],"fmapParser":["2899974ec4a5663b805ac436a7ca7254b661e7bacda2909024f1c81f038827e7"],"fmapState":["173f55349a3a743aede1435449ce50aa0c1131e257f362ba80b6d8e6d4177e03"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["2f1d8e4b6c3c23cbf30e27d43cb5191eb99b1ef326739bd30d6be47afa8b42af"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["bc810a57840e640ccc2e9e2e40be9480c4ea0ef7878ff75bac820f03fd851f1d"],"invertTreeTwice":["0eb26613c0044072286813a4f51ad25cddb01727f1a76ac02ef3965096bd69bf"],"liftA2State":["01245a64386ee8b54baa18f544df708f63f4ab89f61d64ed20708a5091f7ab63"],"list":["0e1c660f7d4b68d1c683a0da600bea35e16faf2efe67499f8aa27d7477f71b29"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["dd5ba6d519589e5c2d0a45e3cfb0e2707d0fdaaba43f9fef13d2fffe2e2f063b"],"monoPair":["002686d2b7391bd9c10be845cbb2f91c7faa74ecd391344d240841b0a7722a3c"],"nil":["ac695b5193a4664f86c249333e3adf61363deff8ae31f796eec3b70a350f107e"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["dd6b53e2749e55e65a23678733d02e8fb5822f49b2429823e137f12ab8e467af"],"parser":["daf281457d099413948cf496b8a4cae74bc8cc6c9dcb80ce73ae8fa1356b4c9b"],"predParser":["af017c1dc75e71de18a7dac3ff8b6be515000977fd4ccba1e499ddef03c614a0"],"pureState":["385d2ff93f84c1fc7796fc620b1f37ce540bb640a09ec00c97276f4abb0f14fc"],"runParser":["22672bf326ebd6307165f5cfcb37a4e25e0c1b00799a9c9b46ee4beabff44a17"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["afd99ec4e239f4c2f66270fde501d0de300ede9ab34bccf83afdd06eeb9caf6d"],"storeName":["14911c53fe5fe243a489a748ca66fbcb15318de65914310ab9fc33a7a4638265"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["0f02100d95b6bc3fdac0931255c29974de4242ab39c0451cb7949220eab35dad"],"tree":["e6d5d56773f95458450ad9f2f3188f397eadd0802090ddc17b4bca766b0439fe"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json b/compiler/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json deleted file mode 100644 index 421556b1..00000000 --- a/compiler/test/golden/SaveProject/360ce64eaef8bc5512ad6923d5da4159586f7127b844c456e4654b5594619708.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["89ec42d372033b7a5d322f418c1c773b2cb72a25c3ee1fa00c0a6a16ca0dad92"],"aRecord":["67c91729b64f5e925ff20a372d655b09c22c8fe825692f49e44ee01b0571c7fe"],"addInt":["50d596f035ef2298486dfe76fce2eb559aa9790444b8fe198b1aa18fb8098f00"],"and":["dda72ee0b169eca331a8e82c7e2ea5e9eec65423a697fbd6c0c550f0658fa602"],"anyChar":["506016edce16d305a382b50895ba565b36591c777af422deab19d836a633992b"],"apState":["ccd75a4b14bbaac07de81f51ead2677e45e42f0e806a35cb5fb29363c6874df5"],"bindParser":["06c44f8b06787e06c9937a619acbd87b6cc30c0228fe13c0727b68da574e7bc0"],"bindState":["491e3832b8573dd503ce8ae77a33fe10e26230cd005391520115582431672268"],"compose":["e080b6add324eb92cbef140e85bff5adc3278371ae13b6ebcd954f941fecec69","21d6bf82bd841b80647b19055fcfff02e8f2a195bc97d0801388ee2d15911754"],"cons":["d9d8d53a5eb27950e916f5bc716e28fd80148de11437477af86439f87fecae22"],"const":["065947481f020264ce041ba551f5534fa49a7d81a5b2836b74069635ac7134a8"],"constFalse":["6887c73fa2acc5014df704ae64b0789fa13a631ece9829772d0b2f973892a657"],"constTrue":["3cbfc22aec69a1f929939a6e95db2562c2d7aef97817b76747f239153e44e69f"],"either":["2b50845346ae7befaad7d06ed4cbea233e01b2365d168792f0de0914d468c353"],"eq":["7865e0a2b8d0e86ff3c1538fbbab1e2b7637fb725068837106678b6c992955c4"],"eqTen":["ae67718536e7366d3e44624f024c5a2ade5396fc224fec2531c793d2820bbb48"],"evalState":["d618faa423396f0bb3a79ae01dd1940f51f4eb3a9c83daab2082e797deca8d39"],"execState":["9b5c8e929db9e174f1ce1394e835df1d8cc6cf1a7ff906c52f8ed4fe74cddba7"],"failParser":["fa5edee30d30af98e23ea1bffd2214cb652510fea5d0159cae92557de4ffe378"],"fmapMaybe":["22266c91dc63819a66db32fdcba6f8779d30ee789317a97b08f69bfa45516363"],"fmapParser":["cd42896cef20904082efe867f8704fef86d93e45036d3f6037b4d43fb579cc91"],"fmapState":["b3e0ec45ae5d3a6fa1962886e9531ceac3626bd3d9227498dd482fb926b41031"],"fst":["f978339d21f76522684de9dfe0cc33a1375356e813aae7e36169fb5ff7477067"],"fstPair":["140640e279b2ab46a2cd4f7c0c6f43974c23d4336f0c818c3f26934cf6a832fe"],"id":["6bcbfacffa7df2141fdaab499b254937055614a413d00bbaca98998028dabad4"],"ident":["47863facbb14b341c179244839967614be2682bb8999b8246107a48bd7928cb8"],"incrementInt":["41632fd3b67d33aa652e4057598b592deaf890763869aa88cd10fc17338d6845"],"int":["09cd4349c6c00d40e14689ad994bfb71a4512728bc12a71a10d3b152e9e0bba8"],"invertTree":["f128ac2dc2cd03b663886a45c92a993bfae3b18cb35695cd47a0e834056d891b"],"invertTreeTwice":["21acd81c00a43b6b3ce53b7bf9075de96c78fc6d8a570c96e48ea39444e3edba"],"liftA2State":["99110470e13a475f5968feb06acf7f4157667f28848b928bb79a66f76985369d"],"list":["07310ce985594d4b40df473d66f3a7b0dc6e245ce8fbd7f409ec02fcae961ce7"],"mapArray":["af09b9118c81903f2f1d1452ab9a2d8d2b8764115467c8f74a362e22d4b7b93a"],"maybeMonoid":["e720c445e6c1ca3efd534925c3d617ee11d62e96d321ec2a9ef78716edec1231"],"monoPair":["8dfd7bec63258df923500c9945740b2e6bef48120ef989c85ee27b7c4cc6e3c2"],"nil":["5488e660b1ca97664bafb058886a2dc02e182976fb244f56f4e8175fe1f7c68b"],"not":["eeb4c3a7f5a8dff2bf11d64864d39fafeadef96bd3d2cf8c6786b462c3e839db"],"pair":["b792651c6b6f38ee27bbc8bb471b4c9b9712ca89820625609c9d52a1a62bba77"],"parser":["d0c809ccb07f8a0e6242f19caf922734c00c5e382e247da40ed16dbc950fe899"],"predParser":["5b84e032adbb016f2b1fc5836936a0a4354b457c8373a97460098fea5366ca8f"],"pureState":["e9828be4d35ef15b9391b05c46830d82a6512506930e36273e82cc0466323e36"],"runParser":["d7f6ff73646c63539b4282a98cf9b432dcd5504900a3a1b5580d5055f25d197f"],"runState":["52f8cc7edcb587683bf83846d4afecb42444ba4ff38886c4e49308871eed0e11"],"snd":["27b0c6ec1fa2ae2b61809756a138cece632f47b2c46377065c32e81f0276ce8d"],"sndPair":["8b4e660d07a0f0fcd0b7b7f32d8d884a2b4480d75a8f5bd90e6411acae9ad1ae"],"state":["47e1c8e33c8646c744c513a752c4beda810f713176b426d2eee1a36ca7c94ba0"],"storeName":["8e9c28a29597c9fff7e8c520771e9d52c155a87a532cc3136291133f553f3851"],"stringMonoid":["019a523b2c4757f5949f06c9b961addcbad359c73945739ccc5f8ab606816da1"],"stringReduce":["68a148f7fc27644880c28c3fc48fc615e2cf0f52085ccc68f579962b9cfd0753"],"subtractInt":["c88909ec5c5c953982dae03632f48e6b5484168da1b3c2f822c212ed7f580b3c"],"sumMonoid":["7f9473b31145d179d7b24606e07d3d0d6e4e2de502f8d71440d6eea98714017f"],"testStateUsages":["f909477d250128aeed4e3996ea20bfd13b0036b28f1a380a5518ae30427d67bb"],"trafficLight":["29cfc3f9d88ccdfc1a42affc423abe2647a39b1aa0e95827ea0edb4975ee57b0"],"tree":["8b91340817fc53dd09a94c5ab008badb547d602917d0a7d07df405bf9335c02d"],"typePerson":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"typeState":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"typeThese":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"useEither":["569c11ec794434330f77e3e8782bd64a597a3a666159cb37ea4b9f41025a131b"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Cons":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Either":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"Green":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Ident":["eaea1fa57623e4b29172d982c3fb03d5048391668504c0129ae3081497d9d2f6"],"Just":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Leaf":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Left":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"List":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Maybe":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"MonoPair":["bb6f10ce0fead888d2f2d85defc08e21919ee06c01503a769b8b7286865ae920"],"Monoid":["1d49dac60d3b201147ddad2493dd67e98be499e801db0897f86f5de37666422b"],"Nil":["50790a1f3688ae1ab3f52bf060b778ecdb3f7a3b224e405ce48b0a4bdc9f0d0c"],"Nothing":["869565058daf6c73edf768ae1acb43b2b03299c41898e02ba31f80eef4906930"],"Pair":["19817d3943f7ef924625ccb655e5492adf0168f29238edec61a0310eb999bc2c"],"Parser":["56c450b3dadc5621e7fc54162257f50aa3b0091c22fba1efce0d97935d60484f"],"Person":["38646cb631a99a0068d80c10fe45660dc7ef0df869b970f6890ccd6b7ac02276"],"Red":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Right":["735f5eabdabc4299efe5a8d3c3b6af1ff6a6d15e15559cb4903dfae8dcb525b4"],"State":["63469d9155ce6dcd64bfab0e3e40ec9d43f54905c7f236e3a3c568636d145697"],"That":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"These":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"This":["c18b5935dc821433144f77ab299c3f66a77ec623d08f63f54f30e3d6176ea4aa"],"TrafficLight":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"],"Tree":["3cb82a3aa0f856efc077def8e3d3c8d1c28e11b10882b0e88a21e979db2eee61"],"Yellow":["f7d4b8a9bdead5271b8d598c25c54693d21fac526faa9f79882d74add661818b"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json b/compiler/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json deleted file mode 100644 index 1d941a0c..00000000 --- a/compiler/test/golden/SaveProject/41c12dd3215458613796c7fe31d0b40f678b4836693a1203eda44cfddaf61b51.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"either":["3ad39b95de874f41155ed120214a8b6bf4806de4724ca767a56e382fd41a918e"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"ident":["58a15454149ac2522fbabe8d0f02ebc337387a20ac6a1f69ec23695a25402d2e"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"list":["9efb85b4e31211f2d52625ff67322afde36666eaebb8916b410d74cba3908d1c"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"monoPair":["655b43c29357507b056375293896c57e6cfe54d76a1a2a40a4352cda0dac74b4"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"pair":["e10ed627d4bd04d627cf6a0be4a45cbc62edbf2e22abe313e708fc49733cd26f"],"parser":["7f7143df6b2f89939ff155b12af24a0a97bfe1484daf830c335b569ff4e716d5"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"state":["dcf1ef2c08c1633fa2856672b3c4c169090209b0b880640a7e1b26da8f5e59b6"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"trafficLight":["b26be775cce5d0c946bfe294e93487efced94cc3e6d078026fb7c41c169dba7d"],"tree":["539932969ffd5f80ded1860ba6f80bc14c5b81fc54c5a4d7fae6558e4ec5d726"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json b/compiler/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json deleted file mode 100644 index 92de9233..00000000 --- a/compiler/test/golden/SaveProject/4c461b4c8121cf8a6c573cedec1e25e794e0c8ffc9f36b53e0bf9d3b693a839e.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["46cd0904b3b7e50e21f410f5d5a11eda60575cfa87a5e2416def629304edcc4f"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["f868615577ab7ce33c230ed080649c41c08adc20a5359d0309dffb82e72d2e14"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["65667097df805e67884fb5fddbb4fe3c73a45028aed63c51bdaa27ae8254a314"],"int":["ba787a0a0d3a4b0d6e37c94ec146f4570bb9d2a954c9861ffd633781be5874e3"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["e09bef28f58fa386b6f40b4c81d6ea840bf7c17636f017ff9a6ef83c09f96b49"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json b/compiler/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json deleted file mode 100644 index 92a658be..00000000 --- a/compiler/test/golden/SaveProject/4deaba0e48039011de0f9027202215efcbab99ec33a5b53fd3f707595996281c.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["083684fc6b7cb4d27b88a7863f67479e53b48a5f7674c468eef04b853e9433f5"],"apState":["283f4fbab3788ba6117924600a3ba5230d332ee5a22eaf19d1f273af44ab534b"],"bindParser":["d66871ef7bedc9de45bcabdca4f971f70fee99a89a9a6a30b51ab3f3c30a66c9"],"bindState":["bfb2f0aee54fba387e9b258288b487744aab08dbf6907a7a013e6a6e4b0f872b"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["a14881a7387acb9039631e994483db537509e46ae9f42cab84b47e39335a202f"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["c84f48dee904724bc26d8bcf38865ecacf86c2bfd3bf6b04ccc3add9ca2b744e"],"execState":["6b733e012024944c0e9686148262783ba5b7b3c85c50156f795989958e36f1ad"],"failParser":["15f7b24a87ffe1b581fe010e63c8747761e05f2cf0ede98c4968a23a24f15901"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["8742d1ace60025e5284113e8ed502e6f23b6fae38f1d602a66e7e96f0908d69d"],"fmapState":["62dbcca5660c739a43007a754c944e828440235134c8b9ae54bf6531c4b84ecd"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["2e9a7bcf0300305fecec03664b6c2dc7f48619bb67454c4d7de247031aa2dccb"],"invertTreeTwice":["6ec6257fb10acf5e08a4efbbbbaf3e75b5bf452a8a07b960d7bf34334b300669"],"liftA2State":["089389e128e47062ee3731e811ae48a85e5dcc22b02fe402bcac0def8763eb80"],"list":["f0a2012a96469af95ec480d19ed6f69c027522d4a807527f9551ede6232ea9bd"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["ac695b5193a4664f86c249333e3adf61363deff8ae31f796eec3b70a350f107e"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["967935ec5c616814f8369b640795a2f0454670a50d6bc7f26768eeb38b9d427c"],"predParser":["de34ba51235c912fdd0e599ee18894c15b26d2b3c4e5f2472f373f927e4c7f28"],"pureState":["385d2ff93f84c1fc7796fc620b1f37ce540bb640a09ec00c97276f4abb0f14fc"],"runParser":["45d81aaff450c7b6734fc72895143d3261e39a66fde5c004bd383d54a76720c9"],"runState":["ddfcc8951fbb56683cd34c8f882ebf55b533106e5e36771594d269e01dd4ba37"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["71b57a7a7c7ddbbc7cc4a704933402abcd934022233149af984b8b6a09859c60"],"storeName":["14911c53fe5fe243a489a748ca66fbcb15318de65914310ab9fc33a7a4638265"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["66e1741d6b297340d8bb5dc3627797868309e951c7df851c76116a4cf7cfbc28"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["d363661cb79548b8233150614bc14002cbf49b996ec2ddbb834b2be9dd3fdf08"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json b/compiler/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json deleted file mode 100644 index 478f5f98..00000000 --- a/compiler/test/golden/SaveProject/6bd7bed57ee30cd17a55bf9d295b1216053a4b4ad4e0be6514244b86f7af98b7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["297e35cb517d517c2a24989483d6199a60db33ad8846dd26b97c839b2574fffd"],"apState":["54f3819144ac1b88d91d8c3a0a947619822f72e5aa9fd2052759809faa66e366"],"bindParser":["9d8762693b374bed27d371c55cd4595c7e86ebfa11b8ed17ecab776e1f27fa69"],"bindState":["cf847c5366c839b29b9339c0fa5f3f559c133d6b91371f2ff5f82539c9c3f181"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["7e4ef48720177021e3f48d4256d5848192e15a0bf94836ce774f6231213c33e4"],"execState":["82aefb756fb90bcfc41f85606376d57dcf9bf38fb92a9280a60287797ca495f9"],"failParser":["22bebbdde0911d354934c9b4886b6c2a12f27c2d2d0d5e3d7d2fb6aa0a0a07da"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["54d2b690ff720fdf3e7be4b773dc27014c6c9eb2deec2928cf70b70875b83757"],"fmapState":["e6f78e79bbaaf040c8208803711f63161ac54668044e0b77150e4e677f30f2d2"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["7872b1a76a424b43e388d3c7be328b1c8a4e535b0d1336a8e9627d1330f1407c"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["821d5e08fb08d5e515b5b82d910e3ed93896534838314a58e95ea780cfa0dac1"],"predParser":["6887ea3fb37cef9cfc0a6209836f61705971e69b9d2f724c1213421009f39c35"],"pureState":["77f4a6b4082798e873d900dc2207531f51337eba207eb2c9fccd944ab8cb90ee"],"runParser":["f95bd9b922e330b773141a8f680f5929c4abf3703259b12b0351efecfee03c42"],"runState":["7f9425beb1f577987d3ecfb740787862b0b50538de5d4e5e385d3966ca1c07fb"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["9f35b95d44c104db253fb00824ee8195d77c66de535ac379bf45524fbe412b11"],"storeName":["36db63e2d0b85d35ca8de30e390c7491fc1524eb010c46c327fa6d5ff06524c1"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["982c95f58d970572fc5eeffc6f5eea023173d5a6ddabec6521305bca1bc6db15"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["ae433b51c033cb923d998da0031fa93093860fde722ce633f82e2038a01406ac"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["32089fe4191be388f2dc157a799cebd2b45e85cea44bc3c2e9aed97015d68ce3"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json b/compiler/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json deleted file mode 100644 index 7a215db7..00000000 --- a/compiler/test/golden/SaveProject/74f6c62b749e564c2536024756b0446c146bd901b5873a29f7e2833ac329ac65.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["ed50f7f6cdc04f714265445332416837baf7b6622570eadc7a53b016fcbd562a"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["bd40bf8c67991238da566ac940e3d717539c2e1f68ecc518001092b0b54dbac7"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["079a166be166a599c628782ad851e4ac119cc6a19195d4660ac3c27c077df01c"],"int":["450f59bd44aa97758f440aabf38922a6f94517813e49078f6e60f573f21221db"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["e09bef28f58fa386b6f40b4c81d6ea840bf7c17636f017ff9a6ef83c09f96b49"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json b/compiler/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json deleted file mode 100644 index 52d8f2cc..00000000 --- a/compiler/test/golden/SaveProject/8601f364f259759bbfad29f2ead83f2eeb6c14a7d2f60012fe82b62c2e8364e7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["cabc3adb3fd00d7ee7a630ff7e662a382985db903634e339265f7393c02d1a71"],"apState":["474c9e5812fc03307729b41cbdc5e4df39e02b93a241cffea9fc63f18b5906b0"],"bindParser":["e558af66bf0ddda0d31d22f065145d3b18c007b7da8be941439f3fe0a0b5cb9f"],"bindState":["94fea6cada757975ce1882a5a722387985171e5c02b054e69bc59d3f091cac3c"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["92c3ddb2e35f770b549f3d9dbef487f922cfa365ecdf26de5d956c27fd3262fb"],"execState":["50b79824541ff08d2c9be12836fa6212320e520c549d691a281d85947fc37add"],"failParser":["9f2fcc268d31d3c2a466c8e3ad553fe625930103d826df70747e5c6280fd7098"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["a4dd49f8f7146a432fd1b09c2f746b7239f722cb04c4e279ac6f63c74d3b933a"],"fmapState":["633aca8016215dccd72b7f0b399186d332aa9e4a055cbb5e852a4c88f841f48c"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["9742c8438dc255d6533367183aa89829253d339f9e103b9f7ff169815505fab0"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["f8b9f1ccfdb0efdc548c3a5a9c31074268cb38569a2518882874ad5376c01c7c"],"predParser":["96c65fa8156863c92273f3f15d41f5345e372e7d4dcc06996dae9472456df8ee"],"pureState":["eda0b66dbe5f9ebc4d756754e33f18d3e55c535e90d2de6b254d36e263096ee4"],"runParser":["cef56401f54aaac76d10bbdb61a461edbc84126607c996a018d540a98d21c271"],"runState":["b3bfa579d66dc2db77126258564e9d52eb35a5c77aed5a6c390327e5f23e3a44"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["b2ac90987336a46b8e305bc7e8d6ba79f12a0cc03008e3b8ffb54d2f954e37c3"],"storeName":["9ed928277b23cf65eb8b6b8dc4737cd168608a8bcd13a7e650512d17467c021e"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["52f37998002585c589d395e7f619b55a786a10a44cec7aed09eeb22bce3fe98a"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["6d2eb1958a3871f2688149259726370d6add5493a840c0848a2606c8d68cce3e"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["a0849d808771ff392b06f343f47848fb8340a323f682b6955f4a07cd3012e3bc"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json b/compiler/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json deleted file mode 100644 index ce99f973..00000000 --- a/compiler/test/golden/SaveProject/8a1ed7933f478d69d8b260deaf5fd6686130250213b06c8b0e8578afec138b09.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["46cd0904b3b7e50e21f410f5d5a11eda60575cfa87a5e2416def629304edcc4f"],"and":["4cc066d3d7e454b2ea236657524e077ed1587916b11545de73075fa17797aaf9"],"anyChar":["ae7cb77843ce926f8fb5e87fe7e45cb118c1e6266adc8c90aafafea161951f71"],"apState":["3c37433304b1df0033c016622c402bee0e1380bab9b1d8f0e5e706b9a9206c46"],"bindParser":["f868615577ab7ce33c230ed080649c41c08adc20a5359d0309dffb82e72d2e14"],"bindState":["303d76f05fb68c66535b5fbe1cf8879df535a2810837277b1a0a6a2a36fbb63f"],"compose":["190e2e489c782628f575a9a9abbb9fa3a1e5458f0a09199dc252eb3096c514d5","2fbd946cec485971ae82d4eb4f238881f4af31b6f82d82204ef00683fc45cd5e"],"cons":["f31edb806ed400fe8beff308ccfbc95ab0cb96c640474475f167e254b81e7b97"],"const":["318eae38c5827ddbd81f24223d3ce79a7c2942ca2a91d92640adc803457a2f8d"],"constFalse":["a85af19c0d5eeba9dc2404ee912ef11db6781ea9a6fd0945d711d179ab55e0df"],"constTrue":["b18545baf6addb6ba98957ec153f08a0f77eda7da941a77784fc6ad745010bff"],"either":["0c6cc7b39b8938fb23a5b5562750bba80f5338a8dab90e09509476a486864046"],"eq":["225930d462e608b46cbe6aec21e4b05b3ed5775db8169ea5f031cdbdea84d052"],"eqTen":["2725f483a80eb9264e9a516a03925577d77cf8a79ff14d4513792596419e73b1"],"evalState":["0f8f614b685ef56751c618e6e7d37708899cae711d8ef86d9718915e68a83a30"],"execState":["9d25e58547343bcfbf9c80df7cf5abd3bfeb6f3343bf78094dfb184555c7228b"],"failParser":["c204e46830c5ae5e07a9f1f9e68d54becdc50fc491422b9f5567f2a7689e4172"],"fmapMaybe":["038d6107137fb9979e5a0b3e5e644e938b2e8eb9cbe682247c317d0c3296c4ba"],"fmapParser":["5629029f213c88ec18ad73a742671182140e981e3a6fbe2322c835d89024e3d0"],"fmapState":["d7b7e2090fc42589dfbf45944a212daad577a286400e45b5460bb2be048c45d2"],"fst":["1af15349f163c44bed392a5b730e6d0e7cf6bd2723f00aaddbb6f058740a7b7f"],"fstPair":["ee0844f59a6ec7a0dea74bcdced82f9eb6bf06fd812c1612821f3eb6567e2b33"],"id":["70d6629c58c186dfaafeee6e0210e10c36f0f8c07f61d761fae8ca7469ee8bba"],"ident":["ab09032929e5da0d21e198c8fcf94b1f9c170197613444ca025c2539177d9b9a"],"incrementInt":["65667097df805e67884fb5fddbb4fe3c73a45028aed63c51bdaa27ae8254a314"],"int":["ba787a0a0d3a4b0d6e37c94ec146f4570bb9d2a954c9861ffd633781be5874e3"],"invertTree":["15c156a877d610aaeb0504e1cb1be173b3b0f0d977454acc87a15169705d04ce"],"invertTreeTwice":["8afa91043e48beecbd5a72455026cb31b80c26092ef34edbd4be9fa9aebfdfa7"],"liftA2State":["c9623686d7c0848a5e9eea5d55b366607eac76633ac254254d5d794ceb5eb0ad"],"list":["d3dedf3ba3b02162386ef51f03e1cbb973f040c65228f684bcf9834fc5bf1ad7"],"mapArray":["ad757f69927445c35ec664a8e31d129220bdaa9693dd71a7366dfebff2595d24"],"maybeMonoid":["7a1b8240a2ba91f7df452e152b37fe15bb1492ffe73b73a873627358a9edb856"],"monoPair":["ad7dca5396772714d1d1b77312aa0ac95ae052e936d9bdcb7e96f147001f518c"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["a42a167327f7fb3b33202f46c21d9902f5b1bb44e659bb8b7c2b1e9269908156"],"pair":["385031a7eb9418bb0d58a7ad4d591f359b0d5f84341d6e65bf72144da45e09a5"],"parser":["367663d099a4a25e1f599f64c66bcd8939e4cf22e717147d6a97a59c70572b5a"],"predParser":["766d70864281dced7e4530b9c584b8c3235931262d4343b29a9bba328a80c541"],"pureState":["bdff2ba965fc828def052028a9238ceb68b56212c7e77999c93714c658a61de0"],"runParser":["e699f6da054500c2ffea42e1d790dbd7c485a642f2441ab85d1b037767aebd6e"],"runState":["e518ef5c678a30573f00b979b795a98faaae6dab511ae97feac758dd8567efef"],"snd":["39b1b0b8f1a6152d87d7a81b6696218fe9ce9aa3857420ab2c96e027fdbaec24"],"sndPair":["32fe53155198f17b82bc62667670408bb2665802181207c4569bbe6a02d74f2f"],"state":["6abf6fc3d55adfd59777dc7155cc333b66ab11aca9e1533668e828736928b34e"],"storeName":["f3d8d104c76f916dba4cb38e4d06e2191cd05f948d54d492c76df3ef6825f58f"],"stringMonoid":["84f19b0a3a7e92204f8fb5d3362e7b6b99ece00fbb57993322ff46a9ef074d55"],"stringReduce":["86686ed82543c4e06510a6c32871d47bf66808c2b65539382523b090ffe4b677"],"subtractInt":["2b33b9b1d6c7350df79b4109c51bbf5ad4401a1320152db98b157800fb69a04f"],"sumMonoid":["99fa1ac270b897dcaa35b0af7ba2fc53c272ab7669bc59cec4b29e604d025772"],"testStateUsages":["64ba616ee223ff34920fffc05c39710eef3e3788b282b67cc6584b04d079f401"],"trafficLight":["c3ac7393a309e4de28350e75da1450320413434a3fd718b0756d5efb59858c22"],"tree":["0335e4bfbb7f5b4a70d3e61520e2a41bced11c3a74be5b43889a5a66729d3922"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json b/compiler/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json deleted file mode 100644 index dac79196..00000000 --- a/compiler/test/golden/SaveProject/983bb8dcba2fcded5b6abcbdf595314a91e8ee1f9a5d94092d5336801301f5c7.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["5515afaf798dd91ecbfc42b798a0c4670139b6dd45b238f05958e6cb26637e95"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json b/compiler/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json deleted file mode 100644 index aafb314b..00000000 --- a/compiler/test/golden/SaveProject/a2d67b093273caddd52d1339a0dcb89fbb9835d356d23214678c5cdec521cfd1.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["cabc3adb3fd00d7ee7a630ff7e662a382985db903634e339265f7393c02d1a71"],"apState":["474c9e5812fc03307729b41cbdc5e4df39e02b93a241cffea9fc63f18b5906b0"],"bindParser":["e558af66bf0ddda0d31d22f065145d3b18c007b7da8be941439f3fe0a0b5cb9f"],"bindState":["94fea6cada757975ce1882a5a722387985171e5c02b054e69bc59d3f091cac3c"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["92c3ddb2e35f770b549f3d9dbef487f922cfa365ecdf26de5d956c27fd3262fb"],"execState":["50b79824541ff08d2c9be12836fa6212320e520c549d691a281d85947fc37add"],"failParser":["9f2fcc268d31d3c2a466c8e3ad553fe625930103d826df70747e5c6280fd7098"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["a4dd49f8f7146a432fd1b09c2f746b7239f722cb04c4e279ac6f63c74d3b933a"],"fmapState":["633aca8016215dccd72b7f0b399186d332aa9e4a055cbb5e852a4c88f841f48c"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["9742c8438dc255d6533367183aa89829253d339f9e103b9f7ff169815505fab0"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["f8b9f1ccfdb0efdc548c3a5a9c31074268cb38569a2518882874ad5376c01c7c"],"predParser":["96c65fa8156863c92273f3f15d41f5345e372e7d4dcc06996dae9472456df8ee"],"pureState":["eda0b66dbe5f9ebc4d756754e33f18d3e55c535e90d2de6b254d36e263096ee4"],"runParser":["cef56401f54aaac76d10bbdb61a461edbc84126607c996a018d540a98d21c271"],"runState":["b3bfa579d66dc2db77126258564e9d52eb35a5c77aed5a6c390327e5f23e3a44"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["b2ac90987336a46b8e305bc7e8d6ba79f12a0cc03008e3b8ffb54d2f954e37c3"],"storeName":["9ed928277b23cf65eb8b6b8dc4737cd168608a8bcd13a7e650512d17467c021e"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["52f37998002585c589d395e7f619b55a786a10a44cec7aed09eeb22bce3fe98a"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["6d2eb1958a3871f2688149259726370d6add5493a840c0848a2606c8d68cce3e"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["a0849d808771ff392b06f343f47848fb8340a323f682b6955f4a07cd3012e3bc"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json b/compiler/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json deleted file mode 100644 index 0d504131..00000000 --- a/compiler/test/golden/SaveProject/a739e436051c4de364b770363c7eae4177b99b3dda036dc436e8cb4a5c0721f5.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["32e3387df3b4b18ebeda0afca60225a154a48371d164789c956e4c5a49b17bdc"],"aRecord":["9112acc2cdf642f66a0a283a198207635beec1c7f04001b4d6e43f470031cfd1"],"addInt":["4772cc431963e0a86b168b003ea37e8d0fab7bda90fd1cc722645ac9e210cf23"],"and":["122ccf19f546518e39e0adbe9be33929a6c9314d487d5cb495286a28af106c38"],"anyChar":["b5f6acfcc3a056c960f31f84e6789d572b106e722f895fae747a4b87136fd273"],"apState":["d6e99bee2544b969d9d369c5a5f082d81e4740aa300a22f0946c542653691c84"],"bindParser":["47edb93a6b0b4a3c01d68a7fd52f08442d7289803237b5c2a8f200d448454005"],"bindState":["1eb908357b8e8223a981269e2adb22dc10d43ea0b201fab400c394014fd536c8"],"compose":["8a845c3ef5616a89a8927c68dc62a1908c326c5ede7add452d788ba0b7de05a4","bf3dc20eeb6614cd151e26c4aa7e2716ae7cb8f1cae69d793396ab5efa8fb273"],"cons":["3cad04611eaf137d0ad23f51e61260ff5120f20295606d917962ed7300bbcb58"],"const":["fec31c15ea368a9fbb4fe5ef038c8a37269530fe1117eba095731c79bd6a9635"],"constFalse":["0f58a12bda085f26872f0cbe6754222871855e08cd28d1444b6a12be97dd81ff"],"constTrue":["b12fb6d73184c100567007de6594066c2098ea8ad2be5f96a74bc6db455e4a16"],"either":["501147426d42ccfebbbb76d67bb16086184edd5bfe6715a8fd90f7ae59a59d71"],"eq":["c503c8739f0c22ddbb505011251b06c837d302a3397d6a901a2fad387eeb6d90"],"eqTen":["1990686d247f39d9954099a66811f6273809bb1a0ce42fe6e9894dd9de2fbd81"],"evalState":["6166462ac4206dfe75a6067bd36a2fa7811849804dbf843d404ba5047e370dfc"],"execState":["fc0d19e23f1c0784011960197dac06e0c08856a0e2e1582cb9b7865dcaca8177"],"failParser":["36b449f51c55b838bde50859be97322017e3c99bbfc484f7abf0b6e4d2c9a6bb"],"fmapMaybe":["fe5ed307a7ce88b1006e1f56dd8ba7e8d0db89e9c2fd1a9b82906102c2091657"],"fmapParser":["a8dc8a285cdb5ecfac122b77fb870d1ba454b06155606fc12d53b2145d481515"],"fmapState":["f618ae22fd8c9268fcfcc36c1a7e067f158979caaad1d531458150dadf244e6f"],"fst":["0932ee5bcebd5191c6ee76c6b3e16028f153be8f738023debdbba1a54aba26f0"],"fstPair":["57c8234c457d2b3a96168827901766394143904b2bfe1378cbeff671ff918464"],"id":["b65915cd81a715f5a614ca62c213fa670c869536f9a5596829fbb93e1b763d74"],"ident":["301583b4517c9de80b2c246026effc4e25c495d6107b4e640573560c6e851471"],"incrementInt":["654cec4400556acc4bd90bfacd28d49285a160be11802053dee3824b20d44590"],"int":["6ee873255b8121d6b3a82032eba1729dada717a88f4287c8d0be35395e3f1b0d"],"invertTree":["fc7e18d95ab90baafbe46cc5d146b2b4411bff5d0c7e6fb65845aa776d2ec23b"],"invertTreeTwice":["e6d841629e65d3a67f92dd3a05933e5564a46339ebce468abc844038a509f32f"],"liftA2State":["d3603a9866b9c80c4f75b2c1497f0f278bdec65d8da95541e1db3eb3d65b62f7"],"list":["3d426d272aa7c704c1b2ba3a0af626150ea51d1a2e43afca1edf3174e9b57d35"],"mapArray":["cb4124d901b6b4354db3cba0a747dfaa1d64d239b67149e765d7be8e0e63fae3"],"maybeMonoid":["3373d02343dd56a5ec29c9870643537b6bf636262c0a2ad1332e8c87285d9bfb"],"monoPair":["59ac207a8b04136bd54131b331385ce2c2cad80a9fff3541172a589d9d70dbfa"],"nil":["ab01638d0d4d4acd5f7e410d67d62635632128c47f861e8d1d6b3a40579d562f"],"not":["b0ae419acf10e7f7e6e3c7787a28ea08f73d442ac66107395b021e92bdf67590"],"pair":["3cca75d531ce66164655c3ff1778d81369c88ce7832322a4dd84d30c260d0538"],"parser":["2bc4d8d49e71ae2610cda34212ea2eded7aa843c571964fcc91b3ab4e1465adb"],"predParser":["7879f5e691cf64e7dca63d3ce4aa70de83e5c8fe81ff3f68b7936719ec55535a"],"pureState":["78e11f8742dc54c377915e272959439eb47ade103e053e02fcc5b5675e677587"],"runParser":["66f09524c3c60936d263f68393670689a9bb6709a8c238dbee769f81aeec0479"],"runState":["715e51086ffcb881f2d9a6eb66bf72d9d6017e39119a1cfe97d8f9fc14f8c06c"],"snd":["4ea0e511225f23fa2bd1b883405a8fbdb65aebb646bd3019d95ef94e7e4ba392"],"sndPair":["78abe012b8267506338e52d3fc2f7a554605647209da2c11f6c25755ab5db10f"],"state":["555e241ebdbd568940258bb94c2a18f28e6b62d4e8e31ff3066179b4cfec2ebf"],"storeName":["461a93b6f7fa70e49b3774f728e7332f1cfece99c66f0d75949bfadac00f1eab"],"stringMonoid":["61c95801905716d6cf2cece27014df746b7fc05c6c5ae90a1e05d98690ecc267"],"stringReduce":["fc432dde4c87422e85a6585ab669bfd2aa69eb2fae2e4017252f8fb712412af8"],"subtractInt":["8a17f7af7659c6de550e515c773294a9d1e22d705e94a0508ca3d6f3942b773a"],"sumMonoid":["1ea69033874f1e075b5c89d0d893953a09992b467d5dbb33dc26b5e1e19781a6"],"testStateUsages":["e5d73bbc3516962a12082c109e7466128d3460714e3da092fd0542f71aed5fdc"],"trafficLight":["cc4b8ba5bf82c9c52cdfad3f3ec24ca40c3f8a9c3b9b48d9ace366f50b48977a"],"tree":["4b6d3ab35108928f8c9ccf27045804de250c1c886883158352277a406d65f627"],"typePerson":["8eb8d8583595006f73b4b536962f4826fcf1ded91cd944a384b1fe772aaf8a16"],"typeState":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"typeThese":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"useEither":["9c553da783f2164588e81b4aea85c5aa953801d4d20c085ce0647d4ebdf43a21"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Cons":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Either":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"Green":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Ident":["de460e6d1f8c8114b101dae644aa659407c9f8b401a38bef23fd1d33f5b00246"],"Just":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"Leaf":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Left":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"List":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Maybe":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"MonoPair":["6349e9b3fb39d7fb47c8e5ae3eb966b584c0012d47a4a173c64dca37e2dc6348"],"Monoid":["8eae267c0cdbeb23a5ee80312d6a960cd80efc7bc573a27696f6193fc20b98b3"],"Nil":["0fa03f4758712d009a2bf3fc72f55a5f5ebc3f8b7456de4d6d1d8ad3824047ad"],"Nothing":["391b70569d02818cf1f4b6d6c07cd93447c409978bc873ce07312ae8ed80f008"],"Pair":["ca3b8c870829ceba8372c653f8d78180a1d160823949faee41697fab90db6e80"],"Parser":["e872afb38fc0dfc021403a8787cd47423134dc707008edc1bc7f4feeb44f8a9c"],"Person":["8eb8d8583595006f73b4b536962f4826fcf1ded91cd944a384b1fe772aaf8a16"],"Red":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Right":["cbaadbc109b5fa04d68259ba356a3f7bb6f9b0b7231f579fcd5d5b1413fda3ef"],"State":["301e34ef7ef6b49db554874e444217a5da6403b8dcbd563a02502bfe86e5f7f4"],"That":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"These":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"This":["c58ea50b3562a0fae88f2799588970c2625e198aaa34c783e2590571c1f82373"],"TrafficLight":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"],"Tree":["e754d0495d40858833cfaff782b6e2c4a2166b951dd089926c52b64202ca64bb"],"Yellow":["6ee9c10784ab7e6145e98137fe4fed791a99bbb8b0ed4143612ab08e16297fb0"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json b/compiler/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json deleted file mode 100644 index f975f036..00000000 --- a/compiler/test/golden/SaveProject/b6613887f9e8cb6863840877f99fc9dbf88aae1668c1935644c9a9c0a155369b.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["297e35cb517d517c2a24989483d6199a60db33ad8846dd26b97c839b2574fffd"],"apState":["54f3819144ac1b88d91d8c3a0a947619822f72e5aa9fd2052759809faa66e366"],"bindParser":["9d8762693b374bed27d371c55cd4595c7e86ebfa11b8ed17ecab776e1f27fa69"],"bindState":["cf847c5366c839b29b9339c0fa5f3f559c133d6b91371f2ff5f82539c9c3f181"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["db670f6f106ad50bc9f9aaa8a6872b509ad6ec4033fd6ea846dfe428982949ca"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["6085e32bfa61213ab22e5ecec9d078af55ca3434e5ccd33e171d9631687bed68"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["7e4ef48720177021e3f48d4256d5848192e15a0bf94836ce774f6231213c33e4"],"execState":["82aefb756fb90bcfc41f85606376d57dcf9bf38fb92a9280a60287797ca495f9"],"failParser":["22bebbdde0911d354934c9b4886b6c2a12f27c2d2d0d5e3d7d2fb6aa0a0a07da"],"fmapMaybe":["d26e03faf0dc9fa42f1f1a82fc01a921d68c8bfa8ca2e4096d5cacae13261c15"],"fmapParser":["54d2b690ff720fdf3e7be4b773dc27014c6c9eb2deec2928cf70b70875b83757"],"fmapState":["e6f78e79bbaaf040c8208803711f63161ac54668044e0b77150e4e677f30f2d2"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["041698092dc998df4ce99fe8ac269d90c7ff5d62d8fdcf42da277e1dc1fe7266"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["69d330cbdd064f04de105b1b4502611e5e4aea7c3be595459a7091deea5a0bb9"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["7d435d8c633657af9268bf8dbc55c2ba23648e61535880a34d4f4348fa9266ee"],"invertTreeTwice":["ffa35ed393bc8d12a544706ef29fb381f8da6f69ce738a14e54207cfc07c83cc"],"liftA2State":["7872b1a76a424b43e388d3c7be328b1c8a4e535b0d1336a8e9627d1330f1407c"],"list":["53cdac11383eb006c76be38370c3c5f0390001767f522d9f8c05ebe8205036da"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["25af49ac4ba54c5ed3692d7defd7dd7292b541f2710fe0107dbbe117dea4b872"],"monoPair":["cb675dcc3e043e690524098c9432bcbe41d1ac615db3b8604f9d1c9b0c27b081"],"nil":["f919e5588423caa9b0702fa5e9c746ae4bfa7a9b48c5921330120bc383697527"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["639b7308f4b6c71a5732dd720ae7af667f87bc85e11e947914605baff2f54777"],"parser":["821d5e08fb08d5e515b5b82d910e3ed93896534838314a58e95ea780cfa0dac1"],"predParser":["6887ea3fb37cef9cfc0a6209836f61705971e69b9d2f724c1213421009f39c35"],"pureState":["77f4a6b4082798e873d900dc2207531f51337eba207eb2c9fccd944ab8cb90ee"],"runParser":["f95bd9b922e330b773141a8f680f5929c4abf3703259b12b0351efecfee03c42"],"runState":["7f9425beb1f577987d3ecfb740787862b0b50538de5d4e5e385d3966ca1c07fb"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["778ddd7324066fb1343e1b56dd087d073ca9492ab3d1dff2681f80b5fcdb081e"],"state":["9f35b95d44c104db253fb00824ee8195d77c66de535ac379bf45524fbe412b11"],"storeName":["36db63e2d0b85d35ca8de30e390c7491fc1524eb010c46c327fa6d5ff06524c1"],"stringMonoid":["edec5482fcda0c4241226cb7a0d1b125fbf37201944baaf486ef775f6001428c"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["805cb52d6603edc20d866ff623b32e99a770a7b21e10326eb2b1ae3f1970c7c4"],"testStateUsages":["982c95f58d970572fc5eeffc6f5eea023173d5a6ddabec6521305bca1bc6db15"],"trafficLight":["766ef9953ca13bd9575b0b990ce740d2b21321c371e8100046ed6ab66fc7b628"],"tree":["c5d840c45b8fd14fbe1977c0e61d9a955e4afe5971e70727b57bbbbed8cc2f56"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectModules":{},"projectPropertyTests":{},"projectTypes":{"Branch":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Cons":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["f40383f4133836b906363c8d3dd5d9c407505c64fdc553b2eed4c9b29ccb3d35"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["ae433b51c033cb923d998da0031fa93093860fde722ce633f82e2038a01406ac"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["32089fe4191be388f2dc157a799cebd2b45e85cea44bc3c2e9aed97015d68ce3"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["73cc772a4410eb24a670fc3263ad5132ec94dffe6364ddadd2c538a169de1732"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json b/compiler/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json deleted file mode 100644 index ffe274ab..00000000 --- a/compiler/test/golden/SaveProject/c4476125a5729d7d91dcf6820c0ba031dcbaeef0d001e61dfeb18b6ce92d55c8.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["35266e63ec46d7f16f410b90b353243cf6673d264e279a5db04bde1a54eeea92"],"apState":["9905c9b5f8072e86ab7fef59e876bcbc6f195c7532e6a381e145220c6ed317f1"],"bindParser":["b594c371f07dfe022baaeaa61088e3d7204a6c62e53ca9946ee1f9f4a499fc46"],"bindState":["ce99f0b83532da6261f39cf852a6524a255738254cf4c4b0ba40792f823dadbe"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["63a7a1a4337e0b36578d4fc675820b547be60672e12c06e6bd160aeb1e5dee41"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["0666576cfc3df7a65e79c1422c8f04b403c3b02c65ec95c168a693c19a9ee4d4"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["7d6feac67a11fa3a49d4511dca8e196ff091b4f1ffe8cedb27f7d7203245f13d"],"fmapParser":["c2cbd4d6a53c14f388edd5f2329c5771a04fe13a1ad26659da9b1f967df7fcb7"],"fmapState":["f2ac935429ee25923bf5212b48e2ddd3a03725bc596cd744e5ed1d69f29ddd74"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["97a41678b3bf32d877aaf23404f5cb09758e80b2856815222676ed36d33bc550"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["c010847a1c4fa1a43a04c2a27e69ce335146f1ebd61b8977d40a8c8deb545775"],"invertTreeTwice":["462e15d015da51e06785e2b17894809a26923a89a059eff50c2a1af2903fc0e8"],"liftA2State":["6b649dc6135514c20eca1745baf22ecb1b79ee56f672ad6f3affe3bf6860bafa"],"list":["3c14cea5ebbad925c63d1612369cdd840498105d9661d62edc55fd6f86b8ba74"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["c3fca83349cb5f786938fee7bf972b0b59776c150f3c73240e856fb595b32309"],"monoPair":["c5459a5d4896dfaf5d2c3d790fabeb4d2cb11a261dd3177365e6d5daeb0b2b82"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["5acc7f1fdb40e0cd3c652319edb3daa9649d39f5e057ea0aa60474bb2531509a"],"parser":["58c3caf3327c52048ccc8de05529d9a4a63b7c987cf06172305b247c0fe353d9"],"predParser":["750a6cdd2dc1f80f181e7d2a1d421bcbbb9956f50139e93b810da3cd0f93a023"],"pureState":["9c856307f18254ea5ebe0c7b155483e489080d35b12b8a65ded3d0888ba9016a"],"runParser":["397fa1cc7e750a73ff2e7c9d4bbd3b4accb2dbf3f6dcbd1cab86c0bbecc6ae9c"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["49d3792687fb9d010133cedee17453379e3109bf1b0252679e8d9492b21e0498"],"storeName":["2cfe0854f7983f78c262a2e9558b93e8de49e9b70b6f5766b3bc011d944ebf78"],"stringMonoid":["231ce2b454ffd520ee694022c7be72b432999bd49fb4f2809b2c6118ceca9545"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["fbb04dc15026fb41234d88fe94c661e7dd179b56879546f90c56bb76578e1df6"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["74393de28f2b32c60b82bb3439848e39c6ff7b874e732087893f425d2f21846b"],"tree":["6086e8fd70a725ba6dd51f4ecc531e87eb8391458aa9f641ad75a91650f477ce"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json b/compiler/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json deleted file mode 100644 index 8e20a0c2..00000000 --- a/compiler/test/golden/SaveProject/c621036a2ee0e9d43035953ca0c8a218cf0ddd6ac2dd428fd38059d9adfc1705.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["2d8951923af0fe26996f48ba2ae9ccb2bd2abecb95a298cd60b3b1187017b96d"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json b/compiler/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json deleted file mode 100644 index b59e3572..00000000 --- a/compiler/test/golden/SaveProject/c98217e70fc1ff2ba50d75154a4b6afbfd7eacfb73dc34fb26b57e6a46ca489d.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["9f8ecfb902d9606cb01a814b8d8bb0e9ebd9afb28b5d4c725846761f42567ef5"],"apState":["1d68cbed58eb17ed35708076893319b31291c909fa44ea0062a1680927725229"],"bindParser":["83c832b14532ecd033e36895a44c806b12eeab164a4139ff5eae3cfedf6e3130"],"bindState":["24b5d68e48b2ea9e4747c6a1aae092ad3bed564e19826a5171da7023d2cc40d7"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["9aabe059a7860bda9c3ea4333fcc72ec16bc8ac7cb834a0273505cf826ea2083"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["e6fb1010149ecc029d0a27c9e9043d3c7eec2e51e4d8278381a42212d62a856b"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["51fa29855f8c5c302ca63b7677bd7e4d0cfd7e9f0ace126011254ce26493fcae"],"execState":["7165d7ef023009f92cfe5e4640c0591dcd14c296404694fee2ff0866d9446999"],"failParser":["8d4cda3c93498584a19ecf0c03f5c1400fa270aa523724b6f4f56e3cd188f726"],"fmapMaybe":["b6a1213dee74d17f8c0cb7ec8cf7743f899d08989a7a294b38ec5f6f72ec87bd"],"fmapParser":["0843ca134a7637579eaf6769fae3fd56fd4a3db80b8e55db84733b86f3340868"],"fmapState":["58f6d000f9bc8ed24b9ea30da318cba9fcef1c6bd1787956028c66e33db0bb95"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["b8fbb39f50cfbcc44e457aa902c8f412fc182d6c5970e30cda69f2e9e3d511b3"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["0e40f97479498b172a1a78cd815984462f3d93fd7ece7840b61cdbdd0ee292c0"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["b1b1e5da7e2fcf29e2506552941740a87bf7aa1228747d015b78c8f4b29c4448"],"invertTreeTwice":["9c9519db71acf81d8edaee24f9c5b2054b839547868a50a1858a05e45debffac"],"liftA2State":["cf939392c57e54f48a2507e4c26378211bef4fe52dad56b9fc1cd3c7990f9a6b"],"list":["353cb03b02df1b560585a0da7d93fa10f7da710e3cb1453756c026c7e7343da0"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["e71fa9c8d1b80e77975794df26daf91fc183b4ea8e49d7cafba256385cc3dfea"],"monoPair":["f581cf0196c3212802b7b8620fb5a1bd7117b4b7c34a1594cfec80baa4a2efcd"],"nil":["5b3c6213c2844463fb2da0cd97251591c596965ae40ce0e58bfd1503372a04b4"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["3c1c9c70a3db62c7a31b50bffedf06b48396c1245105ee0a47e5bc5f5d5525e8"],"parser":["163c156f44d0e7f28d0742c19ef904c11d71cdd0602326940208959d60cfc37e"],"predParser":["4be1c8cba1622ff2640f0924153e5d986f7bd3626b9ef5100ff7d720aa23ea2b"],"pureState":["644628e25ade34269f484799ea7485bfd89df5d3c5b137d9b140be033341bb74"],"runParser":["0d38a5d84a2665b1cafe5d9483126ac872668e5626de65242bc746d6f7a7752f"],"runState":["9da6a20626dfbfeca6dfb7f36163c57011cf4792688796bbbab6db5e04251519"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["f1d8ff509761d7db377c28478c094ba8474a8482cd44a2b9eb94f1756dd3726e"],"state":["5ab94d165b820798534d5232b18c99ad344f71ac99688e1c0f70a4d62bf88ee7"],"storeName":["7878ae674578af5904a6b18572825e9a311aa95c49162c2a486f61de6a8ad9f2"],"stringMonoid":["69a03497a06eeaa289f2081bdbc6a325ae06886e18c9826cec3e717556deb82f"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["8fd08ed6d8a70e4e9784e028a862d605023cf183ce7b3fb9ee685fd27ad53ac6"],"testStateUsages":["84e854bf6edbc8984260877bb495a5c7091aa48621798bb464f3a80b72c8ca55"],"trafficLight":["86cc854bdb7bf9641b19e5c6f27bfa916f00f8c881fb100cc05660b656a349e5"],"tree":["a8cb80e978057cc9386b6fd569453824be23087b695f774e7a79a0ad025d92c8"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"typeThese":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"]},"projectPropertyTests":{},"projectTypes":{"Branch":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Cons":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Either":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["f05c81cacb68cbbd2b18fe2b1dbc9e864db9087472324b7a39a4e2764bf154c9"],"Just":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Leaf":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Left":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"List":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Maybe":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"MonoPair":["cb9570a2fdba6e615f7f09aaba7e2d824afc4140b29b2031a2888b226d60d8c5"],"Monoid":["ce3eae7871b82404f16cc1614f427da95c1a6bc5d32713dda4dee8b9ce3b2fd1"],"Nil":["38c2566cbc27755c862137def166a5ce16089d300636e9fd2cdbbf2ad984eaf1"],"Nothing":["b6a23b8d347bc060643b5665c760702fc5bf662bdefc1b2f05e424209a32e998"],"Pair":["f5fccdd2cd7618e9d7d73d9bec5682973c85d40edb1898893a0358912ba2eb0d"],"Parser":["2b1b227ae018cfd4b2bdbf74fbba704e82c392e51006de7572a4efc2c89b9ccf"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["68b2ca9d9101ba09a29f527c548546810656bc5350be8ecd4fe357cea89e79b6"],"State":["3c462aa219866bcf929053f1480258a1c488acbab77cd2a50ae2a451d0fe0762"],"That":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"These":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"This":["a3e5fef195f218fa3f692df7c30930ae055cc32cef8660e22ee1eec273bb2de8"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["47f79729ae8c08c5e5866dc4166be63fd1fe9ce5ea277905979ac89580328f5a"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json b/compiler/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json deleted file mode 100644 index 3bae2292..00000000 --- a/compiler/test/golden/SaveProject/cbd182a6df1ed6e86d3180fb5ec12e1c345f8e7ef087ebfa3d12688b1107d131.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["a633bbd61639e51ef51f83e26ab063b317b49f727c186586c83ee193c20c7e0b"],"and":["0edabf4b735dcccdc7ec278cc19e763d53b776cbd68c8e65cc86a556c55eacbf"],"anyChar":["571b7a9232e559cbf5dc55086fe049f2e12886111fe26623089b655ad2564889"],"apState":["1b9a6915b6c7ce06f5c602a3b6197774db490e4540f258f667f28d73806d3ac4"],"bindParser":["aec25a94a22234e816803d8fc925bf0fce75bdff2fa4be15cd71494a5441def6"],"bindState":["31529394943886b514f88657113760b5423df30164b42c51b75b6a774ea88241"],"compose":["012498930748d054357648846508c8668d095a2148736dfc7d42131fc9719956","da7358bea5b798fe034a031766ea4af1d1dcde64bfc2158964f515b3c27677c8"],"cons":["0029f1a6e37ba0fa4012001fff933d8d6abe379c6e2e127d477b4c77190ac000"],"const":["a6f4c53af47cd68cb04fefa257325830659778b756b3200389da868c52d97300"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["27316cb5583568e5844ecf4e9409825a4612993c538ffd80d46bf50d5234abd0"],"eq":["6b6f954052905fc349c65819c6aac49e2fb347a86c555de35c43f9f59aff0f9d"],"eqTen":["78ff5a32160c9b1c602056631c6ab79b038ff60fa985993b5268ecac3dd5d77f"],"evalState":["641a5672bd09a206083284c57989143f3fed90afd1f411a09682d7b2ed012513"],"execState":["33f513d6c8e396b15323ee9512c61375b83caa637f7525ba354b9f78c4b6af0b"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["bf48314115ad5d188f9844374279bb9f5a7b62335129d79687b321e96556cdd1"],"fmapParser":["29970127fa844f2a635728283ddd4c79482bd31a5bfbb85b9f758a4d687a131e"],"fmapState":["63dda77ec0685fdd12271bbb4f316ec2ae062106c67fe744b094ef58d5c5fd71"],"fst":["b247ae9a373d917660aae21d1bbf3c3a3e314bd33f5b326d8bf8544738376c8e"],"fstPair":["f6527a8319d391a46e37e710a7ccd9449000415e03a4ae4ec6727bcf069c49d6"],"id":["ce5280bfbe4c03d894bd10b0cdc5942523be69af719ed3ce6002e36bd37e6df4"],"ident":["79817f8420635dd02316645b5f2693239b32d4c67b41ad3f4cf009ae64866428"],"incrementInt":["e4b4a8e25f4f3f3065e909daeb9492fa06f3d251b1d7acfe626f78cb4fcd0b03"],"int":["e31a84b29edaa63e0c589e34ecf4183980eb4992a1dc937c3e64ca873508915a"],"invertTree":["8c53d60529d7993fc279a5bf210e20850d23d537d3e21f48a45fe8ac52f20562"],"invertTreeTwice":["53e158f32fc34e41616f00880f68e07de663d8fd7331db2a0fd387cbbbb08d31"],"liftA2State":["6b9ac7bcddd16f966ec2aed5677801c5ba93b918c14da2cf2d28dfd9d72fb424"],"list":["0dfd51c023d2e73e0bddbd2ae647f2aa3c36a6d45c67e0e6462fdc614ff28241"],"mapArray":["6d6d080909f5db2195e737ff8cbacfcd10e6534da79210ff86a0c1fa4912bc50"],"maybeMonoid":["a08880301cfd4c26c552a556016e4e66305e051fc6427daf9e94d7989669cf4d"],"monoPair":["cf017a32db26e3b762147023aaeb430fa51bc9d871b682e4f9dca47061f0d52e"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["5c18ac6e498d594057cfa68980fe2239d3241d1dbe4b4e5dbe3a640b911f8e6a"],"pair":["f013b11c4c6b60830490a775fbbcafeebd031a5e410daa0a96246b551d5d902c"],"parser":["6faecb05781f5ec27e11f807eabd526253710b260dee8b3df96f453844a4866d"],"predParser":["35f9b6b9ab1d6e7a9bd94d697fc2b0f7742e66e656cb833671a746b4815f0938"],"pureState":["c328ed375962895287294c7d3dbf22e11c5e0ce0277fe519c23ce262471cb707"],"runParser":["91712883878bb77e6ae0eeb7f446b15fd96360aac0f9775a9c0e05e97da2e6ec"],"runState":["8133440314453ec8dc72a9b2c6e0a81b2a63547bf7f6641184e691dd40c97b61"],"snd":["b716c74c15d77239a4604cc55fd700a96963f824a45e2a1474ba5bd1a5541384"],"sndPair":["4aff9e474dcb0490b0cb8f4923ba1a0dcf8c7512c54320bb8c860b6aeb7ffdf2"],"state":["9c3f3c7add5392272fd569265cb977e39a4c19c3be68bdbb1988c6b91e8b0d65"],"storeName":["f50771e104e47a30bf24b7d0b937114376adc346ad78ad1fea3ef05ea10bbf11"],"stringMonoid":["d8aeb2b1f7ef648f6c2aa04df3b2afc93a753d3b65a48fb64b64b8e63e4abf36"],"stringReduce":["65ac59d424563945926e215c1afe83565648099ce5251288f07d48e114d379a0"],"subtractInt":["a941e799c1a151a6a468edd89c4f5e63dd841372a2d5b9762e329337d72119a8"],"sumMonoid":["44cec5be64b705a40806b8715ef905d349be689af00d7f524a0c613f1efb4401"],"testStateUsages":["56c6b9bc7f944bb725174f01a12ce993c18a261c9f60f72deb7a78ef0e8c39c9"],"trafficLight":["19997a1f48d2f2022ecf9e38a393a9b9611f974a832cdb72a1a8dc8d7688e987"],"tree":["dca27bd6d533d1d3b4fc196b479cc7186783c64a0c55a21250a25d736633a59d"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json b/compiler/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json deleted file mode 100644 index 80a0edbe..00000000 --- a/compiler/test/golden/SaveProject/d4a5fb178fdfc40b4baf59cdab72a044674f184dae7712178aada1bc7a58f45c.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["a76a8f5104ea5b9fe4fcb70ba7286b56d92e20cd577df0d3f42c6443d4a49f20"],"aRecord":["90b80417f8f0a565eab402de4ff17196c25ffcd2caae8242f3f042bb897b95e7"],"addInt":["f8810fde9265bc07f787e4acfc9abdf3ce4b9a6c201c1686362567ffac37d024"],"and":["13412b8909c4c7f19397a9ae7c9ad349fa4802ff8c3273b11e44546c736dd392"],"anyChar":["4b69d3c4cbabfc605d5037a46208de2a2ef4ce70f2d0cbb9d3380f4599072216"],"apState":["949e3dfc9832260b3892091b0135039421218eb6eaa8417f9d16a335a30e561d"],"bindParser":["fdddf2902d8d7de74a2b580c8b603c137327630e4b2f0a90d603c75d65fb06a3"],"bindState":["5ef4d61a19169dfe3bfb65c537f15a5073434d2804c2be06683d9ba1ecdf6d29"],"compose":["fbc8b14f5c06a8ea4250f6bd1790dd8ed22a342909d8016b65d9e00c6ec31732","0f0698b3bec47fce9abb4a4b1eb79427d034e82d2c42f470fcc1710eb9c700be"],"cons":["406597e4ad72fcf1c2e5d7c74b65c7e9d23b0edf5d58d0b979285dbdf68a6493"],"const":["1c9e6580bcbf4032efc3d200c482269b3a9084adee362a2541ed3c675dc85e49"],"constFalse":["4ef8a89011eee16b16ea7f5560a525805e1e264dd92a88907f4e480c432ec333"],"constTrue":["2cae674037e1b0ebab97cf9bfc8752378eba70069f88b24e949cc17113141132"],"eq":["92d7bf46d6182a08c80d1e49fdbae6b31feb2197a623040b4f3d4cc9882676f9"],"eqTen":["098bb991141b84ddffcdf868a8aec89edd0c500c85342e907a89b4ed4f842e0c"],"evalState":["4d49e1654451e793595ed82401818e90d20077cb1e5d61e81b39e78709505606"],"execState":["0bfc149a8e9f6c444d39921d8db8e1cbe8b857da56be2b32dad53e2458caded3"],"failParser":["678136c01485fbf8fdc103bf0a106b13a02e49e1bdd9f1dc80b01fb44a22bdf7"],"fmapMaybe":["6d7541e82a674530ac2e42f1d58fff1b8aa363c6b08c30247d8e8823fbbeb3e6"],"fmapParser":["6a8c00518089f9704f9953fcf60d8801d3231add3f88b303ac74045d697d7107"],"fmapState":["53d7a98a1e9087a3a34bc1d015bac118c8f96902da855b1e628e2aac4087e0ee"],"fst":["6c58f3c4abd7f088adf0c410ba6cf2e4389efb7fb04ce3f445dcb3a215d6bedb"],"fstPair":["520c94d1edf219037f0109b1c448a09966f252f667f6ee0c1694c6c7ed5bcf74"],"id":["1329c66dd95a4c7b889b1d30a4c19399f1f68fae8b5cbc5c9a9fc2247d227152"],"incrementInt":["7db82df7231e1ce60cbe6d3f154f36495c4ed7c55330ebf6361f80d740170b18"],"int":["6eb93e96cb5588947171c44c3114fb1406cffcd14a65df1d4ca06847061e462e"],"invertTree":["888a67baeeaf17f54eb0e26192617a0a9bedc014d16abe4e23a098e295ec864b"],"invertTreeTwice":["f52e80f2da1e03280158c81e8d4548c8f318ee2b047f36f734a903596b10e9ae"],"liftA2State":["4ad403ce614a1ff72242d5ef0edf891f4ec2107c5cc04390bc6c356e83519f36"],"mapArray":["b07b8a1d7e9c5c986e4810186fa17ef3c122df1cce78f68a0416d31061145228"],"maybeMonoid":["0b4c657157101e6324115729c2899282ebbb90dde38474a2e992d523b1830ac0"],"nil":["3833bcc8533961e445e38f2b1c627bd64866fd5ada8181f47b0452b23bb60962"],"not":["5757c108499f698e5f1f6c54eab20a1e41d858152ce7e74f9c3b7e470036dadd"],"predParser":["d82149834327c5c2fecc0e6363b751b4aab7c1ef1dfd7f0ca9bcf101478d63cf"],"pureState":["2d9c7440baffc9ae67ff95211a2396c7f336bec74c3d7d3cd5b570d68ed4f978"],"runParser":["b94d0124d384d5be061d21bd4034bc0db4069f97a3878fe422130abf0b26f01e"],"runState":["24c6714b2395974647ee98c9333cc6fa0451794103b5672f252d7e20689b810d"],"snd":["6f1ad05d7387dd96faa8089019befd3ebef863696f6bff18b0643319e7960383"],"sndPair":["69640f459d35efa35f163ff89ef0d9290f8e73aa090e4d66492dba867fd8cec0"],"storeName":["7224e41c20c1c5ef041f9735ec96561278f2fc839243f28f90f50a2cf6b6d685"],"stringMonoid":["d93a0328be2c9a8d0ae84bc24589ba9a2f3319eb22b6e1ecf20daee2818f558f"],"stringReduce":["d02fef71a500932ada7ad2e0700859de582d83f7eb8ad2d9540301525aa10b4a"],"subtractInt":["f110048ec174f7742c8eeba648b72124723da510d9077d15de3e9ee092f2a609"],"sumMonoid":["733da4530fecb488cdc58dc264676d678cd20ef27c4c54cfdc0fe92ddec7fbb1"],"testStateUsages":["5af560de2bddd4348b79745c599c890e926a5da539e80e8cd3f1b5843e03bc8d"],"typePerson":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"typeState":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"typeThese":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"useEither":["29a52e43325c0546a821fca3d4e3852481e1fbe9995bd6cced2d5beff958236c"]},"projectModules":{},"projectTypes":{"Branch":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Cons":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Either":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"Green":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Ident":["b6cf1348b6530fc367bb16ff0cabd1cb1f4fe04e78176f39100d94c0bb2a8afc"],"Just":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Leaf":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Left":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"List":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Maybe":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"MonoPair":["1abc241fe92190084bb57320cef406d487d60139b275dcce68d9644fb5ba5fbd"],"Monoid":["267d670d997069af71f4d06010c721bb73ee0d1f07353a6afb41b9f5289597d3"],"Nil":["926b22874da8f7b90309100bffa550e00735652d506d64c58af42828b6527bc2"],"Nothing":["e16a38e2e28c40b91ca12fb8a051ff92feb8a87023cd10cbba58c236625ba13b"],"Pair":["cbb4e4a913869fcfbd4404bb9caf1b55f2666ed8e4406ad966e3bd05b735c7cd"],"Parser":["2fc2d85fbc941d63e01a828f01e893b7b7de740c67a1ab5c905ce581c5c71bb5"],"Person":["0e714594ce3ce0d1310a54aa1ceb19f98f2bfc972c9c628d39ab60f27c82f931"],"Red":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Right":["c98b4a5de0bcb3f1f366fb715dc77cd30c53c55451ac67b8d504c3ebbf8b27d7"],"State":["4ededb14b4ad21c65b41d901fb14db905065a2bafa8765e40f08a4c599a21c22"],"That":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"These":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"This":["4b6fee12fd52f846eec7e42c570d246d706f408e35877e4814b593f94034118f"],"TrafficLight":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"],"Tree":["7215c215a9d936714afd7c3bbc85cad2cc620f59bcabade096651312fa3f318c"],"Yellow":["94ffb29fa20569ae20948383c6037c50c3de2f9eaec5de693c9a61e56fb2019c"]},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json b/compiler/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json deleted file mode 100644 index c2a346c9..00000000 --- a/compiler/test/golden/SaveProject/d79915855551eb04b7ad82a1e1c7dd76b06341c29f2f421af30267ca6f889ab4.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["fed744690133c39eb9deeaaed372ec71873fd5254cac68a9b5412f9ea55cc562"],"aRecord":["052c2b3636065acfa936448c7238d6ff8d16ab08476fd816ec501d764ba6fe4f"],"addInt":["3ef93551066cafeb1d829466fd2dc6938571a5305487ef532de578b4f123854a"],"and":["308a904cb48bf5f1785e638b0b3f6596951e0ed30c2e849d6018a984a6050f60"],"anyChar":["4b90a9db9ed1e661233c549b67af42b5c755c041dd2879d28b9565d389297308"],"apState":["9018027dd79f09e2d69245a9b1f4eb50ddfd6770b1b7797dc9939293f759aa08"],"bindParser":["48a08149bf69b2e46d7475c99a53dc2b365925f7835e46f80c761f4da92df0a6"],"bindState":["ec4e1ed69dcae59734c825ef17307644ac08ce874bc715e936c50ad75211fa88"],"compose":["12166a16e2cbb289c2512b46357b34111d0afa4d2a8087e20b9687eeb0490a0b","bd71034cf006e85b5575763d5ea20eef506825c343b023e755efeacecf499e43"],"cons":["58cb7968d7e83a89016adb0672bea619731191928aae2db602e0507403efcd61"],"const":["9387a07499d50491fd082db3e66f8ffdea1c4189c82d380d6dc04c4349208e3b"],"constFalse":["f07f8ab6aa0503844f1878bc37848080af4a67e7353b53ab93b0f85849df8b88"],"constTrue":["f4112d90d8c27ae9015f1ee71c276168e137d0e5377a027081f971d10548661d"],"either":["6a01d802e0efe804d6158293189ea3f7ac540c1bc45e3f4dd3bfc0e694bdfe85"],"eitherAp":["31e1c8000ed68042ec3b3ecd14678486805cff96c354f43928c4ec7095c90959"],"eitherFmap":["c304ae93c70ba3cf64514c247e8d8ea52e0b7120f554a68d147562554ef29061"],"eitherPure":["3ebb49763d68268fbea25eaf6c18a115e99a8967e2dfc87037c5743a295c7905"],"eq":["85abca156c53397532609979d779ab160d68d6ad1612865b59af40f73ce4e887"],"eqTen":["804e87d2173c6c4b9368b95d441b0be3f9df46c9967f351066b82714adfdcde8"],"evalState":["37bb788a914d7c07252f034c327b3e2417ed62ab73700a2b20d0fad0278e3803"],"execState":["496d291d4d81d9c0dd63569a3cb5ef5db2bfd6d2234603a77b56eaeb314be70d"],"failParser":["ced41144d00431cb31ba72bf73aa6a9b1d67c42a4682bf3dbe62131447174a0f"],"fmapMaybe":["fd411c194d0c04498769f3effde3dc4856982a557335f2b354abd04d8e724dd9"],"fmapParser":["bb560587760531c3009a6dc52b153a18ead7b7b1ce5f4cfc773d56c91b5649a4"],"fmapState":["c4da1bf839d1fe79e30e3afa21293d0184a407f75ba5755581b487d53b6a54d6"],"fst":["048b062907abe8c0164c07000a90e2a8983ebaac1db93bc4d6c9353b57648515"],"fstPair":["1c8ceee1c36b78304cf8c8e1166a6e532927bc7ffba6c06fd66073922a4a256c"],"id":["9fc53499ba8adf4c325d7505c5a7c5836af8d45cb23e5e31624e28b9782e9ff1"],"incrementInt":["ecf3e463244841f5fbd0b8852cd1a500bf307a97f1198e7896ebd0fc5a41ac5d"],"int":["a4973324cdf38f405014214b19e112b32cda213ec707036b15ddff0d407ecb4a"],"invertTree":["0ea1834b5ad4fabd6dcf1ce8b61f3eab206e3ccaeb8fc615222d359fdd24a2c5"],"invertTreeTwice":["5bc3190d057e120329c5a9ab109993ddebed605fe73b4d9e59a378af242ce804"],"liftA2State":["5c2e5dff07af6a0715b9db00b4c93f6c733311d02c1936991eff6739f240f639"],"mapArray":["ca307ea04ae021bd3018ec19ceb14f425e6015bb5a586a20aa76b66a2764b1e6"],"maybeMonoid":["19ae0e05aa64bf5145058e08b508602b1d8fa9eb235651428d55c9b35966943d"],"nil":["3a86e9a8fffed70a7c4fdfcccd6a4126805b92cc68b83052087483e24f122869"],"not":["5c4b4a2cb55448c0a1359f96666bde45087bb232b436739dd54bde71d0068a8e"],"predParser":["a982e3f0d8d4750e90366a9442724482206fce622cf796464b0a59539a71c4fc"],"pureState":["f0ca5dff527b6b0017d060027c5f918287eed7e875110dd9165ddfedc8ac6cca"],"runParser":["2f7039c6ca426fba40ba8fa3c433b7fa70037c3ee2ee079f17e5100bdfe35f46"],"runState":["fd5311967def1abdf7fea307f165a1b8478b9624f4b78a18052f82a468d23301"],"snd":["3eb8d68d2c34de918b06b5bb9199953150d0fd7dabeb58f6b679c74362893b0b"],"sndPair":["0e342b303b4127c9df462d6cdd1361ee2f79797b81680afe018f9fa11faeb5dc"],"storeName":["8b703562918ccd5f0d0150f911c2deb381f6107736139b2c0478669ebc69949f"],"stringMonoid":["f0202326f9b8b65c906952d84ff57973cbf3feb0b0df96c8d44994ce3a9f8218"],"stringReduce":["d5029621929817a78e970bbf59f56af6e60911ac1c748d77ca08cfa18af52a86"],"subtractInt":["2bca4c46f1ae350ded077cb717b239ceca4301bd1e30f7534e368293f9f60836"],"sumMonoid":["82e70990b8aa56a94f74e978acf5430e1f41b63fec242035d0c10c275beae817"],"testStateUsages":["36ac78adb85711f877650f387afcf3d3e776729a5efd04d0f6c6e95fe21b3505"],"typePerson":["ce6e217349280fb2d7870186eeb5b3deac1597e0b5d04ef83c9d3ae10be2a928"],"typeState":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"typeThese":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"useEither":["a8e5f5d25c2bc388369c2f2ef79534e943084b5808e65821f27c3ca310f41ad3"]},"projectModules":{},"projectTypes":{"Branch":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Cons":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Either":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"Green":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Ident":["e895a099ce4c950b4e836dbaf22dc4d5a697bf15fee777719b1856aedd1d4b05"],"Just":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"Leaf":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Left":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"List":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Maybe":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"MonoPair":["d00356ba9544f564a9fba9996d1de5880fb1acfec335567f71efc127bd84f3d0"],"Monoid":["b5835570bca0b7e2aa75e190417bc6453d5fdecd26027fd29dfe77f7c65ee09e"],"Nil":["a8dd7a8123992b30be720d0f89f8dc3950d283c617ffbf801d529a383c5d237d"],"Nothing":["491f483bba1d703cba464069f406f169797353c3ce87690f6069231f308ca43e"],"Pair":["13db6dd3fab20132a3d9705f49212f5687b8fd4f33f57a5a5e7a6cc2e72feb85"],"Parser":["9ca802dfb7eeb599865cb5ea4211b465f4f838c7ca3fa9fd06a53a4a03188329"],"Person":["ce6e217349280fb2d7870186eeb5b3deac1597e0b5d04ef83c9d3ae10be2a928"],"Red":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Right":["0fd6476dbb9df43f169641ff9be4f7ca71fba1efca727a49fcffc7eba39a4da8"],"State":["968c8d82bd23200c3aa54ff82cfc426564719275869b9665ca851ca79274df84"],"That":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"These":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"This":["12a7f858d7144d870f5be6cb4071aa5465a1e6c6be84a65e6def81df15910457"],"TrafficLight":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"],"Tree":["1e59c3bc543b8fefbc94b459f9cf54714acda164b1494b4eea6631d64fd92630"],"Yellow":["f6d4bff57cd5d28483f7f49065948a4e2f2510882361ba3872ecfd212e3de165"]},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json b/compiler/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json deleted file mode 100644 index 7ab22250..00000000 --- a/compiler/test/golden/SaveProject/d7b75f5f5a39bbaa06bb80a664711933d4b49f185dcb0d781cdb3d20dac1dd1b.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["3cc9a8f984a113b123d9500bc235b36c980ca2bd6d99e518a5ac2c5bfeab6f42"],"aRecord":["ee18a974bff1da16a4e4f1de2f3daf34266c21f70561766222e6154f3b9a5df6"],"addInt":["564fe022edea28ec30688de5b24d419bd1479c5e3efa6386314d976d7918f0fa"],"and":["983bdbd686db48a88339a2c37e1a64edf93d1f5bc1b783925509a0cfafb48612"],"anyChar":["f0b87f25ab2551a64cf76870a40203505a858140aba720a55697057d9e18b58c"],"apState":["754292fb4d010d5b9f81822f8cff5458c8e81b7e56d382bcd74b8465a742545f"],"bindParser":["969185e087e8a84264ca852df1b9a720d3bbea221632457f7abd81c7c5eef84b"],"bindState":["8c4a645c439a13c91236f4ab2bf1a16dba612898cb1b89b1ffedbac1c726cf47"],"compose":["9802567a9ddb3b25c6979f283601141a5c1a0b1a8eadf41ce64ab871f7b9d48c","f1a84537e946c764c38552185b442e3ed6853e6cd0139bc300df02594b9ebd92"],"cons":["8a7c26e1bb9f471c8cc88717546abbc055089224657d2fb96d98b9deecba3d3b"],"const":["40619e2c9bfa20111dcd95633cb1b78914d3c49d5ab485d12df1c3700a4ba5fc"],"constFalse":["f5e106addba3244db724d4674bff67ffe518c60c521d67d9f950f67b21bb8082"],"constTrue":["c51c58b3d2375908fd12628ba1e4bc146f2cfb3371625953490d97bbfdf1eba8"],"either":["14afa550ce281e9196044cb2ea107e982fa7848c12a9d13067d6ad04fe153bc3"],"eq":["98127c7994d0dc20e87dee10d0864070cc94ee7d3fc9909347194af244fcff11"],"eqTen":["7dff3edf448b2fac3908bcc5d77774469cb43d404754425462589a175aa57e7f"],"evalState":["6886a75a52fd35e96208ddd8db13c50412cd15c0911e9c13d5e16e06c33e9566"],"execState":["601b7dffe29ac215ce16d61eeb9b631448d4c89fa8639b9bb95ce2c76ddeb788"],"failParser":["02ccbe26109935d1fd1d31351428a7cb49957da79b4eac4d56f9dd069ad3b754"],"fmapMaybe":["acaa54ecf365cb128ab0d91bdeb39e2d6720567be884f62a80600fb73f8fbf71"],"fmapParser":["4f33514798d927b8f9cc0a3a48fdcc997b09fac57a711401790de3cec54626e2"],"fmapState":["93f29ab687f13b74d58a17d9e49e071d272945976bebbda90d57d84e4c203460"],"fst":["043df458ea1c0e2e55c92babc57f768b2366e531b5d881e2e89db9ef2f5e4172"],"fstPair":["a3018207d295b542c3d276608889e1a08c5de0283103e6f02432b9cef4bbcf4c"],"id":["177e7ddb0df8237a4e9b0376761fc0c74b397052e21fc43b7ef508cc18af7e80"],"ident":["61214b4316572596495924e7904c6e5724bf7620bc5e25a17a99040101579b11"],"incrementInt":["894e262a84ab339a2fbc5fd5eb3b0d03e8dcf91ba1e2c69b6d4592bcf07b7b2b"],"int":["ba3dbaa24506c0d4f9e20e6b8a53ca5ae02ed9590683278aef2d40455da6dd65"],"invertTree":["d2c52690c3ff11e4b531fa96cd26643fa9ff89d511ef8e30c247ab7c7f058878"],"invertTreeTwice":["9be11ab8d3e49acd919207699fefa9dfb0efe8f755f9728ee00d7e8dd8b411f1"],"liftA2State":["52190c14154da761fb420427bbcdc8cbcee9a4fdfd874781f12287498e7c49b8"],"list":["8393f59b10de70da08f696635167da6df4c790baaf10f61b43c739b21c55a66a"],"mapArray":["bf58fc7601c3510031b063cbe9ae857207e6ed785933f23b24d849317e3a51d0"],"maybeMonoid":["478068ac81705ccf3bb2cc7d0422a11104a05dfea430d9595a82ea1ff79fd282"],"monoPair":["16531f5c137dcd9f7db9ceeabfcc635251e0c096e39c810bbaad568226048d33"],"nil":["d9e543ea3b3a2761b2292855f666f32afc703a24ea1152894088f01578f5893a"],"not":["b5825daf1abb6f94bbc495dab53be4fbd9eb8010eb43b476464acb4cb561fac1"],"pair":["036537315507ac137c3eb206737afaa2180b02e16fc9ee017f88e4c04f218119"],"parser":["0a727ff2218cbd8385960e8f0848ac955ee90e7938b5ed886bb72711feea86d9"],"predParser":["553978e21e6426677ed67cb373d06ef8c1c88401d10f6fc066c1b92e328c7992"],"pureState":["8674e747ceb537f80b5931c08f8167b5db590d58af1aa4cbaf57279af3ae2abb"],"runParser":["3a040b24ee14f16ae774c6ed36a1863a1fc0cee6e559939f079fdd29fc6424d2"],"runState":["c8b1e583def0528e7308518305c095f6b92464c936be4ddf6453b2f098b16797"],"snd":["e1abb2c217c19aa7d92d1e9caaf4aaf120b3a62cd49bb6db6499a52a86026ad7"],"sndPair":["0f1e1edaeea414f9aa3b563d0831147bc977c550bb602354f4f2dbc4581a7e6d"],"state":["ce06ae8292af0cbcbb024d38faeb5987c8703c12566da7a908e83ae6501507c9"],"storeName":["1b605459ec2d16825896019ed04bab5859d77b941b5af91fcc1cacdce4d670b8"],"stringMonoid":["ab19b9174926c2797981aad834b345bc4bb1465d3b08888e2fc9e05d2d6376c4"],"stringReduce":["5de707fc94368a529da7175fa5f6775abac76dc9ecfbabb110116cea38759680"],"subtractInt":["a7ca7fa6302de8b7cdf2f80966cc62bf6a9d89d4648136bf271551d7d30849b7"],"sumMonoid":["713625cc16fdf819517becf021d06376e62d56a87daad47233b9a180fbf4d0f2"],"testStateUsages":["a5339f9c482857ccd113fb54cec09f77b29e7ac7da501e4b7d83dd4a9004525d"],"trafficLight":["e08c74299429366ee29d211ad142f58c7785d459295d731c4d23d3e6f1a9c3dd"],"tree":["0eff9607730498416aea2ef180bed2dcf0748c41bb006701842886e62e1f07b8"],"typePerson":["a3a24862f94d92c5c2c1a965e14e902aa34776834c2a2f7dfa157baf7407adc1"],"typeState":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"typeThese":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"]},"projectPropertyTests":{},"projectTypes":{"Branch":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Cons":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Either":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"Green":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Ident":["f387354763fda433ac316bbafee15a52d9ad38a15d8b443aed86c4278a35ed3d"],"Just":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"Leaf":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Left":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"List":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Maybe":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"MonoPair":["269637495b741c1c7d94c56a26b7a8ddd2475b8aea0460e6095026bb71413dd9"],"Monoid":["8e9411f0b59c7619b10e77721d02f2bf89ad0b9881a0dc7c93f38d0de55d988f"],"Nil":["55e4f1f6eb8366a166dd813509d0fdb080638f194678ee0976ab9d60d535c92c"],"Nothing":["afe7e2073231d74d7ba674e8556af019f7898cf1268b2d96570067028b8af6bd"],"Pair":["36737c23643be94c5685b4f5bce2f4e6b3fd22aca18153dc03e3c97115b0b48b"],"Parser":["64ab0a53205e51f3e6b4b9856ec210b9129e920baa98bda23b026af219918905"],"Person":["a3a24862f94d92c5c2c1a965e14e902aa34776834c2a2f7dfa157baf7407adc1"],"Red":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Right":["5d5c06b3321a9e2f6fe82fec101fbf2ad565598c517864224eed15206228e9a5"],"State":["a565d8df513a67c795efaa5ebeeaa65b4ff8343366c2f5942363dd472a475cb2"],"That":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"These":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"This":["f3987e54b34bbf70b56214fd7c7a81aca503b6c0dd8e21477349985f415b70ae"],"TrafficLight":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"],"Tree":["c8990feea6b86cf3bb69f8a8ec7c572914ead4631731e19a720caf7dbf20b5a3"],"Yellow":["dd1bbaa74b2d03a34a6b6f6a73508cc522104838f486070929ab8be00567a0bf"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json b/compiler/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json deleted file mode 100644 index 262daf42..00000000 --- a/compiler/test/golden/SaveProject/f421742c2b6d0d7849bfcdb63142d186f310fc073bbb109b9d0050e507df1aea.json +++ /dev/null @@ -1 +0,0 @@ -{"projectBindings":{"aPair":["4e392a789038c550189de93aebcf8feff8908b87683396ecedc37512edae59fe"],"aRecord":["ee1fb878531b9a13c92d4be2f189c2fd82a0920754f26cfcd2a992ad6a6b7b59"],"addInt":["4da994b0930852ff88436b70ee6f19cbb5ccf1d1f8adab367019f1ceb1690db4"],"and":["78b1a672334741bbb5d6d8af6c5991486bd3ef553962282379bddac0dbb07d2d"],"anyChar":["35266e63ec46d7f16f410b90b353243cf6673d264e279a5db04bde1a54eeea92"],"apState":["9905c9b5f8072e86ab7fef59e876bcbc6f195c7532e6a381e145220c6ed317f1"],"bindParser":["b594c371f07dfe022baaeaa61088e3d7204a6c62e53ca9946ee1f9f4a499fc46"],"bindState":["ce99f0b83532da6261f39cf852a6524a255738254cf4c4b0ba40792f823dadbe"],"compose":["b6f0d92205dd2074db926421071341983697b086210fa61195f6ec9dca18affb","7081e962a081f614770790e8e6508f4dbda5691b7b0f5032185c71eba77e2f32"],"cons":["63a7a1a4337e0b36578d4fc675820b547be60672e12c06e6bd160aeb1e5dee41"],"const":["c278bc186d065b1ba67259e531033505211f4e1b06054f51ef104e8949f7ad86"],"constFalse":["34c8193ed1feb92ca70743094cc4eecfa03fb71b9a19c6ba5881b0398f72f38b"],"constTrue":["e7052ce240e3801f76b301bca992dddf53f0ad6ff01e9e77fd567a84803f813e"],"either":["0666576cfc3df7a65e79c1422c8f04b403c3b02c65ec95c168a693c19a9ee4d4"],"eq":["080b0c41a3a54fcd600224b2ecd95ba8db30eb36f1f1b956022b3029e5e8f23f"],"eqTen":["a30f10c456bcb5c3a050a69a0c83a7656455ebd678f22d0ad751597dbff3f7c3"],"evalState":["e809a5193899e3565052d55a5eb97b2afd9848a4ee5bf1cad6f4779f4ba27d4e"],"execState":["f028bc92f432f9207fc119c9b1385c9f14b816d7a8b321415bf7383a94b850fb"],"failParser":["89f32df44ebd5d1ae005f1390ca85cc182966c43efb7914ed5bf62ab540f9153"],"fmapMaybe":["7d6feac67a11fa3a49d4511dca8e196ff091b4f1ffe8cedb27f7d7203245f13d"],"fmapParser":["c2cbd4d6a53c14f388edd5f2329c5771a04fe13a1ad26659da9b1f967df7fcb7"],"fmapState":["f2ac935429ee25923bf5212b48e2ddd3a03725bc596cd744e5ed1d69f29ddd74"],"fst":["020615545c3d9f27795711950b509fea8918cbab126b8fd845fd6f13c86cd5fb"],"fstPair":["8f17f04b25d56d9adcda0222b3178678e6ff2b6c1eb6b0bda80694379c79463c"],"id":["00c43dc56b1b82e23d7c0e1ae65c3fe565a8bac8459bca7aee72fa920d8ee409"],"ident":["97a41678b3bf32d877aaf23404f5cb09758e80b2856815222676ed36d33bc550"],"incrementInt":["b35ec09485a066744fedd76eb262bcfc3f674965ceb6e21a9a46d2d10e1384db"],"int":["72d12a4f6c3846f3f8c24c9c4fc94aaaa9eb58f6e7c3e88626b1d2005870234e"],"invertTree":["c010847a1c4fa1a43a04c2a27e69ce335146f1ebd61b8977d40a8c8deb545775"],"invertTreeTwice":["462e15d015da51e06785e2b17894809a26923a89a059eff50c2a1af2903fc0e8"],"liftA2State":["6b649dc6135514c20eca1745baf22ecb1b79ee56f672ad6f3affe3bf6860bafa"],"list":["3c14cea5ebbad925c63d1612369cdd840498105d9661d62edc55fd6f86b8ba74"],"mapArray":["ef0f5ba59467c0c4f7d377b5d6eee3fa629ba2b8f931d66a3865d28c337619cd"],"maybeMonoid":["c3fca83349cb5f786938fee7bf972b0b59776c150f3c73240e856fb595b32309"],"monoPair":["c5459a5d4896dfaf5d2c3d790fabeb4d2cb11a261dd3177365e6d5daeb0b2b82"],"nil":["17b14724f0d6297d35ffb5c66b5077e96336dfb7a2066d1b78a58ec6aaa34c6b"],"not":["44aad0f79b68e1a88c98d677fa24bf05125cd809198e833d5c2ffab47daaf631"],"pair":["5acc7f1fdb40e0cd3c652319edb3daa9649d39f5e057ea0aa60474bb2531509a"],"parser":["58c3caf3327c52048ccc8de05529d9a4a63b7c987cf06172305b247c0fe353d9"],"predParser":["750a6cdd2dc1f80f181e7d2a1d421bcbbb9956f50139e93b810da3cd0f93a023"],"pureState":["9c856307f18254ea5ebe0c7b155483e489080d35b12b8a65ded3d0888ba9016a"],"runParser":["397fa1cc7e750a73ff2e7c9d4bbd3b4accb2dbf3f6dcbd1cab86c0bbecc6ae9c"],"runState":["b3ee93287fa79946839a1bdcf03b0812fc0052ef4c0fe2491e8eeca42a745f85"],"snd":["efedb887ce84a0909236562353099335d664da8f89c751d2269e92d2d109a399"],"sndPair":["4bf4b6108d22ed9dee5e2b0f4f2f467cfa32e7c5e8d911c3edd71f105a46eb16"],"state":["49d3792687fb9d010133cedee17453379e3109bf1b0252679e8d9492b21e0498"],"storeName":["2cfe0854f7983f78c262a2e9558b93e8de49e9b70b6f5766b3bc011d944ebf78"],"stringMonoid":["231ce2b454ffd520ee694022c7be72b432999bd49fb4f2809b2c6118ceca9545"],"stringReduce":["3225ff4f82ac87eb20be5184e6de926b1a561a50b6752135649b926d45376fea"],"subtractInt":["af26cdbe701e3d2ec983d8712978d1c05f86812a659bf92f5d8152b25bf5d18c"],"sumMonoid":["fbb04dc15026fb41234d88fe94c661e7dd179b56879546f90c56bb76578e1df6"],"testStateUsages":["4382adbe7d53aaaba4e858fe31e16f5a8fb029533d0e99d1e53f945dd3e85ec7"],"trafficLight":["74393de28f2b32c60b82bb3439848e39c6ff7b874e732087893f425d2f21846b"],"tree":["6086e8fd70a725ba6dd51f4ecc531e87eb8391458aa9f641ad75a91650f477ce"],"typePerson":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"typeState":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"typeThese":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"useEither":["86e0f761e230ab7a0a2e7f8c8e3fa3dc7bab10f62563e5d8010f99f1488f4ae9"]},"projectPropertyTests":{},"projectTypes":{"Branch":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Cons":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Either":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"Green":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Ident":["1cf2c774adea9e6fc11b1d88a7fb316fd22b27b6a5be8e9befa745d1e361fa3f"],"Just":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Leaf":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Left":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"List":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Maybe":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"MonoPair":["610cdbd5aca57d9078ea3370f3e275f8a57095fde19e440af300ec5fd163a8b1"],"Monoid":["4a1b5f9aed18ad9ccdb15e47c8a0b6fcca74dc1f9d167ceb32dfd2fa10de01f9"],"Nil":["4a81f17c8c3af829596d69db892e99efd3ddf9e4309627ffb8b9598bf2970cfe"],"Nothing":["216051294469b5f6aaeb92b79c8a320db8af827f72760de83dda29de05f55962"],"Pair":["04242b82991ca7486ce2918e9008350da68c9bc9b4668f4c523988c0b44c5ac9"],"Parser":["c85c2d83526ac90d441460d6b2b4892eb6c5837f5eafea23609642888d601e8f"],"Person":["7207725ff36f9d5c13787902d047a0ce50a0db15efeea100b9c35e482426754d"],"Red":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Right":["ab9610b05f0910a5239b1ded7e1a171cc526bf9db3f89fca9c89562b1efb66c4"],"State":["47b67c2d468b6d9ec3f2814b7aff64218b79648cdbbb7f2d6db92fb1a6d41c30"],"That":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"These":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"This":["5377ce29a548d1ba6f543bfb48b809bf0cf216815b7e9b3b84374602616c3b4b"],"TrafficLight":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"],"Tree":["16a894dc0643052e97b16d362824b9e7928410f5d25a87b0d65d379d0cda1184"],"Yellow":["d05dd866fb15c738774804f0d982fdcd8db6a40df19e6adb9becbfacda8b3c00"]},"projectUnitTests":{},"projectVersion":1} \ No newline at end of file diff --git a/compiler/test/modules/1.mimsa b/compiler/test/modules/1.mimsa deleted file mode 100644 index 08cb0dd8..00000000 --- a/compiler/test/modules/1.mimsa +++ /dev/null @@ -1,20 +0,0 @@ -def main: String = fromMaybe (id log) (Just (const (exclaim horse) False)) - -def id a = a - -def const a b = id a - -def exclaim (str: String): String = str ++ "!!!!!!!" - -def horse = "fucking horse" - -def fromMaybe (default: a) (maybeA: Maybe a): a = - match maybeA with - Just a -> a - | _ -> default - -def log = const "Yes" True - -type Maybe a = Just a | Nothing - - diff --git a/compiler/test/modules/10.mimsa b/compiler/test/modules/10.mimsa deleted file mode 100644 index 524ea606..00000000 --- a/compiler/test/modules/10.mimsa +++ /dev/null @@ -1,10 +0,0 @@ -export type Maybe a = Just a | Nothing - -def alt (mA: Maybe a) (mB: Maybe a): Maybe a = - match mA with - Just a -> Just a - | Nothing -> mB - -infix <|> = alt - -def useAlt = Nothing <|> Just 1 diff --git a/compiler/test/modules/2.mimsa b/compiler/test/modules/2.mimsa deleted file mode 100644 index e422a944..00000000 --- a/compiler/test/modules/2.mimsa +++ /dev/null @@ -1,4 +0,0 @@ -def duplicate = 1 -def duplicate = 2 - - diff --git a/compiler/test/modules/3.mimsa b/compiler/test/modules/3.mimsa deleted file mode 100644 index 4a455ea2..00000000 --- a/compiler/test/modules/3.mimsa +++ /dev/null @@ -1,3 +0,0 @@ -type Maybe a = Just a | Nothing -type Maybe b = Dogs | Horses - diff --git a/compiler/test/modules/4.mimsa b/compiler/test/modules/4.mimsa deleted file mode 100644 index 4833cd34..00000000 --- a/compiler/test/modules/4.mimsa +++ /dev/null @@ -1,3 +0,0 @@ -type Maybe a = Just a | Nothing -type Other b = Dogs | Nothing - diff --git a/compiler/test/modules/5.mimsa b/compiler/test/modules/5.mimsa deleted file mode 100644 index 009f1e71..00000000 --- a/compiler/test/modules/5.mimsa +++ /dev/null @@ -1 +0,0 @@ -def useMissingThing = eatEgg 100 diff --git a/compiler/test/modules/6.mimsa b/compiler/test/modules/6.mimsa deleted file mode 100644 index 2e9385c5..00000000 --- a/compiler/test/modules/6.mimsa +++ /dev/null @@ -1 +0,0 @@ -def doesntTypecheck = 1 + True diff --git a/compiler/test/modules/7.mimsa b/compiler/test/modules/7.mimsa deleted file mode 100644 index ebbddc8b..00000000 --- a/compiler/test/modules/7.mimsa +++ /dev/null @@ -1 +0,0 @@ -def doesntTypecheckBecauseAnnotation (a: String): String = 1 + a diff --git a/compiler/test/modules/8.mimsa b/compiler/test/modules/8.mimsa deleted file mode 100644 index 8ea45c5e..00000000 --- a/compiler/test/modules/8.mimsa +++ /dev/null @@ -1,7 +0,0 @@ -def fullType (a: String) (b: String): String = a ++ b - -def partialTypeAndReturn (a: String) b : String = a ++ b - -def partialType (a: String) b = a ++ b - -def noType a b = a ++ b diff --git a/compiler/test/modules/9.mimsa b/compiler/test/modules/9.mimsa deleted file mode 100644 index cd6568b5..00000000 --- a/compiler/test/modules/9.mimsa +++ /dev/null @@ -1 +0,0 @@ -def id (str: String): a = str diff --git a/core/.gitignore b/core/.gitignore deleted file mode 100644 index a19ce96d..00000000 --- a/core/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -.direnv/ - -.stack-work/ -*~ -store/*.json -result -result/ - -output/ - -*.hie -swagger.json - -# .prof files generated for profiling -*.prof - -# cabal shit -dist-newstyle diff --git a/core/LICENSE b/core/LICENSE deleted file mode 100644 index e637cdee..00000000 --- a/core/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/core/core.cabal b/core/core.cabal deleted file mode 100644 index aa37262e..00000000 --- a/core/core.cabal +++ /dev/null @@ -1,126 +0,0 @@ -cabal-version: 2.2 -name: core -version: 0.1.0.0 -description: - Please see the README on GitHub at - -homepage: https://github.com/danieljharvey/mimsa#readme -bug-reports: https://github.com/danieljharvey/mimsa/issues -author: Daniel J Harvey -maintainer: danieljamesharvey@gmail.com -copyright: 2021 Daniel J Harvey -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple - -source-repository head - type: git - location: https://github.com/danieljharvey/mimsa - -common common-all - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - -library - import: common-all - exposed-modules: - Language.Mimsa.Core - Language.Mimsa.Core.ExprUtils - Language.Mimsa.Core.Parser - Language.Mimsa.Core.Parser.Helpers - Language.Mimsa.Core.Parser.Identifier - Language.Mimsa.Core.Parser.Identifiers - Language.Mimsa.Core.Parser.Language - Language.Mimsa.Core.Parser.Lexeme - Language.Mimsa.Core.Parser.Literal - Language.Mimsa.Core.Parser.Module - Language.Mimsa.Core.Parser.MonoType - Language.Mimsa.Core.Parser.Pattern - Language.Mimsa.Core.Parser.TypeDecl - Language.Mimsa.Core.Parser.Types - Language.Mimsa.Core.Printer - Language.Mimsa.Core.Types.AST - Language.Mimsa.Core.Types.AST.Annotation - Language.Mimsa.Core.Types.AST.DataType - Language.Mimsa.Core.Types.AST.Expr - Language.Mimsa.Core.Types.AST.Identifier - Language.Mimsa.Core.Types.AST.InfixOp - Language.Mimsa.Core.Types.AST.Literal - Language.Mimsa.Core.Types.AST.Operator - Language.Mimsa.Core.Types.AST.Pattern - Language.Mimsa.Core.Types.AST.Spread - Language.Mimsa.Core.Types.AST.StringPart - Language.Mimsa.Core.Types.AST.StringType - Language.Mimsa.Core.Types.Identifiers - Language.Mimsa.Core.Types.Identifiers.Name - Language.Mimsa.Core.Types.Identifiers.TestName - Language.Mimsa.Core.Types.Identifiers.TyCon - Language.Mimsa.Core.Types.Identifiers.TypeIdentifier - Language.Mimsa.Core.Types.Identifiers.TypeName - Language.Mimsa.Core.Types.Identifiers.TyVar - Language.Mimsa.Core.Types.Module - Language.Mimsa.Core.Types.Module.DefIdentifier - Language.Mimsa.Core.Types.Module.Entity - Language.Mimsa.Core.Types.Module.Module - Language.Mimsa.Core.Types.Module.ModuleHash - Language.Mimsa.Core.Types.Module.ModuleName - Language.Mimsa.Core.Types.Type - Language.Mimsa.Core.Types.Type.MonoType - Language.Mimsa.Core.TypeUtils - Language.Mimsa.Core.Utils - - hs-source-dirs: src - default-extensions: Strict - build-depends: - , aeson - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , hashable - , megaparsec - , mtl - , openapi3 - , parser-combinators - , prettyprinter - , text - , transformers - - default-language: Haskell2010 - -test-suite core-test - import: common-all - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - CoreTest.Parser.DataTypes - CoreTest.Parser.MonoTypeParser - CoreTest.Parser.Pattern - CoreTest.Parser.Syntax - CoreTest.Prettier - CoreTest.Utils.Helpers - - hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - , aeson - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , hashable - , hspec - , megaparsec - , mtl - , openapi3 - , parser-combinators - , prettyprinter - , text - , transformers - - default-language: Haskell2010 diff --git a/core/src/Language/Mimsa/Core.hs b/core/src/Language/Mimsa/Core.hs deleted file mode 100644 index 63450858..00000000 --- a/core/src/Language/Mimsa/Core.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Language.Mimsa.Core - ( module Language.Mimsa.Core.Parser, - module Language.Mimsa.Core.Types.AST, - module Language.Mimsa.Core.Types.Type, - module Language.Mimsa.Core.Types.Identifiers, - module Language.Mimsa.Core.Types.Module, - module Language.Mimsa.Core.Printer, - module Language.Mimsa.Core.TypeUtils, - module Language.Mimsa.Core.ExprUtils, - module Language.Mimsa.Core.Utils, - ) -where - -import Language.Mimsa.Core.ExprUtils -import Language.Mimsa.Core.Parser -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.TypeUtils -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module -import Language.Mimsa.Core.Types.Type -import Language.Mimsa.Core.Utils diff --git a/core/src/Language/Mimsa/Core/ExprUtils.hs b/core/src/Language/Mimsa/Core/ExprUtils.hs deleted file mode 100644 index 56148f6a..00000000 --- a/core/src/Language/Mimsa/Core/ExprUtils.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Core.ExprUtils - ( withMonoid, - mapExpr, - bindExpr, - toEmptyAnnotation, - getAnnotation, - mapPattern, - nameFromIdent, - detailsFromIdent, - ) -where - -import Data.Bifunctor (second) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core.Types.AST.Expr (Expr (..)) -import Language.Mimsa.Core.Types.AST.Identifier -import Language.Mimsa.Core.Types.AST.Pattern - -------- --- Functions for operating on the Expr type -------- - --- | Removes any annotations in the expression, useful when serialising --- expressions -toEmptyAnnotation :: - (Monoid b) => - Expr var a -> - Expr var b -toEmptyAnnotation = fmap (const mempty) - --- | Retrieve the annotation for any given Expression -getAnnotation :: Expr var ann -> ann -getAnnotation (MyLiteral ann _) = ann -getAnnotation (MyAnnotation ann _ _) = ann -getAnnotation (MyVar ann _ _) = ann -getAnnotation (MyLet ann _ _ _) = ann -getAnnotation (MyLetPattern ann _ _ _) = ann -getAnnotation (MyInfix ann _ _ _) = ann -getAnnotation (MyLambda ann _ _) = ann -getAnnotation (MyApp ann _ _) = ann -getAnnotation (MyIf ann _ _ _) = ann -getAnnotation (MyTuple ann _ _) = ann -getAnnotation (MyRecord ann _) = ann -getAnnotation (MyRecordAccess ann _ _) = ann -getAnnotation (MyTupleAccess ann _ _) = ann -getAnnotation (MyConstructor ann _ _) = ann -getAnnotation (MyTypedHole ann _) = ann -getAnnotation (MyArray ann _) = ann -getAnnotation (MyPatternMatch ann _ _) = ann - --- | Given a function `f` that turns any piece of the expression in a Monoid --- `m`, flatten the entire expression into `m` -withMonoid :: - (Monoid m) => - (Expr var ann -> (Bool, m)) -> - Expr var ann -> - m -withMonoid f whole@(MyLiteral _ _) = snd (f whole) -withMonoid f whole@MyVar {} = snd (f whole) -withMonoid f whole@(MyAnnotation _ _ expr) = - let (go, m) = f whole - in if not go - then m - else m <> withMonoid f expr -withMonoid f whole@(MyLet _ _ bindExpr' inExpr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f bindExpr' - <> withMonoid f inExpr -withMonoid f whole@(MyLetPattern _ _ expr body) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f expr - <> withMonoid f body -withMonoid f whole@(MyInfix _ _ a b) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f a - <> withMonoid f b -withMonoid f whole@(MyLambda _ _binder expr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f expr -withMonoid f whole@(MyApp _ func arg) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f func - <> withMonoid f arg -withMonoid f whole@(MyIf _ matchExpr thenExpr elseExpr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f matchExpr - <> withMonoid f thenExpr - <> withMonoid f elseExpr -withMonoid f whole@(MyTuple _ a as) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f a - <> mconcat (withMonoid f <$> NE.toList as) -withMonoid f whole@(MyRecord _ items) = - let (go, m) = f whole - in if not go - then m - else - m - <> mconcat - ( snd <$> M.toList (withMonoid f <$> items) - ) -withMonoid f whole@(MyArray _ items) = - let (go, m) = f whole - in if not go - then m - else - m - <> mconcat - (withMonoid f <$> items) -withMonoid f whole@(MyRecordAccess _ expr _name) = - let (go, m) = f whole - in if not go then m else m <> withMonoid f expr -withMonoid f whole@(MyTupleAccess _ expr _index) = - let (go, m) = f whole - in if not go then m else m <> withMonoid f expr -withMonoid f whole@MyConstructor {} = snd (f whole) -withMonoid f whole@MyTypedHole {} = snd (f whole) -withMonoid f whole@(MyPatternMatch _ matchExpr matches) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f matchExpr - <> mconcat - (withMonoid f <$> (snd <$> matches)) - --- | Map a function `f` over the expression. This function takes care of --- recursing through the Expression -mapExpr :: (Expr a b -> Expr a b) -> Expr a b -> Expr a b -mapExpr _ (MyLiteral ann a) = MyLiteral ann a -mapExpr _ (MyVar ann modName a) = MyVar ann modName a -mapExpr f (MyAnnotation ann mt expr) = - MyAnnotation ann mt (f expr) -mapExpr f (MyLet ann binder bindExpr' inExpr) = - MyLet ann binder (f bindExpr') (f inExpr) -mapExpr f (MyLetPattern ann pat expr body) = - MyLetPattern ann pat (f expr) (f body) -mapExpr f (MyInfix ann op a b) = MyInfix ann op (f a) (f b) -mapExpr f (MyLambda ann binder expr) = MyLambda ann binder (f expr) -mapExpr f (MyApp ann func arg) = MyApp ann (f func) (f arg) -mapExpr f (MyIf ann matchExpr thenExpr elseExpr) = - MyIf ann (f matchExpr) (f thenExpr) (f elseExpr) -mapExpr f (MyTuple ann a as) = MyTuple ann (f a) (f <$> as) -mapExpr f (MyRecord ann items) = MyRecord ann (f <$> items) -mapExpr f (MyRecordAccess ann expr name) = - MyRecordAccess ann (f expr) name -mapExpr f (MyTupleAccess ann expr index) = - MyTupleAccess ann (f expr) index -mapExpr f (MyArray ann items) = MyArray ann (f <$> items) -mapExpr _ (MyConstructor ann modName cons) = MyConstructor ann modName cons -mapExpr f (MyPatternMatch ann matchExpr patterns) = - MyPatternMatch ann (f matchExpr) (second f <$> patterns) -mapExpr _ (MyTypedHole ann a) = MyTypedHole ann a - --- | Bind a function `f` over the expression. This function takes care of --- recursing through the expression. -bindExpr :: - (Applicative m) => - (Expr a b -> m (Expr a b)) -> - Expr a b -> - m (Expr a b) -bindExpr _ (MyLiteral ann a) = - pure $ MyLiteral ann a -bindExpr _ (MyVar ann modName a) = - pure $ MyVar ann modName a -bindExpr f (MyAnnotation ann mt expr) = - MyAnnotation ann mt <$> f expr -bindExpr f (MyLet ann binder bindExpr' inExpr) = - MyLet ann binder <$> f bindExpr' <*> f inExpr -bindExpr f (MyLetPattern ann pat expr body) = - MyLetPattern ann pat <$> f expr <*> f body -bindExpr f (MyInfix ann op a b) = - MyInfix ann op <$> f a <*> f b -bindExpr f (MyLambda ann binder expr) = - MyLambda ann binder <$> f expr -bindExpr f (MyApp ann func arg) = - MyApp ann <$> f func <*> f arg -bindExpr f (MyIf ann matchExpr thenExpr elseExpr) = - MyIf ann <$> f matchExpr <*> f thenExpr <*> f elseExpr -bindExpr f (MyTuple ann a as) = - MyTuple ann <$> f a <*> traverse f as -bindExpr f (MyRecord ann items) = - MyRecord ann <$> traverse f items -bindExpr f (MyRecordAccess ann expr name) = - MyRecordAccess ann <$> f expr <*> pure name -bindExpr f (MyTupleAccess ann expr index) = - MyTupleAccess ann <$> f expr <*> pure index -bindExpr f (MyArray ann items) = - MyArray ann <$> traverse f items -bindExpr _ (MyConstructor ann modName cons) = - pure $ MyConstructor ann modName cons -bindExpr _ (MyTypedHole ann a) = pure (MyTypedHole ann a) -bindExpr f (MyPatternMatch ann matchExpr patterns) = - MyPatternMatch - ann - <$> f matchExpr - <*> traverse traverseSecond patterns - where - traverseSecond (a, b) = (a,) <$> f b - --- | Map a function `f` over the pattern. This function takes care of --- recursing through the Pattern -mapPattern :: (Pattern a b -> Pattern a b) -> Pattern a b -> Pattern a b -mapPattern _ (PWildcard ann) = PWildcard ann -mapPattern _ (PVar ann a) = PVar ann a -mapPattern _ (PLit ann a) = PLit ann a -mapPattern f (PConstructor ann modName tyCon vars) = - PConstructor ann modName tyCon (f <$> vars) -mapPattern f (PTuple ann a as) = - PTuple ann (f a) (f <$> as) -mapPattern f (PRecord ann as) = - PRecord ann (f <$> as) -mapPattern f (PArray ann as spread) = - PArray ann (f <$> as) spread -mapPattern _ (PString ann pHead pTail) = - PString ann pHead pTail - -nameFromIdent :: Identifier var ann -> var -nameFromIdent = fst . detailsFromIdent - -detailsFromIdent :: Identifier var ann -> (var, ann) -detailsFromIdent (Identifier ann name) = (name, ann) diff --git a/core/src/Language/Mimsa/Core/Parser.hs b/core/src/Language/Mimsa/Core/Parser.hs deleted file mode 100644 index ed320791..00000000 --- a/core/src/Language/Mimsa/Core/Parser.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Language.Mimsa.Core.Parser - ( module Language.Mimsa.Core.Parser.Language, - module Language.Mimsa.Core.Parser.MonoType, - module Language.Mimsa.Core.Parser.TypeDecl, - module Language.Mimsa.Core.Parser.Module, - module Language.Mimsa.Core.Parser.Lexeme, - module Language.Mimsa.Core.Parser.Pattern, - module Language.Mimsa.Core.Parser.Identifiers, - ) -where - -import Language.Mimsa.Core.Parser.Identifiers -import Language.Mimsa.Core.Parser.Language -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Module -import Language.Mimsa.Core.Parser.MonoType -import Language.Mimsa.Core.Parser.Pattern -import Language.Mimsa.Core.Parser.TypeDecl diff --git a/core/src/Language/Mimsa/Core/Parser/Helpers.hs b/core/src/Language/Mimsa/Core/Parser/Helpers.hs deleted file mode 100644 index d7d8dc75..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Helpers.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Helpers - ( parseAndFormat, - commaSep, - between2, - addLocation, - withLocation, - maybePred, - filterProtectedNames, - filterProtectedOperators, - inBrackets, - orInBrackets, - chainl1, - ) -where - -import Data.Bifunctor (first) -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Text.Megaparsec -import Text.Megaparsec.Char - --- run a parser and then run Megaparsec pretty printer on the error -parseAndFormat :: Parser a -> Text -> Either Text a -parseAndFormat p = first (T.pack . errorBundlePretty) . parse (p <* eof) "repl" - --- parses between two chars -between2 :: Char -> Char -> Parser a -> Parser a -between2 a b parser = do - _ <- myLexeme (char a) - val <- parser - _ <- myLexeme (char b) - pure val - ------ - --- helper for adding location to a parser -withLocation :: (Annotation -> a -> b) -> Parser a -> Parser b -withLocation withP p = do - start <- getOffset - value <- p - end <- getOffset - pure (withP (Location start end) value) - --- | wraps any parser of Exprs and adds location information -addLocation :: Parser ParserExpr -> Parser ParserExpr -addLocation = withLocation (mapOuterExprAnnotation . const) - --- | modify the outer annotation of an expression --- useful for adding line numbers during parsing -mapOuterExprAnnotation :: (ann -> ann) -> Expr a ann -> Expr a ann -mapOuterExprAnnotation f expr' = - case expr' of - MyInfix ann a op b -> MyInfix (f ann) a op b - MyAnnotation ann expr mt -> MyAnnotation (f ann) expr mt - MyLiteral ann a -> MyLiteral (f ann) a - MyVar ann modName a -> MyVar (f ann) modName a - MyLet ann a b c -> MyLet (f ann) a b c - MyLetPattern ann a b c -> MyLetPattern (f ann) a b c - MyLambda ann a b -> MyLambda (f ann) a b - MyApp ann a b -> MyApp (f ann) a b - MyIf ann a b c -> MyIf (f ann) a b c - MyTuple ann a as -> MyTuple (f ann) a as - MyRecord ann as -> MyRecord (f ann) as - MyRecordAccess ann a b -> MyRecordAccess (f ann) a b - MyTupleAccess ann a b -> MyTupleAccess (f ann) a b - MyArray ann as -> MyArray (f ann) as - MyConstructor ann a b -> MyConstructor (f ann) a b - MyTypedHole ann a -> MyTypedHole (f ann) a - MyPatternMatch ann a b -> MyPatternMatch (f ann) a b - ------ - -inBrackets :: Parser a -> Parser a -inBrackets = between2 '(' ')' - ------ - -orInBrackets :: Parser a -> Parser a -orInBrackets parser = try parser <|> try (inBrackets parser) - ------ - -maybePred :: (Show a) => Parser a -> (a -> Maybe b) -> Parser b -maybePred parser predicate' = try $ do - a <- parser - case predicate' a of - Just b -> pure b - _ -> fail $ T.unpack $ "Predicate did not hold for " <> T.pack (show a) - ------ - -filterProtectedNames :: Text -> Maybe Text -filterProtectedNames tx = - if S.member tx protectedNames - then Nothing - else Just tx - -filterProtectedOperators :: Text -> Maybe Text -filterProtectedOperators tx = - if S.member tx protectedOperators - then Nothing - else Just tx - ---- - --- | stolen from Parsec, allows parsing infix expressions without recursion --- death -chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a -chainl1 p op = do x <- p; rest x - where - rest x = - do - f <- op - y <- p - rest (f x y) - <|> return x - ---- - -commaSep :: Parser p -> Parser (NE.NonEmpty p) -commaSep p = NE.fromList <$> p `sepBy1` myString "," diff --git a/core/src/Language/Mimsa/Core/Parser/Identifier.hs b/core/src/Language/Mimsa/Core/Parser/Identifier.hs deleted file mode 100644 index 9d09b357..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Identifier.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Language.Mimsa.Core.Parser.Identifier - ( identifierParser, - ) -where - -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Identifiers -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers - ----- - -identifierParser :: Parser (Identifier Name Annotation) -identifierParser = - plainIdentifierParser - -plainIdentifierParser :: Parser (Identifier Name Annotation) -plainIdentifierParser = - myLexeme - ( withLocation - Identifier - nameParserInt - ) diff --git a/core/src/Language/Mimsa/Core/Parser/Identifiers.hs b/core/src/Language/Mimsa/Core/Parser/Identifiers.hs deleted file mode 100644 index 9151ec90..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Identifiers.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Identifiers - ( varParser, - nameParser, - nameParserInt, - infixOpParser, - tyConParser, - typedHoleParser, - constructorParser, - moduleNameParser, - typeNameParser, - ) -where - -import Control.Monad ((>=>)) -import Data.Char as Char -import Data.Text (Text) -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName -import Text.Megaparsec - ----- - -varParser :: Parser ParserExpr -varParser = - try namespacedVarParser <|> try plainVarParser - --- `dog`, `log`, `a` -plainVarParser :: Parser ParserExpr -plainVarParser = - myLexeme (withLocation (`MyVar` Nothing) nameParser) - --- `Dog.log`, `Maybe.fmap` -namespacedVarParser :: Parser ParserExpr -namespacedVarParser = - let inner = do - mName <- moduleNameParser - myString "." - MyVar mempty (Just mName) <$> nameParser - in myLexeme (addLocation inner) - ---- - -identifier :: Parser Text -identifier = takeWhile1P (Just "variable name") Char.isAlphaNum - -nameParser :: Parser Name -nameParser = - myLexeme nameParserInt - --- use this when you are going to wrap myLexeme yourself -nameParserInt :: Parser Name -nameParserInt = - maybePred - identifier - (filterProtectedNames >=> safeMkName) - ---- - -constructorParser :: Parser ParserExpr -constructorParser = - try namespacedConstructorParser - <|> try plainConstructorParser - -plainConstructorParser :: Parser ParserExpr -plainConstructorParser = withLocation (`MyConstructor` Nothing) tyConParser - -namespacedConstructorParser :: Parser ParserExpr -namespacedConstructorParser = - let inner = do - mName <- moduleNameParser - myString "." - MyConstructor mempty (Just mName) <$> tyConParser - in myLexeme (addLocation inner) - --- - -tyConParser :: Parser TyCon -tyConParser = - myLexeme $ - maybePred - identifier - (filterProtectedNames >=> safeMkTyCon) - ---- - -typeNameParser :: Parser TypeName -typeNameParser = - myLexeme $ - maybePred - identifier - (filterProtectedNames >=> safeMkTypeName) - ---- - -moduleNameParser :: Parser ModuleName -moduleNameParser = - myLexeme $ - maybePred - identifier - (filterProtectedNames >=> safeMkModuleName) - ------ - -typedHoleParser :: Parser ParserExpr -typedHoleParser = - withLocation - MyTypedHole - ( do - myString "?" - nameParser - ) - ------ - -infixIdentifier :: Parser Text -infixIdentifier = takeWhile1P (Just "infix operator") (not . Char.isSpace) - -infixOpParser :: Parser InfixOp -infixOpParser = - myLexeme - ( maybePred - infixIdentifier - (filterProtectedOperators >=> safeMkInfixOp) - ) diff --git a/core/src/Language/Mimsa/Core/Parser/Language.hs b/core/src/Language/Mimsa/Core/Parser/Language.hs deleted file mode 100644 index 55c08af9..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Language.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Core.Parser.Language - ( parseExpr, - parseMonoType, - parseExprAndFormatError, - parseAndFormat, - expressionParser, - patternMatchParser, - recordAccessParser, - varParser, - nameParser, - tyConParser, - typeDeclParser, - ParseErrorType, - Parser, - ) -where - -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Text (Text) -import GHC.Natural -import Language.Mimsa.Core.Parser.Helpers (addLocation, chainl1, commaSep, inBrackets, orInBrackets, parseAndFormat, withLocation) -import Language.Mimsa.Core.Parser.Identifier -import Language.Mimsa.Core.Parser.Identifiers -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Literal -import Language.Mimsa.Core.Parser.MonoType -import Language.Mimsa.Core.Parser.Pattern -import Language.Mimsa.Core.Parser.TypeDecl -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers (Name) -import Language.Mimsa.Core.Types.Type -import Text.Megaparsec -import Text.Megaparsec.Char - --- parse expr, using it all up -parseExpr :: Text -> Either ParseErrorType ParserExpr -parseExpr = parse (space *> expressionParser <* eof) "repl" - --- parse monotype -parseMonoType :: Text -> Either ParseErrorType MonoType -parseMonoType = parse (space *> monoTypeParser <* eof) "type" - -parseExprAndFormatError :: Text -> Either Text ParserExpr -parseExprAndFormatError = parseAndFormat (space *> expressionParser <* eof) - -expressionParser :: Parser ParserExpr -expressionParser = - let parsers = - infixParser - <|> literalParser - <|> annotationParser - <|> complexParser - <|> varParser - <|> constructorParser - in orInBrackets parsers - -complexParser :: Parser ParserExpr -complexParser = - arrayParser - <|> try letParser - <|> letPatternParser - <|> try appParser - <|> ifParser - <|> try tupleAccessParser - <|> tupleParser - <|> try recordAccessParser - <|> recordParser - <|> lambdaParser - <|> patternMatchParser - <|> typedHoleParser - ----- - -letParser :: Parser ParserExpr -letParser = try letInParser <|> letFuncParser - -letInParser :: Parser ParserExpr -letInParser = addLocation $ do - _ <- myString "let" - (name, anno) <- identifierOrAnnotatedParser - _ <- myString "=" - boundExpr <- expressionParser - _ <- try (myString ";") <|> myString "in" - case anno of - Just mt -> - MyLet - mempty - name - (MyAnnotation mempty mt boundExpr) - <$> expressionParser - Nothing -> - MyLet mempty name boundExpr - <$> expressionParser - -letFuncParser :: Parser ParserExpr -letFuncParser = addLocation $ do - myString "let" - (name, anno) <- identifierOrAnnotatedParser - args <- chainl1 ((: []) <$> identifierParser) (pure (<>)) - myString "=" - expr <- expressionParser - _ <- try (myString ";") <|> myString "in" - let expr' = foldr (MyLambda mempty) expr args - case anno of - Just mt -> - MyLet mempty name (MyAnnotation mempty mt expr') - <$> expressionParser - Nothing -> - MyLet mempty name expr' <$> expressionParser - -identifierOrAnnotatedParser :: - Parser - ( Identifier Name Annotation, - Maybe MonoType - ) -identifierOrAnnotatedParser = - let regularParser = (,Nothing) <$> identifierParser - spicyParser = do - name <- identifierParser - myString ":" - mt <- monoTypeParser - pure (name, Just mt) - in try (inBrackets spicyParser) <|> regularParser - ------ - -letPatternParser :: Parser ParserExpr -letPatternParser = - addLocation $ - do - myString "let" - pat <- orInBrackets patternParser - myString "=" - expr <- expressionParser - myString ";" <|> myString "in" - MyLetPattern mempty pat expr - <$> expressionParser - ------ - -lambdaParser :: Parser ParserExpr -lambdaParser = - addLocation $ do - _ <- myString "\\" - ident <- identifierParser - _ <- myString "->" - MyLambda mempty ident <$> expressionParser - ------ - -appFunc :: Parser ParserExpr -appFunc = - try recordAccessParser - <|> try tupleAccessParser - <|> try varParser - <|> try constructorParser - <|> try annotationParser - <|> try (inBrackets lambdaParser) - <|> typedHoleParser - <|> inBrackets appParser - --- we don't want to include infix stuff here -argParser :: Parser ParserExpr -argParser = - let parsers = - literalParser - <|> arrayParser - <|> letParser - <|> letPatternParser - <|> ifParser - <|> try tupleAccessParser - <|> tupleParser - <|> try recordAccessParser - <|> recordParser - <|> lambdaParser - <|> typedHoleParser - <|> varParser - <|> constructorParser - in try (inBrackets infixParser) - <|> try (inBrackets appParser) - <|> try annotationParser - <|> orInBrackets parsers - -appParser :: Parser ParserExpr -appParser = addLocation $ do - func <- orInBrackets appFunc - let argParser' :: Parser [ParserExpr] - argParser' = (: []) <$> argParser - args <- chainl1 argParser' (pure (<>)) - pure $ foldl (MyApp mempty) func args - ------ - -recordParser :: Parser ParserExpr -recordParser = withLocation MyRecord $ do - let itemParser = - try recordItemParser - <|> punnedRecordItemParser - myString "{" - args <- sepBy itemParser (myString ",") - myString "}" - pure (M.fromList args) - -recordItemParser :: Parser (Name, ParserExpr) -recordItemParser = do - name <- nameParser - myString ":" - expr <- expressionParser - pure (name, expr) - -punnedRecordItemParser :: Parser (Name, ParserExpr) -punnedRecordItemParser = do - name <- nameParser - pure (name, MyVar mempty Nothing name) - ------ - -recordAccessParser :: Parser ParserExpr -recordAccessParser = - let combine location (record, names) = - foldl (MyRecordAccess location) record names - in withLocation combine $ do - record <- try varParser <|> recordParser - names <- some dotName - pure (record, names) - -dotName :: Parser Name -dotName = do - _ <- myString "." - nameParser - ------ - -tupleAccessParser :: Parser ParserExpr -tupleAccessParser = - let combine location (tuple, indexes) = - foldl (MyTupleAccess location) tuple indexes - in withLocation combine $ do - tuple <- try varParser <|> try tupleParser - indexes <- some dotIndex - pure (tuple, indexes) - -dotIndex :: Parser Natural -dotIndex = do - _ <- myString "." - natParser - ---- - -ifParser :: Parser ParserExpr -ifParser = addLocation $ do - _ <- myString "if" - predP <- expressionParser - _ <- myString "then" - thenP <- expressionParser - _ <- myString "else" - MyIf mempty predP thenP <$> expressionParser - ------ - -tupleParser :: Parser ParserExpr -tupleParser = label "tuple" $ - addLocation $ do - _ <- myString "(" - neArgs <- commaSep expressionParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - _ <- myString ")" - pure (MyTuple mempty (NE.head neArgs) neTail) - ------ - --- we don't allow super complicate exprs to be used around infix --- just because it makes awful code and it's slow to parse -infixExpr :: Parser ParserExpr -infixExpr = - let parsers = - try literalParser - <|> try complexParser - <|> try varParser - <|> try annotationParser - <|> try constructorParser - in orInBrackets parsers - -opParser :: Parser Operator -opParser = - try - ( Custom <$> infixOpParser - ) - <|> try - ( myString "==" - $> Equals - ) - <|> try - ( myString "-" - $> Subtract - ) - <|> try - ( myString "<>" - $> ArrayConcat - ) - <|> try - ( myString ">=" - $> GreaterThanOrEqualTo - ) - <|> try - ( myString "<=" - $> LessThanOrEqualTo - ) - <|> try - ( myString ">" - $> GreaterThan - ) - <|> try - ( myString "<" - $> LessThan - ) - <|> try - ( myString "++" - $> StringConcat - ) - <|> try - ( myString "+" - $> Add - ) - -infixParser :: Parser ParserExpr -infixParser = - addLocation - ( chainl1 - infixExpr - ( MyInfix mempty <$> opParser - ) - ) - ----------- - -arrayParser :: Parser ParserExpr -arrayParser = withLocation MyArray $ do - myString "[" - args <- sepBy expressionParser (myString ",") - myString "]" - pure args - -{- - -PATTERN MATCHING - -pattern matches are of form - -match a with - (Just b) -> b - _ -> False - --} - -patternMatchParser :: Parser ParserExpr -patternMatchParser = addLocation $ do - matchExpr <- matchExprWithParser - patterns <- - try patternMatchesParser - <|> pure - <$> patternCaseParser - pure $ MyPatternMatch mempty matchExpr patterns - -matchExprWithParser :: Parser ParserExpr -matchExprWithParser = do - myString "match" - sumExpr <- expressionParser - myString "with" - pure sumExpr - -patternMatchesParser :: Parser [(ParserPattern, ParserExpr)] -patternMatchesParser = - sepBy - patternCaseParser - (myString "|") - -patternCaseParser :: Parser (ParserPattern, ParserExpr) -patternCaseParser = do - pat <- orInBrackets patternParser - myString "->" - patExpr <- expressionParser - pure (pat, patExpr) - ----------- - -annotationParser :: Parser ParserExpr -annotationParser = - let innerParser = do - expr <- expressionParser - myString ":" - MyAnnotation mempty <$> monoTypeParser <*> pure expr - in addLocation (inBrackets innerParser) diff --git a/core/src/Language/Mimsa/Core/Parser/Lexeme.hs b/core/src/Language/Mimsa/Core/Parser/Lexeme.hs deleted file mode 100644 index 72f7f9e1..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Lexeme.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Language.Mimsa.Core.Parser.Lexeme where - -import Control.Applicative -import Data.Functor (($>)) -import Data.Text (Text) -import Language.Mimsa.Core.Parser.Types -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -myLexeme :: Parser a -> Parser a -myLexeme = L.lexeme (L.space space1 empty empty) - -myString :: Text -> Parser () -myString s = myLexeme (string s) $> () diff --git a/core/src/Language/Mimsa/Core/Parser/Literal.hs b/core/src/Language/Mimsa/Core/Parser/Literal.hs deleted file mode 100644 index 6c7f30a4..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Literal.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Literal - ( literalParser, - testNameParser, - stringLiteral, - trueParser, - falseParser, - integerLiteral, - natParser, - ) -where - -import Data.Functor (($>)) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Natural -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -literalParser :: Parser ParserExpr -literalParser = - try boolParser - <|> try intParser - <|> try stringParser - ----- - --- 2, -2, +2 -integerLiteral :: Parser Literal -integerLiteral = - MyInt <$> L.signed (string "" $> ()) L.decimal - -intParser :: Parser ParserExpr -intParser = myLexeme (withLocation MyLiteral integerLiteral) - ---- - -natParser :: Parser Natural -natParser = L.decimal - ---- - -boolParser :: Parser ParserExpr -boolParser = - myLexeme - ( withLocation - MyLiteral - (trueParser <|> falseParser) - ) - -trueParser :: Parser Literal -trueParser = myString "True" $> MyBool True - -falseParser :: Parser Literal -falseParser = myString "False" $> MyBool False - ------ - -textLiteral :: Parser Text -textLiteral = T.pack <$> (char '\"' *> manyTill L.charLiteral (char '\"')) - -stringLiteral :: Parser Literal -stringLiteral = - MyString . StringType <$> textLiteral - -stringParser :: Parser ParserExpr -stringParser = - myLexeme - ( withLocation - MyLiteral - stringLiteral - ) - -testNameParser :: Parser TestName -testNameParser = TestName <$> myLexeme textLiteral diff --git a/core/src/Language/Mimsa/Core/Parser/Module.hs b/core/src/Language/Mimsa/Core/Parser/Module.hs deleted file mode 100644 index 7301fc35..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Module.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Module - ( parseModule, - moduleParser, - DefPart (..), - ) -where - -import Data.Char as Char -import Data.Text (Text) -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Identifier -import Language.Mimsa.Core.Parser.Identifiers -import Language.Mimsa.Core.Parser.Language -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Literal -import Language.Mimsa.Core.Parser.MonoType -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Module.Module -import Language.Mimsa.Core.Types.Module.ModuleHash -import Text.Megaparsec hiding (parseTest) -import Text.Megaparsec.Char - -parseModule :: Text -> Either ParseErrorType [ModuleItem Annotation] -parseModule = parse (space *> moduleParser <* eof) "repl" - --- currently fails at the first hurdle --- since we can parse each thing separately, maybe --- we should be making each throw errors for later, but returning `mempty` so --- we can collect all of the separate parse errors at once? --- use `registerParseError` from https://hackage.haskell.org/package/megaparsec-9.2.1/docs/Text-Megaparsec.html -moduleParser :: Parser [ModuleItem Annotation] -moduleParser = - let bigParsers = parseModuleItem <|> parseExport - in mconcat - <$> ( chainl1 ((: []) <$> bigParsers) (pure (<>)) - <|> pure mempty - ) - --- we've excluded Export here -parseModuleItem :: Parser [ModuleItem Annotation] -parseModuleItem = - parseDef - <|> try typeParser - <|> parseImport - <|> parseInfix - <|> parseTest - -------- - --- type definitions --- type Maybe a = Just a | Nothing --- type Tree a = Branch (Tree a) a (Tree a) | Leaf a -typeParser :: Parser [ModuleItem Annotation] -typeParser = do - td <- typeDeclParser - pure [ModuleDataType td] - -------- - --- definitions --- def oneHundred = 100 --- def id a = a --- def exclaim (str: String) = str ++ "!!!" --- def exclaim2 (str: String): String = str ++ "!!!" - -defPartParser :: Parser (DefPart Annotation) -defPartParser = - let parseDefArg = DefArg <$> identifierParser - parseTypeArg = - inBrackets - ( do - name <- identifierParser - myString ":" - DefTypedArg name <$> monoTypeParser - ) - parseDefType = do - myString ":" - DefType <$> monoTypeParser - in parseDefType <|> parseTypeArg <|> parseDefArg - --- top level definition -parseDef :: Parser [ModuleItem Annotation] -parseDef = do - myString "def" - name <- nameParser - parts <- - chainl1 ((: []) <$> defPartParser) (pure (<>)) - <|> pure mempty - myString "=" - expr <- expressionParser - pure [ModuleExpression name parts expr] - -parseExport :: Parser [ModuleItem Annotation] -parseExport = do - myString "export" - items <- parseModuleItem - pure (ModuleExport <$> items) - -parseHash :: Parser ModuleHash -parseHash = - ModuleHash - <$> myLexeme - ( takeWhile1P (Just "module hash") Char.isAlphaNum - ) - --- TODO: maybe make these into one parser that handles both to avoid --- backtracking -parseImport :: Parser [ModuleItem Annotation] -parseImport = try parseImportAll <|> parseImportNamed - --- `import Prelude from a123123bcbcbcb` -parseImportNamed :: Parser [ModuleItem Annotation] -parseImportNamed = do - myString "import" - modName <- moduleNameParser - myString "from" - hash <- parseHash - pure [ModuleImport (ImportNamedFromHash hash modName)] - --- `import * from a123123bcbcbcb` -parseImportAll :: Parser [ModuleItem Annotation] -parseImportAll = do - myString "import" - myString "*" - myString "from" - hash <- parseHash - pure [ModuleImport (ImportAllFromHash hash)] - --- `infix <|> = altMaybe` -parseInfix :: Parser [ModuleItem Annotation] -parseInfix = do - myString "infix" - infixOp <- infixOpParser - myString "=" - boundExpr <- expressionParser - pure [ModuleInfix infixOp boundExpr] - --- `test "1 + 1 == 2" = 1 + 1 == 2` -parseTest :: Parser [ModuleItem Annotation] -parseTest = do - myString "test" - testName <- testNameParser - myString "=" - boundExpr <- expressionParser - pure [ModuleTest testName boundExpr] diff --git a/core/src/Language/Mimsa/Core/Parser/MonoType.hs b/core/src/Language/Mimsa/Core/Parser/MonoType.hs deleted file mode 100644 index 034f9f2b..00000000 --- a/core/src/Language/Mimsa/Core/Parser/MonoType.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Language.Mimsa.Core.Parser.MonoType - ( monoTypeParser, - typeDeclParser', - ) -where - -import Control.Monad ((>=>)) -import Control.Monad.Combinators.Expr -import qualified Data.Char as Char -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Identifiers (moduleNameParser, nameParser, typeNameParser) -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.TypeUtils (dataTypeWithVars) -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName -import Language.Mimsa.Core.Types.Type -import Text.Megaparsec - --- | top-level parser for type signatures -monoTypeParser :: Parser MonoType -monoTypeParser = - try (orInBrackets functionParser) - <|> simpleTypeParser - --- | all the types except functions -simpleTypeParser :: Parser MonoType -simpleTypeParser = - let parsers = - try tupleParser - <|> try varParser - <|> try primitiveParser - <|> try recordParser - <|> try arrayParser - <|> try dataTypeParser - in orInBrackets parsers - --- | all the types but prefer no constructor arguments -typeDeclParser' :: Parser MonoType -typeDeclParser' = - let parsers = - try tupleParser - <|> try varParser - <|> try primitiveParser - <|> try recordParser - <|> try arrayParser - <|> try functionParser - <|> try monoDataTypeParser - in try (orInBrackets parsers) - <|> inBrackets multiDataTypeParser - --- | used where a function must be inside brackets for clarity -subParser :: Parser MonoType -subParser = - try simpleTypeParser - <|> try (inBrackets functionParser) - -primitiveParser :: Parser MonoType -primitiveParser = MTPrim mempty <$> primParser - where - primParser = - try (myString "String" $> MTString) - <|> try (myString "Boolean" $> MTBool) - <|> try (myString "Int" $> MTInt) - -arrParse :: Operator Parser MonoType -arrParse = InfixR $ do - myString "->" - pure (MTFunction mempty) - -functionParser :: Parser MonoType -functionParser = do - val <- makeExprParser subParser [[arrParse]] - case val of - MTFunction {} -> pure val - _ -> fail "don't use function for parsing non-function values" - -tupleParser :: Parser MonoType -tupleParser = do - myString "(" - neArgs <- commaSep monoTypeParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - myString ")" - pure (MTTuple mempty (NE.head neArgs) neTail) - -identifier :: Parser Text -identifier = myLexeme (takeWhile1P (Just "type variable name") Char.isAlphaNum) - -inProtectedTypes :: Text -> Maybe Text -inProtectedTypes tx = - if S.member tx protectedTypeNames - then Nothing - else Just tx - --- these names cannot be used as type variables -protectedTypeNames :: Set Text -protectedTypeNames = - S.fromList - [ "String", - "Int", - "Boolean", - "Unit", - "in", - "def", - "type", - "infix", - "test", - "import", - "export" - ] - -tyVarParser :: Parser TyVar -tyVarParser = - myLexeme $ - maybePred - identifier - (inProtectedTypes >=> safeMkTyVar) - -varParser :: Parser MonoType -varParser = do - MTVar mempty <$> (TVName <$> tyVarParser) - -recordParser :: Parser MonoType -recordParser = - withLocation - (\loc (args, rest) -> MTRecord loc args rest) - ( do - args <- recordArgs - rest <- optional $ do - myString "|" - monoTypeParser - myString "}" - pure (args, rest) - ) - -recordArgs :: Parser (Map Name MonoType) -recordArgs = do - myString "{" - args <- sepBy recordItemParser (myString ",") - pure (M.fromList args) - -recordItemParser :: Parser (Name, MonoType) -recordItemParser = do - name <- nameParser - myString ":" - expr <- monoTypeParser - pure (name, expr) - -dataTypeParser :: Parser MonoType -dataTypeParser = - try multiDataTypeParser - <|> monoDataTypeParser - -multiDataTypeParser :: Parser MonoType -multiDataTypeParser = do - (modName, tyName) <- constructorParser - tyArgs <- some subParser - pure (dataTypeWithVars mempty modName tyName tyArgs) - -monoDataTypeParser :: Parser MonoType -monoDataTypeParser = do - (modName, tyName) <- constructorParser - pure (dataTypeWithVars mempty modName tyName mempty) - ----- - -constructorParser :: Parser (Maybe ModuleName, TypeName) -constructorParser = - try namespacedConstructorParser - <|> try plainConstructorParser - -plainConstructorParser :: Parser (Maybe ModuleName, TypeName) -plainConstructorParser = - (Nothing,) <$> typeNameParser - -namespacedConstructorParser :: Parser (Maybe ModuleName, TypeName) -namespacedConstructorParser = do - mName <- moduleNameParser - myString "." - (,) (Just mName) <$> typeNameParser - ---- - -arrayParser :: Parser MonoType -arrayParser = do - myString "[" - arg <- monoTypeParser - myString "]" - pure (MTArray mempty arg) diff --git a/core/src/Language/Mimsa/Core/Parser/Pattern.hs b/core/src/Language/Mimsa/Core/Parser/Pattern.hs deleted file mode 100644 index d86798bf..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Pattern.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Pattern - ( patternParser, - ParserPattern, - ) -where - -import Data.Either (partitionEithers) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Language.Mimsa.Core.Parser.Helpers -import Language.Mimsa.Core.Parser.Identifiers (moduleNameParser, nameParser, tyConParser) -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.Literal -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers -import Text.Megaparsec -import Text.Megaparsec.Char - -type ParserPattern = Pattern Name Annotation - -patternParser :: Parser ParserPattern -patternParser = - label - "pattern match" - ( orInBrackets - ( try stringParser - <|> try tupleParser - <|> try wildcardParser - <|> try variableParser - <|> try litParser - <|> try recordParser - <|> try constructorParser - <|> try arrayParser - ) - ) - ----- - -wildcardParser :: Parser ParserPattern -wildcardParser = - myLexeme $ - withLocation - (\loc _ -> PWildcard loc) - (string "_") - ----- - -variableParser :: Parser ParserPattern -variableParser = - myLexeme $ withLocation PVar nameParser - ----- - -tupleParser :: Parser ParserPattern -tupleParser = label "tuple" $ - withLocation (\loc (pHead, pTail) -> PTuple loc pHead pTail) $ do - _ <- myString "(" - neArgs <- commaSep patternParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - _ <- myString ")" - pure (NE.head neArgs, neTail) - ----- - -litParser :: Parser ParserPattern -litParser = withLocation PLit lit - where - lit = - try (myLexeme integerLiteral) - <|> try (myLexeme stringLiteral) - <|> trueParser - <|> falseParser - ---- - -recordParser :: Parser ParserPattern -recordParser = withLocation PRecord $ do - let itemParser = - try recordItemParser - <|> punnedRecordItemParser - _ <- myString "{" - args <- sepBy itemParser (myString ",") - _ <- myString "}" - pure (M.fromList args) - -recordItemParser :: Parser (Name, ParserPattern) -recordItemParser = do - name <- nameParser - myString ":" - expr <- patternParser - pure (name, expr) - -punnedRecordItemParser :: Parser (Name, ParserPattern) -punnedRecordItemParser = do - name <- nameParser - pure (name, PVar mempty name) - ---- - -argsParser :: Parser [ParserPattern] -argsParser = try someP <|> pure [] - where - someP = some patternParser - ----- - -constructorParser :: Parser ParserPattern -constructorParser = - try namespacedConstructorParser - <|> try plainConstructorParser - -plainConstructorParser :: Parser ParserPattern -plainConstructorParser = - let parser = do - cons <- tyConParser - args <- try argsParser - pure (cons, args) - in withLocation - ( \loc (cons, args) -> - PConstructor loc Nothing cons args - ) - parser - -namespacedConstructorParser :: Parser ParserPattern -namespacedConstructorParser = - let inner = do - mName <- moduleNameParser - myString "." - tyCon <- tyConParser - args <- try argsParser - pure (mName, tyCon, args) - in myLexeme - ( withLocation - ( \loc (mName, tyCon, args) -> - PConstructor loc (Just mName) tyCon args - ) - inner - ) - ---- - -arrayParser :: Parser ParserPattern -arrayParser = - let itemParser = - try (Right <$> patternParser) - <|> try (Left <$> spreadParser) - <|> fail "Expected pattern or a spread operator" - parser = do - myString "[" - args <- sepBy itemParser (myString ",") - myString "]" - case getParts args of - Right parts -> pure parts - Left e -> fail e - in withLocation (\loc (as, spread) -> PArray loc as spread) parser - -getParts :: - [Either (Spread Name Annotation) (Pattern Name Annotation)] -> - Either String ([Pattern Name Annotation], Spread Name Annotation) -getParts as = case reverse as of - ((Left spr) : rest) -> - case partitionEithers rest of - ([], pats) | not (null pats) -> pure (reverse pats, spr) - ([], _) -> Left "There must be at least one pattern to use a spread" - _ -> Left "Cannot have more than one spread in an array pattern" - es -> case partitionEithers es of - ([], pats) -> pure (reverse pats, NoSpread) - _ -> Left "Cannot have more than one spread in an array pattern" - ---- - -spreadParser :: Parser (Spread Name Annotation) -spreadParser = - try spreadValueParser - <|> try spreadWildcardParser - -spreadWildcardParser :: Parser (Spread Name Annotation) -spreadWildcardParser = - let parser = - myString "..." - in withLocation (\loc _ -> SpreadWildcard loc) parser - -spreadValueParser :: Parser (Spread Name Annotation) -spreadValueParser = - let parser = do - myString "..." - nameParser - in withLocation SpreadValue parser - ---- - -stringParser :: Parser (Pattern Name Annotation) -stringParser = - let parser = do - a <- stringPartParser - myString "++" - as <- stringPartParser - pure (a, as) - in withLocation (\loc (a, as) -> PString loc a as) parser - -stringPartParser :: Parser (StringPart Name Annotation) -stringPartParser = - try stringWildcard <|> try stringValue - -stringWildcard :: Parser (StringPart Name Annotation) -stringWildcard = - let parser = myString "_" - in withLocation (\loc _ -> StrWildcard loc) parser - -stringValue :: Parser (StringPart Name Annotation) -stringValue = - withLocation StrValue nameParser diff --git a/core/src/Language/Mimsa/Core/Parser/TypeDecl.hs b/core/src/Language/Mimsa/Core/Parser/TypeDecl.hs deleted file mode 100644 index cd0ccff3..00000000 --- a/core/src/Language/Mimsa/Core/Parser/TypeDecl.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.TypeDecl - ( typeDeclParser, - parseTypeDecl, - ) -where - -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import Language.Mimsa.Core.Parser.Identifiers -import Language.Mimsa.Core.Parser.Lexeme -import Language.Mimsa.Core.Parser.MonoType -import Language.Mimsa.Core.Parser.Types -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers (TyCon) -import Language.Mimsa.Core.Types.Type -import Text.Megaparsec - -parseTypeDecl :: Text -> Either ParseErrorType DataType -parseTypeDecl = - parse (typeDeclParser <* eof) "type" - -typeDeclParser :: Parser DataType -typeDeclParser = - try typeDeclParserWithCons - <|> typeDeclParserEmpty - --- it's your "type Void in ..." -typeDeclParserEmpty :: Parser DataType -typeDeclParserEmpty = do - myString "type" - tyName <- typeNameParser - pure (DataType tyName mempty mempty) - --- it's your more complex cases -typeDeclParserWithCons :: Parser DataType -typeDeclParserWithCons = do - myString "type" - tyName <- typeNameParser - tyArgs <- many nameParser - myString "=" - DataType tyName tyArgs <$> manyTypeConstructors - --------- - -manyTypeConstructors :: Parser (Map TyCon [Type ()]) -manyTypeConstructors = do - tyCons <- - sepBy - oneTypeConstructor - (myString "|") - pure (mconcat tyCons) - ------ - -oneTypeConstructor :: Parser (Map TyCon [Type ()]) -oneTypeConstructor = do - name <- tyConParser - args <- - some typeDeclParser' - <|> pure mempty - let argsWithNoType = ($> ()) <$> args - pure (M.singleton name argsWithNoType) - ------ diff --git a/core/src/Language/Mimsa/Core/Parser/Types.hs b/core/src/Language/Mimsa/Core/Parser/Types.hs deleted file mode 100644 index 9298d74d..00000000 --- a/core/src/Language/Mimsa/Core/Parser/Types.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Parser.Types - ( Parser, - ParseErrorType, - ParserExpr, - protectedNames, - protectedOperators, - ) -where - -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import Data.Void -import Language.Mimsa.Core.Types.AST -import Language.Mimsa.Core.Types.Identifiers (Name) -import Text.Megaparsec - -type Parser = Parsec Void Text - -type ParseErrorType = ParseErrorBundle Text Void - -type ParserExpr = Expr Name Annotation - -protectedNames :: Set Text -protectedNames = - S.fromList - [ "let", - "in", - "if", - "then", - "else", - "type", - "match", - "with", - "infix", - "True", - "False", - "def", - "export", - "import", - "test" - ] - -protectedOperators :: Set Text -protectedOperators = - S.fromList - [ "=", - "==", - "+", - "<>", - "-", - "|", - "++", - "<=", - ">=", - ">", - "<" - ] diff --git a/core/src/Language/Mimsa/Core/Printer.hs b/core/src/Language/Mimsa/Core/Printer.hs deleted file mode 100644 index b3335e12..00000000 --- a/core/src/Language/Mimsa/Core/Printer.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Language.Mimsa.Core.Printer - ( Printer (..), - renderWithWidth, - ) -where - --- the Printer type class is used for internal debugging --- prettyPrint is for debug output --- prettyDoc returns a Prettyprinter doc for nicer output - -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Natural -import Prettyprinter -import Prettyprinter.Render.Text - -renderWithWidth :: Int -> Doc ann -> Text -renderWithWidth w doc = renderStrict (layoutPretty layoutOptions (unAnnotate doc)) - where - layoutOptions = LayoutOptions {layoutPageWidth = AvailablePerLine w 1} - -class Printer a where - prettyPrint :: a -> Text - default prettyPrint :: a -> Text - prettyPrint = renderWithWidth 40 . prettyDoc - - prettyDoc :: a -> Doc ann - default prettyDoc :: a -> Doc ann - prettyDoc = pretty . T.unpack . prettyPrint - -instance (Printer e, Printer a) => Printer (Either e a) where - prettyDoc (Left e) = prettyDoc e - prettyDoc (Right a) = prettyDoc a - -instance Printer Natural where - prettyDoc i = pretty @Int (fromIntegral i) - -instance Printer () where - prettyDoc = const "" - -instance (Printer a) => Printer (Maybe a) where - prettyDoc (Just a) = prettyDoc a - prettyDoc _ = mempty - -instance Printer Text where - prettyPrint a = a - prettyDoc = pretty - -instance Printer Bool where - prettyPrint = T.pack . show - -instance Printer Int where - prettyPrint = T.pack . show - -instance (Printer a) => Printer [a] where - prettyDoc = sep . punctuate "," . fmap prettyDoc - -instance (Printer a) => Printer (NE.NonEmpty a) where - prettyDoc = prettyDoc . NE.toList - -instance (Printer k, Printer v) => Printer (Map k v) where - prettyDoc map' = - let printRow (k, v) = " " <> prettyDoc k <> ":" <+> prettyDoc v - in encloseSep lbrace rbrace comma (printRow <$> M.toList map') - -instance (Printer a, Printer b) => Printer (a, b) where - prettyDoc (a, b) = tupled [prettyDoc a, prettyDoc b] - -instance (Printer a, Printer b, Printer c) => Printer (a, b, c) where - prettyDoc (a, b, c) = - tupled [prettyDoc a, prettyDoc b, prettyDoc c] - -instance (Printer a, Printer b, Printer c, Printer d) => Printer (a, b, c, d) where - prettyDoc (a, b, c, d) = - tupled - [prettyDoc a, prettyDoc b, prettyDoc c, prettyDoc d] - -instance (Printer a) => Printer (Set a) where - prettyDoc as = list (prettyDoc <$> S.toList as) diff --git a/core/src/Language/Mimsa/Core/TypeUtils.hs b/core/src/Language/Mimsa/Core/TypeUtils.hs deleted file mode 100644 index e37557ee..00000000 --- a/core/src/Language/Mimsa/Core/TypeUtils.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Language.Mimsa.Core.TypeUtils (dataTypeWithVars, withMonoidType, mapType, bindType) where - -import Data.Foldable (foldl') -import qualified Data.Map.Strict as M -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module -import Language.Mimsa.Core.Types.Type - -dataTypeWithVars :: - (Monoid ann) => - ann -> - Maybe ModuleName -> - TypeName -> - [Type ann] -> - Type ann -dataTypeWithVars ann modName tyName = - foldl' - (MTTypeApp mempty) - (MTConstructor ann modName tyName) - -withMonoidType :: (Monoid m) => (Type ann -> m) -> Type ann -> m -withMonoidType _ MTVar {} = mempty -withMonoidType _ MTConstructor {} = mempty -withMonoidType _ MTPrim {} = mempty -withMonoidType f (MTTypeApp _ a b) = - f a <> f b -withMonoidType f (MTTuple _ a as) = - f a <> foldMap f as -withMonoidType f (MTArray _ as) = f as -withMonoidType f (MTRecord _ as Nothing) = - mconcat (f <$> M.elems as) -withMonoidType f (MTRecord _ as (Just a)) = - mconcat (f <$> M.elems as) - <> f a -withMonoidType f (MTFunction _ a b) = - f a <> f b -withMonoidType f (MTGlobals _ globs rest expr) = - mconcat (f <$> M.elems globs) <> maybe mempty f rest <> f expr - -mapType :: (Type ann -> Type ann) -> Type ann -> Type ann -mapType _ mt@MTVar {} = mt -mapType _ mt@MTConstructor {} = mt -mapType _ mt@MTPrim {} = mt -mapType f (MTTypeApp ann a b) = - MTTypeApp ann (f a) (f b) -mapType f (MTTuple ann a as) = - MTTuple ann (f a) (f <$> as) -mapType f (MTArray ann as) = MTArray ann (f as) -mapType f (MTRecord ann as a) = - MTRecord ann (f <$> as) (f <$> a) -mapType f (MTFunction ann a b) = - MTFunction ann (f a) (f b) -mapType f (MTGlobals ann globs rest expr) = - MTGlobals ann (f <$> globs) (f <$> rest) (f expr) - --- lift a monadic action over a type -bindType :: - (Applicative m) => - (Type ann -> m (Type ann)) -> - Type ann -> - m (Type ann) -bindType f mt = case mt of - MTVar ann tyIdent -> pure (MTVar ann tyIdent) - MTPrim ann a -> pure (MTPrim ann a) - MTFunction ann arg fun -> - MTFunction ann - <$> f arg - <*> f fun - MTTuple ann a as -> - MTTuple ann - <$> f a - <*> traverse f as - MTRecord ann as rest -> - MTRecord ann - <$> traverse f as - <*> traverse f rest - MTArray ann a -> MTArray ann <$> f a - MTConstructor ann modName name -> - pure (MTConstructor ann modName name) - MTTypeApp ann func arg -> - MTTypeApp ann <$> f func <*> f arg - MTGlobals ann globs rest expr -> - MTGlobals ann - <$> traverse f globs - <*> traverse f rest - <*> f expr diff --git a/core/src/Language/Mimsa/Core/Types/AST.hs b/core/src/Language/Mimsa/Core/Types/AST.hs deleted file mode 100644 index af3e9678..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Language.Mimsa.Core.Types.AST - ( module Language.Mimsa.Core.Types.AST.Expr, - module Language.Mimsa.Core.Types.AST.Literal, - module Language.Mimsa.Core.Types.AST.DataType, - module Language.Mimsa.Core.Types.AST.StringType, - module Language.Mimsa.Core.Types.AST.Annotation, - module Language.Mimsa.Core.Types.AST.Operator, - module Language.Mimsa.Core.Types.AST.InfixOp, - module Language.Mimsa.Core.Types.AST.Pattern, - module Language.Mimsa.Core.Types.AST.Spread, - module Language.Mimsa.Core.Types.AST.StringPart, - module Language.Mimsa.Core.Types.AST.Identifier, - ) -where - -import Language.Mimsa.Core.Types.AST.Annotation -import Language.Mimsa.Core.Types.AST.DataType -import Language.Mimsa.Core.Types.AST.Expr -import Language.Mimsa.Core.Types.AST.Identifier -import Language.Mimsa.Core.Types.AST.InfixOp -import Language.Mimsa.Core.Types.AST.Literal -import Language.Mimsa.Core.Types.AST.Operator -import Language.Mimsa.Core.Types.AST.Pattern -import Language.Mimsa.Core.Types.AST.Spread -import Language.Mimsa.Core.Types.AST.StringPart -import Language.Mimsa.Core.Types.AST.StringType diff --git a/core/src/Language/Mimsa/Core/Types/AST/Annotation.hs b/core/src/Language/Mimsa/Core/Types/AST/Annotation.hs deleted file mode 100644 index 11d56956..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Annotation.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.AST.Annotation (Annotation (..)) where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core.Printer -import Prettyprinter - --- | Source code annotations - this is stored in parsing and used to improve --- errors. Discarded when we store the expressions -data Annotation - = -- | No annotation - None () - | -- | Start and end of this item in the original source - Location {annStart :: Int, annEnd :: Int} - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance Semigroup Annotation where - Location a b <> Location a' b' = Location (min a a') (max b b') - Location a b <> None _ = Location a b - None _ <> a = a - -instance Monoid Annotation where - mempty = None () - -instance Printer Annotation where - prettyDoc (None _) = "-" - prettyDoc (Location a b) = pretty a <> " - " <> pretty b diff --git a/core/src/Language/Mimsa/Core/Types/AST/DataType.hs b/core/src/Language/Mimsa/Core/Types/AST/DataType.hs deleted file mode 100644 index 6eb35ac6..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/DataType.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.AST.DataType - ( DataType (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics (Generic) -import Language.Mimsa.Core.Printer (Printer (prettyDoc)) -import Language.Mimsa.Core.Types.Identifiers - ( Name, - TyCon, - renderName, - ) -import Language.Mimsa.Core.Types.Identifiers.TypeName -import Language.Mimsa.Core.Types.Type.MonoType -import Prettyprinter - -------- - --- | This describes a custom data type, such as `Either e a = Left e | Right a` -data DataType = DataType - { -- | The name of this type, ie `Either` - dtName :: TypeName, - -- | The type variables for the data type, ie `e`, `a` - dtVars :: [Name], - -- | map from constructor name to it's arguments, ie "`Left` -> [`e`]" or "`Right` -> [`a`]" - dtConstructors :: Map TyCon [Type ()] - } - deriving stock - ( Eq, - Ord, - Show, - Generic - ) - deriving anyclass - ( JSON.FromJSON, - JSON.ToJSON - ) - -instance Printer DataType where - prettyDoc = renderDataType - -renderDataType :: DataType -> Doc style -renderDataType (DataType tyCon vars' constructors') = - "type" - <+> prettyDoc tyCon - <> printVars vars' - <+> if M.null constructors' - then mempty - else - group $ - line - <> indent - 2 - ( align $ - vsep $ - zipWith - (<+>) - ("=" : repeat "|") - (printCons <$> M.toList constructors') - ) - where - printVars [] = mempty - printVars as = space <> sep (renderName <$> as) - printCons (consName, []) = prettyDoc consName - printCons (consName, args) = - prettyDoc consName - <> softline - <> hang - 0 - ( align $ - vsep (prettyMt <$> args) - ) - prettyMt mt = case mt of - mtApp@MTTypeApp {} -> "(" <> prettyDoc mtApp <> ")" - mtFunc@MTFunction {} -> "(" <> prettyDoc mtFunc <> ")" - other -> prettyDoc other diff --git a/core/src/Language/Mimsa/Core/Types/AST/Expr.hs b/core/src/Language/Mimsa/Core/Types/AST/Expr.hs deleted file mode 100644 index aa518cba..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Expr.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Core.Types.AST.Expr - ( Expr (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Bifunctor (first) -import Data.Bifunctor.TH -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics (Generic) -import GHC.Natural -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.Identifier -import Language.Mimsa.Core.Types.AST.Literal (Literal) -import Language.Mimsa.Core.Types.AST.Operator -import Language.Mimsa.Core.Types.AST.Pattern -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName -import Language.Mimsa.Core.Types.Type.MonoType -import Language.Mimsa.Core.Utils -import Prettyprinter - -------- - --- | --- The main expression type that we parse from syntax --- `var` is the type of variables. When we parse them they are --- string-based `Name`, but after substitution they become a `Variable` --- which is either a string or a numbered variable -data Expr var ann - = -- | a literal, such as String, Int, Boolean - MyLiteral - { expAnn :: ann, - expLit :: Literal - } - | MyAnnotation - { expAnn :: ann, - expType :: Type ann, - expExpr :: Expr var ann - } - | -- | a named variable - MyVar - { expAnn :: ann, - expModuleName :: Maybe ModuleName, - expVar :: var - } - | -- | binder, expr, body - MyLet - { expAnn :: ann, - expBinder :: Identifier var ann, - expExpr :: Expr var ann, - expBody :: Expr var ann - } - | -- | pat, expr, body - MyLetPattern - { expAnn :: ann, - expPattern :: Pattern var ann, - expExpr :: Expr var ann, - expBody :: Expr var ann - } - | -- | a `f` b - MyInfix - { expAnn :: ann, - expOperator :: Operator, - expExpr :: Expr var ann, - expBody :: Expr var ann - } - | -- | binder, body - MyLambda - { expAnn :: ann, - expBinder :: Identifier var ann, - expBody :: Expr var ann - } - | -- | function, argument - MyApp - { expAnn :: ann, - expFunc :: Expr var ann, - expArg :: Expr var ann - } - | -- | expr, thencase, elsecase - MyIf - { expAnn :: ann, - expPred :: Expr var ann, - expThen :: Expr var ann, - expElse :: Expr var ann - } - | -- | (a,b,...) - MyTuple - { expAnn :: ann, - expA :: Expr var ann, - expB :: NE.NonEmpty (Expr var ann) - } - | -- | (a,b,c).1 == a - MyTupleAccess - { expAnn :: ann, - expTuple :: Expr var ann, - expIndex :: Natural - } - | -- | { dog: MyLiteral (MyInt 1), cat: MyLiteral (MyInt 2) } - MyRecord - { expAnn :: ann, - expRecordItems :: Map Name (Expr var ann) - } - | -- | a.foo - MyRecordAccess - { expAnn :: ann, - expRecord :: Expr var ann, - expKey :: Name - } - | MyArray - { expAnn :: ann, - expArrayItems :: [Expr var ann] - } - | -- | use a constructor by name - MyConstructor - { expAnn :: ann, - expModuleName :: Maybe ModuleName, - expTyCon :: TyCon - } - | -- | expr, [(pattern, expr)] - MyPatternMatch - { expAnn :: ann, - expExpr :: Expr var ann, - expPatterns :: [(Pattern var ann, Expr var ann)] - } - | -- | name - MyTypedHole {expAnn :: ann, expTypedHoleName :: var} - deriving stock (Eq, Ord, Show, Functor, Foldable, Generic) - deriving anyclass (JSON.FromJSON, JSON.ToJSON) - -$(deriveBifunctor ''Expr) - -data InfixBit var ann - = IfStart (Expr var ann) - | IfMore Operator (Expr var ann) - deriving stock (Show) - -getInfixList :: Expr Name ann -> NE.NonEmpty (InfixBit Name ann) -getInfixList expr = case expr of - (MyInfix _ op a b) -> - let start = getInfixList a - in start <> NE.fromList [IfMore op b] - other -> NE.fromList [IfStart other] - -prettyInfixList :: NE.NonEmpty (InfixBit Name ann) -> Doc style -prettyInfixList (ifHead :| ifRest) = - let printInfixBit (IfMore op expr') = prettyDoc op <+> printSubExpr expr' - printInfixBit (IfStart expr') = printSubExpr expr' - in printInfixBit ifHead <+> align (vsep (printInfixBit <$> ifRest)) - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Int -> Doc style -> Doc style -indentMulti i doc = flatAlt (indent i doc) doc - -prettyLet :: - Identifier Name ann -> - Expr Name ann -> - Expr Name ann -> - Doc style -prettyLet var expr1 expr2 = - let (args, letExpr, maybeMt) = splitExpr expr1 - prettyVar = case maybeMt of - Just mt -> - "(" <> prettyDoc var <> ":" <+> prettyDoc mt <> ")" - Nothing -> - prettyDoc var - in group - ( "let" - <+> prettyVar - <> prettyArgs args - <+> "=" - <> line - <> indentMulti 2 (prettyDoc letExpr) - <> newlineOrIn - <> prettyDoc expr2 - ) - where - prettyArgs [] = "" - prettyArgs as = space <> hsep (prettyDoc <$> as) - - splitExpr expr = - case expr of - (MyLambda _ a rest) -> - let (as, expr', mt) = splitExpr rest - in ([a] <> as, expr', mt) - (MyAnnotation _ mt annExpr) -> - let (as, expr', _) = splitExpr annExpr - in (as, expr', Just mt) - other -> ([], other, Nothing) - -prettyLetPattern :: - Pattern Name ann -> - Expr Name ann -> - Expr Name ann -> - Doc style -prettyLetPattern pat expr body = - group - ( "let" - <+> printSubPattern pat - <+> "=" - <> line - <> indentMulti 2 (printSubExpr expr) - <> newlineOrIn - <> printSubExpr body - ) - -newlineOrIn :: Doc style -newlineOrIn = flatAlt (";" <> line <> line) " in " - -prettyTuple :: Expr Name ann -> NE.NonEmpty (Expr Name ann) -> Doc style -prettyTuple a as = - group - ( "(" - <> align - ( vsep - ( punctuate - "," - (printSubExpr <$> ([a] <> NE.toList as)) - ) - ) - <> ")" - ) - -prettyLambda :: - Identifier Name ann -> - Expr Name ann -> - Doc style -prettyLambda binder expr = - group - ( vsep - [ "\\" - <> prettyDoc binder - <+> "->", - indentMulti 2 $ - prettyDoc expr - ] - ) - -prettyRecord :: - Map Name (Expr Name ann) -> - Doc style -prettyRecord map' = - let items = M.toList map' - printRow i (name, val) = - let item = case val of - (MyVar _ _ vName) - | vName == name -> - prettyDoc name - _ -> - prettyDoc name - <> ":" - <+> printSubExpr val - in item <> if i < length items then "," else "" - in case items of - [] -> "{}" - rows -> - let prettyRows = mapWithIndex printRow rows - in group - ( "{" - <+> align - ( vsep - prettyRows - ) - <+> "}" - ) - -prettyArray :: [Expr Name ann] -> Doc style -prettyArray items = - let printRow i val = - printSubExpr val - <> if i < length items then "," else "" - in case items of - [] -> "[]" - rows -> - let prettyRows = mapWithIndex printRow rows - in group - ( "[" - <+> align - ( vsep - prettyRows - ) - <+> "]" - ) - -prettyIf :: - Expr Name ann -> - Expr Name ann -> - Expr Name ann -> - Doc style -prettyIf if' then' else' = - group - ( vsep - [ "if" - <+> wrapInfix if', - "then", - indentMulti 2 (printSubExpr then'), - "else", - indentMulti 2 (printSubExpr else') - ] - ) - -prettyPatternMatch :: - Expr Name ann -> - [(Pattern Name ann, Expr Name ann)] -> - Doc style -prettyPatternMatch sumExpr matches = - "match" - <+> printSubExpr sumExpr - <+> "with" - <+> line - <> indent - 2 - ( align $ - vsep - ( zipWith - (<+>) - (" " : repeat "|") - (printMatch <$> matches) - ) - ) - where - printMatch (construct, expr') = - printSubPattern construct - <+> "->" - <+> line - <> indentMulti 4 (printSubExpr expr') - --- just for debugging -instance (Printer var) => Printer (Expr (var, a) ann) where - prettyDoc = prettyDoc . first (mkName . prettyPrint . fst) - -instance Printer (Expr Name ann) where - prettyDoc (MyLiteral _ l) = - prettyDoc l - prettyDoc (MyAnnotation _ mt expr) = - "(" <> prettyDoc expr <+> ":" <+> prettyDoc mt <> ")" - prettyDoc (MyVar _ (Just modName) var) = - prettyDoc modName <> "." <> prettyDoc var - prettyDoc (MyVar _ Nothing var) = - prettyDoc var - prettyDoc (MyLet _ var expr1 expr2) = - prettyLet var expr1 expr2 - prettyDoc (MyLetPattern _ pat expr body) = - prettyLetPattern pat expr body - prettyDoc wholeExpr@MyInfix {} = - group (prettyInfixList (getInfixList wholeExpr)) - prettyDoc (MyLambda _ binder expr) = - prettyLambda binder expr - prettyDoc (MyApp _ func arg) = - prettyDoc func <+> wrapInfix arg - prettyDoc (MyRecordAccess _ expr name) = - prettyDoc expr <> "." <> prettyDoc name - prettyDoc (MyTupleAccess _ expr index) = - prettyDoc expr <> "." <> prettyDoc index - prettyDoc (MyIf _ if' then' else') = - prettyIf if' then' else' - prettyDoc (MyTuple _ a as) = - prettyTuple a as - prettyDoc (MyRecord _ map') = - prettyRecord map' - prettyDoc (MyArray _ items) = prettyArray items - prettyDoc (MyConstructor _ (Just modName) name) = - prettyDoc modName <> "." <> prettyDoc name - prettyDoc (MyConstructor _ Nothing name) = - prettyDoc name - prettyDoc (MyTypedHole _ name) = "?" <> prettyDoc name - prettyDoc (MyPatternMatch _ expr matches) = - prettyPatternMatch expr matches - -wrapInfix :: Expr Name ann -> Doc style -wrapInfix val = case val of - val'@MyInfix {} -> inParens val' - other -> printSubExpr other - -inParens :: Expr Name ann -> Doc style -inParens = parens . prettyDoc - --- print simple things with no brackets, and complex things inside brackets -printSubExpr :: Expr Name ann -> Doc style -printSubExpr expr = case expr of - all'@MyLet {} -> inParens all' - all'@MyLambda {} -> inParens all' - all'@MyIf {} -> inParens all' - all'@MyApp {} -> inParens all' - all'@MyTuple {} -> inParens all' - all'@MyPatternMatch {} -> inParens all' - a -> prettyDoc a diff --git a/core/src/Language/Mimsa/Core/Types/AST/Identifier.hs b/core/src/Language/Mimsa/Core/Types/AST/Identifier.hs deleted file mode 100644 index c6e06967..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Identifier.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Core.Types.AST.Identifier (Identifier (..)) where - -import qualified Data.Aeson as JSON -import Data.Bifunctor.TH -import GHC.Generics -import Language.Mimsa.Core.Printer - -data Identifier var ann = Identifier - { idAnn :: ann, - idVar :: var - } - deriving stock (Eq, Ord, Show, Functor, Foldable, Generic) - deriving anyclass (JSON.FromJSON, JSON.ToJSON) - -$(deriveBifunctor ''Identifier) - -instance (Printer var) => Printer (Identifier var ann) where - prettyDoc (Identifier _ var) = prettyDoc var diff --git a/core/src/Language/Mimsa/Core/Types/AST/InfixOp.hs b/core/src/Language/Mimsa/Core/Types/AST/InfixOp.hs deleted file mode 100644 index 84b309ac..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/InfixOp.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.AST.InfixOp where - -import qualified Data.Aeson as JSON -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core.Printer - ------------- - -newtype InfixOp = InfixOp Text - deriving newtype - ( Eq, - Ord, - Show, - JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON, - JSON.FromJSONKey - ) - -------------- - -validChars :: String -validChars = "" - -validInfixOp :: Text -> Bool -validInfixOp a = - T.length a > 1 - && T.filter (`elem` validChars) a == a - -mkInfixOp :: Text -> InfixOp -mkInfixOp a = - if validInfixOp a - then InfixOp a - else error $ T.unpack $ "InfixOp validation fail for '" <> a <> "'" - -safeMkInfixOp :: Text -> Maybe InfixOp -safeMkInfixOp a = - if validInfixOp a - then Just (InfixOp a) - else Nothing - -instance IsString InfixOp where - fromString = mkInfixOp . T.pack - -instance Printer InfixOp where - prettyPrint (InfixOp t) = t diff --git a/core/src/Language/Mimsa/Core/Types/AST/Literal.hs b/core/src/Language/Mimsa/Core/Types/AST/Literal.hs deleted file mode 100644 index c205f935..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Literal.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.AST.Literal - ( Literal (..), - ) -where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.StringType -import Prettyprinter - -------- - --- | A literal value in the source code -data Literal - = -- | an integer - MyInt {litInt :: Int} - | -- | a boolean - MyBool {litBool :: Bool} - | -- | a string - MyString {litString :: StringType} - deriving stock - ( Eq, - Ord, - Show, - Generic - ) - deriving anyclass - ( JSON.FromJSON, - JSON.ToJSON - ) - -instance Printer Literal where - prettyDoc = renderLiteral - -renderLiteral :: Literal -> Doc ann -renderLiteral (MyInt i) = pretty i -renderLiteral (MyBool True) = "True" -renderLiteral (MyBool False) = "False" -renderLiteral (MyString str) = dquotes $ prettyDoc str diff --git a/core/src/Language/Mimsa/Core/Types/AST/Operator.hs b/core/src/Language/Mimsa/Core/Types/AST/Operator.hs deleted file mode 100644 index 951f33c7..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Operator.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.AST.Operator - ( Operator (..), - ) -where - -import qualified Data.Aeson as JSON -import GHC.Generics (Generic) -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.InfixOp - -------- - --- | Infix operators -data Operator - = Equals - | Add - | Subtract - | StringConcat - | ArrayConcat - | GreaterThan - | GreaterThanOrEqualTo - | LessThan - | LessThanOrEqualTo - | Custom {opInfixOp :: InfixOp} - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (JSON.ToJSON, JSON.ToJSONKey, JSON.FromJSON) - -instance Printer Operator where - prettyDoc Equals = "==" - prettyDoc Add = "+" - prettyDoc Subtract = "-" - prettyDoc StringConcat = "++" - prettyDoc ArrayConcat = "<>" - prettyDoc GreaterThan = ">" - prettyDoc GreaterThanOrEqualTo = ">=" - prettyDoc LessThan = "<" - prettyDoc LessThanOrEqualTo = "<=" - prettyDoc (Custom infixOp) = prettyDoc infixOp diff --git a/core/src/Language/Mimsa/Core/Types/AST/Pattern.hs b/core/src/Language/Mimsa/Core/Types/AST/Pattern.hs deleted file mode 100644 index d503fd6f..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Pattern.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Mimsa.Core.Types.AST.Pattern - ( Pattern (..), - printSubPattern, - getPatternAnnotation, - ) -where - -import qualified Data.Aeson as JSON -import Data.Bifunctor.TH -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.Literal -import Language.Mimsa.Core.Types.AST.Spread -import Language.Mimsa.Core.Types.AST.StringPart -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName -import Language.Mimsa.Core.Utils -import Prettyprinter - -data Pattern var ann - = PWildcard - { patAnn :: ann - } - | PVar - { patAnn :: ann, - patVar :: var - } - | PLit - { patAnn :: ann, - patLiteral :: Literal - } - | PConstructor - { patAnn :: ann, - patModuleName :: Maybe ModuleName, - patTyCon :: TyCon, - patMatches :: [Pattern var ann] - } - | PTuple - { patAnn :: ann, - patA :: Pattern var ann, - patAs :: NE.NonEmpty (Pattern var ann) - } - | PRecord - { patAnn :: ann, - patMap :: - Map Name (Pattern var ann) - } - | PArray - { patAnn :: ann, - patArray :: [Pattern var ann], - patSpread :: Spread var ann - } - | PString - { patAnn :: ann, - patHead :: StringPart var ann, - patTail :: StringPart var ann - } - deriving stock (Show, Eq, Ord, Functor, Foldable, Generic) - deriving anyclass (JSON.FromJSON, JSON.ToJSON) - -$(deriveBifunctor ''Map) -$(deriveBifunctor ''Pattern) - -getPatternAnnotation :: Pattern var ann -> ann -getPatternAnnotation (PWildcard ann) = ann -getPatternAnnotation (PVar ann _) = ann -getPatternAnnotation (PLit ann _) = ann -getPatternAnnotation (PConstructor ann _ _ _) = ann -getPatternAnnotation (PTuple ann _ _) = ann -getPatternAnnotation (PRecord ann _) = ann -getPatternAnnotation (PArray ann _ _) = ann -getPatternAnnotation (PString ann _ _) = ann - -inParens :: (Printer a) => a -> Doc style -inParens = parens . prettyDoc - --- print simple things with no brackets, and complex things inside brackets -printSubPattern :: Pattern Name ann -> Doc style -printSubPattern pat = case pat of - all'@PConstructor {} -> inParens all' - a -> prettyDoc a - -instance Printer (Pattern Name ann) where - prettyDoc (PWildcard _) = "_" - prettyDoc (PVar _ a) = prettyDoc a - prettyDoc (PLit _ lit) = prettyDoc lit - prettyDoc (PConstructor _ modName tyCon args) = - let prettyArgs = case args of - [] -> mempty - _ -> foldr (\a b -> " " <> a <> b) mempty (printSubPattern <$> args) - prettyNamespace = case modName of - Just m -> prettyDoc m <> "." - _ -> mempty - in prettyNamespace <> prettyDoc tyCon <> prettyArgs - prettyDoc (PTuple _ a as) = - "(" <> hsep (punctuate "," (prettyDoc <$> ([a] <> NE.toList as))) <> ")" - prettyDoc (PArray _ as spread) = - "[" <> concatWith (\a b -> a <> ", " <> b) (prettyDoc <$> as) <> prettyDoc spread <> "]" - prettyDoc (PRecord _ map') = - let items = M.toList map' - printRow i (name, val) = - let item = case val of - (PVar _ vName) | vName == name -> prettyDoc name - _ -> - prettyDoc name - <> ":" - <+> printSubPattern val - in item <> if i < length items then "," else "" - in case items of - [] -> "{}" - rows -> - let prettyRows = mapWithIndex printRow rows - in group - ( "{" - <+> align - ( vsep - prettyRows - ) - <+> "}" - ) - prettyDoc (PString _ a as) = - prettyDoc a <> " ++ " <> prettyDoc as diff --git a/core/src/Language/Mimsa/Core/Types/AST/Spread.hs b/core/src/Language/Mimsa/Core/Types/AST/Spread.hs deleted file mode 100644 index 133dfc83..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/Spread.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Core.Types.AST.Spread - ( Spread (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Bifunctor.TH -import GHC.Generics -import Language.Mimsa.Core.Printer - -data Spread var ann - = NoSpread - | SpreadWildcard - { sprAnn :: ann - } - | SpreadValue - { sprAnn :: ann, - sprVar :: var - } - deriving stock - ( Show, - Eq, - Ord, - Functor, - Foldable, - Generic - ) - deriving anyclass - ( JSON.FromJSON, - JSON.ToJSON - ) - -$(deriveBifunctor ''Spread) - -instance (Printer var, Show var) => Printer (Spread var ann) where - prettyDoc NoSpread = "" - prettyDoc (SpreadWildcard _) = ", ..." - prettyDoc (SpreadValue _ a) = ", ..." <> prettyDoc a diff --git a/core/src/Language/Mimsa/Core/Types/AST/StringPart.hs b/core/src/Language/Mimsa/Core/Types/AST/StringPart.hs deleted file mode 100644 index 33e446c3..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/StringPart.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Mimsa.Core.Types.AST.StringPart - ( StringPart (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Bifunctor.TH -import GHC.Generics -import Language.Mimsa.Core.Printer - -data StringPart var ann - = StrWildcard - { stpAnn :: ann - } - | StrValue - { stpAnn :: ann, - stpVar :: var - } - deriving stock (Show, Eq, Ord, Functor, Foldable, Generic) - deriving anyclass (JSON.FromJSON, JSON.ToJSON) - -$(deriveBifunctor ''StringPart) - -instance (Printer var) => Printer (StringPart var ann) where - prettyDoc (StrWildcard _) = "_" - prettyDoc (StrValue _ a) = prettyDoc a diff --git a/core/src/Language/Mimsa/Core/Types/AST/StringType.hs b/core/src/Language/Mimsa/Core/Types/AST/StringType.hs deleted file mode 100644 index d3f117a5..00000000 --- a/core/src/Language/Mimsa/Core/Types/AST/StringType.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Core.Types.AST.StringType - ( StringType (..), - stringLength, - stringSplit, - ) -where - -import qualified Data.Aeson as JSON -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Prettyprinter - --- | --- Type for our strings, that removes a number of characters that make --- parsing complicated. --- This should probably be revisited at some point -newtype StringType = StringType Text - deriving newtype (Eq, Ord, Show, JSON.FromJSON, JSON.ToJSON) - deriving stock (Generic) - -instance IsString StringType where - fromString = StringType . T.pack - -instance Printer StringType where - prettyDoc = renderStringType - -renderStringType :: StringType -> Doc ann -renderStringType (StringType s) = pretty s - -stringLength :: StringType -> Int -stringLength (StringType s) = T.length s - --- if there is string, return (head, tail) -stringSplit :: StringType -> Maybe (StringType, StringType) -stringSplit st@(StringType s) = - if stringLength st == 0 - then Nothing - else - Just - ( StringType (T.singleton (T.head s)), - StringType (T.tail s) - ) diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers.hs b/core/src/Language/Mimsa/Core/Types/Identifiers.hs deleted file mode 100644 index 37d94bf4..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Language.Mimsa.Core.Types.Identifiers - ( module Language.Mimsa.Core.Types.Identifiers.TyCon, - module Language.Mimsa.Core.Types.Identifiers.Name, - module Language.Mimsa.Core.Types.Identifiers.TypeIdentifier, - module Language.Mimsa.Core.Types.Identifiers.TyVar, - module Language.Mimsa.Core.Types.Identifiers.TypeName, - module Language.Mimsa.Core.Types.Identifiers.TestName, - ) -where - -import Language.Mimsa.Core.Types.Identifiers.Name -import Language.Mimsa.Core.Types.Identifiers.TestName -import Language.Mimsa.Core.Types.Identifiers.TyCon -import Language.Mimsa.Core.Types.Identifiers.TyVar -import Language.Mimsa.Core.Types.Identifiers.TypeIdentifier -import Language.Mimsa.Core.Types.Identifiers.TypeName diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/Name.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/Name.hs deleted file mode 100644 index 28570fa3..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/Name.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Identifiers.Name where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.OpenApi -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Prettyprinter - -renderName :: Name -> Doc ann -renderName = pretty . getName - --- | A name is an identifier that starts with a lowercase --- letter used for functions and values. Examples are --- `dog`, `cat` but not `Bat`. -newtype Name = Name {getName' :: Text} - deriving newtype (ToSchema, ToParamSchema) - deriving stock (Eq, Ord, Generic) - deriving newtype - ( Show, - JSON.FromJSONKey, - JSON.ToJSONKey, - JSON.ToJSON, - Semigroup, - Monoid - ) - -instance JSON.FromJSON Name where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkName txt of - Just name' -> pure name' - _ -> fail "Text is not a valid name" - -instance IsString Name where - fromString = mkName . T.pack - -getName :: Name -> Text -getName (Name t) = t - -validName :: Text -> Bool -validName a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isLower (T.head a) - -mkName :: Text -> Name -mkName a = - if validName a - then Name a - else error $ T.unpack $ "Name validation fail for '" <> a <> "'" - -safeMkName :: Text -> Maybe Name -safeMkName a = - if validName a - then Just (Name a) - else Nothing - -instance Printer Name where - prettyDoc = renderName diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/TestName.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/TestName.hs deleted file mode 100644 index 24eceda1..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/TestName.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Language.Mimsa.Core.Types.Identifiers.TestName - ( TestName (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import Data.Text (Text) -import Language.Mimsa.Core.Printer - -newtype TestName = TestName Text - deriving newtype - ( Eq, - Ord, - Show, - JSON.ToJSON, - JSON.FromJSON, - ToSchema - ) - -instance Printer TestName where - prettyPrint (TestName n) = n diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/TyCon.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/TyCon.hs deleted file mode 100644 index 7044fe40..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/TyCon.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Identifiers.TyCon where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.OpenApi -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.Identifiers.Name -import Prettyprinter - --- | A TyCon is a Type Constructor like `Just` or `Right`. --- It must start with a capital letter. -newtype TyCon = TyCon Text - deriving stock (Generic, Ord) - deriving newtype - ( Eq, - Show, - ToSchema, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey, - Semigroup, - Monoid - ) - -instance JSON.FromJSON TyCon where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkTyCon txt of - Just tyCon' -> pure tyCon' - _ -> fail "Text is not a valid TyCon" - -instance IsString TyCon where - fromString = mkTyCon . T.pack - -getTyCon :: TyCon -> Text -getTyCon (TyCon t) = t - -validTyCon :: Text -> Bool -validTyCon a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkTyCon :: Text -> TyCon -mkTyCon a = - if validTyCon a - then TyCon a - else error $ T.unpack $ "TyCon validation fail for '" <> a <> "'" - -safeMkTyCon :: Text -> Maybe TyCon -safeMkTyCon a = - if validTyCon a - then Just (TyCon a) - else Nothing - -instance Printer TyCon where - prettyDoc = pretty . getTyCon - -tyConToName :: TyCon -> Name -tyConToName (TyCon tc) = mkName (tHead <> T.tail tc) - where - tHead = T.pack . pure . Ch.toLower . T.head $ tc diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/TyVar.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/TyVar.hs deleted file mode 100644 index ff2bef1f..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/TyVar.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Identifiers.TyVar - ( TyVar (..), - renderTyVar, - mkTyVar, - safeMkTyVar, - ) -where - --- a TyVar is the string token for any unknown type - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Prettyprinter - -renderTyVar :: TyVar -> Doc ann -renderTyVar = pretty . getTyVar - -newtype TyVar = TyVar {getTyVar' :: Text} - deriving stock (Generic) - deriving newtype - ( Eq, - Ord, - Show, - JSON.FromJSON, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance IsString TyVar where - fromString = mkTyVar . T.pack - -getTyVar :: TyVar -> Text -getTyVar (TyVar t) = t - --- a valid TyVar is non-empty, only consists of letters and numbers, and starts --- with a letter -validTyVar :: Text -> Bool -validTyVar a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isLower (T.head a) - -mkTyVar :: Text -> TyVar -mkTyVar a = - if validTyVar a - then TyVar a - else error $ T.unpack $ "TyVar validation fail for '" <> a <> "'" - -safeMkTyVar :: Text -> Maybe TyVar -safeMkTyVar a = - if validTyVar a - then Just (TyVar a) - else Nothing - -instance Printer TyVar where - prettyDoc = renderTyVar diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/TypeIdentifier.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/TypeIdentifier.hs deleted file mode 100644 index 1e351408..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/TypeIdentifier.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Identifiers.TypeIdentifier - ( TypeIdentifier (..), - renderTypeIdentifier, - printTypeNum, - getUniVar, - ) -where - --- the two types of id a type var can have - a named or numbered one - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.Identifiers.Name -import Language.Mimsa.Core.Types.Identifiers.TyVar -import Prettyprinter - -data TypeIdentifier - = TVName -- a type variable from a type signature - { tiVar :: TyVar - } - | TVUnificationVar -- invented type for unification - { tiUniVar :: Int - } - | TVScopedVar -- named variable with unique int to allow scoping - { tiUniVar :: Int, - tvName :: Name - } - deriving stock - ( Eq, - Ord, - Show, - Generic - ) - deriving anyclass - ( JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON - ) - -instance Printer TypeIdentifier where - prettyDoc = renderTypeIdentifier - -printTypeNum :: Int -> String -printTypeNum i = [toEnum (index + start)] <> suffix - where - index = (i - 1) `mod` 26 - start = fromEnum 'a' - suffix = - let diff = (i - 1) `div` 26 - in if diff < 1 then "" else show diff - -renderTypeIdentifier :: TypeIdentifier -> Doc ann -renderTypeIdentifier (TVName n) = renderTyVar n -renderTypeIdentifier (TVUnificationVar i) = pretty (printTypeNum i) -renderTypeIdentifier (TVScopedVar i _) = pretty (printTypeNum i) - -getUniVar :: TypeIdentifier -> Maybe Int -getUniVar (TVName _) = Nothing -getUniVar (TVUnificationVar i) = Just i -getUniVar (TVScopedVar i _) = Just i diff --git a/core/src/Language/Mimsa/Core/Types/Identifiers/TypeName.hs b/core/src/Language/Mimsa/Core/Types/Identifiers/TypeName.hs deleted file mode 100644 index 6a06cc53..00000000 --- a/core/src/Language/Mimsa/Core/Types/Identifiers/TypeName.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Identifiers.TypeName - ( TypeName (..), - getTypeName, - validTypeName, - safeMkTypeName, - typeNameToName, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.OpenApi -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.Identifiers.Name -import Prettyprinter - --- | A TypeName is like `Either` or `Maybe`. --- It must start with a capital letter. -newtype TypeName = TypeName Text - deriving stock (Generic) - deriving newtype - ( Show, - Eq, - Ord, - ToSchema, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance JSON.FromJSON TypeName where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkTypeName txt of - Just tyCon' -> pure tyCon' - _ -> fail "Text is not a valid TypeName" - -instance IsString TypeName where - fromString = mkTypeName . T.pack - -getTypeName :: TypeName -> Text -getTypeName (TypeName t) = t - -validTypeName :: Text -> Bool -validTypeName a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkTypeName :: Text -> TypeName -mkTypeName a = - if validTypeName a - then TypeName a - else error $ T.unpack $ "TypeName validation fail for '" <> a <> "'" - -safeMkTypeName :: Text -> Maybe TypeName -safeMkTypeName a = - if validTypeName a - then Just (TypeName a) - else Nothing - -instance Printer TypeName where - prettyDoc = pretty . getTypeName - -typeNameToName :: TypeName -> Name -typeNameToName (TypeName tn) = mkName (tHead <> T.tail tn) - where - tHead = T.pack . pure . Ch.toLower . T.head $ tn diff --git a/core/src/Language/Mimsa/Core/Types/Module.hs b/core/src/Language/Mimsa/Core/Types/Module.hs deleted file mode 100644 index c2647249..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Language.Mimsa.Core.Types.Module - ( module Language.Mimsa.Core.Types.Module.Entity, - module Language.Mimsa.Core.Types.Module.Module, - module Language.Mimsa.Core.Types.Module.ModuleName, - module Language.Mimsa.Core.Types.Module.ModuleHash, - module Language.Mimsa.Core.Types.Module.DefIdentifier, - ) -where - -import Language.Mimsa.Core.Types.Module.DefIdentifier -import Language.Mimsa.Core.Types.Module.Entity -import Language.Mimsa.Core.Types.Module.Module -import Language.Mimsa.Core.Types.Module.ModuleHash -import Language.Mimsa.Core.Types.Module.ModuleName diff --git a/core/src/Language/Mimsa/Core/Types/Module/DefIdentifier.hs b/core/src/Language/Mimsa/Core/Types/Module/DefIdentifier.hs deleted file mode 100644 index f631f19d..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module/DefIdentifier.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Module.DefIdentifier - ( DefIdentifier (..), - ) -where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.InfixOp -import Language.Mimsa.Core.Types.Identifiers - --- | different kinds of top-level definitions -data DefIdentifier - = DIName Name - | DIInfix InfixOp - | DIType TypeName - | DITest TestName - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass - ( JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON, - JSON.FromJSONKey - ) - -instance Printer DefIdentifier where - prettyPrint (DIName name) = prettyPrint name - prettyPrint (DIInfix infixOp) = prettyPrint infixOp - prettyPrint (DIType typeName) = prettyPrint typeName - prettyPrint (DITest testName) = "\"" <> prettyPrint testName <> "\"" diff --git a/core/src/Language/Mimsa/Core/Types/Module/Entity.hs b/core/src/Language/Mimsa/Core/Types/Module/Entity.hs deleted file mode 100644 index a79f9f2a..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module/Entity.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Module.Entity where - --- a thing --- terrible, pls improve -import qualified Data.Aeson as JSON -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.InfixOp -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName - -data Entity - = -- | a variable, `dog` - EName Name - | -- | an infix operator, `<|>` - EInfix InfixOp - | -- | a namespaced var, `Prelude.id` - ENamespacedName ModuleName Name - | -- | a typename, `Maybe` - EType TypeName - | -- | a namespaced typename, `Prelude.Either` - ENamespacedType ModuleName TypeName - | -- | a constructor, `Just` - EConstructor TyCon - | -- \| a namespaced constructor, `Maybe.Just` - ENamespacedConstructor ModuleName TyCon - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass - ( JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON, - JSON.FromJSONKey - ) - -instance Printer Entity where - prettyPrint (EName name) = prettyPrint name - prettyPrint (EInfix infixOp) = prettyPrint infixOp - prettyPrint (ENamespacedName modName name) = - prettyPrint modName <> "." <> prettyPrint name - prettyPrint (EType typeName) = prettyPrint typeName - prettyPrint (ENamespacedType modName typeName) = - prettyPrint modName <> "." <> prettyPrint typeName - prettyPrint (EConstructor tyCon) = - prettyPrint tyCon - prettyPrint (ENamespacedConstructor modName tyCon) = - prettyPrint modName <> "." <> prettyPrint tyCon diff --git a/core/src/Language/Mimsa/Core/Types/Module/Module.hs b/core/src/Language/Mimsa/Core/Types/Module/Module.hs deleted file mode 100644 index 3d9cae4a..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module/Module.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Module.Module - ( Module (..), - DefPart (..), - ModuleItem (..), - Import (..), - ) -where - -import qualified Data.Aeson as JSON -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.DataType -import Language.Mimsa.Core.Types.AST.Expr -import Language.Mimsa.Core.Types.AST.Identifier -import Language.Mimsa.Core.Types.AST.InfixOp -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.DefIdentifier -import Language.Mimsa.Core.Types.Module.ModuleHash -import Language.Mimsa.Core.Types.Module.ModuleName -import Language.Mimsa.Core.Types.Type.MonoType -import Prettyprinter - --- a module is, broadly, one file --- it defines some datatypes, infixes and definitions --- and it probably exports one or more of those - -data DefPart ann - = -- | typeless argument `a` - DefArg (Identifier Name ann) - | -- | argument with type `(a: String) ->` - DefTypedArg (Identifier Name ann) (Type ann) - | -- | type with no binding `String` - DefType (Type ann) - deriving stock (Eq, Ord, Show, Functor) - --- item parsed from file, kept like this so we can order them and have --- duplicates --- we will remove duplicates when we work out dependencies between everything --- TODO: add more annotations to everything so we can produce clearer errors --- when things don't make sense (duplicate defs etc) -data ModuleItem ann - = ModuleExpression Name [DefPart ann] (Expr Name ann) - | ModuleDataType DataType - | ModuleExport (ModuleItem ann) - | ModuleImport Import - | ModuleInfix InfixOp (Expr Name ann) - | ModuleTest TestName (Expr Name ann) - deriving stock (Functor) - --- going to want way more granularity here in future but _shrug_ -data Import - = ImportAllFromHash ModuleHash - | ImportNamedFromHash ModuleHash ModuleName - --- this is the checked module, it contains no duplicates and we don't care --- about ordering -data Module ann = Module - { moExpressions :: Map DefIdentifier (Expr Name ann), - moExpressionExports :: Set DefIdentifier, - moExpressionImports :: Map DefIdentifier ModuleHash, -- what we imported, where it's from - moDataTypes :: Map TypeName DataType, - moDataTypeExports :: Set TypeName, -- which types to export - moDataTypeImports :: Map TypeName ModuleHash, -- what we imported, where its from, - moNamedImports :: Map ModuleName ModuleHash -- `import sdfsdf as Prelude`.. - } - deriving stock (Eq, Ord, Show, Functor, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -instance (Show ann) => Printer (Module ann) where - prettyDoc mod' = - let printedDefs = - uncurry (printDefinition mod') - <$> M.toList (moExpressions mod') - printedTypes = - uncurry (printTypeDef mod') - <$> M.toList (moDataTypes mod') - printedImports = - printImport - <$> uniq - ( M.elems (moDataTypeImports mod') - <> M.elems (moExpressionImports mod') - ) - printedNamedImports = - printNamedImport <$> M.toList (moNamedImports mod') - in withDoubleLines - ( printedImports - <> printedTypes - <> printedDefs - <> printedNamedImports - ) - -withDoubleLines :: [Doc a] -> Doc a -withDoubleLines = vsep . fmap (line <>) - -uniq :: (Ord a) => [a] -> [a] -uniq = S.toList . S.fromList - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Int -> Doc style -> Doc style -indentMulti i doc = flatAlt (indent i doc) doc - -printNamedImport :: (ModuleName, ModuleHash) -> Doc a -printNamedImport (modName, modHash) = - "import" <+> prettyDoc modName <+> "from" <+> prettyDoc modHash - -printImport :: ModuleHash -> Doc a -printImport modHash = - "import * from" <+> prettyDoc modHash - -printTypeDef :: Module ann -> TypeName -> DataType -> Doc a -printTypeDef mod' tn dt = - let prettyExp = - if S.member tn (moDataTypeExports mod') - then "export " - else "" - in prettyExp <> prettyDoc dt - --- given annotation and expr, pair annotation types with lambdas -printPaired :: Type ann -> Expr Name ann -> Doc a -printPaired (MTFunction _ fn arg) (MyLambda _ ident body) = - "(" - <> prettyDoc ident - <+> ":" - <+> prettyDoc fn - <> ")" - <> line - <> printPaired arg body -printPaired mt expr = - ":" - <+> prettyDoc mt - <+> "=" - <> line - <> indentMulti 2 (prettyDoc expr) - -printDefinition :: Module ann -> DefIdentifier -> Expr Name ann -> Doc a -printDefinition mod' def expr = - let prettyExp = - if S.member def (moExpressionExports mod') - then "export " - else "" - in prettyExp <> case def of - DIName name -> case expr of - (MyAnnotation _ mt rest) -> - "def" - <+> prettyDoc name - <> line - <> indentMulti 2 (printPaired mt rest) - other -> - "def" - <+> prettyDoc name - <+> "=" - <> line - <> indentMulti 2 (prettyDoc other) - DIInfix infixOp -> - "infix" <+> prettyDoc infixOp <+> "=" <+> prettyDoc expr - DIType _ -> error "printDefinition is printing type oh no" - DITest testName -> - "test" <+> "\"" <> prettyDoc testName <> "\"" <+> "=" <+> prettyDoc expr - -instance Semigroup (Module ann) where - (Module a b c d e f g) <> (Module a' b' c' d' e' f' g') = - Module (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') (f <> f') (g <> g') - -instance Monoid (Module ann) where - mempty = - Module - mempty - mempty - mempty - mempty - mempty - mempty - mempty diff --git a/core/src/Language/Mimsa/Core/Types/Module/ModuleHash.hs b/core/src/Language/Mimsa/Core/Types/Module/ModuleHash.hs deleted file mode 100644 index 0cdfc1f3..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module/ModuleHash.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Mimsa.Core.Types.Module.ModuleHash where - -import qualified Data.Aeson as JSON -import Data.OpenApi -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer - --- because of the size of the ints --- and JS's limitations in the browser --- we JSON encode these as strings -newtype ModuleHash = ModuleHash Text - deriving stock (Eq, Ord, Generic) - deriving newtype (ToParamSchema, ToSchema) - deriving newtype - ( JSON.FromJSON, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance Show ModuleHash where - show (ModuleHash a) = T.unpack a - -instance Printer ModuleHash where - prettyPrint (ModuleHash a) = a diff --git a/core/src/Language/Mimsa/Core/Types/Module/ModuleName.hs b/core/src/Language/Mimsa/Core/Types/Module/ModuleName.hs deleted file mode 100644 index 50300715..00000000 --- a/core/src/Language/Mimsa/Core/Types/Module/ModuleName.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Module.ModuleName - ( ModuleName (..), - getModuleName, - validModuleName, - safeMkModuleName, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.OpenApi -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Language.Mimsa.Core.Printer -import Prettyprinter - --- | A ModuleName is like `Either` or `Maybe`. --- It must start with a capital letter. -newtype ModuleName = ModuleName Text - deriving newtype (ToSchema) - deriving stock (Eq, Ord, Generic) - deriving newtype - ( Show, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance JSON.FromJSON ModuleName where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkModuleName txt of - Just tyCon' -> pure tyCon' - _ -> fail "Text is not a valid ModuleName" - -instance IsString ModuleName where - fromString = mkModuleName . T.pack - -getModuleName :: ModuleName -> Text -getModuleName (ModuleName t) = t - -validModuleName :: Text -> Bool -validModuleName a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkModuleName :: Text -> ModuleName -mkModuleName a = - if validModuleName a - then ModuleName a - else error $ T.unpack $ "ModuleName validation fail for '" <> a <> "'" - -safeMkModuleName :: Text -> Maybe ModuleName -safeMkModuleName a = - if validModuleName a - then Just (ModuleName a) - else Nothing - -instance Printer ModuleName where - prettyDoc = pretty . getModuleName diff --git a/core/src/Language/Mimsa/Core/Types/Type.hs b/core/src/Language/Mimsa/Core/Types/Type.hs deleted file mode 100644 index 336fdc5e..00000000 --- a/core/src/Language/Mimsa/Core/Types/Type.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.Mimsa.Core.Types.Type - ( module Language.Mimsa.Core.Types.Type.MonoType, - ) -where - -import Language.Mimsa.Core.Types.Type.MonoType diff --git a/core/src/Language/Mimsa/Core/Types/Type/MonoType.hs b/core/src/Language/Mimsa/Core/Types/Type/MonoType.hs deleted file mode 100644 index 8990bda9..00000000 --- a/core/src/Language/Mimsa/Core/Types/Type/MonoType.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Mimsa.Core.Types.Type.MonoType - ( MonoType, - Type (..), - Primitive (..), - getAnnotationForType, - varsFromDataType, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics -import Language.Mimsa.Core.Printer -import Language.Mimsa.Core.Types.AST.Annotation -import Language.Mimsa.Core.Types.Identifiers -import Language.Mimsa.Core.Types.Module.ModuleName -import Prettyprinter - -data Primitive - = MTInt - | MTString - | MTBool - deriving stock - ( Eq, - Ord, - Show, - Generic - ) - deriving anyclass - ( JSON.ToJSON, - JSON.FromJSON - ) - -instance Printer Primitive where - prettyDoc MTInt = "Int" - prettyDoc MTString = "String" - prettyDoc MTBool = "Boolean" - -type MonoType = Type Annotation - -data Type ann - = MTPrim - { typAnn :: ann, - typPrim :: Primitive - } - | MTVar - { typAnn :: ann, - typIdent :: TypeIdentifier - } - | MTFunction - { typAnn :: ann, - typArg :: Type ann, - typRes :: Type ann -- argument, result - } - | MTTuple - { typAnn :: ann, - typA :: Type ann, - typAs :: NE.NonEmpty (Type ann) -- (a,b,---) - } - | MTRecord - { typAnn :: ann, - typRecordItems :: Map Name (Type ann), -- { foo: a, bar: b | rest } - typRest :: Maybe (Type ann) - } - | MTArray - { typAnn :: ann, - typArrayItems :: Type ann -- [a] - } - | MTConstructor - { typAnn :: ann, - typModuleName :: Maybe ModuleName, - typTypeName :: TypeName -- name - } - | MTTypeApp - { typAnn :: ann, - typFunc :: Type ann, - typArg :: Type ann -- func arg, apply arg to func - } - | MTGlobals - { typAnn :: ann, - typGlobals :: Map Name (Type ann), - typRest :: Maybe (Type ann), - typInner :: Type ann - } - deriving stock (Eq, Ord, Show, Functor, Foldable, Generic) - deriving anyclass (JSON.ToJSON, JSON.FromJSON) - -getAnnotationForType :: Type ann -> ann -getAnnotationForType (MTPrim ann _) = ann -getAnnotationForType (MTVar ann _) = ann -getAnnotationForType (MTFunction ann _ _) = ann -getAnnotationForType (MTTuple ann _ _) = ann -getAnnotationForType (MTRecord ann _ _) = ann -getAnnotationForType (MTConstructor ann _ _) = ann -getAnnotationForType (MTArray ann _) = ann -getAnnotationForType (MTTypeApp ann _ _) = ann -getAnnotationForType (MTGlobals ann _ _ _) = ann - -instance Printer (Type ann) where - prettyDoc = renderMonoType - -renderMonoType :: Type ann -> Doc style -renderMonoType (MTPrim _ a) = prettyDoc a -renderMonoType (MTFunction _ a b) = - withParens a <+> "->" <+> renderMonoType b -renderMonoType (MTTuple _ a as) = - "(" <> hsep (punctuate ", " (renderMonoType <$> ([a] <> NE.toList as))) <> ")" -renderMonoType (MTRecord _ as rest) = - renderRecord as rest -renderMonoType (MTArray _ a) = "[" <+> renderMonoType a <+> "]" -renderMonoType (MTVar _ a) = renderTypeIdentifier a -renderMonoType (MTConstructor _ (Just modName) tyCon) = - prettyDoc modName <> "." <> prettyDoc tyCon -renderMonoType (MTConstructor _ Nothing tyCon) = - prettyDoc tyCon -renderMonoType mt@(MTTypeApp _ func arg) = - case varsFromDataType mt of - Just (modName, tyCon, vars) -> - let typeName = case modName of - Just mName -> prettyDoc mName <> "." <> prettyDoc tyCon - _ -> prettyDoc tyCon - in align $ sep ([typeName] <> (withParens <$> vars)) - Nothing -> - align $ sep [renderMonoType func, renderMonoType arg] -renderMonoType (MTGlobals _ parts rest expr) = - renderRecord parts rest <> " => " <> renderMonoType expr - -renderRecord :: Map Name (Type ann) -> Maybe (Type ann) -> Doc style -renderRecord as Nothing = - group $ - "{" - <> nest - 2 - ( line - <> mconcat - ( punctuate - ("," <> line) - ( renderItem - <$> M.toList as - ) - ) - ) - <> line - <> "}" - where - renderItem (Name k, v) = pretty k <> ":" <+> withParens v -renderRecord as (Just rest) = - group $ - "{" - <> nest - 2 - ( line - <> mconcat - ( punctuate - ("," <> line) - ( renderItem - <$> M.toList as - ) - ) - ) - <> line - <> "|" - <> space - <> renderMonoType rest - <> space - <> "}" - where - renderItem (Name k, v) = pretty k <> ":" <+> withParens v - --- turn nested shit back into something easy to pretty print (ie, easy to --- bracket) -varsFromDataType :: Type ann -> Maybe (Maybe ModuleName, TypeName, [Type ann]) -varsFromDataType mt = - let getInner mt' = - case mt' of - (MTConstructor _ modName tyCon) -> - Just (modName, tyCon, mempty) - (MTTypeApp _ f a) -> - ( \(modName, tyCon, vars) -> - (modName, tyCon, vars <> [a]) - ) - <$> getInner f - _ -> Nothing - in getInner mt - -withParens :: Type ann -> Doc a -withParens ma@MTFunction {} = parens (renderMonoType ma) -withParens mta@MTTypeApp {} = parens (renderMonoType mta) -withParens other = renderMonoType other diff --git a/core/src/Language/Mimsa/Core/Utils.hs b/core/src/Language/Mimsa/Core/Utils.hs deleted file mode 100644 index 033ebc49..00000000 --- a/core/src/Language/Mimsa/Core/Utils.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Language.Mimsa.Core.Utils (mapWithIndex, setMapMaybe, mapKeys, filterMapKeys, addNumbersToMap) where - -import Data.Bifunctor -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S - --- I give in, it is time to throw all these things in a file - -mapWithIndex :: (Int -> a -> b) -> [a] -> [b] -mapWithIndex f as = - uncurry f <$> zip [1 ..] as - -setMapMaybe :: (Ord b) => (a -> Maybe b) -> Set a -> Set b -setMapMaybe f = S.fromList . mapMaybe f . S.toList - -mapKeys :: (Ord k2) => (k1 -> k2) -> Map k1 a -> Map k2 a -mapKeys f = M.fromList . fmap (first f) . M.toList - --- useful to break apart maps where --- key is a sum type -filterMapKeys :: (Ord k2) => (k -> Maybe k2) -> Map k a -> Map k2 a -filterMapKeys f = - M.fromList . mapMaybe (\(k, a) -> (,) <$> f k <*> pure a) . M.toList - -addNumbersToMap :: (Ord k) => Map k a -> Map k (Int, a) -addNumbersToMap = - M.fromList - . fmap (\(i, (k, a)) -> (k, (i, a))) - . zip [0 ..] - . M.toList diff --git a/core/test/CoreTest/Parser/DataTypes.hs b/core/test/CoreTest/Parser/DataTypes.hs deleted file mode 100644 index 8874dba1..00000000 --- a/core/test/CoreTest/Parser/DataTypes.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Parser.DataTypes - ( spec, - ) -where - -import CoreTest.Utils.Helpers -import Data.Either (isRight) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import Language.Mimsa.Core -import Test.Hspec -import Text.Megaparsec - --- specialisation of parseExpr -testParse :: Text -> Either String DataType -testParse t = case parseTypeDecl t of - Right expr -> pure expr - Left e -> Left $ errorBundlePretty e - -spec :: Spec -spec = parallel $ do - describe "DataTypes" $ do - it "Parses Void" $ - testParse "type Void" - `shouldBe` Right - ( DataType - "Void" - mempty - mempty - ) - - it "Parses an absolute unit" $ - testParse "type AbsoluteUnit = AbsoluteUnit" - `shouldBe` Right - ( DataType - "AbsoluteUnit" - mempty - (M.singleton "AbsoluteUnit" mempty) - ) - it "Parses an absolute unit with type var" $ - testParse "type Arr a = Item a" - `shouldBe` Right - ( DataType - "Arr" - ["a"] - ( M.fromList - [ ( "Item", - [MTVar mempty (tvNamed "a")] - ) - ] - ) - ) - - it "Parses an absolute unit with type var" $ - testParse "type Arr a = Empty\n | Item a" - `shouldBe` Right - ( DataType - "Arr" - ["a"] - ( M.fromList - [ ("Empty", mempty), - ( "Item", - [MTVar mempty (tvNamed "a")] - ) - ] - ) - ) - - it "Parses a single constructor with one arg" $ - testParse "type Dog = Dog String" - `shouldBe` Right - ( DataType - "Dog" - mempty - ( M.singleton - "Dog" - [MTPrim mempty MTString] - ) - ) - - it "Parses a french boolean" $ - testParse "type LeBool = Vrai | Faux" - `shouldBe` Right - ( DataType - "LeBool" - mempty - ( M.fromList - [ ("Vrai", []), - ("Faux", []) - ] - ) - ) - - it "Parses a peano number data declaration" $ - testParse "type Nat = Zero | Succ Nat" - `shouldBe` Right - ( DataType - "Nat" - mempty - ( M.fromList - [ ("Zero", []), - ("Succ", [dataTypeWithVars mempty Nothing "Nat" mempty]) - ] - ) - ) - - it "Parses a type declaration with variable" $ - testParse "type Maybe a = Just a | Nothing" - `shouldBe` Right - ( DataType - "Maybe" - ["a"] - ( M.fromList - [ ("Just", [MTVar mempty (tvNamed "a")]), - ("Nothing", []) - ] - ) - ) - - it "Parses a type declaration with a function as arg" $ - testParse "type Reader r a = Reader (r -> a)" - `shouldBe` Right - ( DataType - "Reader" - ["r", "a"] - ( M.fromList - [ ( "Reader", - [ MTFunction - mempty - (MTVar mempty (tvNamed "r")) - (MTVar mempty (tvNamed "a")) - ] - ) - ] - ) - ) - - it "Parses a type declaration with a function and data type as arg" $ - testParse "type Reader r a = Reader (r -> (Pair a b))" - `shouldBe` Right - ( DataType - "Reader" - ["r", "a"] - ( M.fromList - [ ( "Reader", - [ MTFunction - mempty - (MTVar mempty (tvNamed "r")) - ( dataTypeWithVars - mempty - Nothing - "Pair" - [ MTVar mempty (tvNamed "a"), - MTVar mempty (tvNamed "b") - ] - ) - ] - ) - ] - ) - ) - - it "Parses complex type constructors" $ - testParse "type Tree = Leaf Int | Branch Tree Tree" - `shouldBe` Right - ( DataType - "Tree" - [] - ( M.fromList - [ ("Leaf", [MTPrim mempty MTInt]), - ( "Branch", - [ dataTypeWithVars mempty Nothing "Tree" [], - dataTypeWithVars mempty Nothing "Tree" [] - ] - ) - ] - ) - ) - it "Parses even more complex type constructors" $ - testParse "type Tree a = Empty | Branch (Tree a) a (Tree a)" - `shouldBe` Right - ( DataType - "Tree" - ["a"] - ( M.fromList - [ ("Empty", mempty), - ( "Branch", - [ dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")], - MTVar mempty (tvNamed "a"), - dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")] - ] - ) - ] - ) - ) - - it "Tree type" $ - testParse "type Tree a = Leaf a | Branch (Tree a) (Tree a)" - `shouldBe` Right - ( DataType - "Tree" - ["a"] - ( M.fromList - [ ("Leaf", [MTVar mempty (tvNamed "a")]), - ( "Branch", - [ dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")], - dataTypeWithVars mempty Nothing "Tree" [MTVar mempty (tvNamed "a")] - ] - ) - ] - ) - ) - - it "Parses data declaration with location information" $ - testParse "type MyUnit = MyUnit" - `shouldBe` Right - ( DataType - "MyUnit" - mempty - (M.singleton "MyUnit" mempty) - ) - - it "Parses Reader type declaration with 'in'" $ - testParse - "type Reader r a = Reader (r -> a)" - `shouldSatisfy` isRight - - it "Parses Reader type declaration with semicolon" $ - testParse - "type Reader r a = Reader (r -> a)" - `shouldSatisfy` isRight diff --git a/core/test/CoreTest/Parser/MonoTypeParser.hs b/core/test/CoreTest/Parser/MonoTypeParser.hs deleted file mode 100644 index 34eba63c..00000000 --- a/core/test/CoreTest/Parser/MonoTypeParser.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Parser.MonoTypeParser - ( spec, - ) -where - -import Control.Monad.Except -import CoreTest.Utils.Helpers -import Data.Either (isRight) -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Text (Text) -import Language.Mimsa.Core -import Test.Hspec - -testParser :: Text -> Either Text MonoType -testParser input = do - let removeAnn mt = mt $> mempty - doParser i = - removeAnn <$> parseAndFormat monoTypeParser i - original <- doParser input - case doParser (prettyPrint original) of - Right newOne -> - if newOne == original - then pure newOne - else throwError $ "Error! " <> prettyPrint newOne <> " does not equal " <> prettyPrint original - Left e -> throwError e - -spec :: Spec -spec = - describe "MonoType parser" $ do - it "String" $ - testParser "String" `shouldBe` Right (MTPrim mempty MTString) - it "Boolean" $ - testParser "Boolean" `shouldBe` Right (MTPrim mempty MTBool) - it "Int" $ - testParser "Int" `shouldBe` Right (MTPrim mempty MTInt) - it "Function with primitives" $ - testParser "Int -> Int" - `shouldBe` Right - ( MTFunction - mempty - (MTPrim mempty MTInt) - (MTPrim mempty MTInt) - ) - it "Pair of primitives" $ - testParser "(Int, String)" - `shouldBe` Right - (MTTuple mempty (MTPrim mempty MTInt) (NE.singleton $ MTPrim mempty MTString)) - it "Pair with less spacing" $ - testParser "(a,b) -> a" - `shouldBe` Right - ( MTFunction - mempty - (MTTuple mempty (MTVar mempty (tvNamed "a")) (NE.singleton $ MTVar mempty (tvNamed "b"))) - (MTVar mempty (tvNamed "a")) - ) - it "Function with pair" $ - testParser "(Int, String) -> Int" - `shouldBe` Right - ( MTFunction - mempty - (MTTuple mempty (MTPrim mempty MTInt) (NE.singleton $ MTPrim mempty MTString)) - (MTPrim mempty MTInt) - ) - it "Function with variables" $ - testParser "a -> a" - `shouldBe` Right - ( MTFunction - mempty - (MTVar mempty (tvNamed "a")) - (MTVar mempty (tvNamed "a")) - ) - it "Function with 3 variables" $ - testParser "a -> a -> a" - `shouldBe` Right - ( MTFunction - mempty - (typeName "a") - ( MTFunction - mempty - (typeName "a") - (typeName "a") - ) - ) - it "Empty record" $ - testParser "{}" - `shouldBe` Right (MTRecord mempty mempty Nothing) - it "Record with items" $ - testParser "{one:Int,two:String}" - `shouldBe` Right - ( MTRecord - mempty - ( M.fromList - [ ("one", MTPrim mempty MTInt), - ("two", MTPrim mempty MTString) - ] - ) - Nothing - ) - it "Record with functions as items" $ - testParser "{ one: (Int -> Int), two: (String -> b) }" - `shouldBe` Right - ( MTRecord - mempty - ( M.fromList - [ ( "one", - MTFunction - mempty - (MTPrim mempty MTInt) - (MTPrim mempty MTInt) - ), - ( "two", - MTFunction - mempty - (MTPrim mempty MTString) - (MTVar mempty (tvNamed "b")) - ) - ] - ) - Nothing - ) - it "Record with one function inside" $ - testParser "{ one: (Int -> Maybe Int) }" `shouldSatisfy` isRight - it "Record with all sorts of stuff in it" $ - testParser "{ one: (Int -> Maybe Int), two: (String -> (b, Either String Int)) }" - `shouldBe` Right - ( MTRecord - mempty - ( M.fromList - [ ( "one", - MTFunction - mempty - (MTPrim mempty MTInt) - ( dataTypeWithVars - mempty - Nothing - "Maybe" - [MTPrim mempty MTInt] - ) - ), - ( "two", - MTFunction - mempty - (MTPrim mempty MTString) - ( MTTuple - mempty - (MTVar mempty (tvNamed "b")) - ( NE.singleton $ - dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTString, - MTPrim mempty MTInt - ] - ) - ) - ) - ] - ) - Nothing - ) - it "Nullary data type" $ - testParser "MyUnit" - `shouldBe` Right - (dataTypeWithVars mempty Nothing "MyUnit" mempty) - it "Unary data type" $ - testParser "Maybe String" - `shouldBe` Right - ( dataTypeWithVars - mempty - Nothing - "Maybe" - [MTPrim mempty MTString] - ) - it "Binary data type" $ - testParser "Either String Int" - `shouldBe` Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTString, - MTPrim mempty MTInt - ] - ) - it "Binary data type" $ - testParser "Either String Either" - `shouldBe` Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTString, - MTConstructor mempty Nothing "Either" - ] - ) - - it "Binary data type with sub type" $ - testParser "Either String (Maybe Int)" - `shouldBe` Right - ( dataTypeWithVars - mempty - Nothing - "Either" - [ MTPrim mempty MTString, - dataTypeWithVars - mempty - Nothing - "Maybe" - [MTPrim mempty MTInt] - ] - ) - it "Functions with datatypes 1" $ - testParser "MyUnit -> Int" - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "MyUnit" mempty) - (MTPrim mempty MTInt) - ) - it "Functions with datatypes with brackets" $ - testParser "(Maybe String) -> Int" - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "Maybe" [MTPrim mempty MTString]) - (MTPrim mempty MTInt) - ) - it "Functions with datatypes with no brackets" $ - testParser "(Maybe a) -> b" - `shouldBe` Right - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "Maybe" [typeName "a"]) - (typeName "b") - ) - it "Parses higher order function" $ - testParser "(a -> b) -> a -> b" - `shouldBe` Right - ( MTFunction - mempty - (MTFunction mempty (typeName "a") (typeName "b")) - ( MTFunction - mempty - (typeName "a") - (typeName "b") - ) - ) - it "Parses part of fmap" $ - testParser "(a -> b) -> Option a" - `shouldBe` Right - ( MTFunction - mempty - (MTFunction mempty (typeName "a") (typeName "b")) - (dataTypeWithVars mempty Nothing "Option" [typeName "a"]) - ) - it "Parses weird variation on fmap" $ - testParser "(a -> b) -> Option (a -> Option b)" - `shouldBe` Right - ( MTFunction - mempty - (MTFunction mempty (typeName "a") (typeName "b")) - ( dataTypeWithVars - mempty - Nothing - "Option" - [ MTFunction - mempty - (typeName "a") - (dataTypeWithVars mempty Nothing "Option" [typeName "b"]) - ] - ) - ) - it "Parses fmap with brackets" $ - testParser "(a -> b) -> (Option a) -> (Option b)" - `shouldBe` Right - ( MTFunction - mempty - (MTFunction mempty (typeName "a") (typeName "b")) - ( MTFunction - mempty - (dataTypeWithVars mempty Nothing "Option" [typeName "a"]) - (dataTypeWithVars mempty Nothing "Option" [typeName "b"]) - ) - ) - it "Parses function without brackets" $ - testParser "r -> a" `shouldSatisfy` isRight - it "Parses array of numbers" $ - testParser "[Int]" `shouldBe` Right (MTArray mempty (MTPrim mempty MTInt)) - it "Parses RecordRow" $ - testParser "{ a: String | b }" - `shouldBe` Right - ( MTRecord - mempty - (M.singleton "a" (MTPrim mempty MTString)) - (Just $ MTVar mempty (tvNamed "b")) - ) diff --git a/core/test/CoreTest/Parser/Pattern.hs b/core/test/CoreTest/Parser/Pattern.hs deleted file mode 100644 index 4ca9b684..00000000 --- a/core/test/CoreTest/Parser/Pattern.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Parser.Pattern - ( spec, - ) -where - -import Data.Functor -import Data.List (isInfixOf) -import Data.Text (Text) -import Language.Mimsa.Core -import Test.Hspec -import Text.Megaparsec - --- parse pat, using it all up -parsePat :: Text -> Either ParseErrorType ParserPattern -parsePat = parse (patternParser <* eof) "repl" - --- specialisation of parseExpr -testParse :: Text -> Either String (Pattern Name ()) -testParse t = case parsePat t of - Right expr -> pure (expr $> ()) - Left e -> Left $ errorBundlePretty e - -errorContains :: String -> Either String a -> Bool -errorContains s res = case res of - Left e -> s `isInfixOf` e - _ -> False - -spec :: Spec -spec = - describe "Pattern" $ do - it "Parses constructor with no args" $ - testParse "None" `shouldBe` Right (PConstructor mempty Nothing "None" mempty) - it "Parses constructor with 1 arg" $ - testParse "Some _" `shouldBe` Right (PConstructor mempty Nothing "Some" [PWildcard mempty]) - it "Parses constructor with 2 args" $ - testParse "Some _ 1" - `shouldBe` Right - ( PConstructor - mempty - Nothing - "Some" - [ PWildcard mempty, - PLit mempty (MyInt 1) - ] - ) - it "Parses array with two items" $ - testParse "[1,a]" - `shouldBe` Right - ( PArray - mempty - [ PLit mempty (MyInt 1), - PVar mempty "a" - ] - NoSpread - ) - it "Parses array with wildcard spread" $ - testParse "[1, a, ...]" - `shouldBe` Right - ( PArray - mempty - [ PLit mempty (MyInt 1), - PVar mempty "a" - ] - ( SpreadWildcard - mempty - ) - ) - it "Parses array with value spread" $ - testParse "[1, a, ...b]" - `shouldBe` Right - ( PArray - mempty - [ PLit mempty (MyInt 1), - PVar mempty "a" - ] - ( SpreadValue - mempty - "b" - ) - ) - it "Spread needs at least one value" $ - testParse "[...b]" - `shouldSatisfy` errorContains "There must be at least one pattern" - - it "Cannot have more than one spread" $ - testParse "[1, ...a,...b]" - `shouldSatisfy` errorContains "Cannot have more than one spread" - it "Trailing comma in pattern" $ - testParse "[1,2,]" - `shouldSatisfy` errorContains "Expected pattern or a spread operator" - it "Parses pattern for non-empty string" $ - testParse "_ ++ _" - `shouldBe` Right - ( PString - mempty - (StrWildcard mempty) - (StrWildcard mempty) - ) diff --git a/core/test/CoreTest/Parser/Syntax.hs b/core/test/CoreTest/Parser/Syntax.hs deleted file mode 100644 index 7eaea8e8..00000000 --- a/core/test/CoreTest/Parser/Syntax.hs +++ /dev/null @@ -1,875 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Parser.Syntax - ( spec, - ) -where - -import CoreTest.Utils.Helpers -import Data.Either (isLeft, isRight) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Test.Hspec - --- remove annotations for comparison -toEmptyAnn :: Expr a b -> Expr a () -toEmptyAnn = toEmptyAnnotation - --- does the output of our prettyprinting still make sense to the parser? -testParseWithAnn :: Text -> Either Text (Expr Name Annotation) -testParseWithAnn input = do - expr1 <- parseExprAndFormatError input - case parseExprAndFormatError (prettyPrint expr1) of - Left e -> Left e - Right expr2 -> - if toEmptyAnn expr1 /= toEmptyAnn expr2 - then - Left $ - "Pretty:\n" - <> prettyPrint expr1 - <> "\nExpr:\n" - <> T.pack (show expr1) - <> "\nDoes not match re-parsed expr:\n" - <> T.pack (show expr2) - else pure expr1 - --- specialisation of parseExpr -testParse :: Text -> Either Text (Expr Name ()) -testParse t = toEmptyAnnotation <$> testParseWithAnn t - -spec :: Spec -spec = parallel $ do - describe "Syntax" $ do - describe "Language" $ do - it "Parses True" $ - testParse "True" `shouldBe` Right (bool True) - it "Parses False" $ - testParse "False" `shouldBe` Right (bool False) - it "Parses 6" $ - testParse "6" `shouldBe` Right (int 6) - it "Parses 1234567" $ - testParse "1234567" `shouldBe` Right (int 1234567) - it "Does not parse 123.0" $ - testParse "123.0" `shouldSatisfy` isLeft - it "Parses 123 with a space at the end" $ - testParse "123 " `shouldSatisfy` isRight - it "Parses literal with a space at the end" $ - testParse "True " `shouldSatisfy` isRight - it "Parses -6" $ - testParse "-6" `shouldBe` Right (int (-6)) - it "Parses +6" $ - testParse "+6" `shouldBe` Right (int 6) - it "Parses a string" $ - testParse "\"dog\"" `shouldBe` Right (str (StringType "dog")) - it "Parses a variable name" $ - testParse "log" - `shouldBe` Right (MyVar mempty Nothing "log") - it "Parses a namespaced variable name" $ - testParse "Console.log" - `shouldBe` Right (MyVar mempty (Just "Console") "log") - it "Does not accept 'let' as a variable name" $ - isLeft (testParse "let") - `shouldBe` True - it "Does not accept 'in' as a variable name" $ - isLeft (testParse "in") - `shouldBe` True - it "Does not accept 2log as a variable name because it starts with a number" $ - testParse "2log" `shouldSatisfy` isLeft - it "Does not recognise a stupid variable name with crap in it" $ - testParse "log!dog" - `shouldSatisfy` isLeft - it "Does a basic let binding" $ do - let expected = MyLet mempty (Identifier mempty "xa") (bool True) (MyVar mempty Nothing "xa") - testParse "let xa = True in xa" - `shouldBe` Right expected - it "Does a basic let binding with excessive whitespace" $ do - let expected = MyLet mempty (Identifier mempty "x") (bool True) (MyVar mempty Nothing "x") - testParse "let x = True in x" - `shouldBe` Right expected - it "Does a let binding inside parens" $ do - let expected = MyLet mempty (Identifier mempty "x") (bool True) (MyVar mempty Nothing "x") - testParse "(let x = True in x)" - `shouldBe` Right expected - it "Recognises a basic lambda" $ - testParse "\\x -> x" - `shouldBe` Right (MyLambda mempty (Identifier mempty "x") (MyVar mempty Nothing "x")) - it "Recognises a lambda with too much whitespace everywhere" $ - testParse "\\ x -> x" - `shouldBe` Right (MyLambda mempty (Identifier mempty "x") (MyVar mempty Nothing "x")) - it "Recognises a lambda in parens" $ - testParse "(\\x -> x)" - `shouldBe` Right (MyLambda mempty (Identifier mempty "x") (MyVar mempty Nothing "x")) - it "Recognises nested lambdas in parens" $ - testParse "(\\a -> (\\b -> a))" - `shouldBe` Right - ( MyLambda - mempty - (Identifier mempty "a") - (MyLambda mempty (Identifier mempty "b") (MyVar mempty Nothing "a")) - ) - it "Recognises minimal function syntax in let" $ - testParse "let const a b = a in True" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "const") - (MyLambda mempty (Identifier mempty "a") (MyLambda mempty (Identifier mempty "b") (MyVar mempty Nothing "a"))) - (bool True) - ) - it "Recognises function application" $ - testParse "add 1" - `shouldBe` Right - ( MyApp - mempty - ( MyVar mempty Nothing "add" - ) - (int 1) - ) - it "Recognises function application 2" $ - testParse "add True" - `shouldBe` Right - ( MyApp - mempty - ( MyVar mempty Nothing "add" - ) - (bool True) - ) - - it "Recognises function application onto namespaced var" $ - testParse "Console.log 1" - `shouldBe` Right - ( MyApp - mempty - ( MyVar - mempty - (Just "Console") - "log" - ) - (int 1) - ) - - it "Recognises function application with namespaced arg" $ - testParse "log Prelude.one" - `shouldBe` Right - ( MyApp - mempty - ( MyVar - mempty - Nothing - "log" - ) - (MyVar mempty (Just "Prelude") "one") - ) - - it "Recognises function application onto an annotated function" $ - testParse "(\\a -> a: a -> a) True" - `shouldBe` Right - ( MyApp - mempty - ( MyAnnotation - mempty - ( MTFunction mempty (MTVar mempty (TVName "a")) (MTVar mempty (TVName "a")) - ) - (MyLambda mempty (Identifier mempty "a") (MyVar mempty Nothing "a")) - ) - (bool True) - ) - it "Recognises application with an annotated argument" $ - testParse "id (True: Boolean)" - `shouldBe` Right - ( MyApp - mempty - (MyVar mempty Nothing "id") - (MyAnnotation mempty (MTPrim mempty MTBool) (bool True)) - ) - it "Recognises double function application onto a var" $ - testParse "add 1 2" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - ( MyVar mempty Nothing "add" - ) - (int 1) - ) - (int 2) - ) - it "Recognises double function application onto a var with brackets" $ - testParse "add (1) (2)" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - ( MyVar mempty Nothing "add" - ) - (int 1) - ) - (int 2) - ) - - it "Recognises an if statement" $ do - let expected = MyIf mempty (bool True) (int 1) (int 2) - testParse "if True then 1 else 2" `shouldBe` Right expected - it "Recognises an if statement in parens" $ do - let expected = MyIf mempty (bool True) (int 1) (int 2) - testParse "(if True then 1 else 2)" `shouldBe` Right expected - it "Recognises an if statement with lots of whitespace" $ do - let expected = MyIf mempty (bool True) (int 1) (int 2) - testParse "if True then 1 else 2" `shouldBe` Right expected - it "Parses a pair of things" $ - testParse "(2, 2)" - `shouldBe` Right - (MyTuple mempty (int 2) (NE.singleton $ int 2)) - it "Parses a pair of things with silly whitespace" $ - testParse "( 2 , 2 )" - `shouldBe` Right - (MyTuple mempty (int 2) (NE.singleton $ int 2)) - it "Allows a let to use a pair" $ - testParse "let x = ((1,2)) in x" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "x") - (MyTuple mempty (int 1) (NE.singleton $ int 2)) - (MyVar mempty Nothing "x") - ) - it "Allows a let to use a pair and apply to it" $ - testParse "let x = ((1,2)) in fst x" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "x") - (MyTuple mempty (int 1) (NE.singleton $ int 2)) - (MyApp mempty (MyVar mempty Nothing "fst") (MyVar mempty Nothing "x")) - ) - it "Allows a let to use a nested lambda" $ - testParse "let const2 = (\\a -> (\\b -> a)) in (const2)" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "const2") - ( MyLambda - mempty - (Identifier mempty "a") - (MyLambda mempty (Identifier mempty "b") (MyVar mempty Nothing "a")) - ) - (MyVar mempty Nothing "const2") - ) - it "Parses typed hole" $ do - testParse "?dog" `shouldBe` Right (MyTypedHole mempty "dog") - it "Parses a complex let expression" $ - testParse "let const2 = (\\a -> (\\b -> a)) in (let reuse = ({first: const2 True, second: const2 2}) in reuse.second 100)" - `shouldSatisfy` isRight - it "Parses an infix equals expression" $ - testParse "True == True" `shouldBe` Right (MyInfix mempty Equals (bool True) (bool True)) - it "Parses two integers with infix operator" $ - testParse "123 == 123" `shouldBe` Right (MyInfix mempty Equals (int 123) (int 123)) - it "Parses var and number equality" $ - testParse " a == 1" `shouldBe` Right (MyInfix mempty Equals (MyVar mempty Nothing "a") (int 1)) - it "Parsers two constructor applications with infix operator" $ - let mkSome = MyApp mempty (MyConstructor mempty Nothing "Some") - in testParse "(Some 1) == Some 2" - `shouldBe` Right (MyInfix mempty Equals (mkSome (int 1)) (mkSome (int 2))) - it "Parses an empty record literal" $ - testParse "{}" `shouldBe` Right (MyRecord mempty mempty) - it "Parses a record literal with a single item inside" $ - testParse "{ dog: 1 }" - `shouldBe` Right - (MyRecord mempty (M.singleton "dog" (int 1))) - it "Parses a record literal with multiple items inside" $ - testParse "{ dog:1, cat:True, horse:\"of course\" }" - `shouldBe` Right - ( MyRecord mempty $ - M.fromList - [ ("dog", int 1), - ("cat", bool True), - ("horse", str' "of course") - ] - ) - it "Parses a record literal with multiple items inside and less spacing" $ - testParse "{dog:1,cat:True,horse:\"of course\"}" - `shouldBe` Right - ( MyRecord mempty $ - M.fromList - [ ("dog", int 1), - ("cat", bool True), - ("horse", str' "of course") - ] - ) - it "Parses a record literal with a punned item" $ - testParse "{dog,cat:True}" - `shouldBe` Right - ( MyRecord mempty $ - M.fromList - [ ("dog", MyVar mempty Nothing "dog"), - ("cat", bool True) - ] - ) - - it "Parses a destructuring of pairs" $ - testParse "let (a,b) = ((True,1)) in a" - `shouldBe` Right - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyTuple mempty (bool True) (NE.singleton $ int 1)) - (MyVar mempty Nothing "a") - ) - - it "Parses a multiple argument constructor" $ - testParse "Dog \"hi\" \"dog\"" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Dog") - (str' "hi") - ) - (str' "dog") - ) - - it "Uses a constructor" $ - testParse "Vrai" `shouldBe` Right (MyConstructor mempty Nothing "Vrai") - it "Uses a namespaced constructor" $ - testParse "LeBool.Vrai" `shouldBe` Right (MyConstructor mempty (Just "LeBool") "Vrai") - - it "Parses big function application" $ - testParse "thing 1 2 3 4 5" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "thing") - (int 1) - ) - (int 2) - ) - (int 3) - ) - (int 4) - ) - (int 5) - ) - it "Parses big infix fest" $ - testParse "(id 1) + (id 2) + (id 3)" `shouldSatisfy` isRight - it "Parses infix with annotations" $ - testParse "(1 : Int) + (2 : Int) + (3 : Int)" `shouldSatisfy` isRight - it "Parses smaller app in If" $ - testParse "if id True then 1 else 2" `shouldSatisfy` isRight - it "Parses big app in If" $ - testParse "if id True then id 1 else id 2" `shouldSatisfy` isRight - it "Parses big app with brackets in If" $ - testParse "if (id True) then (id 1) else (id 2)" `shouldSatisfy` isRight - it "Parser pureState" $ - testParse "\\a -> State (\\s -> Pair a s)" - `shouldBe` Right - ( MyLambda - mempty - (Identifier mempty "a") - ( MyApp - mempty - (MyConstructor mempty Nothing "State") - ( MyLambda - mempty - (Identifier mempty "s") - ( MyApp - mempty - ( MyApp - mempty - ( MyConstructor mempty Nothing "Pair" - ) - (MyVar mempty Nothing "a") - ) - (MyVar mempty Nothing "s") - ) - ) - ) - ) - it "Nested constructor application" $ - testParse "Log 1 \"dog\" 1" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Log") - (int 1) - ) - (str "dog") - ) - (int 1) - ) - it "Nested constructor and function application" $ - testParse "Log 1 (func \"dog\" 1)" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Log") - (int 1) - ) - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "func") - (str "dog") - ) - (int 1) - ) - ) - - it "Nested application" $ - testParse "func 1 \"dog\" 1" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "func") - (int 1) - ) - (str "dog") - ) - (int 1) - ) - it "Application after brackets" $ - testParse "\\a -> (compose id id) a" - `shouldBe` Right - ( MyLambda - mempty - (Identifier mempty "a") - ( MyApp - mempty - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "compose") - (MyVar mempty Nothing "id") - ) - (MyVar mempty Nothing "id") - ) - (MyVar mempty Nothing "a") - ) - ) - - it "Tree type value" $ - testParse "Branch (Leaf 1) (Leaf 2)" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - (MyConstructor mempty Nothing "Branch") - (MyApp mempty (MyConstructor mempty Nothing "Leaf") (int 1)) - ) - (MyApp mempty (MyConstructor mempty Nothing "Leaf") (int 2)) - ) - - it "dog + log" $ - testParse "dog + log" - `shouldBe` Right (MyInfix mempty Add (MyVar mempty Nothing "dog") (MyVar mempty Nothing "log")) - - it "a+" $ - testParse "a+" `shouldSatisfy` isLeft - - it "a == 1" $ - testParse "a == 1" - `shouldBe` Right - (MyInfix mempty Equals (MyVar mempty Nothing "a") (int 1)) - - it "a + 1" $ - testParse "a + 1" - `shouldBe` Right - (MyInfix mempty Add (MyVar mempty Nothing "a") (int 1)) - - it "a - 1" $ - testParse "a - 1" - `shouldBe` Right - (MyInfix mempty Subtract (MyVar mempty Nothing "a") (int 1)) - - it "a+ 1" $ - testParse "a+ 1" - `shouldBe` Right - (MyInfix mempty Add (MyVar mempty Nothing "a") (int 1)) - - it "a+1" $ - testParse "a+1" - `shouldSatisfy` isRight - - it "a + b" $ - testParse "a + b" - `shouldBe` Right - (MyInfix mempty Add (MyVar mempty Nothing "a") (MyVar mempty Nothing "b")) - - it "1 + a" $ - testParse "1 + a" - `shouldBe` Right - (MyInfix mempty Add (int 1) (MyVar mempty Nothing "a")) - - it "newName ++ \"!!!\"" $ - testParse "newName ++ \"!!!\"" - `shouldBe` Right (MyInfix mempty StringConcat (MyVar mempty Nothing "newName") (str "!!!")) - - it "Applies a lambda to a function" $ - testParse "map (\\a -> a + 1) [1,2,3]" - `shouldBe` Right - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "map") - ( MyLambda - mempty - (Identifier mempty "a") - ( MyInfix mempty Add (MyVar mempty Nothing "a") (int 1) - ) - ) - ) - (MyArray mempty [int 1, int 2, int 3]) - ) - it "Parses passing a lambda to a function" $ - testParse "arrayReduce (\\all -> \\a -> [ all ] <> a) []" - `shouldSatisfy` isRight - it "Parses big nested thing without boo boos" $ - testParse "let parser = bindParser (\\a -> if a == \"d\" then anyChar else failParser) anyChar; runParser parser \"dog\"" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "parser") - ( MyApp - mempty - ( MyApp - mempty - (MyVar mempty Nothing "bindParser") - ( MyLambda - mempty - (Identifier mempty "a") - ( MyIf - mempty - ( MyInfix - mempty - Equals - (MyVar mempty Nothing "a") - (MyLiteral mempty (MyString "d")) - ) - (MyVar mempty Nothing "anyChar") - (MyVar mempty Nothing "failParser") - ) - ) - ) - (MyVar mempty Nothing "anyChar") - ) - (MyApp mempty (MyApp mempty (MyVar mempty Nothing "runParser") (MyVar mempty Nothing "parser")) (MyLiteral mempty (MyString "dog"))) - ) - - it "parses destructuring a tuple" $ - testParse "let (a,b) = (1,2); a" - `shouldBe` Right - ( MyLetPattern - mempty - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - (MyTuple mempty (int 1) (NE.singleton $ int 2)) - (MyVar mempty Nothing "a") - ) - it "parses destructuring a record with puns" $ - testParse "let {a,b:c} = { a: 1, b: 2}; c" - `shouldBe` Right - ( MyLetPattern - mempty - ( PRecord - mempty - ( M.fromList - [ ("a", PVar mempty "a"), - ("b", PVar mempty "c") - ] - ) - ) - (MyRecord mempty (M.fromList [("a", int 1), ("b", int 2)])) - (MyVar mempty Nothing "c") - ) - it "parses access of a record literal" $ do - testParse "{ dog: True }.dog" - `shouldSatisfy` isRight - it "parses an int with type annotation" $ do - testParse "(1 : Int)" - `shouldBe` Right - ( MyAnnotation - mempty - (MTPrim mempty MTInt) - (MyLiteral mempty (MyInt 1)) - ) - it "parses a function with type annotation" $ do - testParse "(\\a -> a : Int -> Int)" - `shouldBe` Right - ( MyAnnotation - mempty - ( MTFunction - mempty - (MTPrim mempty MTInt) - (MTPrim mempty MTInt) - ) - (MyLambda mempty (Identifier mempty "a") (MyVar mempty Nothing "a")) - ) - it "parses a let binding with type annotation" $ do - testParse "let (a: Int) = 1 in True" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "a") - ( MyAnnotation - mempty - (MTPrim mempty MTInt) - (MyLiteral mempty (MyInt 1)) - ) - (MyLiteral mempty (MyBool True)) - ) - it "parses a let function with type annotation" $ do - testParse "let (addOne: Int -> Int) a = a + 1 in True" - `shouldBe` Right - ( MyLet - mempty - (Identifier mempty "addOne") - ( MyAnnotation - mempty - ( MTFunction - mempty - (MTPrim mempty MTInt) - (MTPrim mempty MTInt) - ) - ( MyLambda - mempty - (Identifier mempty "a") - ( MyInfix - mempty - Add - (MyVar mempty Nothing "a") - (MyLiteral mempty (MyInt 1)) - ) - ) - ) - (MyLiteral mempty (MyBool True)) - ) - - describe "Test annotations" $ do - it "Parses a var with location information" $ - testParseWithAnn "dog" `shouldBe` Right (MyVar (Location 0 3) Nothing "dog") - it "Parses a tyCon with location information" $ - testParseWithAnn "Log" `shouldBe` Right (MyConstructor (Location 0 3) Nothing "Log") - it "Parses a true bool with location information" $ - testParseWithAnn "True" `shouldBe` Right (MyLiteral (Location 0 4) (MyBool True)) - it "Parses a false bool with location information" $ - testParseWithAnn "False" `shouldBe` Right (MyLiteral (Location 0 5) (MyBool False)) - it "Parses an integer with location information" $ - testParseWithAnn "100" `shouldBe` Right (MyLiteral (Location 0 3) (MyInt 100)) - it "Parses a string literal with location information" $ - testParseWithAnn "\"horse\"" `shouldBe` Right (MyLiteral (Location 0 7) (MyString $ StringType "horse")) - it "Parses record access with location information" $ - testParseWithAnn "dog.tail" - `shouldBe` Right - ( MyRecordAccess - (Location 0 8) - (MyVar (Location 0 3) Nothing "dog") - "tail" - ) - it "Parses let-in with location information" $ - testParseWithAnn "let a = 1 in a" - `shouldBe` Right - ( MyLet - (Location 0 14) - (Identifier (Location 4 5) "a") - (MyLiteral (Location 8 10) (MyInt 1)) - (MyVar (Location 13 14) Nothing "a") - ) - it "Parses let-newline with location information" $ - testParseWithAnn "let a = 1; a" - `shouldBe` Right - ( MyLet - (Location 0 12) - (Identifier (Location 4 5) "a") - (MyLiteral (Location 8 9) (MyInt 1)) - (MyVar (Location 11 12) Nothing "a") - ) - it "Parsers lambda with location information" $ - testParseWithAnn "\\a -> a" - `shouldBe` Right - (MyLambda (Location 0 7) (Identifier (Location 1 2) "a") (MyVar (Location 6 7) Nothing "a")) - it "Parses application with location information" $ - testParseWithAnn "a 1" - `shouldBe` Right - ( MyApp - (Location 0 3) - (MyVar (Location 0 2) Nothing "a") - (MyLiteral (Location 2 3) (MyInt 1)) - ) - it "Parses record with location information" $ - testParseWithAnn "{ a: True }" - `shouldBe` Right - ( MyRecord - (Location 0 11) - ( M.singleton - "a" - (MyLiteral (Location 5 10) (MyBool True)) - ) - ) - it "Parsers if with location information" $ - testParseWithAnn "if True then 1 else 2" - `shouldBe` Right - ( MyIf - (Location 0 21) - (MyLiteral (Location 3 8) (MyBool True)) - (MyLiteral (Location 13 15) (MyInt 1)) - (MyLiteral (Location 20 21) (MyInt 2)) - ) - it "Parsers pair with location information" $ - testParseWithAnn "(1,2)" - `shouldBe` Right - ( MyTuple - (Location 0 5) - (MyLiteral (Location 1 2) (MyInt 1)) - (NE.singleton $ MyLiteral (Location 3 4) (MyInt 2)) - ) - it "Parses constructor application with location information" $ - testParseWithAnn "Just 1" - `shouldBe` Right - ( MyApp - (Location 0 6) - (MyConstructor (Location 0 5) Nothing "Just") - (MyLiteral (Location 5 6) (MyInt 1)) - ) - it "Parses infix equals with location information" $ - testParseWithAnn "1 == 2" - `shouldBe` Right - ( MyInfix - (Location 0 6) - Equals - (MyLiteral (Location 0 1) (MyInt 1)) - (MyLiteral (Location 5 6) (MyInt 2)) - ) - it "Allows typed holes as function" $ - testParseWithAnn "\\a -> if ?tobool a then 1 else 2" - `shouldSatisfy` isRight - it "Parser function application in infix" $ - testParseWithAnn "id 1 + 1" `shouldSatisfy` isRight - it "Accepts whitespace after record" $ - testParseWithAnn "{ name: 1 } " `shouldSatisfy` isRight - it "Parses array of numbers" $ - testParseWithAnn "[1,2,3]" - `shouldBe` Right - ( MyArray - (Location 0 7) - [ MyLiteral (Location 1 2) (MyInt 1), - MyLiteral (Location 3 4) (MyInt 2), - MyLiteral (Location 5 6) (MyInt 3) - ] - ) - it "Parses empty array" $ - testParseWithAnn "[]" - `shouldBe` Right - ( MyArray (Location 0 2) mempty - ) - describe "Pattern matching" $ do - it "Parses wildcard pattern match" $ - testParseWithAnn "match 1 with _ -> True" - `shouldBe` Right - ( MyPatternMatch - (Location 0 22) - (MyLiteral (Location 6 8) (MyInt 1)) - [ ( PWildcard (Location 13 14), - MyLiteral (Location 18 22) (MyBool True) - ) - ] - ) - it "Parses wildcard pattern match with multiple cases" $ - testParseWithAnn "match 1 with _ -> True | _ -> False" - `shouldBe` Right - ( MyPatternMatch - (Location 0 35) - (MyLiteral (Location 6 8) (MyInt 1)) - [ ( PWildcard (Location 13 14), - MyLiteral (Location 18 23) (MyBool True) - ), - ( PWildcard (Location 25 26), - MyLiteral (Location 30 35) (MyBool False) - ) - ] - ) - it "Parses variable pattern match" $ - testParseWithAnn "match 1 with a -> a" - `shouldBe` Right - ( MyPatternMatch - (Location 0 19) - (MyLiteral (Location 6 8) (MyInt 1)) - [ ( PVar (Location 13 15) "a", - MyVar (Location 18 19) Nothing "a" - ) - ] - ) - it "Parses constructor pattern match" $ - testParseWithAnn "match None with None -> False" - `shouldBe` Right - ( MyPatternMatch - (Location 0 29) - (MyConstructor (Location 6 11) Nothing "None") - [ ( PConstructor (Location 16 21) Nothing "None" mempty, - MyLiteral (Location 24 29) (MyBool False) - ) - ] - ) - it "Parses constructor with arg pattern match" $ - testParseWithAnn "match Some 1 with (Some _) -> True" - `shouldBe` Right - ( MyPatternMatch - (Location 0 34) - (MyApp (Location 6 13) (MyConstructor (Location 6 11) Nothing "Some") (MyLiteral (Location 11 12) (MyInt 1))) - [ ( PConstructor (Location 19 25) Nothing "Some" [PWildcard (Location 24 25)], - MyLiteral (Location 30 34) (MyBool True) - ) - ] - ) - it "Parses namespaced constructor with arg pattern match" $ - testParseWithAnn "match Maybe.Some 1 with (Maybe.Some _) -> True" - `shouldBe` Right - ( MyPatternMatch - (Location 0 46) - (MyApp (Location 6 19) (MyConstructor (Location 6 17) (Just "Maybe") "Some") (MyLiteral (Location 17 18) (MyInt 1))) - [ ( PConstructor (Location 25 37) (Just "Maybe") "Some" [PWildcard (Location 36 37)], - MyLiteral (Location 42 46) (MyBool True) - ) - ] - ) - - describe "Parse regressions" $ do - it "regression 1" $ - testParse "let a = 1; let b = a + 1 in match True with True -> 1 | False -> 2" - `shouldSatisfy` isRight - it "regression 2" $ - testParse "let stringReduce = \\f -> \\defVal -> \\str -> match str with \"\" -> defVal | head ++ tail -> stringReduce f (f defVal head) tail; stringReduce" - `shouldSatisfy` isRight diff --git a/core/test/CoreTest/Prettier.hs b/core/test/CoreTest/Prettier.hs deleted file mode 100644 index f917f543..00000000 --- a/core/test/CoreTest/Prettier.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Prettier - ( spec, - ) -where - -import CoreTest.Utils.Helpers -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Text.IO as T -import Language.Mimsa.Core -import Test.Hspec - -spec :: Spec -spec = - describe "Prettier" $ do - describe "Expr" $ do - it "Cons with infix" $ do - let expr' = unsafeParseExpr "Some (1 == 1)" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "Some (1 == 1)" - - it "Many + operators" $ do - let expr' = unsafeParseExpr "1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10" - renderWithWidth 5 doc `shouldBe` "1 + 2\n + 3\n + 4\n + 5\n + 6\n + 7\n + 8\n + 9\n + 10" - - it "Nested lambdas" $ do - let expr' = unsafeParseExpr "\\f -> \\g -> \\a -> f (g a)" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "\\f -> \\g -> \\a -> f (g a)" - renderWithWidth 5 doc `shouldBe` "\\f ->\n \\g ->\n \\a ->\n f (g a)" - - it "Line between let bindings" $ do - let expr' = unsafeParseExpr "let a = 1; a" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "let a = 1 in a" - renderWithWidth 5 doc `shouldBe` "let a =\n 1;\n\na" - - it "Line between let pair bindings" $ do - let expr' = unsafeParseExpr "let (a,b) = (1,2); a" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "let (a, b) = ((1, 2)) in a" - renderWithWidth 5 doc `shouldBe` "let (a, b) =\n ((1,\n 2));\n\na" - - it "Spreads long pairs across two lines" $ do - let expr' = unsafeParseExpr "(\"horseshorseshorses1\",\"horseshorseshorses2\")" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "(\"horseshorseshorses1\", \"horseshorseshorses2\")" - renderWithWidth 5 doc `shouldBe` "(\"horseshorseshorses1\",\n \"horseshorseshorses2\")" - - it "Renders empty record nicely" $ do - let expr' = unsafeParseExpr "{}" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "{}" - renderWithWidth 5 doc `shouldBe` "{}" - - it "Renders records nicely" $ do - let expr' = unsafeParseExpr "{a:1,b:2,c:3,d:4,e:5}" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "{ a: 1, b: 2, c: 3, d: 4, e: 5 }" - renderWithWidth 5 doc `shouldBe` "{ a: 1,\n b: 2,\n c: 3,\n d: 4,\n e: 5 }" - - it "Renders if nicely" $ do - let expr' = unsafeParseExpr "if True then 1 else 2" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "if True then 1 else 2" - renderWithWidth 4 doc `shouldBe` "if True\nthen\n 1\nelse\n 2" - - it "Renders datatype nicely with two line break" $ do - let expr' = unsafeParseDataType "type These a = That a" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "type These a = That a" - renderWithWidth 5 doc `shouldBe` "type These a \n = That\n a" - - it "Renders new function syntax nicely" $ do - let expr' = unsafeParseExpr "let const a b = a in 1" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "let const a b = a in 1" - renderWithWidth 5 doc `shouldBe` "let const a b =\n a;\n\n1" - - it "Renders annotation for let" $ do - let expr' = unsafeParseExpr "let (num: Int) = 3; True" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "let (num: Int) = 3 in True" - - it "Renders annotation for let function" $ do - let expr' = unsafeParseExpr "let (const: a -> b -> a) a b = a; True" - doc = prettyDoc expr' - renderWithWidth 50 doc `shouldBe` "let (const: a -> b -> a) a b = a in True" - - describe "MonoType" $ do - it "String" $ - T.putStrLn (prettyPrint MTString) - it "Function" $ - let mt :: MonoType - mt = - MTFunction - mempty - (MTFunction mempty (MTPrim mempty MTInt) (MTPrim mempty MTString)) - (MTPrim mempty MTBool) - in T.putStrLn - ( prettyPrint mt - ) - it "Record" $ - let mt :: MonoType - mt = - MTRecord - mempty - ( M.fromList - [ ("dog", MTPrim mempty MTBool), - ("horse", MTPrim mempty MTString), - ( "maybeDog", - dataTypeWithVars - mempty - Nothing - "Maybe" - [MTPrim mempty MTString] - ) - ] - ) - Nothing - in T.putStrLn - ( prettyPrint mt - ) - it "Pair" $ - let mt :: MonoType - mt = - MTTuple - mempty - (MTFunction mempty (MTPrim mempty MTInt) (MTPrim mempty MTInt)) - (NE.singleton $ MTPrim mempty MTString) - in T.putStrLn - (prettyPrint mt) - it "Variables" $ - let mt :: MonoType - mt = - MTFunction - mempty - ( MTVar mempty $ - tvNamed "catch" - ) - (MTVar mempty $ TVUnificationVar 22) - in T.putStrLn - ( prettyPrint mt - ) - it "Names type vars" $ do - let mt = MTVar () (TVUnificationVar 1) - prettyPrint mt `shouldBe` "a" - it "Names type vars 2" $ do - let mt = MTVar () (TVUnificationVar 26) - prettyPrint mt `shouldBe` "z" - it "Names type vars 3" $ do - let mt = MTVar () (TVUnificationVar 27) - prettyPrint mt `shouldBe` "a1" diff --git a/core/test/CoreTest/Utils/Helpers.hs b/core/test/CoreTest/Utils/Helpers.hs deleted file mode 100644 index 045d9b52..00000000 --- a/core/test/CoreTest/Utils/Helpers.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CoreTest.Utils.Helpers - ( joinLines, - fromRight, - fromLeft, - fromJust, - unsafeParseExpr', - int, - bool, - unknown, - str', - textErrorContains, - str, - unsafeParseExpr, - mtBool, - mtString, - mtVar, - mtInt, - unsafeParseDataType, - tvNamed, - tvNum, - typeName, - unsafeParseModuleItem, - mtFun, - unsafeParseMonoType, - ) -where - -import Data.Functor -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core - -joinLines :: [Text] -> Text -joinLines = T.intercalate "\n" - -fromRight :: (Printer e) => Either e a -> a -fromRight either' = case either' of - Left e -> error (T.unpack $ prettyPrint e) - Right a -> a - -fromLeft :: Either e a -> e -fromLeft either' = case either' of - Left e -> e - Right _ -> error "Expected a Left!" - -fromJust :: Maybe a -> a -fromJust maybe' = case maybe' of - Just a -> a - _ -> error "Expected a Just" - -unsafeParseExpr' :: (Monoid ann) => Text -> Expr Name ann -unsafeParseExpr' t = case parseExpr t of - Right a -> a $> mempty - Left _ -> - error $ - "Error parsing expr for Prettier tests:" - <> T.unpack t - -unsafeParseDataType :: Text -> DataType -unsafeParseDataType t = case parseTypeDecl t of - Right a -> a - Left _ -> error $ "could not parse data type: " <> T.unpack t - -unsafeParseExpr :: Text -> Expr Name () -unsafeParseExpr = unsafeParseExpr' - -unsafeParseModuleItem :: (Monoid ann) => Text -> ModuleItem ann -unsafeParseModuleItem t = case parseAndFormat moduleParser t of - Right [item] -> item $> mempty - Right _many -> error "ModuleItem parser succeeded but did not have 1 item" - Left e -> error $ "Error parsing ModuleItem for tests: " <> T.unpack (prettyPrint e) - -unsafeParseMonoType :: Text -> Type () -unsafeParseMonoType t = case parseMonoType t of - Right a -> a $> () - Left _ -> - error $ - "Error parsing monotype for Prettier tests:" - <> T.unpack t - -textErrorContains :: Text -> Either Text a -> Bool -textErrorContains s res = case res of - Left e -> s `T.isInfixOf` e - _ -> False - -bool :: (Monoid ann) => Bool -> Expr a ann -bool a = MyLiteral mempty (MyBool a) - -int :: (Monoid ann) => Int -> Expr a ann -int a = MyLiteral mempty (MyInt a) - -str :: (Monoid ann) => StringType -> Expr a ann -str a = MyLiteral mempty (MyString a) - -str' :: (Monoid ann) => Text -> Expr a ann -str' = str . StringType - --- -unknown :: (Monoid ann) => Int -> Type ann -unknown = MTVar mempty . TVUnificationVar - -typeName :: (Monoid ann) => Text -> Type ann -typeName = MTVar mempty . TVName . mkTyVar - ---- - -tvNum :: Int -> TypeIdentifier -tvNum = TVUnificationVar - -tvNamed :: Text -> TypeIdentifier -tvNamed t = TVName $ mkTyVar t - ----- - -mtInt :: (Monoid ann) => Type ann -mtInt = MTPrim mempty MTInt - -mtBool :: (Monoid ann) => Type ann -mtBool = MTPrim mempty MTBool - -mtString :: (Monoid ann) => Type ann -mtString = MTPrim mempty MTString - -mtVar :: (Monoid ann) => Text -> Type ann -mtVar n = MTVar mempty (tvNamed n) - -mtFun :: (Monoid ann) => Type ann -> Type ann -> Type ann -mtFun = MTFunction mempty diff --git a/core/test/Spec.hs b/core/test/Spec.hs deleted file mode 100644 index 09e781b1..00000000 --- a/core/test/Spec.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Main - ( main, - ) -where - -import qualified CoreTest.Parser.DataTypes -import qualified CoreTest.Parser.MonoTypeParser -import qualified CoreTest.Parser.Pattern -import qualified CoreTest.Parser.Syntax -import qualified CoreTest.Prettier -import Test.Hspec - -main :: IO () -main = - hspec $ do - CoreTest.Parser.DataTypes.spec - CoreTest.Parser.MonoTypeParser.spec - CoreTest.Parser.Pattern.spec - CoreTest.Parser.Syntax.spec - CoreTest.Prettier.spec diff --git a/flake.nix b/flake.nix index 824f6244..68d30065 100644 --- a/flake.nix +++ b/flake.nix @@ -62,7 +62,7 @@ jailbreakUnbreak = pkg: pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); - packageName = "mimsa"; + packageName = "llvm-calc"; in { # we're not interested in building with Nix, just using it for deps @@ -74,16 +74,12 @@ buildInputs = with haskellPackages; [ oldHaskellPackages.hlint oldHaskellPackages.ormolu - # haskell-language-server # this simply does nothing atm ghcid cabal-fmt cabal-install ghc - pkgs.zlib # used by `digest` package - pkgs.nodejs-18_x pkgs.clang_14 pkgs.llvmPackages_14.llvm - pkgs.nodePackages.ts-node ]; # put clang_14 on the path diff --git a/repl/.dockerignore b/repl/.dockerignore deleted file mode 100644 index d7e4614b..00000000 --- a/repl/.dockerignore +++ /dev/null @@ -1,2 +0,0 @@ -.stack-work -dist-newstyle diff --git a/repl/.gitignore b/repl/.gitignore deleted file mode 100644 index a19ce96d..00000000 --- a/repl/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -.direnv/ - -.stack-work/ -*~ -store/*.json -result -result/ - -output/ - -*.hie -swagger.json - -# .prof files generated for profiling -*.prof - -# cabal shit -dist-newstyle diff --git a/repl/LICENSE b/repl/LICENSE deleted file mode 100644 index e637cdee..00000000 --- a/repl/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/repl/repl.cabal b/repl/repl.cabal deleted file mode 100644 index 4f29f3d2..00000000 --- a/repl/repl.cabal +++ /dev/null @@ -1,82 +0,0 @@ -cabal-version: 2.2 -name: repl -version: 0.1.0.0 -description: - Please see the README on GitHub at - -homepage: https://github.com/danieljharvey/mimsa#readme -bug-reports: https://github.com/danieljharvey/mimsa/issues -author: Daniel J Harvey -maintainer: danieljamesharvey@gmail.com -copyright: 2021 Daniel J Harvey -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple - -source-repository head - type: git - location: https://github.com/danieljharvey/mimsa - -common common-all - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - -executable mimsa-repl - import: common-all - main-is: Main.hs - other-modules: - Check.Main - Compile.Main - Eval.Main - Init.Main - Repl.Actions - Repl.Actions.Bindings - Repl.Actions.BindModule - Repl.Actions.Compile - Repl.Actions.Evaluate - Repl.Actions.ListModules - Repl.Helpers - Repl.Main - Repl.Parser - Repl.Persistence - Repl.ReplM - Repl.Types - Shared.LoadProject - - hs-source-dirs: repl - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - , aeson - , backends - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , cryptonite - , diagnose - , directory - , exceptions - , file-embed - , hashable - , haskeline - , megaparsec - , memory - , mimsa - , monad-logger - , mtl - , openapi3 - , optparse-applicative - , parallel - , parser-combinators - , prettyprinter - , QuickCheck - , text - , transformers - , wasm - , zip-archive - - default-language: Haskell2010 diff --git a/repl/repl/Check/Main.hs b/repl/repl/Check/Main.hs deleted file mode 100644 index 6bb2758b..00000000 --- a/repl/repl/Check/Main.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Check.Main - ( check, - ) -where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Either -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.Mimsa.Actions.Modules.Check as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store.RootPath -import Repl.Helpers -import Repl.ReplM -import Repl.Types -import qualified Shared.LoadProject as Shared -import System.Directory -import System.Exit -import Prelude hiding (init) - -createReplConfig :: (MonadIO m) => Bool -> m ReplConfig -createReplConfig showLogs' = do - path <- liftIO getCurrentDirectory - pure $ ReplConfig (RootPath path) showLogs' - --- read a file, check if it is OK etc -checkFile :: Text -> ReplM (Error Annotation) ExitCode -checkFile filePath = do - replOutput ("Reading " <> T.pack (show filePath)) - fileContents <- liftIO $ T.readFile (T.unpack filePath) - - maybeProject <- Shared.loadProject - -- use project if we're in one, if not, stdlib - let project = fromRight stdlib maybeProject - -- check module - case Actions.run project (Actions.checkModule (prjModuleStore project) fileContents) of - Right (_, _, (mod', testResults)) -> do - liftIO $ T.putStrLn $ prettyPrint mod' - liftIO $ T.putStrLn $ prettyPrint testResults -- should failing tests means a non-zero exit code? - -- format and rewrite - -- liftIO $ T.writeFile (T.unpack filePath) (prettyPrint mod') - pure ExitSuccess - Left err -> do - outputErrorAsDiagnostic err - pure (ExitFailure 1) - -check :: Bool -> Text -> IO () -check showLogs' filePath = do - cfg <- createReplConfig showLogs' - exitCode <- runReplM cfg (checkFile filePath) - case exitCode of - Right ec -> exitWith ec - _ -> exitWith $ ExitFailure 1 diff --git a/repl/repl/Compile/Main.hs b/repl/repl/Compile/Main.hs deleted file mode 100644 index 124ff322..00000000 --- a/repl/repl/Compile/Main.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Compile.Main - ( compile, - ) -where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Compile as Actions -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store.RootPath -import Repl.Helpers -import Repl.ReplM -import Repl.Types -import qualified Shared.LoadProject as Shared -import System.Directory -import System.Exit - -createReplConfig :: (MonadIO m) => Bool -> m ReplConfig -createReplConfig showLogs' = do - path <- liftIO getCurrentDirectory - pure $ ReplConfig (RootPath path) showLogs' - -compileProject :: Backend -> ReplM (Error Annotation) ExitCode -compileProject be = do - maybeProject <- Shared.loadProject - case maybeProject of - Right project -> do - _ <- - toReplM project (Actions.compileProject be) - replOutput @Text "Compilation complete!" - pure ExitSuccess - Left _e -> do - replOutput @Text "Failed to load project, have you initialised a project in this folder?" - pure (ExitFailure 1) - -compile :: Backend -> Bool -> IO () -compile be showLogs' = do - cfg <- createReplConfig showLogs' - exitCode <- runReplM cfg (compileProject be) - case exitCode of - Right ec -> exitWith ec - _ -> exitWith $ ExitFailure 1 diff --git a/repl/repl/Eval/Main.hs b/repl/repl/Eval/Main.hs deleted file mode 100644 index 7ccf4f07..00000000 --- a/repl/repl/Eval/Main.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Eval.Main - ( eval, - ) -where - -import Control.Monad.Except -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Either -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Helpers.Parse as Actions -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Store.RootPath -import Repl.Helpers -import Repl.ReplM -import Repl.Types -import qualified Shared.LoadProject as Shared -import System.Directory -import System.Exit -import Prelude hiding (init) - -createReplConfig :: (MonadIO m) => Bool -> m ReplConfig -createReplConfig showLogs' = do - path <- liftIO getCurrentDirectory - pure $ ReplConfig (RootPath path) showLogs' - ---------- - --- evaluate an expression -evalInput :: Text -> ReplM (Error Annotation) ExitCode -evalInput input = do - maybeProject <- Shared.loadProject - -- use project if we're in one, if not, stdlib - let project = fromRight stdlib maybeProject - let action = do - expr <- Actions.parseExpr input - Actions.evaluateModule expr mempty - result <- - (Right <$> toReplM project action) - `catchError` (pure . Left) - - let returnCode = - if isRight result - then ExitSuccess - else ExitFailure 1 - -- - pure returnCode - -eval :: Bool -> Text -> IO () -eval showLogs' input = do - cfg <- createReplConfig showLogs' - exitCode <- runReplM cfg (evalInput input) - case exitCode of - Right ec -> exitWith ec - _ -> exitWith $ ExitFailure 1 diff --git a/repl/repl/Init/Main.hs b/repl/repl/Init/Main.hs deleted file mode 100644 index 2ce68aef..00000000 --- a/repl/repl/Init/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Init.Main - ( init, - ) -where - -import Control.Monad.Reader -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Store.Storage -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store.RootPath -import Repl.Persistence -import Repl.ReplM -import Repl.Types -import System.Directory -import Prelude hiding (init) - -createReplConfig :: (MonadIO m) => Bool -> m ReplConfig -createReplConfig showLogs' = do - path <- liftIO getCurrentDirectory - pure $ ReplConfig (RootPath path) showLogs' - --- start a new project, using the stdlib bindings as a starting point -initialiseProject :: ReplM (Error Annotation) (Project Annotation) -initialiseProject = do - rootPath <- asks rcRootPath - saveAllInStore rootPath (prjStore stdlib) - saveModulesInStore rootPath (prjModuleStore stdlib) - _ <- mapReplError StoreErr (saveProject stdlib) - replOutput ("New project created in " <> T.pack (show rootPath)) - pure stdlib - -init :: Bool -> IO () -init showLogs' = do - cfg <- createReplConfig showLogs' - _ <- runReplM cfg initialiseProject - pure () diff --git a/repl/repl/Main.hs b/repl/repl/Main.hs deleted file mode 100644 index 71b9743a..00000000 --- a/repl/repl/Main.hs +++ /dev/null @@ -1,114 +0,0 @@ -module Main where - -import qualified Check.Main as Check -import qualified Compile.Main as Compile -import Control.Applicative -import Data.Text (Text) -import qualified Eval.Main as Eval -import qualified Init.Main as Init -import Language.Mimsa.Backend.Types -import qualified Options.Applicative as Opt -import qualified Repl.Main as Repl -import System.IO - --- | this runs the repl -parseShowLogs :: Opt.Parser Bool -parseShowLogs = - Opt.flag' True (Opt.short 'v' <> Opt.long "verbose") - <|> pure False - -data AppAction - = Repl - | Init - | Check Text -- check if a file is `ok` - | Eval Text -- evaluate an expression - | Compile Backend -- compile all of a project - -parseAppAction :: Opt.Parser AppAction -parseAppAction = - Opt.hsubparser - ( Opt.command - "repl" - ( Opt.info - (pure Repl) - (Opt.progDesc "Start new module-based Mimsa repl") - ) - <> Opt.command - "init" - ( Opt.info - (pure Init) - (Opt.progDesc "Create a new mimsa project in the current folder") - ) - <> Opt.command - "check" - ( Opt.info - (Check <$> filePathParse) - (Opt.progDesc "Check whether a file is valid and OK etc") - ) - <> Opt.command - "eval" - ( Opt.info - (Eval <$> expressionParse) - (Opt.progDesc "Evaluate an expression. Standard library modules are available for use in the expression.") - ) - <> Opt.command - "compile" - ( Opt.info - (Compile <$> parseBackend) - (Opt.progDesc "Compile the entire project") - ) - ) - -filePathParse :: Opt.Parser Text -filePathParse = - Opt.argument - Opt.str - (Opt.metavar "") - -expressionParse :: Opt.Parser Text -expressionParse = - Opt.argument - Opt.str - (Opt.metavar "") - -parseBackend :: Opt.Parser Backend -parseBackend = - Opt.hsubparser - ( Opt.command - "typescript" - ( Opt.info - (pure Typescript) - (Opt.progDesc "Compile as Typescript") - ) - <> Opt.command - "javascript" - ( Opt.info - (pure ESModulesJS) - (Opt.progDesc "Compile as ES Javascript") - ) - ) - -optionsParse :: Opt.Parser (AppAction, Bool) -optionsParse = (,) <$> parseAppAction <*> parseShowLogs - -helpfulPreferences :: Opt.ParserPrefs -helpfulPreferences = - Opt.defaultPrefs - { Opt.prefShowHelpOnError = True, - Opt.prefShowHelpOnEmpty = True - } - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - (action, showLogs) <- - Opt.customExecParser - helpfulPreferences - (Opt.info (optionsParse <**> Opt.helper) Opt.fullDesc) - case action of - Init -> Init.init showLogs - Repl -> Repl.repl showLogs - Check filePath -> Check.check showLogs filePath - Eval expr -> Eval.eval showLogs expr - Compile be -> Compile.compile be showLogs diff --git a/repl/repl/Repl/Actions.hs b/repl/repl/Repl/Actions.hs deleted file mode 100644 index 5ca0b6dd..00000000 --- a/repl/repl/Repl/Actions.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Repl.Actions - ( doReplAction, - doHelp, - ) -where - -import Data.Functor -import Data.Text (Text) -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Repl.Actions.BindModule -import Repl.Actions.Bindings -import Repl.Actions.Compile -import Repl.Actions.Evaluate -import Repl.Actions.ListModules -import Repl.Helpers -import Repl.ReplM -import Repl.Types - -doReplAction :: - Project Annotation -> - ReplAction Annotation -> - ReplM (Error Annotation) (Project Annotation) -doReplAction prj action = - case action of - Help -> do - doHelp - pure prj - ListModules modName -> - catchMimsaError prj (doListModules prj modName $> prj) - ListBindings -> - catchMimsaError prj (doListBindings $> prj) - BindModule modName -> - catchMimsaError prj (doBindModule prj modName) - (Evaluate expr) -> - catchMimsaError prj (doEvaluate prj expr $> prj) - (AddBinding modItem) -> - catchMimsaError - prj - ( doAddBinding prj modItem $> prj - ) - (OutputModuleJS be moduleName) -> - catchMimsaError prj (doOutputModuleJS prj be moduleName $> prj) - ----------- - -doHelp :: ReplM e () -doHelp = do - replOutput @Text "~~~ MIMSA ~~~" - replOutput @Text ":help - this help screen" - replOutput @Text ":modules - show a list of modules in the project or details of a module" - replOutput @Text ":list - show a list of bindings created in this repl session" - replOutput @Text ":bind - bind an expression, infix or type" - replOutput @Text ":save - save everything created in this repl session into a new module" - replOutput @Text " - Evaluate , returning it's simplified form and type" - replOutput @Text ":compile - compile module" - replOutput @Text ":quit - give up and leave" - ----------- diff --git a/repl/repl/Repl/Actions/BindModule.hs b/repl/repl/Repl/Actions/BindModule.hs deleted file mode 100644 index 85d50618..00000000 --- a/repl/repl/Repl/Actions/BindModule.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Repl.Actions.BindModule - ( doBindModule, - ) -where - -import qualified Language.Mimsa.Actions.Modules.Bind as Actions -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Repl.Helpers -import Repl.ReplM - --- | give the global module a name and clear it -doBindModule :: - Project Annotation -> - ModuleName -> - ReplM (Error Annotation) (Project Annotation) -doBindModule project modName = do - typedModule <- getStoredModule - - let untypedModule = getAnnotationForType <$> typedModule - - -- add the new binding - (newProject, _) <- - toReplM - project - (Actions.bindModule untypedModule modName (prettyPrint typedModule)) - - replOutput $ "Stored repl module to " <> prettyPrint modName - - replDocOutput (prettyDoc typedModule) - - -- clear the module in Repl state - setStoredModule mempty - - pure newProject diff --git a/repl/repl/Repl/Actions/Bindings.hs b/repl/repl/Repl/Actions/Bindings.hs deleted file mode 100644 index 01c99dbc..00000000 --- a/repl/repl/Repl/Actions/Bindings.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Repl.Actions.Bindings - ( doAddBinding, - doListBindings, - ) -where - -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Modules.Bind as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Pretty -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Repl.Helpers -import Repl.ReplM - --- | add a binding to the global repl module -doAddBinding :: - Project Annotation -> - ModuleItem Annotation -> - ReplM (Error Annotation) () -doAddBinding project modItem = do - oldModule <- getStoredModule - -- add the new binding - (_prj, (newModule, testResults)) <- toReplM project (Actions.addBindingToModule mempty oldModule modItem) - - -- show test results - replOutput testResults - - -- store the new module in Repl state - setStoredModule newModule - --- | what is in the current implicit repl module -doListBindings :: ReplM (Error Annotation) () -doListBindings = do - oldModule <- getStoredModule - -- output to console - if oldModule == mempty - then replOutput ("Current module is empty" :: Text) - else replDocOutput (modulePretty oldModule) diff --git a/repl/repl/Repl/Actions/Compile.hs b/repl/repl/Repl/Actions/Compile.hs deleted file mode 100644 index fb88d6b7..00000000 --- a/repl/repl/Repl/Actions/Compile.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Repl.Actions.Compile - ( doOutputModuleJS, - ) -where - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Compile as Actions -import qualified Language.Mimsa.Actions.Helpers.LookupExpression as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Repl.Helpers -import Repl.ReplM - -doOutputModuleJS :: - Project Annotation -> - Maybe Backend -> - ModuleName -> - ReplM (Error Annotation) () -doOutputModuleJS project maybeBackend moduleName = do - let be = fromMaybe ESModulesJS maybeBackend - (_, _, foundModule) <- - replMFromEither $ - Actions.run - project - (Actions.lookupModuleByName moduleName) - (_, _) <- - toReplM project (Actions.compileModule be foundModule) - replOutput @Text "Compilation complete!" diff --git a/repl/repl/Repl/Actions/Evaluate.hs b/repl/repl/Repl/Actions/Evaluate.hs deleted file mode 100644 index 335695f6..00000000 --- a/repl/repl/Repl/Actions/Evaluate.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Repl.Actions.Evaluate - ( doEvaluate, - ) -where - -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Prettyprinter -import Repl.Helpers -import Repl.ReplM - -doEvaluate :: - Project Annotation -> - Expr Name Annotation -> - ReplM (Error Annotation) () -doEvaluate project expr = do - oldModule <- fmap getAnnotationForType <$> getStoredModule - - (_prj, (exprType, evaluatedExpression, _)) <- - toReplM project (Actions.evaluateModule expr oldModule) - - -- print - replDocOutput - ( group - ( prettyDoc evaluatedExpression - <> line - <> "::" - <> line - <> prettyDoc exprType - ) - ) - - pure () - ---------- diff --git a/repl/repl/Repl/Actions/ListModules.hs b/repl/repl/Repl/Actions/ListModules.hs deleted file mode 100644 index ebd2ff5c..00000000 --- a/repl/repl/Repl/Actions/ListModules.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Repl.Actions.ListModules - ( doListModules, - ) -where - -import Data.Foldable (traverse_) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Language.Mimsa.Actions.Helpers.LookupExpression as Actions -import qualified Language.Mimsa.Actions.Modules.Typecheck as Actions -import Language.Mimsa.Core -import Language.Mimsa.Modules.Pretty -import Language.Mimsa.Project -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Repl.Helpers -import Repl.ReplM - --- | get module from project --- | typecheck it --- | pretty display it -showModule :: Project Annotation -> ModuleHash -> ReplM (Error Annotation) () -showModule prj modHash = do - let action = do - mod' <- Actions.lookupModule modHash - Actions.typecheckModule (prettyPrint mod') mod' - (_, typedMod) <- toReplM prj action - replDocOutput (modulePretty typedMod) - -doListModules :: Project Annotation -> Maybe ModuleName -> ReplM (Error Annotation) () -doListModules project Nothing = do - let moduleNames = M.keys (getCurrentModules $ prjModules project) - traverse_ replOutput moduleNames -doListModules project (Just modName) = do - case M.lookup modName (getCurrentModules $ prjModules project) of - Just moduleHash -> showModule project moduleHash - Nothing -> replOutput @Text $ "Could not find module " <> prettyPrint modName diff --git a/repl/repl/Repl/Helpers.hs b/repl/repl/Repl/Helpers.hs deleted file mode 100644 index 74b44a98..00000000 --- a/repl/repl/Repl/Helpers.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Repl.Helpers - ( saveExpression, - toReplM, - catchMimsaError, - outputErrorAsDiagnostic, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Data.Foldable (traverse_) -import Error.Diagnose hiding (Annotation) -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Store -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store -import Repl.ReplM -import Repl.Types - --- | if an error has been thrown, log it and return default value -catchMimsaError :: - a -> - ReplM e a -> - ReplM e a -catchMimsaError defValue computation = - computation `catchError` \_e -> do - pure defValue - --- | Actually save a StoreExpression to disk -saveExpression :: - StoreExpression Annotation -> - ReplM (Error Annotation) ExprHash -saveExpression se = do - rootPath <- asks rcRootPath - mapReplError StoreErr (saveExpr rootPath se) - --- | Actually save a file to disk -saveFile' :: - (Actions.SavePath, Actions.SaveFilename, Actions.SaveContents) -> - ReplM (Error Annotation) () -saveFile' details = do - rootPath <- asks rcRootPath - mapReplError StoreErr (saveFile rootPath details) - --- | Run an Action, printing any messages to the console and saving any --- expressions to disk -toReplM :: - Project Annotation -> - Actions.ActionM a -> - ReplM (Error Annotation) (Project Annotation, a) -toReplM project action = case Actions.run project action of - Left e -> do - outputErrorAsDiagnostic e - throwError e - Right (newProject, outcomes, a) -> do - traverse_ replOutput (Actions.messagesFromOutcomes outcomes) - traverse_ saveExpression (Actions.storeExpressionsFromOutcomes outcomes) - traverse_ saveFile' (Actions.writeFilesFromOutcomes outcomes) - pure (newProject, a) - --- use diagnostics for errors where possible, falling back to boring errors -outputErrorAsDiagnostic :: Error Annotation -> ReplM e () -outputErrorAsDiagnostic err' = - let diag = errorToDiagnostic err' - in printDiagnostic stderr True True 4 defaultStyle diag diff --git a/repl/repl/Repl/Main.hs b/repl/repl/Repl/Main.hs deleted file mode 100644 index 8692c8b1..00000000 --- a/repl/repl/Repl/Main.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Repl.Main - ( repl, - ) -where - -import Control.Monad.Except -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Control.Monad.Trans.Class (lift) -import Data.Text (Text) -import qualified Data.Text as T -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store.RootPath -import Repl.Actions (doReplAction) -import Repl.Helpers -import Repl.Parser (replParser) -import Repl.Persistence -import Repl.ReplM -import Repl.Types -import qualified Shared.LoadProject as Shared -import System.Console.Haskeline -import System.Directory -import Text.Megaparsec - -createReplConfig :: (MonadIO m) => Bool -> m ReplConfig -createReplConfig showLogs' = do - path <- liftIO getCurrentDirectory - pure $ ReplConfig (RootPath path) showLogs' - -getProject :: ReplM (Error Annotation) (Project Annotation) -getProject = - do - maybeProject <- Shared.loadProject - case maybeProject of - Right prj -> do - let moduleItems = length . prjModuleStore $ prj - replOutput ("Successfully loaded project." :: Text) - replOutput $ T.pack (show moduleItems) <> " modules found" - pure prj - Left e -> do - logDebugN (prettyPrint e) - replOutput @Text "Failed to load project, have you initialised a project in this folder?" - throwError e - -repl :: Bool -> IO () -repl showLogs' = do - cfg <- createReplConfig showLogs' - _ <- runReplM cfg replLoop - pure () - -replLoop :: ReplM (Error Annotation) () -replLoop = do - env <- getProject - _ <- doReplAction env Help - runInputT defaultSettings (loop env) - where - loop :: - Project Annotation -> - InputT (ReplM (Error Annotation)) () - loop exprs' = do - minput <- getInputLine ":> " - case minput of - Nothing -> return () - Just ":quit" -> return () - Just input -> do - newEnv <- lift $ parseCommand exprs' (T.pack input) - loop newEnv - -parseCommand :: - Project Annotation -> - Text -> - ReplM (Error Annotation) (Project Annotation) -parseCommand env input = - case parse replParser "" input of - Left errBundle -> do - outputErrorAsDiagnostic (ParseError input errBundle) - pure env - Right replAction -> do - newExprs <- doReplAction env replAction - _ <- mapReplError StoreErr (saveProject newExprs) - pure newExprs diff --git a/repl/repl/Repl/Parser.hs b/repl/repl/Repl/Parser.hs deleted file mode 100644 index e60ffae3..00000000 --- a/repl/repl/Repl/Parser.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Repl.Parser - ( replParser, - ) -where - -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Repl.Types -import Text.Megaparsec - -type ReplActionAnn = ReplAction Annotation - -replParser :: Parser ReplActionAnn -replParser = - try helpParser - <|> listModulesParser - <|> listBindingsParser - <|> bindModuleParser - <|> try addBindingParser - <|> try outputJSModuleParser - <|> evalParser - -helpParser :: Parser ReplActionAnn -helpParser = Help <$ myString ":help" - -evalParser :: Parser ReplActionAnn -evalParser = - Evaluate - <$> expressionParser - -listModulesParser :: Parser ReplActionAnn -listModulesParser = do - myString ":modules" - modName <- optional moduleNameParser - pure (ListModules modName) - -listBindingsParser :: Parser ReplActionAnn -listBindingsParser = ListBindings <$ myString ":list" - --- return very basic error -explode :: String -> Parser any -explode msg = - failure Nothing (S.singleton (Label (NE.fromList msg))) - -addBindingParser :: Parser ReplActionAnn -addBindingParser = AddBinding <$> singleModuleItemParser - where - singleModuleItemParser = do - _ <- myString ":bind" - item <- moduleParser - case item of - [] -> explode "Expected a module binding" - [a] -> pure a - _other -> explode "Expected a single module binding" - -bindModuleParser :: Parser ReplActionAnn -bindModuleParser = do - _ <- myString ":save" - BindModule <$> moduleNameParser - -backendParser :: Parser (Maybe Backend) -backendParser = - myString "javascript" - $> Just ESModulesJS - <|> myString "typescript" - $> Just Typescript - <|> pure Nothing - -outputJSModuleParser :: Parser ReplActionAnn -outputJSModuleParser = do - myString ":compile" - be <- backendParser - OutputModuleJS be <$> moduleNameParser diff --git a/repl/repl/Repl/Persistence.hs b/repl/repl/Repl/Persistence.hs deleted file mode 100644 index d83cd2e4..00000000 --- a/repl/repl/Repl/Persistence.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Repl.Persistence - ( loadProject, - saveProject, - ) -where - --- functions for Projects as opposed to the larger Store - -import Control.Exception -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as LBS -import Data.Functor -import qualified Data.Text as T -import Language.Mimsa.Project.Helpers -import Language.Mimsa.Store.Hashing -import Language.Mimsa.Store.Persistence -import Language.Mimsa.Types.Error.StoreError -import Language.Mimsa.Types.Project -import Language.Mimsa.Types.Store.RootPath -import Repl.Types - -projectFilePath :: RootPath -> String -projectFilePath (RootPath rp) = rp <> "/mimsa.json" - --- load environment.json and any hashed exprs mentioned in it --- should probably consider loading the exprs lazily as required in future -loadProject :: - (MonadIO m, MonadError StoreError m, Monoid ann, MonadReader ReplConfig m, MonadLogger m) => - m (Project ann) -loadProject = do - proj <- loadProject' - pure $ proj $> mempty - -loadProject' :: - (MonadIO m, MonadError StoreError m, MonadLogger m, MonadReader ReplConfig m) => - m (Project ()) -loadProject' = do - rootPath <- asks rcRootPath - logDebugN ("Attempting to load project file at " <> T.pack (projectFilePath rootPath)) - project' <- liftIO $ try $ LBS.readFile (projectFilePath rootPath) - case project' of - Left (_ :: IOError) -> throwError (CouldNotReadFilePath ProjectFile (projectFilePath rootPath)) - Right json' -> do - logDebugN "Project file found" - case JSON.decode json' of - Just sp -> do - logDebugN "Project file successfully decoded. Fetching project items...." - fetchProjectItems rootPath mempty mempty sp -- we're starting from scratch with this one - _ -> throwError $ CouldNotDecodeFile (projectFilePath rootPath) - --- save project in local folder -saveProject :: - (MonadIO m, MonadError StoreError m, MonadLogger m, MonadReader ReplConfig m) => - Project ann -> - m ProjectHash -saveProject p = saveProject' (p $> ()) - -saveProject' :: - (MonadIO m, MonadError StoreError m, MonadLogger m, MonadReader ReplConfig m) => - Project () -> - m ProjectHash -saveProject' env = do - rootPath <- asks rcRootPath - let (jsonStr, hash) = contentAndHash (projectToSaved env) - success <- liftIO $ try $ LBS.writeFile (projectFilePath rootPath) jsonStr - case success of - Left (_ :: IOError) -> - throwError (CouldNotWriteFilePath ProjectFile (projectFilePath rootPath)) - Right _ -> do - logDebugN ("Successfully updated project file at " <> T.pack (projectFilePath rootPath)) - pure hash - --- diff --git a/repl/repl/Repl/ReplM.hs b/repl/repl/Repl/ReplM.hs deleted file mode 100644 index 9168627b..00000000 --- a/repl/repl/Repl/ReplM.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Repl.ReplM - ( ReplM (..), - ReplState (..), - runReplM, - mapReplError, - setStoredModule, - getStoredModule, - replMFromEither, - replOutput, - replDocOutput, - ) -where - -import Control.Monad.Catch -import Control.Monad.Except -import Control.Monad.Logger - ( LoggingT, - MonadLogger, - filterLogger, - runStdoutLoggingT, - ) -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.Text.IO as T -import Language.Mimsa.Core -import Prettyprinter -import Repl.Types - --- | to allow us to do 'bindings' in the repl, --- we maintain a current Module and add to it -newtype ReplState = ReplState - { rsModule :: Module MonoType - } - --- | Although we are lucky and can keep much of our work --- outside of IO, we do need to do some Serious Business sometimes --- so here is a Monad to do it in -newtype ReplM e a = ReplM - { getReplM :: - ExceptT - e - ( LoggingT - ( ReaderT - ReplConfig - (StateT ReplState IO) - ) - ) - a - } - deriving newtype - ( Functor, - Applicative, - Monad, - MonadIO, - MonadReader ReplConfig, - MonadState ReplState, - MonadError e, - MonadLogger, - MonadThrow, - MonadCatch, - MonadMask - ) - --- | change error type -mapReplError :: (e -> e') -> ReplM e a -> ReplM e' a -mapReplError f = ReplM . withExceptT f . getReplM - --- | run this big brave boy -runReplM :: ReplConfig -> ReplM e a -> IO (Either e a) -runReplM config app = - let innerApp = runExceptT (getReplM app) - emptyState = ReplState mempty - in evalStateT - ( runReaderT - ( runStdoutLoggingT - (logFilter config innerApp) - ) - config - ) - emptyState - -logFilter :: ReplConfig -> LoggingT m a -> LoggingT m a -logFilter mc app = if rcShowLogs mc then app else filterLogger (\_ _ -> False) app - --- | lift Either into ReplM -replMFromEither :: Either e a -> ReplM e a -replMFromEither = ReplM . liftEither - --- | Output stuff for use in repl -replOutput :: (Printer a) => a -> ReplM e () -replOutput = liftIO . T.putStrLn . prettyPrint - --- | Output a Doc from prettyprinter -replDocOutput :: Doc a -> ReplM e () -replDocOutput = liftIO . T.putStrLn . renderWithWidth 40 - --- | we maintain a module in state, this allows us to update it -setStoredModule :: Module MonoType -> ReplM e () -setStoredModule newMod = - modify (\s -> s {rsModule = newMod}) - -getStoredModule :: ReplM e (Module MonoType) -getStoredModule = gets rsModule diff --git a/repl/repl/Repl/Types.hs b/repl/repl/Repl/Types.hs deleted file mode 100644 index 1efec02f..00000000 --- a/repl/repl/Repl/Types.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Repl.Types - ( ReplAction (..), - ReplConfig (..), - ) -where - -import GHC.Generics -import Language.Mimsa.Backend.Types -import Language.Mimsa.Core -import Language.Mimsa.Types.Store.RootPath - -data ReplAction ann - = Help - | Evaluate (Expr Name ann) - | AddBinding (ModuleItem ann) - | ListModules (Maybe ModuleName) - | ListBindings - | BindModule ModuleName - | OutputModuleJS (Maybe Backend) ModuleName - -data ReplConfig = ReplConfig - { rcRootPath :: RootPath, - rcShowLogs :: Bool - } - deriving stock (Generic, Eq, Ord, Show) diff --git a/repl/repl/Shared/LoadProject.hs b/repl/repl/Shared/LoadProject.hs deleted file mode 100644 index 2af93173..00000000 --- a/repl/repl/Shared/LoadProject.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Shared.LoadProject - ( loadProject, - ) -where - -import Control.Monad.Except -import Language.Mimsa.Core -import Language.Mimsa.Types.Error -import Language.Mimsa.Types.Project -import qualified Repl.Persistence as Repl -import Repl.ReplM - -loadProject :: - ReplM - (Error Annotation) - (Either (Error Annotation) (Project Annotation)) -loadProject = - do - env <- mapReplError StoreErr Repl.loadProject - pure (Right env) - `catchError` (pure . Left) diff --git a/smol-backend/.gitignore b/smol-backend/.gitignore deleted file mode 100644 index 39dffb9e..00000000 --- a/smol-backend/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -dist-newstyle -.direnv diff --git a/smol-backend/CHANGELOG.md b/smol-backend/CHANGELOG.md deleted file mode 100644 index fcf2589c..00000000 --- a/smol-backend/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for nix-basic - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/smol-backend/smol-backend.cabal b/smol-backend/smol-backend.cabal deleted file mode 100644 index c4520168..00000000 --- a/smol-backend/smol-backend.cabal +++ /dev/null @@ -1,110 +0,0 @@ -cabal-version: 2.4 -name: smol-backend -version: 0.1.0.0 - --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: -author: Daniel Harvey -maintainer: danieljamesharvey@gmail.com - --- A copyright notice. --- copyright: --- category: -extra-source-files: - CHANGELOG.md - static/runtime.c - -common shared - ghc-options: - -threaded -rtsopts -with-rtsopts=-N -Wall - -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - - build-depends: - , base - , bytestring - , containers - , directory - , file-embed - , llvm-hs-pretty - , llvm-hs-pure - , mtl - , process - , smol-core - , string-conversions - , text - , unix - -library - import: shared - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - hs-source-dirs: src - default-language: Haskell2010 - exposed-modules: - Smol.Backend - Smol.Backend.Compile.RunLLVM - Smol.Backend.IR.FromExpr.DataTypes - Smol.Backend.IR.FromExpr.Expr - Smol.Backend.IR.FromExpr.Helpers - Smol.Backend.IR.FromExpr.Pattern - Smol.Backend.IR.FromExpr.Type - Smol.Backend.IR.FromExpr.Types - Smol.Backend.IR.IRExpr - Smol.Backend.IR.ToLLVM.Helpers - Smol.Backend.IR.ToLLVM.Patterns - Smol.Backend.IR.ToLLVM.ToLLVM - Smol.Backend.Types.GetPath - Smol.Backend.Types.PatternPredicate - -test-suite smol-backend-tests - import: shared - type: exitcode-stdio-1.0 - hs-source-dirs: test - hs-source-dirs: src - build-depends: - , hspec >=2.8.3 && <3 - , hspec-core >=2.8.3 && <3 - , nonempty-containers - - other-modules: - Smol.Backend - Smol.Backend.Compile.RunLLVM - Smol.Backend.IR.FromExpr.DataTypes - Smol.Backend.IR.FromExpr.Expr - Smol.Backend.IR.FromExpr.Helpers - Smol.Backend.IR.FromExpr.Pattern - Smol.Backend.IR.FromExpr.Type - Smol.Backend.IR.FromExpr.Types - Smol.Backend.IR.IRExpr - Smol.Backend.IR.ToLLVM.Helpers - Smol.Backend.IR.ToLLVM.Patterns - Smol.Backend.IR.ToLLVM.ToLLVM - Smol.Backend.Types.GetPath - Smol.Backend.Types.PatternPredicate - Test.BuiltInTypes - Test.Helpers - Test.IR.CompileSpec - Test.IR.DataTypesSpec - Test.IR.FromExprSpec - Test.IR.IRSpec - Test.IR.PatternSpec - Test.IR.RawSamples - Test.IR.Samples - - main-is: Main.hs - default-language: Haskell2010 diff --git a/smol-backend/src/Smol/Backend.hs b/smol-backend/src/Smol/Backend.hs deleted file mode 100644 index 21a9ce93..00000000 --- a/smol-backend/src/Smol/Backend.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Smol.Backend - ( module Smol.Backend.Compile.RunLLVM, - ) -where - -import Smol.Backend.Compile.RunLLVM diff --git a/smol-backend/src/Smol/Backend/Compile/RunLLVM.hs b/smol-backend/src/Smol/Backend/Compile/RunLLVM.hs deleted file mode 100644 index 517c1570..00000000 --- a/smol-backend/src/Smol/Backend/Compile/RunLLVM.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Smol.Backend.Compile.RunLLVM (run, RunResult (..)) where - -import Control.Exception (bracket) -import Data.FileEmbed -import Data.String.Conversions -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import LLVM.AST hiding (Type, function) -import LLVM.Pretty -import System.CPUTime -import System.Directory -import System.IO -import System.Posix.Temp -import qualified System.Process as Sys -import qualified Text.Printf as Printf - --- these are saved in a file that is included in compilation -cRuntime :: Text -cRuntime = - T.decodeUtf8 $(makeRelativeToProject "static/runtime.c" >>= embedFile) - -time :: IO t -> IO (Text, t) -time a = do - start <- getCPUTime - v <- a - end <- getCPUTime - let diff = fromIntegral (end - start) / (10 ^ (12 :: Integer)) - let formatted = Printf.printf "%0.9f sec" (diff :: Double) - return (T.pack formatted, v) - --- compile some shit -compile :: Module -> FilePath -> IO () -compile llvmModule outfile = - bracket (mkdtemp "build") removePathForcibly $ \buildDir -> - withCurrentDirectory buildDir $ do - -- create temporary file for "output.ll" - (llvm, llvmHandle) <- mkstemps "output" ".ll" - (runtime, runtimeHandle) <- mkstemps "runtime" ".c" - - let moduleText = cs (ppllvm llvmModule) - - -- T.putStrLn moduleText - - -- write the llvmmodule Smol.Backend.to a file - T.hPutStrLn llvmHandle moduleText - T.hPutStrLn runtimeHandle cRuntime - - hClose llvmHandle - hClose runtimeHandle - -- link the runtime with the assembly - Sys.callProcess - "clang" - ["-Wno-override-module", "-lm", llvm, runtime, "-o", "../" <> outfile] - -data RunResult = RunResult - { rrResult :: Text, - rrComptime :: Text, - rrRuntime :: Text - } - --- run the code, get the output, die -run :: [(String, String)] -> Module -> IO RunResult -run runArgs llvmModule = do - (compTime, _) <- time (compile llvmModule "./a.out") - let process = - (Sys.proc "./a.out" []) - { Sys.env = Just runArgs - } - (runTime, result) <- time (cs <$> Sys.readCreateProcess process "") - removePathForcibly "./a.out" - pure (RunResult result compTime runTime) diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/DataTypes.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/DataTypes.hs deleted file mode 100644 index 6ab3b59a..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/DataTypes.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Backend.IR.FromExpr.DataTypes - ( getDataTypeInMemory, - typeToDataTypeInMemory, - patternTypeInMemory, - constructorTypeInMemory, - DataTypeInMemory (..), - ) -where - -import Control.Monad.Except -import Control.Monad.State -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Semigroup -import Data.Word (Word64) -import Smol.Backend.IR.FromExpr.Helpers -import Smol.Backend.IR.FromExpr.Types -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Subtype -import qualified Smol.Core.Typecheck.Types as Smol -import qualified Smol.Core.Types as Smol -import Smol.Core.Types.ResolvedDep - -patternTypeInMemory :: - ( Show ann, - MonadState (FromExprState ann) m - ) => - Smol.Pattern ResolvedDep (Smol.Type ResolvedDep ann) -> - m DataTypeInMemory -patternTypeInMemory (Smol.PLiteral ty _) = - toRepresentation ty -patternTypeInMemory (Smol.PVar ty _) = - toRepresentation ty -patternTypeInMemory (Smol.PTuple ty _ _) = - toRepresentation ty -patternTypeInMemory (Smol.PArray ty _ _) = - toRepresentation ty -patternTypeInMemory (Smol.PWildcard ty) = - toRepresentation ty -patternTypeInMemory (Smol.PConstructor ty c _) = - snd <$> constructorTypeInMemory ty (resolveConstructor c) - -constructorTypeInMemory :: - ( MonadState (FromExprState ann) m, - Show ann - ) => - Smol.Type ResolvedDep ann -> - Smol.Constructor -> - m (DataTypeInMemory, DataTypeInMemory) -constructorTypeInMemory ty constructor = do - -- there is probably a nicer version of this function that just returns - -- the whole amd speciic types - dtInMem <- typeToDataTypeInMemory ty - - pure $ case dtInMem of - (Right (DTDataType whole byConstructor)) -> - let consStruct = - case M.lookup constructor byConstructor of - Just found -> DTTuple $ [DTPrim Smol.TPInt] <> found - Nothing -> error "could not find constructor in types" - in (whole, consStruct) - (Right DTEnum) -> (DTEnum, DTEnum) - _ -> error "unexpected memory explanation" - -typeToDataTypeInMemory :: - ( MonadState (FromExprState ann) m, - Show ann - ) => - Smol.Type ResolvedDep ann -> - m (Either (Smol.TCError ann) DataTypeInMemory) -typeToDataTypeInMemory ty = do - result <- runExceptT $ flattenConstructorType ty - case result of - Right (typeName, typeArgs) -> do - dt <- lookupTypeName typeName - Right <$> getDataTypeInMemory dt typeArgs - Left e -> pure $ Left e - --- given a datatype, and enough args to fulfil it's vars (in order) --- plan data type as it will live in memory --- this will fail if passed more type vars, --- we need to get concrete, people -getDataTypeInMemory :: - ( Show ann, - MonadState (FromExprState ann) m - ) => - Smol.DataType ResolvedDep ann -> - [Smol.Type ResolvedDep ann] -> - m DataTypeInMemory -getDataTypeInMemory (Smol.DataType _ [] _constructors) [] = - pure DTEnum -getDataTypeInMemory (Smol.DataType _ dtVars constructors) args = do - consDts <- - traverse - ( \cnArgs -> - resolveDataType dtVars cnArgs args - ) - constructors - let arraySize = - getMax $ - foldMap - (Max . getSum . foldMap (Sum . howManyInts)) - (M.elems consDts) - whole = - DTTuple - [ DTPrim Smol.TPInt, - DTArray arraySize (DTPrim Smol.TPInt) - ] - pure $ DTDataType whole consDts - --- | very approximate way of working out how much memory to allocate --- this can definitely be improved uponw -howManyInts :: DataTypeInMemory -> Word64 -howManyInts DTEnum = 1 -howManyInts (DTPrim Smol.TPInt) = 1 -howManyInts (DTPrim Smol.TPBool) = 1 -howManyInts (DTPrim Smol.TPString) = 1 -howManyInts (DTTuple as) = getSum $ foldMap (Sum . howManyInts) as -howManyInts (DTArray size a) = size * howManyInts a -howManyInts (DTDataType whole _) = howManyInts whole -- wrong? - --- given ['e','a'], [TVar _ "a", TVar _ "e"] and [Int, Bool] return [Bool, Int] --- putting each arg into place -resolveDataType :: - ( Show ann, - MonadState (FromExprState ann) m - ) => - [Smol.Identifier] -> - [Smol.Type ResolvedDep ann] -> - [Smol.Type ResolvedDep ann] -> - m [DataTypeInMemory] -resolveDataType dtVars constructorArgs args = - let substitutions = zipWith Substitution (SubId . LocalDefinition <$> dtVars) args - in traverse toRepresentation $ substituteMany substitutions <$> constructorArgs - -toRepresentation :: - ( Show ann, - MonadState (FromExprState ann) m - ) => - Smol.Type ResolvedDep ann -> - m DataTypeInMemory -toRepresentation (Smol.TPrim _ prim) = pure $ DTPrim prim -toRepresentation (Smol.TLiteral _ (Smol.TLInt _)) = pure $ DTPrim Smol.TPInt -toRepresentation (Smol.TLiteral _ (Smol.TLBool _)) = pure $ DTPrim Smol.TPBool -toRepresentation (Smol.TLiteral _ (Smol.TLString _)) = pure $ DTPrim Smol.TPString -toRepresentation ty@Smol.TApp {} = do - result <- typeToDataTypeInMemory ty - case result of - Right dtInMem -> pure dtInMem - Left e -> error (show e) -toRepresentation (Smol.TTuple _ tyHead tyTail) = - DTTuple <$> traverse toRepresentation ([tyHead] <> NE.toList tyTail) -toRepresentation (Smol.TArray _ size a) = do - dtInner <- toRepresentation a - pure $ DTTuple [DTPrim Smol.TPInt, DTArray size dtInner] -toRepresentation union | isNatLiteral union = pure $ DTPrim Smol.TPInt -toRepresentation union | isIntLiteral union = pure $ DTPrim Smol.TPInt -toRepresentation ty = error ("can't make rep of " <> show ty) - -data DataTypeInMemory - = DTEnum -- int - | DTPrim Smol.TypePrim -- a primitive llvm type - | DTTuple [DataTypeInMemory] - | DTArray Word64 DataTypeInMemory - | DTDataType - { dtWhole :: DataTypeInMemory, -- a big enough allocation to fill all the constructors - dtConstructors :: Map Smol.Constructor [DataTypeInMemory] -- the actual constructors (these don't contain the discriminator int) - } - deriving stock (Eq, Ord, Show) diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/Expr.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/Expr.hs deleted file mode 100644 index f254b3dd..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/Expr.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Backend.IR.FromExpr.Expr - ( irFromModule, - fromExpr, - FromExprState (..), - getConstructorNumber, - ) -where - -import Control.Monad ((>=>)) -import Control.Monad.State -import Control.Monad.Writer -import Data.Bifunctor -import Data.Foldable (foldl', toList, traverse_) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Smol.Backend.IR.FromExpr.DataTypes -import qualified Smol.Backend.IR.FromExpr.Helpers as Compile -import Smol.Backend.IR.FromExpr.Pattern -import Smol.Backend.IR.FromExpr.Type -import Smol.Backend.IR.FromExpr.Types -import Smol.Backend.IR.IRExpr -import Smol.Backend.Types.GetPath -import Smol.Backend.Types.PatternPredicate -import Smol.Core.Helpers -import Smol.Core.Modules.Types (Module (..), TopLevelExpression (..)) -import Smol.Core.Typecheck (flattenConstructorApplication, getTypeAnnotation) -import Smol.Core.Typecheck.Shared (getExprAnnotation) -import Smol.Core.Types.Constructor -import Smol.Core.Types.DataType -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Op -import Smol.Core.Types.Prim -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - -irPrintInt :: IRExtern -irPrintInt = - IRExtern - { ireName = "printint", - ireArgs = [IRInt32], - ireReturn = IRInt32 - } - -irPrintBool :: IRExtern -irPrintBool = - IRExtern - { ireName = "printbool", - ireArgs = [IRInt2], - ireReturn = IRInt32 - } - -irPrintString :: IRExtern -irPrintString = - IRExtern - { ireName = "printstring", - ireArgs = [IRPointer IRInt8], - ireReturn = IRInt32 - } - -irStringConcat :: IRExtern -irStringConcat = - IRExtern - { ireName = "stringconcat", - ireArgs = [IRPointer IRInt8, IRPointer IRInt8], - ireReturn = IRPointer IRInt8 - } - -irStringEquals :: IRExtern -irStringEquals = - IRExtern - { ireName = "stringequals", - ireArgs = [IRPointer IRInt8, IRPointer IRInt8], - ireReturn = IRInt2 - } - -getPrinter :: - (Show ann, Show (dep Identifier), Show (dep TypeName)) => - Type dep ann -> - IRExtern -getPrinter (TPrim _ TPInt) = irPrintInt -getPrinter (TPrim _ TPBool) = irPrintBool -getPrinter (TLiteral _ (TLBool _)) = irPrintBool -getPrinter (TLiteral _ (TLInt _)) = irPrintInt -getPrinter (TLiteral _ (TLString _)) = irPrintString -getPrinter other = error ("could not find a printer for type " <> show other) - -getPrintFuncName :: - ( Show ann, - Show (dep Identifier), - Show (dep TypeName) - ) => - Type dep ann -> - IRFunctionName -getPrintFuncName ty = - case getPrinter ty of - (IRExtern n _ _) -> n - -getPrintFuncType :: - ( Show ann, - Show (dep Identifier), - Show (dep TypeName) - ) => - Type dep ann -> - IRType -getPrintFuncType ty = - case getPrinter ty of - (IRExtern _ fnArgs fnReturn) -> IRFunctionType fnArgs fnReturn - -getFreshName :: (MonadState (FromExprState ann) m) => String -> m String -getFreshName prefix = do - current <- gets fesFreshInt - modify (\s -> s {fesFreshInt = current + 1}) - pure (prefix <> show current) - -getFreshFunctionName :: (MonadState (FromExprState ann) m) => m IRFunctionName -getFreshFunctionName = IRFunctionName <$> getFreshName "function" - -getFreshClosureName :: (MonadState (FromExprState ann) m) => m IRIdentifier -getFreshClosureName = IRIdentifier <$> getFreshName "closure" - -addVar :: - (MonadState (FromExprState ann) m) => - IRIdentifier -> - IRExpr -> - m () -addVar ident expr = - modify (\s -> s {fesVars = fesVars s <> M.singleton ident expr}) - --- | turn a Smol module into an IR one --- no considerations for name collisions etc -irFromModule :: (Show ann) => Module ResolvedDep (Type ResolvedDep ann) -> IRModule -irFromModule myModule = - let mainFunc = case M.lookup "main" (moExpressions myModule) of - Just expr -> expr - Nothing -> error "expected a main function" - otherFuncs = - M.delete "main" (moExpressions myModule) - dataTypes = - M.fromList - . fmap (bimap LocalDefinition (fmap getTypeAnnotation)) - . M.toList - $ moDataTypes myModule - in IRModule $ - [ IRExternDef $ getPrinter (getExprAnnotation $ tleExpr mainFunc), - IRExternDef irStringConcat, - IRExternDef irStringEquals -- we should dynamically include these once we get a lot of stdlib helpers - ] - <> modulePartsFromExpr dataTypes (tleExpr <$> otherFuncs) (tleExpr mainFunc) - -fromPrim :: (Monad m) => Prim -> m IRExpr -fromPrim (PInt i) = pure $ IRPrim (IRPrimInt32 i) -fromPrim (PBool b) = pure $ IRPrim (IRPrimInt2 b) -fromPrim PUnit = pure $ IRPrim (IRPrimInt2 False) -- Unit is represented the same as False -fromPrim (PString txt) = pure $ IRString txt - -fromInfix :: - (Show ann, MonadState (FromExprState ann) m, MonadWriter (Map IRIdentifier IRExpr) m) => - Op -> - Expr ResolvedDep (Type ResolvedDep ann) -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m IRExpr -fromInfix OpAdd a b = do - irA <- fromExpr a - irB <- fromExpr b - if Compile.isStringType (getExprAnnotation a) - then - let (IRExtern fnName fnArgs fnReturn) = irStringConcat - in pure $ IRApply (IRFunctionType fnArgs fnReturn) (IRFuncPointer fnName) [irA, irB] - else pure (IRInfix IRAdd irA irB) -fromInfix OpEquals a b = do - irA <- fromExpr a - irB <- fromExpr b - if Compile.isStringType (getExprAnnotation a) - then - let (IRExtern fnName fnArgs fnReturn) = irStringEquals - in pure $ IRApply (IRFunctionType fnArgs fnReturn) (IRFuncPointer fnName) [irA, irB] - else pure (IRInfix IREquals irA irB) - -functionReturnType :: IRType -> ([IRType], IRType) -functionReturnType (IRStruct [IRPointer (IRFunctionType args ret), _]) = - (args, ret) -functionReturnType other = error ("non-function " <> show other) - -fromExpr :: - ( Show ann, - MonadState (FromExprState ann) m, - MonadWriter (Map IRIdentifier IRExpr) m - ) => - Expr ResolvedDep (Type ResolvedDep ann) -> - m IRExpr -fromExpr (EPrim _ prim) = fromPrim prim -fromExpr (EInfix _ op a b) = fromInfix op a b -fromExpr (EAnn _ _ inner) = fromExpr inner -fromExpr (EIf ty predExpr thenExpr elseExpr) = do - irPred <- fromExpr predExpr - irThen <- fromExpr thenExpr - irElse <- fromExpr elseExpr - responseType <- fromType ty - pure $ - IRMatch - irPred - responseType - ( NE.fromList - [ IRMatchCase - { irmcType = IRInt2, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt2 True)], - irmcGetPath = mempty, - irmcExpr = irThen - }, - IRMatchCase - { irmcType = IRInt2, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt2 False)], - irmcGetPath = mempty, - irmcExpr = irElse - } - ] - ) -fromExpr (EPatternMatch ty matchExpr pats) = do - irMatch <- fromExpr matchExpr - let withPat (p, pExpr) = do - irExpr <- fromExpr pExpr - preds <- predicatesFromPattern fromPrim p - destructured <- destructurePattern fromIdentifier p - dt <- patternTypeInMemory p - pure $ - IRMatchCase - { irmcType = fromDataTypeInMemory dt, - irmcPatternPredicate = preds, - irmcGetPath = destructured, - irmcExpr = irExpr - } - irPats <- traverse withPat pats - responseType <- fromType ty - pure $ - IRMatch - irMatch - responseType - irPats -fromExpr (ELambda ty ident body) = - closureFromExpr ty (Compile.resolveIdentifier ident) body -fromExpr (EApp ty fn val) = - appFromExpr ty fn val -fromExpr (EVar ty v@(LocalDefinition var)) = do - let irIdentifier = fromIdentifier $ Compile.resolveIdentifier v - irType <- fromType ty - case ty of - TFunc _ _ arg ret -> do - irRet <- fromType ret - irArg <- fromType arg - let envType = IRStruct [] - functionType = IRFunctionType [irArg, envType] irRet - closureType = IRStruct [IRPointer functionType, envType] - - -- ir puts the function in a closure with no env - let irExpr = - IRInitialiseDataType - (IRAlloc closureType) - closureType - closureType - [ IRSetTo - [0] - (IRPointer functionType) - (IRFuncPointer (functionNameFromIdentifier var)) - ] - - tell (M.singleton irIdentifier irExpr) - pure (IRVar irIdentifier) - _ -> do - -- no args funcs are like thunked values - let irExpr = IRApply (IRFunctionType [] irType) (IRFuncPointer (functionNameFromIdentifier var)) [] - tell (M.singleton irIdentifier irExpr) - pure (IRVar irIdentifier) -fromExpr (EVar _ var) = - pure (IRVar $ fromIdentifier $ Compile.resolveIdentifier var) -fromExpr (ETuple ty tHead tTail) = do - statements <- - traverseInd - ( \expr i -> do - irExpr <- fromExpr expr - exprType <- fromType (getExprAnnotation expr) - pure $ IRSetTo [i] exprType irExpr - ) - ([tHead] <> NE.toList tTail) - structType <- fromType ty - pure $ - IRInitialiseDataType - (IRAlloc structType) - structType - structType - statements -fromExpr (ELet _ ident expr body) = do - irExpr <- fromExpr expr - addVar (fromIdentifier (Compile.resolveIdentifier ident)) irExpr -- remember pls - irBody <- fromExpr body - pure (IRLet (fromIdentifier (Compile.resolveIdentifier ident)) irExpr irBody) -fromExpr (EConstructor ty constructor) = do - tyResult <- Compile.flattenConstructorType ty - case tyResult of - -- genuine enum, return number - (_typeName, []) -> getConstructorNumber (Compile.resolveConstructor constructor) - (_typeName, _) -> do - (structType, specificStructType) <- - bimap - fromDataTypeInMemory - fromDataTypeInMemory - <$> constructorTypeInMemory ty (Compile.resolveConstructor constructor) - - -- get number for constructor - consNum <- getConstructorNumber (Compile.resolveConstructor constructor) - - let setConsNum = IRSetTo [0] IRInt32 consNum - - pure $ - IRInitialiseDataType - (IRAlloc structType) - specificStructType - structType - [setConsNum] -fromExpr (EArray ty items) = do - irType <- fromType ty - let setCount = IRSetTo [0] IRInt32 (IRPrim $ IRPrimInt32 $ fromIntegral $ length items) - setItems <- - traverseInd - ( \item i -> do - tyItem <- fromType (getExprAnnotation item) - irItem <- fromExpr item - pure $ IRSetTo [1, i] tyItem irItem - ) - (toList items) - pure $ - IRInitialiseDataType - (IRAlloc irType) - irType - irType - ([setCount] <> setItems) -fromExpr expr = error ("fuck: " <> show expr) - --- | given an env type, put all it's items in scope --- replaces "a" with a reference it's position in scope -bindingsFromEnv :: Map (ResolvedDep Identifier) (Type ResolvedDep ann) -> IRExpr -> IRExpr -bindingsFromEnv env inner = - foldr - ( \(ident, i) irExpr -> - swapVar (fromIdentifier (Compile.resolveIdentifier ident)) (IRStructPath [i] (IRVar "env")) irExpr - ) - inner - (zip (M.keys env) [0 ..]) - -swapVar :: IRIdentifier -> IRExpr -> IRExpr -> IRExpr -swapVar target replace = - go - where - go (IRVar a) | a == target = replace - go other = mapIRExpr go other - -mapIRExpr :: (IRExpr -> IRExpr) -> IRExpr -> IRExpr -mapIRExpr _ (IRVar a) = IRVar a -mapIRExpr _ (IRString txt) = IRString txt -mapIRExpr _ (IRAlloc ty) = IRAlloc ty -mapIRExpr _ (IRPrim p) = IRPrim p -mapIRExpr f (IRInfix op a b) = IRInfix op (f a) (f b) -mapIRExpr f (IRApply ty fn arg) = IRApply ty (f fn) (f <$> arg) -mapIRExpr f (IRLet ident expr rest) = - IRLet ident (f expr) (f rest) -mapIRExpr f (IRStructPath as var) = - IRStructPath as (f var) -mapIRExpr _ (IRFuncPointer p) = IRFuncPointer p -mapIRExpr f (IRMatch expr ty pats) = - IRMatch (f expr) ty ((\(IRMatchCase a b c irExpr) -> IRMatchCase a b c (f irExpr)) <$> pats) -mapIRExpr f (IRStatements as rest) = - IRStatements as (f rest) -mapIRExpr f (IRPointerTo a b) = - IRPointerTo a (f b) -mapIRExpr f (IRInitialiseDataType input a b args) = - let mapSetTo (IRSetTo path ty expr) = IRSetTo path ty (f expr) - in IRInitialiseDataType (f input) a b (mapSetTo <$> args) - -closureFromExpr :: - ( MonadState (FromExprState ann) m, - MonadWriter (Map IRIdentifier IRExpr) m, - Show ann - ) => - Type ResolvedDep ann -> - Identifier -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m IRExpr -closureFromExpr ty ident body = do - irType <- fromType ty - let (argTypes, retType) = functionReturnType irType - let argType = case argTypes of - (a : _) -> a - _ -> error "why don't we have any args to this function?" - let envArgs = case ty of - TFunc _ env _ _ -> env - _ -> error "type is not lambda wtf" - - funcName <- getFreshFunctionName - - irBody <- fromExpr body - envType <- typeFromEnv envArgs - - modulePart <- do - pure - ( IRFunctionDef - ( IRFunction - { irfName = funcName, - irfArgs = [(argType, fromIdentifier ident), (envType, "env")], - irfReturn = retType, - irfBody = - [ IRRet retType (bindingsFromEnv envArgs irBody) - ] - } - ) - ) - - pushModulePart modulePart - - let functionType = IRFunctionType [argType, envType] retType - closureType = IRStruct [IRPointer functionType, envType] - - envStatements <- structFromEnv envArgs - - pure $ - IRInitialiseDataType - (IRAlloc closureType) - closureType - closureType - ( [ IRSetTo - [0] - (IRPointer functionType) - (IRFuncPointer funcName) - ] - <> envStatements - ) - --- given an `env` value, capture all the vars from the environment to put in --- the closure -structFromEnv :: - ( MonadState (FromExprState ann) m, - Show ann - ) => - Map (ResolvedDep Identifier) (Type ResolvedDep ann) -> - m [IRSetTo] -structFromEnv env = - traverseInd - ( \(ident, ty) i -> do - irType <- fromType ty - let irVal = IRVar (fromIdentifier (Compile.resolveIdentifier ident)) - pure (IRSetTo [1, i] irType irVal) - ) - (M.toList env) - --- | applying `1` to `Just`, in the literal `Just 1` for instance -constructorAppFromExpr :: - ( MonadState (FromExprState ann) m, - MonadWriter (Map IRIdentifier IRExpr) m, - Show ann - ) => - Type ResolvedDep ann -> - Constructor -> - [Expr ResolvedDep (Type ResolvedDep ann)] -> - m IRExpr -constructorAppFromExpr ty constructor cnArgs = do - -- the constructor case, build up everything we need pls - (structType, specificStructType) <- - bimap - fromDataTypeInMemory - fromDataTypeInMemory - <$> constructorTypeInMemory ty constructor - - -- get number for constructor - consNum <- getConstructorNumber constructor - - let setConsNum = IRSetTo [0] IRInt32 consNum - - statements <- - traverseInd - ( \expr i -> do - irExpr <- fromExpr expr - exprType <- fromType (getExprAnnotation expr) - pure $ - IRSetTo - [i + 1] - exprType - irExpr - ) - cnArgs - - pure $ - IRInitialiseDataType - (IRAlloc structType) - specificStructType - structType - ([setConsNum] <> statements) - --- | application could be function application or constructor application --- first, we need to deal with nested `app` around a constructor and flatten --- that into something ok -appFromExpr :: - ( Show ann, - MonadState (FromExprState ann) m, - MonadWriter (Map IRIdentifier IRExpr) m - ) => - Type ResolvedDep ann -> - Expr ResolvedDep (Type ResolvedDep ann) -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m IRExpr -appFromExpr ty fn val = do - case flattenConstructorApplication (EApp ty fn val) of - Just (constructor, cnArgs) -> - constructorAppFromExpr ty (Compile.resolveConstructor constructor) cnArgs - Nothing -> do - -- regular function application (`id True` for instance) - irFn <- fromExpr fn - irVal <- fromExpr val - fnType <- fromType (getExprAnnotation fn) - closureName <- getFreshClosureName - - -- arguably we could look into trashing the env - -- where it's empty but for now let's keep this easier - pure - ( IRLet - closureName - irFn - ( IRApply - fnType - (IRStructPath [0] irFn) - [ irVal, - IRPointerTo [1] (IRVar closureName) - ] - ) - ) - -fromIdentifier :: Identifier -> IRIdentifier -fromIdentifier (Identifier ident) = IRIdentifier (T.unpack ident) - -functionNameFromIdentifier :: Identifier -> IRFunctionName -functionNameFromIdentifier (Identifier ident) = - IRFunctionName (T.unpack ident) - -pushModulePart :: (MonadState (FromExprState ann) m) => IRModulePart -> m () -pushModulePart part = - modify (\s -> s {fesModuleParts = fesModuleParts s <> [part]}) - -fromOtherExpr :: - (Show ann, MonadState (FromExprState ann) m) => - Identifier -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m IRModulePart -fromOtherExpr name (EAnn _ _ inner) = fromOtherExpr name inner -fromOtherExpr name (ELambda ty ident body) = do - (irBody, vars) <- runWriterT (fromExpr body) - - let (tFrom, tTo) = case ty of - (TFunc _ _ tFrom' tTo') -> (tFrom', tTo') - _ -> error "sdfdsf" - - irReturnType <- fromType tTo - irArgType <- fromType tFrom - - pure - ( IRFunctionDef - ( IRFunction - { irfName = functionNameFromIdentifier name, - irfArgs = - [ (irArgType, fromIdentifier (Compile.resolveIdentifier ident)), - (IRStruct [], IRIdentifier "env") - ], - irfReturn = irReturnType, - irfBody = [IRRet irReturnType (addVarsToExpr vars irBody)] - } - ) - ) -fromOtherExpr name expr = do - (irExpr, vars) <- runWriterT (fromExpr expr) - irReturnType <- fromType (getExprAnnotation expr) - - pure - ( IRFunctionDef - ( IRFunction - { irfName = functionNameFromIdentifier name, - irfArgs = [], - irfReturn = irReturnType, - irfBody = [IRRet irReturnType (addVarsToExpr vars irExpr)] - } - ) - ) - -addVarsToExpr :: Map IRIdentifier IRExpr -> IRExpr -> IRExpr -addVarsToExpr vars expr = - foldl' (\e (ident, binding) -> IRLet ident binding e) expr (M.toList vars) - --- | given an expr, return the `main` function, as well as adding any extra --- module Core.parts to the State -modulePartsFromExpr :: - (Show ann) => - Map (ResolvedDep TypeName) (DataType ResolvedDep ann) -> - Map Identifier (Expr ResolvedDep (Type ResolvedDep ann)) -> - Expr ResolvedDep (Type ResolvedDep ann) -> - [IRModulePart] -modulePartsFromExpr dataTypes otherExprs mainExpr = - let (irMainExpr, FromExprState {fesModuleParts = otherParts}) = do - let action = do - traverse_ - ( uncurry fromOtherExpr - >=> pushModulePart - ) - (M.toList otherExprs) - (irExpr, mainVars) <- runWriterT (fromExpr mainExpr) - pure $ addVarsToExpr mainVars irExpr - runState action (FromExprState mempty dataTypes 1 mempty) - printFuncName = getPrintFuncName (getExprAnnotation mainExpr) - printFuncType = getPrintFuncType (getExprAnnotation mainExpr) - in otherParts - <> [ IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard (IRApply printFuncType (IRFuncPointer printFuncName) [irMainExpr]), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - -getConstructorNumber :: - (MonadState (FromExprState ann) m) => - Constructor -> - m IRExpr -getConstructorNumber = - Compile.primFromConstructor >=> fromPrim diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/Helpers.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/Helpers.hs deleted file mode 100644 index 9f638182..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/Helpers.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Smol.Backend.IR.FromExpr.Helpers - ( flattenConstructorType, - primFromConstructor, - lookupTypeName, - isStringType, - resolveConstructor, - resolveIdentifier, - ) -where - -import Control.Monad.State -import qualified Data.Map.Strict as M -import Data.String (fromString) -import GHC.Records (HasField (..)) -import Smol.Backend.IR.FromExpr.Types -import Smol.Core.Helpers -import qualified Smol.Core.Typecheck.Shared as TC -import qualified Smol.Core.Types as Smol -import Smol.Core.Types.ResolvedDep - -resolveConstructor :: Smol.ResolvedDep Smol.Constructor -> Smol.Constructor -resolveConstructor (LocalDefinition c) = c -resolveConstructor (UniqueDefinition c idx) = c <> fromString ("_" <> show idx) -resolveConstructor (TypeclassCall c idx) = fromString "tc_" <> c <> fromString ("_" <> show idx) - -resolveIdentifier :: Smol.ResolvedDep Smol.Identifier -> Smol.Identifier -resolveIdentifier (LocalDefinition c) = c -resolveIdentifier (UniqueDefinition i idx) = i <> fromString ("_" <> show idx) -resolveIdentifier (TypeclassCall i idx) = fromString "tc_" <> i <> fromString ("_" <> show idx) - -isStringType :: Smol.Type dep ann -> Bool -isStringType (Smol.TPrim _ Smol.TPString) = True -isStringType (Smol.TLiteral _ (Smol.TLString _)) = True -isStringType _ = False - -flattenConstructorType :: - ( Monad m, - Show ann, - Show (dep Smol.Identifier), - Show (dep Smol.TypeName) - ) => - Smol.Type dep ann -> - m (dep Smol.TypeName, [Smol.Type dep ann]) -flattenConstructorType ty = do - let result = TC.flattenConstructorType ty - pure (fromRight result) - --- | lookup constructor, get number for it and expected number of args --- we'll use this to create datatype etc -primFromConstructor :: - ( MonadState (FromExprState ann) m - ) => - Smol.Constructor -> - m Smol.Prim -primFromConstructor constructor = do - dt <- lookupConstructor constructor - let i = getConstructorNumber dt constructor - pure (Smol.PInt i) - --- | lookup constructor, get number for it and expected number of args --- we'll use this to create datatype etc -lookupConstructor :: - ( MonadState (FromExprState ann) m - ) => - Smol.Constructor -> - m (Smol.DataType ResolvedDep ann) -lookupConstructor constructor = do - maybeDt <- - gets - ( mapFind - ( \dt@(Smol.DataType _ _ constructors) -> - (,) dt <$> M.lookup constructor constructors - ) - . getField @"fesDataTypes" - ) - case maybeDt of - Just (dt, _) -> pure dt - Nothing -> error "cant find, what the hell man" - -lookupTypeName :: - ( MonadState (FromExprState ann) m - ) => - ResolvedDep Smol.TypeName -> - m (Smol.DataType ResolvedDep ann) -lookupTypeName tn = do - maybeDt <- gets (M.lookup tn . getField @"fesDataTypes") - case maybeDt of - Just dt -> pure dt - Nothing -> error $ "couldn't find datatype for " <> show tn - -getConstructorNumber :: Smol.DataType ResolvedDep ann -> Smol.Constructor -> Integer -getConstructorNumber (Smol.DataType _ _ constructors) constructor = - case M.lookup constructor (mapToNumbered constructors) of - Just i -> i - Nothing -> error "blah" diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/Pattern.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/Pattern.hs deleted file mode 100644 index 135809b0..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/Pattern.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Backend.IR.FromExpr.Pattern - ( predicatesFromPattern, - destructurePattern, - ) -where - -import Control.Monad.State -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Smol.Backend.IR.FromExpr.Helpers -import Smol.Backend.IR.FromExpr.Types -import Smol.Backend.Types.GetPath -import Smol.Backend.Types.PatternPredicate -import Smol.Core.Helpers -import qualified Smol.Core.Types as Smol - --- | given a pattern, pull out all the vars we're interested in and how to get --- to them -destructurePattern :: - ( MonadState s m, - Ord p - ) => - (Smol.Identifier -> p) -> - Smol.Pattern Smol.ResolvedDep (Smol.Type Smol.ResolvedDep ann) -> - m (Map p GetPath) -destructurePattern fromIdentifier = - destructInner [] - where - destructInner path (Smol.PTuple _ pHead pTail) = - let pats = [pHead] <> NE.toList pTail - in mconcat <$> traverseInd (\pat i -> destructInner (path <> [i]) pat) pats - destructInner _ (Smol.PWildcard _) = pure mempty - destructInner _ (Smol.PLiteral _ _) = pure mempty - destructInner path (Smol.PArray _ as spread) = do - let pathSoFar = path <> [1] -- arrays are length-indexed so actually (lengthInt, [items]) - let spreadPath = case spread of - Smol.NoSpread -> mempty - Smol.SpreadWildcard _ -> mempty - Smol.SpreadValue _ ident -> - M.singleton - (fromIdentifier (resolveIdentifier ident)) - (GetPath path (GetArrayTail (fromIntegral $ length as))) - mappend spreadPath . mconcat <$> traverseInd (\pat i -> destructInner (pathSoFar <> [i]) pat) as - destructInner path (Smol.PConstructor _ _ pArgs) = do - -- get DataTypeInMemory from `ty` - -- use it to work out where to reach into Struct to find data - -- then return path - mconcat <$> traverseInd (\pat i -> destructInner (path <> [i + 1]) pat) pArgs - destructInner path (Smol.PVar _ ident) = - pure $ M.singleton (fromIdentifier (resolveIdentifier ident)) (GetPath path GetValue) - -predicatesFromPattern :: - ( MonadState (FromExprState ann) m, - Show ann - ) => - (Smol.Prim -> m p) -> - Smol.Pattern Smol.ResolvedDep (Smol.Type Smol.ResolvedDep ann) -> - m [PatternPredicate p] -predicatesFromPattern fromPrim = - predicatesInner [] - where - predicatesInner _ (Smol.PWildcard _) = pure mempty - predicatesInner _ (Smol.PVar _ _) = pure mempty - predicatesInner path (Smol.PArray _ pats spread) = do - llPrim <- - fromPrim - ( Smol.PInt - (fromIntegral $ length pats) - ) - let spreadPred = case spread of - Smol.NoSpread -> - [ PathEquals - (GetPath (path <> [0]) GetValue) - llPrim - ] - _ -> [] - mappend spreadPred . mconcat - <$> traverseInd - ( \pat i -> - predicatesInner (path <> [1, i]) pat - ) - pats - predicatesInner path (Smol.PLiteral ty prim) | isStringType ty = do - llPrim <- fromPrim prim - pure [StringEquals (GetPath path GetValue) llPrim] - predicatesInner path (Smol.PLiteral _ prim) = do - llPrim <- fromPrim prim - pure [PathEquals (GetPath path GetValue) llPrim] - predicatesInner path (Smol.PTuple _ pHead pTail) = - let pats = [pHead] <> NE.toList pTail - in mconcat <$> traverseInd (\pat i -> predicatesInner (path <> [i]) pat) pats - predicatesInner path (Smol.PConstructor ty constructor pArgs) = do - (_typeName, tyArgs) <- flattenConstructorType ty - - case tyArgs of - -- if no args, it's a primitive - [] -> do - prim <- primFromConstructor (resolveConstructor constructor) - llPrim <- fromPrim prim - pure [PathEquals (GetPath path GetValue) llPrim] - _ -> do - -- if there's args it's a struct - prim <- primFromConstructor (resolveConstructor constructor) - llPrim <- fromPrim prim - let constructorPath = PathEquals (GetPath (path <> [0]) GetValue) llPrim - - -- work out predicates for rest of items - predRest <- mconcat <$> traverseInd (\pat i -> predicatesInner (path <> [i + 1]) pat) pArgs - pure $ [constructorPath] <> predRest diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/Type.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/Type.hs deleted file mode 100644 index 1e52531b..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/Type.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Backend.IR.FromExpr.Type (fromType, typeFromEnv, fromDataTypeInMemory) where - -import Control.Monad.State -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Smol.Backend.IR.FromExpr.DataTypes -import qualified Smol.Backend.IR.FromExpr.Helpers as Compile -import Smol.Backend.IR.FromExpr.Types -import Smol.Backend.IR.IRExpr -import Smol.Core.Typecheck.Subtype (isIntLiteral, isNatLiteral) -import qualified Smol.Core.Types as Smol - -typeFromEnv :: - (Show ann, MonadState (FromExprState ann) m) => - Map (Smol.ResolvedDep Smol.Identifier) (Smol.Type Smol.ResolvedDep ann) -> - m IRType -typeFromEnv env = IRStruct <$> traverse fromType (M.elems env) - -fromType :: - (Show ann, MonadState (FromExprState ann) m) => - Smol.Type Smol.ResolvedDep ann -> - m IRType -fromType (Smol.TPrim _ Smol.TPBool) = pure IRInt2 -fromType (Smol.TPrim _ Smol.TPInt) = pure IRInt32 -fromType (Smol.TPrim _ Smol.TPString) = pure (IRPointer IRInt8) -fromType (Smol.TLiteral _ lit) = pure $ fromLit lit - where - fromLit (Smol.TLBool _) = IRInt2 - fromLit (Smol.TLInt _) = IRInt32 - fromLit Smol.TLUnit = IRInt2 -- unit become bool? - fromLit (Smol.TLString _as) = - IRPointer IRInt8 -- a C string is a pointer to the char at the start of the string -fromType (Smol.TFunc _ env tArg tBody) = do - argType <- fromType tArg - envType <- typeFromEnv env - irFunc <- IRFunctionType [argType, envType] <$> fromType tBody - pure (IRStruct [IRPointer irFunc, envType]) -fromType (Smol.TTuple _ tHead tTail) = - IRStruct <$> traverse fromType ([tHead] <> NE.toList tTail) -fromType ty@Smol.TApp {} = do - (typeName, typeArgs) <- Compile.flattenConstructorType ty - dt <- Compile.lookupTypeName typeName - getIrTypeForDataType dt typeArgs -fromType (Smol.TConstructor _ constructor) = do - dt <- Compile.lookupTypeName constructor - getIrTypeForDataType dt [] -fromType (Smol.TArray _ size item) = do - dtItem <- fromType item - pure $ IRStruct [IRInt32, IRArray size dtItem] -fromType union | isNatLiteral union = pure IRInt32 -fromType union | isIntLiteral union = pure IRInt32 -fromType other = - error $ "could not calculate IR type from smol type: " <> show other - --- get the type for a datatype --- first we get all the args and apply them, they must not be vars --- then we find the biggest one of the constructors and says its that --- we'll bitcast the types (ie, coerce the type) when it comes to saving shit --- in it -getIrTypeForDataType :: - (Show ann, MonadState (FromExprState ann) m) => - Smol.DataType Smol.ResolvedDep ann -> - [Smol.Type Smol.ResolvedDep ann] -> - m IRType -getIrTypeForDataType dt dtArgs = - fromDataTypeInMemory <$> getDataTypeInMemory dt dtArgs - -fromDataTypeInMemory :: DataTypeInMemory -> IRType -fromDataTypeInMemory = \case - DTEnum -> IRInt32 - DTTuple vals -> - IRStruct (fromDataTypeInMemory <$> vals) - DTArray size tyInner -> - IRArray size (fromDataTypeInMemory tyInner) - DTPrim prim -> fromTypePrim prim - DTDataType whole _ -> fromDataTypeInMemory whole - -fromTypePrim :: Smol.TypePrim -> IRType -fromTypePrim Smol.TPBool = IRInt2 -fromTypePrim Smol.TPInt = IRInt32 -fromTypePrim Smol.TPString = IRPointer IRInt8 diff --git a/smol-backend/src/Smol/Backend/IR/FromExpr/Types.hs b/smol-backend/src/Smol/Backend/IR/FromExpr/Types.hs deleted file mode 100644 index 9bcd13b1..00000000 --- a/smol-backend/src/Smol/Backend/IR/FromExpr/Types.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Backend.IR.FromExpr.Types - ( FromExprState (..), - ) -where - -import Data.Map.Strict (Map) -import Smol.Backend.IR.IRExpr -import qualified Smol.Core.Types as Smol - -data FromExprState ann = FromExprState - { fesModuleParts :: [IRModulePart], - fesDataTypes :: - Map - (Smol.ResolvedDep Smol.TypeName) - (Smol.DataType Smol.ResolvedDep ann), - fesFreshInt :: Int, - fesVars :: Map IRIdentifier IRExpr - } diff --git a/smol-backend/src/Smol/Backend/IR/IRExpr.hs b/smol-backend/src/Smol/Backend/IR/IRExpr.hs deleted file mode 100644 index eb8376fc..00000000 --- a/smol-backend/src/Smol/Backend/IR/IRExpr.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Backend.IR.IRExpr - ( IRModulePart (..), - IRExtern (..), - IRModule (..), - IRFunction (..), - IRIdentifier (..), - IRPrim (..), - IRType (..), - IRFunctionName (..), - IRState (..), - IROp (..), - IRExpr (..), - IRSetTo (..), - IRStatement (..), - IRMatchCase (..), - prettyModule, - ) -where - -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Word (Word64) -import qualified LLVM.AST as LLVM hiding (function) -import Smol.Backend.Types.GetPath -import Smol.Backend.Types.PatternPredicate - -newtype IRName = IRName String - deriving newtype (Eq, Ord, Show) - -newtype IRFunctionName = IRFunctionName String - deriving newtype (Eq, Ord, Show) - -instance IsString IRFunctionName where - fromString = IRFunctionName - -data IRType - = IRInt2 - | IRInt8 - | IRInt32 - | IRStruct [IRType] - | IRPointer IRType - | IRFunctionType [IRType] IRType - | IRArray Word64 IRType - deriving stock (Eq, Ord, Show) - -data IRPrim - = IRPrimInt2 Bool - | IRPrimInt32 Integer - deriving stock (Eq, Ord, Show) - -newtype IRModule = IRModule [IRModulePart] - deriving newtype (Eq, Ord, Show) - -newtype IRIdentifier = IRIdentifier String - deriving newtype (Eq, Ord, Show) - -instance IsString IRIdentifier where - fromString = IRIdentifier - -data IROp = IRAdd | IREquals - deriving stock (Eq, Ord, Show) - -data IRModulePart - = IRExternDef IRExtern - | IRFunctionDef IRFunction - deriving stock (Eq, Ord, Show) - -data IRStatement - = IRSet [Integer] IRType IRExpr IRExpr -- (path, fromType, from, to) set part of a struct to a value - | IRDiscard IRExpr -- do the thing, bin the result - | IRRet IRType IRExpr - deriving stock (Eq, Ord, Show) - -data IRSetTo = IRSetTo - { irstPath :: [Integer], - irstType :: IRType, - irstExpr :: IRExpr - } - deriving stock (Eq, Ord, Show) - -data IRExpr - = IRAlloc IRType - | IRPrim IRPrim - | IRInfix IROp IRExpr IRExpr - | IRApply IRType IRExpr [IRExpr] -- fnType, fn, [args] - | IRVar IRIdentifier - | IRLet IRIdentifier IRExpr IRExpr - | IRStructPath [Integer] IRExpr - | IRFuncPointer IRFunctionName -- this will get turned into a lookup for a given function by name - | IRMatch IRExpr IRType (NE.NonEmpty IRMatchCase) - | IRStatements [IRStatement] IRExpr -- [things to do], value - | IRPointerTo [Integer] IRExpr - | IRInitialiseDataType IRExpr IRType IRType [IRSetTo] -- where to put stuff, type of whole thing, type of constructor, values - | IRString Text - deriving stock (Eq, Ord, Show) - -data IRMatchCase = IRMatchCase - { irmcType :: IRType, - irmcPatternPredicate :: [PatternPredicate IRExpr], - irmcGetPath :: Map IRIdentifier GetPath, - irmcExpr :: IRExpr - } - deriving stock (Eq, Ord, Show) - --- a top level function -data IRFunction = IRFunction - { irfName :: IRFunctionName, - irfArgs :: [(IRType, IRIdentifier)], - irfReturn :: IRType, - irfBody :: [IRStatement] - } - deriving stock (Eq, Ord, Show) - -data IRExtern = IRExtern - { ireName :: IRFunctionName, - ireArgs :: [IRType], - ireReturn :: IRType - } - deriving stock (Eq, Ord, Show) - -data IRState = IRState - { irFunctions :: Map IRFunctionName (Either IRFunction IRExtern), - irVars :: Map IRIdentifier LLVM.Operand, - irStrings :: Map Text LLVM.Operand - } - -prettyModule :: IRModule -> Text -prettyModule (IRModule parts) = - T.intercalate "\n\n" (prettyModulePart <$> parts) - -prettyModulePart :: IRModulePart -> Text -prettyModulePart = T.pack . show diff --git a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs b/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs deleted file mode 100644 index 18046810..00000000 --- a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -module Smol.Backend.IR.ToLLVM.Helpers - ( irPrimToLLVM, - emptyIRState, - storeExtern, - storeFunction, - addVar, - lookupVar, - lookupString, - returnType, - lookupFunctionType, - irTypeNeedsPointer, - irIdentifierToLLVM, - irTypeToLLVM, - functionReturnType, - irTypeMaybePointer, - functionArgsType, - irFunctionNameToLLVM, - irStoreInStruct, - getCastType, - irVarFromPath, - allocLocal, - functionAndType, - getPrintInt, - loadFromStruct, - storePrimInStruct, - moveToStruct, - callClosure, - callWithReturnStruct, - fromClosure, - struct, - pointerType, - primFromConstructor, - irFuncPointerToLLVM, - ) -where - -import Control.Monad.Identity -import Control.Monad.State -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Records (HasField (..)) -import qualified LLVM.AST as AST -import qualified LLVM.AST as LLVM hiding (function) -import qualified LLVM.AST.AddrSpace as AST -import qualified LLVM.AST.AddrSpace as LLVM -import qualified LLVM.AST.Constant as LLVM -import qualified LLVM.AST.Operand as Op -import LLVM.AST.Type as AST -import LLVM.AST.Type as LLVM -import qualified LLVM.IRBuilder.Constant as C -import qualified LLVM.IRBuilder.Constant as LLVM -import qualified LLVM.IRBuilder.Instruction as LLVM -import LLVM.IRBuilder.Module -import qualified LLVM.IRBuilder.Module as L -import qualified LLVM.IRBuilder.Module as LLVM -import qualified LLVM.IRBuilder.Monad as L -import qualified LLVM.IRBuilder.Monad as LLVM -import Smol.Backend.IR.IRExpr -import Smol.Backend.Types.GetPath -import Smol.Core.Helpers -import qualified Smol.Core.Types as Smol - --- | lookup constructor, get number for it and expected number of args --- we'll use this to create datatype etc -primFromConstructor :: - ( MonadState s m, - HasField "dataTypes" s (Map Smol.TypeName (Smol.DataType Identity ann)) - ) => - Smol.Constructor -> - m Smol.Prim -primFromConstructor constructor = do - dt <- lookupConstructor constructor - let i = getConstructorNumber dt constructor - pure (Smol.PInt i) - --- | lookup constructor, get number for it and expected number of args --- we'll use this to create datatype etc -lookupConstructor :: - ( MonadState s m, - HasField "dataTypes" s (Map Smol.TypeName (Smol.DataType Identity ann)) - ) => - Smol.Constructor -> - m (Smol.DataType Identity ann) -lookupConstructor constructor = do - maybeDt <- - gets - ( mapFind - ( \dt@(Smol.DataType _ _ constructors) -> - (,) dt <$> M.lookup constructor constructors - ) - . getField @"dataTypes" - ) - case maybeDt of - Just (dt, _) -> pure dt - Nothing -> error "cant find, what the hell man" - -getConstructorNumber :: Smol.DataType Identity ann -> Smol.Constructor -> Integer -getConstructorNumber (Smol.DataType _ _ constructors) constructor = - case M.lookup constructor (mapToNumbered constructors) of - Just i -> i - Nothing -> error "blah" - --- create function and it's type at once -functionAndType :: - (MonadModuleBuilder m) => - AST.Name -> - [(Type, ParameterName)] -> - Type -> - ([Op.Operand] -> L.IRBuilderT m ()) -> - m (Op.Operand, AST.Type) -functionAndType name fnArgs tyReturn body = do - fn <- function name fnArgs tyReturn body - let ty = - AST.FunctionType - tyReturn - (fst <$> fnArgs) - False - pure (fn, ty) - -getPrintInt :: (L.MonadModuleBuilder m) => m Op.Operand -getPrintInt = extern "printint" [AST.i32] AST.i32 - --- | given a pointer to a struct, get the value at `index` -loadFromStruct :: - (L.MonadIRBuilder m, L.MonadModuleBuilder m) => - Op.Operand -> - [Integer] -> - m Op.Operand -loadFromStruct struct' indexes = do - -- get pointer to slot `i` - slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes) - -- load value - LLVM.load slot1 0 - -storePrimInStruct :: - (L.MonadIRBuilder m, L.MonadModuleBuilder m) => - Op.Operand -> - [Integer] -> - Op.Operand -> - m () -storePrimInStruct struct' indexes a = do - -- get pointer to element - slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes) - -- store a in slot1 - LLVM.store slot1 0 a - --- given some data in a structure, put it in another struct -moveToStruct :: - ( L.MonadModuleBuilder m, - L.MonadIRBuilder m - ) => - Op.Operand -> - Op.Operand -> - m () -moveToStruct fromStruct toStruct = do - input <- LLVM.load fromStruct 0 - LLVM.store toStruct 0 input - -callClosure :: - ( L.MonadModuleBuilder m, - L.MonadIRBuilder m - ) => - Op.Operand -> - Op.Operand -> - m Op.Operand -callClosure opFunc opArg = do - -- get fn pt and env - (fn, env) <- fromClosure opFunc - - -- call fn with env + arg - LLVM.call - fn - [ (opArg, []), - (env, []) - ] - --- | call a function that returns a struct, initialising a struct for it to --- fill, then passing that to the function -callWithReturnStruct :: - (L.MonadModuleBuilder m, L.MonadIRBuilder m) => - Op.Operand -> - Type -> - [Op.Operand] -> - m Op.Operand -callWithReturnStruct fn structType fnArgs = do - retStruct <- allocLocal "struct-return" structType - - let allArgs = (,[]) <$> (fnArgs <> [retStruct]) - - _ <- LLVM.call fn allArgs - - pure retStruct - -struct :: [AST.Type] -> AST.Type -struct = - AST.StructureType False - -pointerType :: AST.Type -> AST.Type -pointerType ty = - AST.PointerType ty (AST.AddrSpace 0) - -allocLocal :: - (L.MonadIRBuilder m) => - String -> - AST.Type -> - m Op.Operand -allocLocal label ty = - LLVM.alloca ty Nothing 0 `L.named` fromString label - --- | get fn and environment from closure for calling -fromClosure :: - (L.MonadIRBuilder m, L.MonadModuleBuilder m) => - Op.Operand -> - m (Op.Operand, Op.Operand) -fromClosure closure = do - -- get fn pt - fn <- loadFromStruct closure [0] - - -- get pointer to env - envAddress <- LLVM.gep closure [C.int32 0, C.int32 1] - - pure (fn, envAddress) - -emptyIRState :: IRState -emptyIRState = IRState mempty mempty mempty - -storeExtern :: (MonadState IRState m) => IRExtern -> m () -storeExtern ext@(IRExtern name _ _) = - modify (\s -> s {irFunctions = irFunctions s <> M.singleton name (Right ext)}) - -storeFunction :: (MonadState IRState m) => IRFunction -> m () -storeFunction fn@(IRFunction name _ _ _) = - modify (\s -> s {irFunctions = irFunctions s <> M.singleton name (Left fn)}) - -lookupString :: (MonadState IRState m, LLVM.MonadIRBuilder m, LLVM.MonadModuleBuilder m) => Text -> m LLVM.Operand -lookupString txt = do - found <- gets (M.lookup txt . irStrings) - - case found of - Just op -> pure op - Nothing -> do - count <- gets (M.size . irStrings) - let nm = LLVM.mkName (show count <> ".str") - op <- LLVM.ConstantOperand <$> LLVM.globalStringPtr (T.unpack txt) nm - - modify - ( \irState -> - irState - { irStrings = irStrings irState <> M.singleton txt op - } - ) - - pure op - -addVar :: (MonadState IRState m) => IRIdentifier -> LLVM.Operand -> m () -addVar ident op = - modify (\s -> s {irVars = irVars s <> M.singleton ident op}) - -lookupVar :: (MonadState IRState m) => IRIdentifier -> m LLVM.Operand -lookupVar ident = - gets (M.lookup ident . irVars) >>= \case - Just op -> pure op - Nothing -> error $ "could not find " <> show ident - -returnType :: IRType -> ([IRType], IRType) -returnType (IRFunctionType args ret) = (args, ret) -returnType (IRStruct [IRPointer (IRFunctionType args ret), _]) = (args, ret) -returnType other = error ("non-function " <> show other) - -lookupFunctionType :: (MonadState IRState m) => IRFunctionName -> m LLVM.Type -lookupFunctionType fnName = - gets (M.lookup fnName . irFunctions) >>= \case - Just (Right (IRExtern _ eArgs eRet)) -> - pure $ LLVM.FunctionType (irTypeToLLVM eRet) (irTypeToLLVM <$> eArgs) False - Just (Left (IRFunction _ fArgs fRet _)) -> do - let llRet = - if irTypeNeedsPointer fRet - then LLVM.void - else irTypeToLLVM fRet - llArgs = irTypeMaybePointer . fst <$> fArgs <> [(fRet, "sRet") | irTypeNeedsPointer fRet] - pure $ LLVM.FunctionType llRet llArgs False - Nothing -> do - funcs <- gets irFunctions - error $ "lookupFunctionType: could not find " <> show fnName <> " in " <> show funcs - -irTypeNeedsPointer :: IRType -> Bool -irTypeNeedsPointer (IRStruct _) = True -irTypeNeedsPointer _ = False - -irIdentifierToLLVM :: (IsString a) => IRIdentifier -> a -irIdentifierToLLVM (IRIdentifier s) = fromString s - -irPrimToLLVM :: IRPrim -> LLVM.Operand -irPrimToLLVM (IRPrimInt32 i) = LLVM.int32 i -irPrimToLLVM (IRPrimInt2 False) = LLVM.bit 0 -irPrimToLLVM (IRPrimInt2 True) = LLVM.bit 1 - -irTypeToLLVM :: IRType -> LLVM.Type -irTypeToLLVM IRInt32 = LLVM.i32 -irTypeToLLVM IRInt8 = LLVM.i8 -irTypeToLLVM IRInt2 = LLVM.i1 -irTypeToLLVM (IRArray size inner) = LLVM.ArrayType size (irTypeToLLVM inner) -irTypeToLLVM (IRStruct bits) = - LLVM.StructureType False (irTypeToLLVM <$> bits) -irTypeToLLVM (IRPointer target) = - LLVM.PointerType (irTypeToLLVM target) (LLVM.AddrSpace 0) -irTypeToLLVM (IRFunctionType tyArgs tyRet) = - LLVM.FunctionType (functionReturnType tyRet) (functionArgsType tyRet tyArgs) False - -functionReturnType :: IRType -> LLVM.Type -functionReturnType irType = - if irTypeNeedsPointer irType - then LLVM.void - else irTypeToLLVM irType - -irTypeMaybePointer :: IRType -> LLVM.Type -irTypeMaybePointer ty = - if irTypeNeedsPointer ty - then irTypeToLLVM (IRPointer ty) - else irTypeToLLVM ty - -functionArgsType :: IRType -> [IRType] -> [LLVM.Type] -functionArgsType fnRet fnArgs = - irTypeMaybePointer <$> (fnArgs <> [fnRet | irTypeNeedsPointer fnRet]) - -irFunctionNameToLLVM :: IRFunctionName -> LLVM.Name -irFunctionNameToLLVM (IRFunctionName name) = fromString name - -irStoreInStruct :: - (LLVM.MonadIRBuilder m, LLVM.MonadModuleBuilder m) => - IRType -> - LLVM.Operand -> - [Integer] -> - LLVM.Operand -> - m () -irStoreInStruct fromTy toStruct indexes from = do - input <- - if irTypeNeedsPointer fromTy - then LLVM.load from 0 - else pure from - -- get pointer to element - slot1 <- LLVM.gep toStruct $ LLVM.int32 <$> ([0] <> indexes) - -- store a in slot1 - LLVM.store slot1 0 input - --- when using `bitcast` we need to cast to a PointerType for structs -getCastType :: IRType -> IRType -getCastType irType = - if irTypeNeedsPointer irType - then IRPointer irType - else irType - --- given a path into a struct, name it! -irVarFromPath :: - ( MonadState IRState m, - LLVM.MonadModuleBuilder m, - LLVM.MonadIRBuilder m - ) => - LLVM.Operand -> - IRIdentifier -> - GetPath -> - m () -irVarFromPath llExpr ident (GetPath as GetValue) = do - val <- if null as then pure llExpr else loadFromStruct llExpr as - addVar ident val -irVarFromPath _llExpr _ident (GetPath _ (GetArrayTail _)) = do - error "spread on arrays not implemented as we'll need some sort of malloc" - -irFuncPointerToLLVM :: (MonadState IRState m) => IRFunctionName -> m LLVM.Operand -irFuncPointerToLLVM fnName = do - fnType <- lookupFunctionType fnName - pure $ - LLVM.ConstantOperand - (LLVM.GlobalReference (pointerType fnType) (irFunctionNameToLLVM fnName)) diff --git a/smol-backend/src/Smol/Backend/IR/ToLLVM/Patterns.hs b/smol-backend/src/Smol/Backend/IR/ToLLVM/Patterns.hs deleted file mode 100644 index 7096fa73..00000000 --- a/smol-backend/src/Smol/Backend/IR/ToLLVM/Patterns.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Backend.IR.ToLLVM.Patterns - ( createSelectTable, - predicatesToOperand, - patName, - selectToOperand, - GetPath (..), - GetValue (..), - PatternPredicate (..), - ) -where - -import Control.Monad (foldM) -import Control.Monad.State -import qualified Data.ByteString.Short as SBS -import qualified Data.List.NonEmpty as NE -import Data.String -import qualified LLVM.AST.IntegerPredicate as IP -import qualified LLVM.AST.Operand as Op -import qualified LLVM.IRBuilder.Constant as C -import qualified LLVM.IRBuilder.Instruction as L -import qualified LLVM.IRBuilder.Module as L -import qualified LLVM.IRBuilder.Monad as L -import Smol.Backend.IR.IRExpr -import Smol.Backend.IR.ToLLVM.Helpers -import Smol.Backend.Types.GetPath -import Smol.Backend.Types.PatternPredicate - --- | get name for pattern block -patName :: Integer -> SBS.ShortByteString -patName i = "pat" <> fromString (show i) - --- given a big predicate, make it into one operand -predicatesToOperand :: - (L.MonadModuleBuilder m, L.MonadIRBuilder m, MonadState IRState m) => - Op.Operand -> - NE.NonEmpty (PatternPredicate IRExpr) -> - (IRExpr -> m Op.Operand) -> - m Op.Operand -predicatesToOperand input nePreds irExprToLLVM = do - firstOp <- compilePred (NE.head nePreds) - foldM - ( \op pat -> do - predOp <- compilePred pat - L.and op predOp - ) - firstOp - (NE.tail nePreds) - where - compilePred (PathEquals (GetPath as GetValue) prim) = do - val <- - if null as - then pure input - else loadFromStruct input as - llExpr <- irExprToLLVM prim - L.icmp IP.EQ val llExpr - compilePred (StringEquals (GetPath as GetValue) prim) = do - val <- - if null as - then pure input - else loadFromStruct input as - llExpr <- irExprToLLVM prim - llFunction <- irFuncPointerToLLVM "stringequals" - L.call llFunction [(val, []), (llExpr, [])] - compilePred (PathEquals (GetPath _ (GetArrayTail _)) _) = - error "predicatesToOperand GetArrayTail" - compilePred (StringEquals (GetPath _ (GetArrayTail _)) _) = - error "predicatesToOperand GetArrayTail" - --- | captures the idea of "if this predicate then 0, if this predicate then --- 1..." --- etc -createSelectTable :: - NE.NonEmpty a -> - SelectList a -createSelectTable = - withPats 0 - where - withPats i pats = case NE.uncons pats of - (_, Nothing) -> SelectThen i - (pat, Just morePats) -> - SelectOr i pat $ withPats (i + 1) morePats - --- numbered list -data SelectList a - = SelectOr Integer a (SelectList a) - | SelectThen Integer - --- | combines the select into one operand --- need to work out how to bitcast after peeking at the first value --- so to make sure any further items we peek at are correct -selectToOperand :: - ( L.MonadModuleBuilder m, - L.MonadIRBuilder m, - MonadState IRState m - ) => - Op.Operand -> - (IRExpr -> m Op.Operand) -> - SelectList ([PatternPredicate IRExpr], IRType) -> - m Op.Operand -selectToOperand input irExprToLLVM = go - where - go (SelectThen i) = pure (C.int32 i) `L.named` "fallback" - go (SelectOr i (preds, irType) rest) = do - opRest <- go rest - opPred <- case NE.nonEmpty preds of - Just nePreds -> do - castInput <- L.bitcast input (irTypeToLLVM (getCastType irType)) - predicatesToOperand castInput nePreds irExprToLLVM `L.named` "pred" - Nothing -> pure (C.bit 1) -- ie, const True - L.select opPred (C.int32 i) opRest diff --git a/smol-backend/src/Smol/Backend/IR/ToLLVM/ToLLVM.hs b/smol-backend/src/Smol/Backend/IR/ToLLVM/ToLLVM.hs deleted file mode 100644 index 4a0aca1e..00000000 --- a/smol-backend/src/Smol/Backend/IR/ToLLVM/ToLLVM.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module Smol.Backend.IR.ToLLVM.ToLLVM - ( irToLLVM, - ) -where - -import Control.Monad.Fix (MonadFix) -import Control.Monad.State - ( MonadState, - StateT (runStateT), - ) -import Data.Bifunctor (Bifunctor (bimap)) -import Data.Foldable (traverse_) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified LLVM.AST as LLVM hiding (function) -import qualified LLVM.AST.Constant as LLVM -import qualified LLVM.AST.IntegerPredicate as LLVM -import qualified LLVM.IRBuilder.Constant as LLVM -import qualified LLVM.IRBuilder.Instruction as LLVM -import qualified LLVM.IRBuilder.Module as LLVM -import qualified LLVM.IRBuilder.Monad as LLVM -import Smol.Backend.IR.IRExpr -import Smol.Backend.IR.ToLLVM.Helpers -import Smol.Backend.IR.ToLLVM.Patterns -import Smol.Core.Helpers (traverseIndNe) - -irToLLVM :: IRModule -> LLVM.Module -irToLLVM (IRModule bits) = - LLVM.buildModule "example" $ do - runStateT (traverse_ irModulePartToLLVM bits) emptyIRState - -irModulePartToLLVM :: - ( LLVM.MonadModuleBuilder m, - MonadFix m, - MonadState IRState m - ) => - IRModulePart -> - m () -irModulePartToLLVM (IRFunctionDef fn@(IRFunction fnName fnArgs fnRet fnBody)) = do - storeFunction fn - let allFnArgs = fnArgs <> [(IRPointer fnRet, "sRet") | irTypeNeedsPointer fnRet] - args = - bimap irTypeMaybePointer irIdentifierToLLVM <$> allFnArgs - ret = functionReturnType fnRet - name = irFunctionNameToLLVM fnName - _ <- LLVM.function name args ret $ \inputs -> do - -- put vars in scope - let pairs = zip (snd <$> allFnArgs) inputs - traverse_ (uncurry addVar) pairs - traverse_ irStatementToLLVM fnBody - pure () -irModulePartToLLVM (IRExternDef ext@(IRExtern eName eArgs eRet)) = do - storeExtern ext - _ <- LLVM.extern (irFunctionNameToLLVM eName) (irTypeToLLVM <$> eArgs) (irTypeToLLVM eRet) - pure () - -irStatementToLLVM :: - ( MonadFix m, - LLVM.MonadModuleBuilder m, - LLVM.MonadIRBuilder m, - MonadState IRState m - ) => - IRStatement -> - m () -irStatementToLLVM (IRRet ty expr) = - if irTypeNeedsPointer ty - then do - opExpr <- irExprToLLVM expr - opRet <- lookupVar "sRet" -- magic strings, what could go wrong - moveToStruct opExpr opRet -- copy the return value to 'sRet' - LLVM.retVoid - else irExprToLLVM expr >>= LLVM.ret -irStatementToLLVM (IRSet path tyFrom fromExp toExp) = do - opFrom <- irExprToLLVM fromExp - opTo <- irExprToLLVM toExp - irStoreInStruct tyFrom opTo path opFrom -irStatementToLLVM (IRDiscard expr) = do - _ <- irExprToLLVM expr - pure () - -irExprToLLVM :: - ( LLVM.MonadIRBuilder m, - LLVM.MonadModuleBuilder m, - MonadState IRState m, - MonadFix m - ) => - IRExpr -> - m LLVM.Operand -irExprToLLVM (IRPrim prim) = pure $ irPrimToLLVM prim -irExprToLLVM (IRString txt) = lookupString txt -irExprToLLVM (IRApply fnType fn fnArgs) = do - functionConst <- irExprToLLVM fn - let (_, tyRet) = returnType fnType - if irTypeNeedsPointer tyRet - then do - retStruct <- LLVM.alloca (irTypeToLLVM tyRet) Nothing 0 `LLVM.named` "ret-struct" - args <- - traverse - ( \arg -> do - opExpr <- irExprToLLVM arg - pure (opExpr, []) - ) - fnArgs - _ <- LLVM.call functionConst (args <> [(retStruct, [])]) - pure retStruct - else do - args <- - traverse - ( \arg -> do - opExpr <- irExprToLLVM arg - pure (opExpr, []) - ) - fnArgs - LLVM.call functionConst args -irExprToLLVM (IRAlloc ty) = do - LLVM.alloca (irTypeToLLVM ty) Nothing 0 -irExprToLLVM (IRStructPath path expr) = do - llExpr <- irExprToLLVM expr - loadFromStruct llExpr path -irExprToLLVM (IRPointerTo i expr) = do - llExpr <- irExprToLLVM expr - LLVM.gep llExpr $ LLVM.int32 <$> ([0] <> i) -- get pointer to item -irExprToLLVM (IRVar ident) = lookupVar ident -irExprToLLVM (IRLet ident expr body) = do - llExpr <- irExprToLLVM expr - addVar ident llExpr - irExprToLLVM body -irExprToLLVM (IRInfix op a b) = irInfixToLLVM op a b -irExprToLLVM (IRStatements statements expr) = do - traverse_ irStatementToLLVM statements - irExprToLLVM expr -irExprToLLVM (IRInitialiseDataType input tyThis tyWhole args) = do - llInput <- irExprToLLVM input - - -- cast to tyThis - castInput <- LLVM.bitcast llInput (irTypeToLLVM (getCastType tyThis)) - - -- set all the items inside - - let setArg (IRSetTo path ty arg) = do - opArg <- irExprToLLVM arg - irStoreInStruct ty castInput path opArg - traverse_ setArg args - - -- case to tyWhole - LLVM.bitcast castInput (irTypeToLLVM (getCastType tyWhole)) -irExprToLLVM (IRMatch matchExpr tyRet matches) = mdo - llMatch <- irExprToLLVM matchExpr - -- make return hole - retValue <- LLVM.alloca (irTypeToLLVM tyRet) Nothing 0 - - -- create an int with the index of the matching case - matchingInt <- - selectToOperand - llMatch - irExprToLLVM - ( createSelectTable - ( (\match -> (irmcPatternPredicate match, irmcType match)) <$> matches - ) - ) - - -- go to that block ... - -- block returns from all this - let defaultLabel = snd (NE.head blocks) - LLVM.switch matchingInt defaultLabel (NE.toList blocks) - - -- now we create a table of which thing to do, depending on value of - -- `matchValue` - blocks <- - traverseIndNe - ( \(tyCast, fetches, expr) i -> - (,) (LLVM.Int 32 i) - <$> irExprToLLVMBlock expr tyCast fetches mergeBlock llMatch retValue - ) - ((\irMatchCase -> (irmcType irMatchCase, irmcGetPath irMatchCase, irmcExpr irMatchCase)) <$> matches) - - -- merge block, we always end up here - mergeBlock <- LLVM.block `LLVM.named` "merge" - -- return value - LLVM.load retValue 0 -irExprToLLVM (IRFuncPointer fnName) = irFuncPointerToLLVM fnName - -irInfixToLLVM :: - ( LLVM.MonadIRBuilder m, - LLVM.MonadModuleBuilder m, - MonadState IRState m, - MonadFix m - ) => - IROp -> - IRExpr -> - IRExpr -> - m LLVM.Operand -irInfixToLLVM IRAdd a b = do - lhs <- irExprToLLVM a - rhs <- irExprToLLVM b - LLVM.add lhs rhs -irInfixToLLVM IREquals a b = do - lhs <- irExprToLLVM a - rhs <- irExprToLLVM b - LLVM.icmp LLVM.EQ lhs rhs - -irExprToLLVMBlock :: - ( MonadFix m, - LLVM.MonadIRBuilder m, - LLVM.MonadModuleBuilder m, - MonadState IRState m - ) => - IRExpr -> - IRType -> - Map IRIdentifier GetPath -> - LLVM.Name -> - LLVM.Operand -> - LLVM.Operand -> - m LLVM.Name -irExprToLLVMBlock blockExpr tyCastTo destructured mergeBlock opExpr opResult = do - -- start a new block - patBlock <- LLVM.block `LLVM.named` "pattern" - - -- cast opExpr to the right type - castExpr <- LLVM.bitcast opExpr (irTypeToLLVM (getCastType tyCastTo)) - - -- add vals to scope - traverse_ (uncurry $ irVarFromPath castExpr) (M.toList destructured) - - -- run patExpr with new destructured vars - patResult <- irExprToLLVM blockExpr - - -- store result - LLVM.store opResult 0 patResult - - -- branch home - LLVM.br mergeBlock - - -- return a reference to the block - pure patBlock diff --git a/smol-backend/src/Smol/Backend/Types/GetPath.hs b/smol-backend/src/Smol/Backend/Types/GetPath.hs deleted file mode 100644 index b0760f8b..00000000 --- a/smol-backend/src/Smol/Backend/Types/GetPath.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Backend.Types.GetPath - ( GetPath (..), - GetValue (..), - ) -where - --- how do we get at a given item that we've matched on -data GetPath = GetPath [Integer] GetValue - deriving stock (Eq, Ord, Show) - -data GetValue - = GetValue -- fetch the item pointed to here - | GetArrayTail Integer -- fetch the array here, but drop X items - deriving stock (Eq, Ord, Show) diff --git a/smol-backend/src/Smol/Backend/Types/PatternPredicate.hs b/smol-backend/src/Smol/Backend/Types/PatternPredicate.hs deleted file mode 100644 index f8158e3b..00000000 --- a/smol-backend/src/Smol/Backend/Types/PatternPredicate.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Backend.Types.PatternPredicate - ( PatternPredicate (..), - ) -where - -import Smol.Backend.Types.GetPath - --- TODO: go through pattern, create a big predicate that says "i am matched" -data PatternPredicate p - = PathEquals GetPath p -- path to value, value it should equal - | StringEquals GetPath p -- path to value, value it should equal using string equality function - deriving stock (Eq, Ord, Show) diff --git a/smol-backend/static/runtime.c b/smol-backend/static/runtime.c deleted file mode 100644 index 44885ffb..00000000 --- a/smol-backend/static/runtime.c +++ /dev/null @@ -1,35 +0,0 @@ -#include -#include -#include -#include - -void printint(int i) { - printf("%d", i); -} - -void printbool(int b) { - printf(b ? "True" : "False"); -} - -// our string value is a struct { length: int, values: int [] } -// for now ignore input -void printstring(char *arr) { - printf("%s", arr); -} - -// yolo: https://stackoverflow.com/questions/8465006/how-do-i-concatenate-two-strings-in-c -char* stringconcat(const char *s1, const char *s2) -{ - const size_t len1 = strlen(s1); - const size_t len2 = strlen(s2); - char *result = malloc(len1 + len2 + 1); // +1 for the null-terminator - // in real code you would check for errors in malloc here - memcpy(result, s1, len1); - memcpy(result + len1, s2, len2 + 1); // +1 to copy the null-terminator - return result; -} - -// check two strings are the same -bool stringequals(const char *s1, const char *s2) { - return (strcmp(s1, s2) == 0); -} diff --git a/smol-backend/test/Main.hs b/smol-backend/test/Main.hs deleted file mode 100644 index 4b705cd1..00000000 --- a/smol-backend/test/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main (main) where - -import Test.Hspec -import qualified Test.IR.CompileSpec -import qualified Test.IR.DataTypesSpec -import qualified Test.IR.FromExprSpec -import qualified Test.IR.IRSpec -import qualified Test.IR.PatternSpec - -main :: IO () -main = hspec $ do - Test.IR.DataTypesSpec.spec - Test.IR.PatternSpec.spec - Test.IR.FromExprSpec.spec - Test.IR.CompileSpec.spec - Test.IR.IRSpec.spec diff --git a/smol-backend/test/Test/BuiltInTypes.hs b/smol-backend/test/Test/BuiltInTypes.hs deleted file mode 100644 index df415401..00000000 --- a/smol-backend/test/Test/BuiltInTypes.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Test.BuiltInTypes - ( builtInTypes, - ) -where - -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Smol.Core.Types - --- | these should move to the test suite, and instead we should rely on types --- defined in module -builtInTypes :: - (Monoid ann, Ord (dep TypeName), Ord (dep Identifier)) => - (forall a. a -> dep a) -> - Map (dep TypeName) (DataType dep ann) -builtInTypes liftDep = - let identityDt = - DataType - "Identity" - ["a"] - (M.singleton "Identity" [TVar mempty $ liftDep "a"]) - maybeDt = - DataType - "Maybe" - ["a"] - (M.fromList [("Just", [TVar mempty $ liftDep "a"]), ("Nothing", [])]) - eitherDt = - DataType - "Either" - ["e", "a"] - ( M.fromList - [ ("Left", [TVar mempty $ liftDep "e"]), - ("Right", [TVar mempty $ liftDep "a"]) - ] - ) - - theseDt = - DataType - "These" - ["a", "b"] - ( M.fromList - [ ("This", [TVar mempty $ liftDep "a"]), - ("That", [TVar mempty $ liftDep "b"]), - ("These", [TVar mempty $ liftDep "a", TVar mempty $ liftDep "b"]) - ] - ) - ordDt = - DataType - "Ord" - [] - ( M.fromList [("LT", mempty), ("EQ", mempty), ("GT", mempty)] - ) - - stateDt = - DataType - "State" - ["s", "a"] - ( M.singleton - "State" - [ TFunc - mempty - mempty - (TVar mempty (liftDep "s")) - ( TTuple - mempty - (TVar mempty (liftDep "a")) - (NE.fromList [TVar mempty (liftDep "s")]) - ) - ] - ) - - listDt = - DataType - "List" - ["a"] - ( M.fromList - [ ( "Cons", - [ TVar mempty (liftDep "a"), - TApp mempty (TConstructor mempty (liftDep "List")) (TVar mempty (liftDep "a")) - ] - ), - ("Nil", mempty) - ] - ) - in M.fromList - [ (liftDep "Maybe", maybeDt), - (liftDep "Either", eitherDt), - (liftDep "Ord", ordDt), - (liftDep "These", theseDt), - (liftDep "Identity", identityDt), - (liftDep "List", listDt), - (liftDep "State", stateDt) - ] diff --git a/smol-backend/test/Test/Helpers.hs b/smol-backend/test/Test/Helpers.hs deleted file mode 100644 index 52d0b46d..00000000 --- a/smol-backend/test/Test/Helpers.hs +++ /dev/null @@ -1,133 +0,0 @@ -module Test.Helpers - ( tyBool, - tyBoolLit, - tyInt, - tyIntLit, - tyVar, - tyUnknown, - tyTuple, - tyCons, - bool, - int, - var, - tuple, - array, - unit, - identifier, - constructor, - patternMatch, - unsafeParseExpr, - unsafeParseModule, - unsafeParseType, - unsafeParseTypedExpr, - ) -where - -import Data.Foldable (foldl') -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Sequence as Seq -import qualified Data.Set.NonEmpty as NES -import Data.Text (Text) -import Smol.Core -import Smol.Core.Modules.FromParts -import Smol.Core.Modules.Types.Module -import Smol.Core.Typecheck.FromParsedExpr - -tyBool :: (Monoid ann) => Type dep ann -tyBool = TPrim mempty TPBool - -tyBoolLit :: (Monoid ann) => Bool -> Type dep ann -tyBoolLit = TLiteral mempty . TLBool - -tyInt :: (Monoid ann) => Type dep ann -tyInt = TPrim mempty TPInt - -tyIntLit :: (Monoid ann) => [Integer] -> Type dep ann -tyIntLit = TLiteral mempty . TLInt . NES.fromList . NE.fromList - -tyVar :: (Monoid ann) => Text -> Type ParseDep ann -tyVar = TVar mempty . emptyParseDep . Identifier - -tyUnknown :: (Monoid ann) => Integer -> Type dep ann -tyUnknown = TUnknown mempty - -tyTuple :: - (Monoid ann) => - Type dep ann -> - [Type dep ann] -> - Type dep ann -tyTuple a as = TTuple mempty a (NE.fromList as) - -tyCons :: - (Monoid ann) => - TypeName -> - [Type ParseDep ann] -> - Type ParseDep ann -tyCons typeName = - foldl' (TApp mempty) (TConstructor mempty (emptyParseDep typeName)) - -unit :: (Monoid ann) => Expr dep ann -unit = EPrim mempty PUnit - -bool :: (Monoid ann) => Bool -> Expr dep ann -bool = EPrim mempty . PBool - -int :: (Monoid ann) => Integer -> Expr dep ann -int = EPrim mempty . PInt - -var :: (Monoid ann) => Text -> Expr ParseDep ann -var = EVar mempty . emptyParseDep . Identifier - -tuple :: - (Monoid ann) => - Expr dep ann -> - [Expr dep ann] -> - Expr dep ann -tuple a as = ETuple mempty a (NE.fromList as) - -constructor :: - (Monoid ann) => - Text -> - Expr ParseDep ann -constructor lbl = EConstructor mempty (emptyParseDep (Constructor lbl)) - -identifier :: Text -> ParseDep Identifier -identifier = emptyParseDep . Identifier - -patternMatch :: - (Monoid ann) => - Expr dep ann -> - [(Pattern dep ann, Expr dep ann)] -> - Expr dep ann -patternMatch expr pats = - EPatternMatch mempty expr (NE.fromList pats) - -array :: (Monoid ann) => [Expr dep ann] -> Expr dep ann -array as = EArray mempty (Seq.fromList as) - ------- - -unsafeParseExpr :: Text -> Expr ParseDep () -unsafeParseExpr input = case parseExprAndFormatError input of - Right expr -> expr $> () - Left e -> error (show e) - -unsafeParseType :: Text -> Type ParseDep () -unsafeParseType input = case parseTypeAndFormatError input of - Right ty -> ty $> () - Left e -> error (show e) - -unsafeParseModule :: Text -> Module ParseDep () -unsafeParseModule input = case parseModuleAndFormatError input of - Right parts -> case moduleFromModuleParts parts of - Right a -> a $> () - Left e -> error (show e) - Left e -> error (show e) - --- | parse a typed expr, ie parse it and fill the type with crap --- this should not be compiled because `fromParsedExpr is nonsense -unsafeParseTypedExpr :: Text -> ResolvedExpr (Type ResolvedDep Annotation) -unsafeParseTypedExpr input = case parseExprAndFormatError input of - Right expr -> fromParsedExpr expr $> TPrim mempty TPBool - Left e -> error (show e) diff --git a/smol-backend/test/Test/IR/CompileSpec.hs b/smol-backend/test/Test/IR/CompileSpec.hs deleted file mode 100644 index 28e1e569..00000000 --- a/smol-backend/test/Test/IR/CompileSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.IR.CompileSpec (spec) where - -import Data.Text (Text) -import LLVM.AST hiding (function) -import qualified Smol.Backend.Compile.RunLLVM as Run -import Test.Hspec -import Test.IR.RawSamples - --- run the code, get the output, die -run :: Module -> IO Text -run = fmap Run.rrResult . Run.run [] - -spec :: Spec -spec = do - describe "Compile" $ do - describe "Examples" $ do - it "Compiles and runs an example module" $ do - resp <- run print42 - resp `shouldBe` "42" - it "Uses id function" $ do - resp <- run useId42 - resp `shouldBe` "42" - it "Uses add function" $ do - resp <- run useAdd42 - resp `shouldBe` "42" - it "Uses const function (curried)" $ do - resp <- run useConst42Curried - resp `shouldBe` "42" - it "Makes and deconstructs a one tuple" $ do - resp <- run oneTuple42 - resp `shouldBe` "42" - it "Makes and deconstructs a two tuple" $ do - resp <- run twoTuple42 - resp `shouldBe` "42" - it "Makes and deconstructs a nested two tuple" $ do - resp <- run nestedTuple42 - resp `shouldBe` "42" - it "Basic if statement" $ do - resp <- run useBasicIf - resp `shouldBe` "1" - it "Makes and deconstructs a sum type" $ do - resp <- run either42 - resp `shouldBe` "42" diff --git a/smol-backend/test/Test/IR/DataTypesSpec.hs b/smol-backend/test/Test/IR/DataTypesSpec.hs deleted file mode 100644 index d7c5f2f7..00000000 --- a/smol-backend/test/Test/IR/DataTypesSpec.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.IR.DataTypesSpec (spec) where - -import Control.Monad.State -import qualified Data.Map.Strict as M -import qualified Smol.Backend.IR.FromExpr.DataTypes as DT -import Smol.Backend.IR.FromExpr.Types -import Smol.Core.Typecheck.FromParsedExpr -import qualified Smol.Core.Typecheck.Types as Smol -import Smol.Core.Types -import qualified Smol.Core.Types as Smol -import Test.BuiltInTypes (builtInTypes) -import Test.Helpers -import Test.Hspec - -typeToDataType :: - Smol.Type ResolvedDep () -> - Either (Smol.TCError ()) DT.DataTypeInMemory -typeToDataType ty = - evalState - (DT.typeToDataTypeInMemory ty) - ( FromExprState - { fesModuleParts = mempty, - fesDataTypes = builtInTypes LocalDefinition, - fesFreshInt = 0, - fesVars = mempty - } - ) - -parseToResolvedDep :: Type ParseDep a -> Type ResolvedDep a -parseToResolvedDep = fromParsedType - -spec :: Spec -spec = do - describe "Data types in memory" $ do - it "Enum shaped datatype" $ do - let ty = tyCons "Ord" [] - typeToDataType (parseToResolvedDep ty) - `shouldBe` Right DT.DTEnum - - it "Maybe Int" $ do - let ty = tyCons "Maybe" [tyInt] - expected = - DT.DTDataType - { DT.dtWhole = DT.DTTuple [DT.DTPrim TPInt, DT.DTArray 1 (DT.DTPrim TPInt)], - DT.dtConstructors = - M.fromList - [ ("Just", [DT.DTPrim TPInt]), - ("Nothing", []) - ] - } - typeToDataType (parseToResolvedDep ty) - `shouldBe` Right expected - - it "Either Int Bool" $ do - let ty = tyCons "Either" [tyInt, tyBool] - expected = - DT.DTDataType - { DT.dtWhole = DT.DTTuple [DT.DTPrim TPInt, DT.DTArray 1 (DT.DTPrim TPInt)], - DT.dtConstructors = - M.fromList - [ ("Left", [DT.DTPrim TPInt]), - ("Right", [DT.DTPrim TPBool]) - ] - } - typeToDataType (parseToResolvedDep ty) - `shouldBe` Right expected - - it "These Int Bool" $ do - let ty = tyCons "These" [tyInt, tyBool] - expected = - DT.DTDataType - { DT.dtWhole = DT.DTTuple [DT.DTPrim TPInt, DT.DTArray 2 (DT.DTPrim TPInt)], - DT.dtConstructors = - M.fromList - [ ("That", [DT.DTPrim TPBool]), - ("This", [DT.DTPrim TPInt]), - ("These", [DT.DTPrim TPInt, DT.DTPrim TPBool]) - ] - } - typeToDataType (parseToResolvedDep ty) - `shouldBe` Right expected diff --git a/smol-backend/test/Test/IR/FromExprSpec.hs b/smol-backend/test/Test/IR/FromExprSpec.hs deleted file mode 100644 index 0cd9f59d..00000000 --- a/smol-backend/test/Test/IR/FromExprSpec.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.IR.FromExprSpec (spec) where - -import Control.Monad.State -import Control.Monad.Writer -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Text (Text) -import qualified Smol.Backend.IR.FromExpr.Expr as IR -import Smol.Backend.IR.IRExpr -import Smol.Backend.IR.ToLLVM.Patterns -import Smol.Core.Typecheck -import Smol.Core.Types -import Test.BuiltInTypes (builtInTypes) -import Test.Helpers -import Test.Hspec - -evalExpr :: Text -> Expr ResolvedDep (Type ResolvedDep Annotation) -evalExpr input = - let env = - TCEnv - { tceDataTypes = builtInTypes emptyResolvedDep, - tceVars = mempty, - tceClasses = mempty, - tceInstances = mempty, - tceConstraints = mempty - } - in case elaborate env (unsafeParseTypedExpr input $> mempty) of - Right (typedExpr, _) -> typedExpr - Left e -> error (show e) - -testEnv :: (Monoid ann) => IR.FromExprState ann -testEnv = - IR.FromExprState - { IR.fesModuleParts = mempty, - IR.fesDataTypes = builtInTypes LocalDefinition, - IR.fesFreshInt = 1, - IR.fesVars = mempty - } - -getMainExpr :: Text -> IRExpr -getMainExpr = fst . createIR - -createIR :: Text -> (IRExpr, [IRModulePart]) -createIR input = do - let smolExpr = evalExpr input - ((mainExpr, _), IR.FromExprState {IR.fesModuleParts = otherParts}) = - runState (runWriterT $ IR.fromExpr smolExpr) testEnv - in (mainExpr, otherParts) - -findFunction :: IRFunctionName -> [IRModulePart] -> IRFunction -findFunction fnName fns = - let matches = - mapMaybe - ( \case - IRFunctionDef f -> if irfName f == fnName then Just f else Nothing - _ -> Nothing - ) - fns - in case matches of - [a] -> a - _ -> error $ "could not find " <> show fnName <> " in " <> show fns - -spec :: Spec -spec = do - describe "IR from expressions" $ do - it "Prim ints become numbers" $ do - getMainExpr "42" `shouldBe` IRPrim (IRPrimInt32 42) - - it "Creates a struct from a tuple" $ do - let structType = IRStruct [IRInt32, IRInt32, IRInt32] - getMainExpr "(1,2,3)" - `shouldBe` IRInitialiseDataType - (IRAlloc structType) - structType - structType - [ IRSetTo [0] IRInt32 (IRPrim $ IRPrimInt32 1), - IRSetTo [1] IRInt32 (IRPrim $ IRPrimInt32 2), - IRSetTo [2] IRInt32 (IRPrim $ IRPrimInt32 3) - ] - - it "Enum-like constructors become numbers" $ do - getMainExpr "EQ" `shouldBe` IRPrim (IRPrimInt32 0) - - it "Constructors with arguments become structs" $ do - let maybeIntType = IRStruct [IRInt32, IRArray 1 IRInt32] - justIntType = IRStruct [IRInt32, IRInt32] - getMainExpr "Just 42" - `shouldBe` IRInitialiseDataType - (IRAlloc maybeIntType) - justIntType - maybeIntType - [ IRSetTo [0] IRInt32 (IRPrim $ IRPrimInt32 0), - IRSetTo [1] IRInt32 (IRPrim $ IRPrimInt32 42) - ] - - it "Non-enum constructors with no arguments still become structs" $ do - let maybeIntType = IRStruct [IRInt32, IRArray 1 IRInt32] - nothingIntType = IRStruct [IRInt32] - getMainExpr "(Nothing : Maybe Int)" - `shouldBe` IRInitialiseDataType - (IRAlloc maybeIntType) - nothingIntType - maybeIntType - [ IRSetTo [0] IRInt32 (IRPrim $ IRPrimInt32 1) - ] - - -- ignore what the function DOES, what does it give us back to play with? - -- this has an empty env, in future lets optimise so that we don't bother - -- with the struct etc for these cases, and instead just return a function - -- pointer - it "Lambda returns closure" $ do - let functionPointerType = IRFunctionType [IRInt32, IRStruct []] IRInt32 - closureType = - IRStruct - [ IRPointer functionPointerType, - IRStruct [] - ] - getMainExpr "(\\a -> 1 : Int -> Int)" - `shouldBe` IRInitialiseDataType - (IRAlloc closureType) - closureType - closureType - [ IRSetTo [0] (IRPointer functionPointerType) (IRFuncPointer "function1") - ] - - -- ignore what the function DOES, what does it give us back to play with? - -- this has an empty env, in future lets optimise so that we don't bother - -- with the struct etc for these cases, and instead just return a function - -- pointer - it "Runs lambda from closure" $ do - let functionPointerType = IRFunctionType [IRInt32, IRStruct []] IRInt32 - closureType = - IRStruct - [ IRPointer functionPointerType, - IRStruct [] - ] - innerStructType = - IRStruct - [IRPointer (IRFunctionType [IRInt32, IRStruct []] IRInt32), IRStruct []] - - getMainExpr "(\\a -> 1 : Int -> Int) 2" - `shouldBe` IRLet - "closure2" - ( IRInitialiseDataType - (IRAlloc closureType) - closureType - closureType - [ IRSetTo [0] (IRPointer functionPointerType) (IRFuncPointer "function1") - ] - ) - ( IRApply - (IRStruct [IRPointer (IRFunctionType [IRInt32, IRStruct []] IRInt32), IRStruct []]) - ( IRStructPath - [0] - ( IRInitialiseDataType - (IRAlloc innerStructType) - innerStructType - innerStructType - [ IRSetTo - [0] - (IRPointer (IRFunctionType [IRInt32, IRStruct []] IRInt32)) - (IRFuncPointer "function1") - ] - ) - ) - [IRPrim (IRPrimInt32 2), IRPointerTo [1] (IRVar "closure2")] - ) - - xit "Runs a function returned from a lambda twice" $ do - let func2Env = IRStruct [IRInt32] - func2Type = IRFunctionType [IRInt32, IRPointer func2Env] IRInt32 - add1ReturnType = - IRStruct - [ IRPointer func2Type, - func2Env - ] - - getMainExpr "(\\a -> \\b -> a + b : Int -> Int -> Int) 1 2" - `shouldBe` IRLet - "emptyenv" - (IRAlloc (IRStruct [])) - ( IRLet - "closure" - ( IRApply - (IRFunctionType [IRInt32] add1ReturnType) - (IRFuncPointer "add1") - [IRPrim (IRPrimInt32 20), IRVar "emptyenv"] - ) - ( IRApply - func2Type - (IRStructPath [0] (IRVar "closure")) - [ IRPrim (IRPrimInt32 22), - IRPointerTo [1] (IRVar "closure") - ] - ) - ) - - it "Creates function that returns a lambda closure" $ do - let (_expr, fns) = createIR "(\\a -> \\b -> a + b : Int -> Int -> Int) 1 2" - let func2Env = IRStruct [IRInt32] - func2Type = - IRFunctionType - [IRInt32, func2Env] - IRInt32 - add1ReturnType = - IRStruct - [ IRPointer func2Type, - func2Env - ] - -- this is the \\a -> ... function that returns a closure with env - findFunction "function1" fns - `shouldBe` IRFunction - { irfName = "function1", - irfArgs = [(IRInt32, "a"), (IRStruct [], "env")], - irfReturn = - IRStruct - [ IRPointer (IRFunctionType [IRInt32, IRStruct [IRInt32]] IRInt32), - IRStruct [IRInt32] - ], - irfBody = - [ IRRet - add1ReturnType - ( IRInitialiseDataType - (IRAlloc add1ReturnType) - add1ReturnType - add1ReturnType - [ IRSetTo - [0] - (IRPointer func2Type) - (IRFuncPointer "function2"), - IRSetTo - [1, 0] - IRInt32 - (IRVar "a") - ] - ) - ] - } - - it "Creates lambda closure that returns a plain value" $ do - let (_expr, fns) = createIR "(\\a -> \\b -> a + b : Int -> Int -> Int) 1 2" - findFunction "function2" fns - `shouldBe` IRFunction - { irfName = "function2", - irfArgs = [(IRInt32, "b"), (IRStruct [IRInt32], "env")], - irfReturn = IRInt32, - irfBody = - [ IRRet - IRInt32 - (IRInfix IRAdd (IRStructPath [0] (IRVar "env")) (IRVar "b")) - ] - } - - it "Creates constructor with arg" $ do - getMainExpr "Just 41" - `shouldBe` IRInitialiseDataType - (IRAlloc (IRStruct [IRInt32, IRArray 1 IRInt32])) - (IRStruct [IRInt32, IRInt32]) - (IRStruct [IRInt32, IRArray 1 IRInt32]) - [ IRSetTo {irstPath = [0], irstType = IRInt32, irstExpr = IRPrim (IRPrimInt32 0)}, - IRSetTo - { irstPath = [1], - irstType = - IRInt32, - irstExpr = IRPrim (IRPrimInt32 41) - } - ] - - it "Pattern matches enum" $ do - getMainExpr "(case LT of GT -> 21 | EQ -> 23 | LT -> 42 : Int)" - `shouldBe` IRMatch - (IRPrim (IRPrimInt32 2)) - IRInt32 - ( NE.fromList - [ IRMatchCase - { irmcType = IRInt32, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt32 1)], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 21) - }, - IRMatchCase - { irmcType = IRInt32, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt32 0)], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 23) - }, - IRMatchCase - { irmcType = IRInt32, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt32 2)], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 42) - } - ] - ) - - it "Pattern matches 2-arg type" $ do - let typeTheseIntInt = IRStruct [IRInt32, IRArray 2 IRInt32] - thisIntInt = IRStruct [IRInt32, IRInt32] - thatIntInt = IRStruct [IRInt32, IRInt32] - theseIntInt = IRStruct [IRInt32, IRInt32, IRInt32] - getMainExpr "(case (This 42 : These Int Int) of This a -> a | That b -> 0 | These tA tB -> tA + tB : Int)" - `shouldBe` IRMatch - ( IRInitialiseDataType - (IRAlloc typeTheseIntInt) - thisIntInt - typeTheseIntInt - [ IRSetTo [0] IRInt32 (IRPrim (IRPrimInt32 2)), - IRSetTo [1] IRInt32 (IRPrim (IRPrimInt32 42)) - ] - ) - IRInt32 - ( NE.fromList - [ IRMatchCase - { irmcType = thisIntInt, - irmcPatternPredicate = - [ PathEquals - (GetPath [0] GetValue) - (IRPrim $ IRPrimInt32 2) - ], - irmcGetPath = M.singleton "a" (GetPath [1] GetValue), - irmcExpr = IRVar "a" - }, - IRMatchCase - { irmcType = thatIntInt, - irmcPatternPredicate = - [ PathEquals - (GetPath [0] GetValue) - (IRPrim $ IRPrimInt32 0) - ], - irmcGetPath = M.singleton "b" (GetPath [1] GetValue), - irmcExpr = IRPrim (IRPrimInt32 0) - }, - IRMatchCase - { irmcType = theseIntInt, - irmcPatternPredicate = - [ PathEquals - (GetPath [0] GetValue) - (IRPrim $ IRPrimInt32 1) - ], - irmcGetPath = - M.fromList - [ ("tA", GetPath [1] GetValue), - ("tB", GetPath [2] GetValue) - ], - irmcExpr = IRInfix IRAdd (IRVar "tA") (IRVar "tB") - } - ] - ) diff --git a/smol-backend/test/Test/IR/IRSpec.hs b/smol-backend/test/Test/IR/IRSpec.hs deleted file mode 100644 index e23a2409..00000000 --- a/smol-backend/test/Test/IR/IRSpec.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.IR.IRSpec (spec) where - -import Control.Monad.Except -import Data.Foldable (traverse_) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified LLVM.AST as LLVM -import qualified Smol.Backend.Compile.RunLLVM as Run -import Smol.Backend.IR.FromExpr.Expr -import Smol.Backend.IR.ToLLVM.ToLLVM -import Smol.Core.Modules.FromParts -import Smol.Core.Modules.ResolveDeps -import Smol.Core.Modules.Typecheck -import Smol.Core.Modules.Types -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Parser (parseModuleAndFormatError) -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types -import Test.BuiltInTypes -import Test.Hspec -import Test.IR.Samples - --- run the code, get the output, die -run :: LLVM.Module -> [(String, String)] -> IO Text -run llModule env = - Run.rrResult <$> Run.run env llModule - -createLLVMModuleFromExpr :: Text -> LLVM.Module -createLLVMModuleFromExpr input = - createLLVMModuleFromModule $ "def main = " <> input - -testCompileIR :: (Text, Text) -> Spec -testCompileIR (input, result) = it ("Via IR " <> show input) $ do - resp <- run (createLLVMModuleFromExpr input) [] - resp `shouldBe` result - -createLLVMModuleFromModule :: Text -> LLVM.Module -createLLVMModuleFromModule input = - case resolveModule input of - Right typecheckedModule -> - irToLLVM (irFromModule typecheckedModule) - Left e -> error (show e) - --- add the empty ones for testing -addTestDataTypesToModule :: forall ann. (Monoid ann) => Module ParseDep ann -> Module ParseDep ann -addTestDataTypesToModule myModule = - let resolvedBuiltIns :: M.Map TypeName (DataType ParseDep ann) - resolvedBuiltIns = M.mapKeys pdIdentifier (builtInTypes emptyParseDep) - in myModule {moDataTypes = resolvedBuiltIns <> moDataTypes myModule} - -resolveModule :: Text -> Either (ModuleError Annotation) (Module ResolvedDep (Type ResolvedDep Annotation)) -resolveModule input = - case parseModuleAndFormatError input of - Right moduleItems -> runExcept $ do - myModule <- moduleFromModuleParts moduleItems - - let classes = resolveTypeclass <$> moClasses myModule - typeclassMethods = S.fromList . M.elems . fmap tcFuncName $ classes - - (resolvedModule, deps) <- - modifyError ErrorInResolveDeps (resolveModuleDeps typeclassMethods (addTestDataTypesToModule myModule)) - - typecheckModule input resolvedModule deps - Left e -> error (show e) - -testCompileModuleIR :: ([Text], Text) -> Spec -testCompileModuleIR (inputs, result) = - let input = T.intercalate "\n" inputs - in it ("Via IR " <> show input) $ do - resp <- run (createLLVMModuleFromModule input) [] - resp `shouldBe` result - -spec :: Spec -spec = do - describe "Compile via IR" $ do - describe "IR" $ do - it "print 42" $ do - resp <- run (irToLLVM irPrint42) mempty - resp `shouldBe` "42" - it "use id function" $ do - resp <- run (irToLLVM irId42) mempty - resp `shouldBe` "42" - it "creates and destructures tuple" $ do - resp <- run (irToLLVM irTwoTuple42) mempty - resp `shouldBe` "42" - it "does an if statement" $ do - resp <- run (irToLLVM irBasicIf) mempty - resp `shouldBe` "42" - it "does a pattern match" $ do - resp <- run (irToLLVM irPatternMatch) mempty - resp `shouldBe` "42" - it "recursive function" $ do - resp <- run (irToLLVM irRecursive) mempty - resp `shouldBe` "49995000" - it "curried function (no closure)" $ do - resp <- run (irToLLVM irCurriedNoClosure) mempty - resp `shouldBe` "22" - it "curried function" $ do - resp <- run (irToLLVM irCurried) mempty - resp `shouldBe` "42" - - describe "From modules" $ do - let testModules = - [ ( [ "def one = 1", - "def main = one + one" - ], - "2" - ), - ( [ "def increment a = (a + 1 : Int)", - "def main = increment 41" - ], - "42" - ), - ( [ "def add : Int -> Int -> Int", - "def add a b = a + b", - "def main = add 20 22" - ], - "42" - ), - ( [ "type Identity a = Identity a", - "def main = case Identity 42 of Identity a -> a" - ], - "42" - ), - ( [ "type Identity a = Identity a", - "def main = case Identity (41 + 1) of Identity a -> a" - ], - "42" - ), - ( [ "type Identity a = Identity a", - "def main = let id = (\\a -> a : Int -> Int); case Identity (id 42) of Identity a -> a" - ], - "42" - ), - ( [ "type Identity a = Identity a", - "def runIdentity : Identity Int -> Int", - "def runIdentity identA = case identA of Identity b -> b", - "def main = runIdentity (Identity 42)" - ], - "42" - ) - ] - describe "IR compile" $ do - traverse_ testCompileModuleIR testModules - - describe "From expressions" $ do - describe "Basic" $ do - let testVals = - [ ("42", "42"), - ("True", "True"), - ("False", "False"), - ("(1 + 1 : Int)", "2"), - ("(1 + 2 + 3 + 4 + 5 + 6 : Int)", "21"), - ("(if True then 1 else 2 : Int)", "1"), - ("(if False then 1 else 2 : Int)", "2"), - ("\"horse\"", "horse"), - ("if True then \"horse\" else \"no-horse\"", "horse"), - ("\"hor\" + \"se\"", "horse"), - ("\"horse\" == \"horse\"", "True"), - ("\"hor\" + \"se\" == \"horse\"", "True"), - ("(\"dog\" : String) == (\"log\" : String)", "False"), - ("case \"dog\" of \"dog\" -> True | _ -> False", "True"), - ("case (\"log\" : String) of \"dog\" -> True | _ -> False", "False"), - ("case \"dog\" of \"dog\" -> True | _ -> False", "True") - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - - describe "Functions" $ do - let testVals = - [ ("(\\a -> a + 1 : Int -> Int) 2", "3"), - ("(\\b -> if b then 42 else 41 : Bool -> Int) True", "42"), - ("(\\b -> if b then 1 else 42 : Bool -> Int) False", "42"), - ("(\\a -> a + 1: Int -> Int) 41", "42"), - ("(\\a -> 42 : Int -> Int) 21", "42"), - ("(\\a -> \\b -> a + b : Int -> Int -> Int) 20 22", "42"), - ("let a = (1 : Int); let useA = (\\b -> b + a : Int -> Int); useA (41 : Int)", "42"), - ("let add = (\\a -> \\b -> a + b : Int -> Int -> Int); add (1 : Int) (2 : Int)", "3"), - ("let f = (\\i -> i + 1 : Int -> Int) in f (1 : Int)", "2"), -- single arity function that return prim - ("let f = (\\i -> (i,i) : Int -> (Int,Int)); let b = f (1 : Int); 42", "42"), -- single arity function that returns struct - ("let f = (\\i -> (i,10) : Int -> (Int,Int)) in (case f (100 : Int) of (a,b) -> a + b : Int)", "110"), -- single arity function that returns struct - ("let flipConst = (\\a -> \\b -> b : Int -> Int -> Int); flipConst (1 : Int) (2 : Int)", "2") -- oh fuck - -- ("let sum = (\\a -> if a == 10 then 0 else let a2 = a + 1 in a + sum a2 : Int -> Int); sum (0 : Int)", "1783293664"), - -- ("let add3 = (\\a -> \\b -> \\c -> a + b + c : Int -> Int -> Int -> Int); add3 (1 : Int) (2 : Int) (3 : Int)", "6"), - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - - describe "Tuples and matching" $ do - let testVals = - [ ("let pair = (20,22); (case pair of (a,b) -> a + b : Int)", "42"), - ("(\\pair -> case pair of (a,b) -> a + b : (Int,Int) -> Int) (20,22)", "42"), - ("(\\triple -> case triple of (a,b,c) -> a + b + c : (Int,Int,Int) -> Int) (20,11,11)", "42"), - ("(\\bool -> case bool of True -> 0 | False -> 1 : Bool -> Int) False", "1"), - ("(\\bools -> case bools of (True,_) -> 0 | (False,_) -> 1 : (Bool,Bool) -> Int) (False,False)", "1") - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - - describe "Arrays and matching" $ do - let testVals = - [ ("let arr = [20,22]; case arr of [a,b] -> (a + b : Int) | _ -> 0", "42"), - ("let arr = [20,20,2]; case arr of [a,b,c] -> (a + b + c : Int) | _ -> 0", "42"), - ("let arr = [1,100]; case arr of [100, a] -> 0 | [1,b] -> b | _ -> 0", "100"), - ("let arr = [1,2,3]; case arr of [_,_] -> 0 | _ -> 1", "1") -- ie, are we checking the length of the array? - -- ("let arr1 = [1,2,3]; let arr2 = case arr1 of [_,...rest] -> rest | _ -> [1]; case arr2 of [d,e] -> d + e | _ -> 0", "5") -- need malloc to dynamically create new array - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - - describe "Datatypes" $ do - let testVals = - [ ("(\\ord -> case ord of GT -> 21 | EQ -> 23 | LT -> 42 : Ord -> Int) LT", "42"), -- constructor with no args - ("(\\maybe -> case maybe of _ -> 42 : Maybe Int -> Int) (Just 41)", "42"), - ("(\\maybe -> case maybe of Just a -> a + 1 | Nothing -> 0 : Maybe Int -> Int) (Just 41)", "42"), - ("(\\maybe -> case maybe of Just 40 -> 100 | Just a -> a + 1 | Nothing -> 0 : Maybe Int -> Int) (Just 41)", "42"), -- predicates in constructor - ("(\\maybe -> case maybe of Just 40 -> 100 | Just a -> a + 1 | Nothing -> 0 : Maybe Int -> Int) (Nothing : Maybe Int)", "0"), -- predicates in constructor - ("(\\these -> case these of This aa -> aa | That 27 -> 0 | These a b -> a + b : These Int Int -> Int) (This 42 : These Int Int)", "42"), -- data shapes are wrong - ("(\\these -> case these of This aa -> aa | That 60 -> 0 | These a b -> a + b : These Int Int -> Int) (These 20 22 : These Int Int)", "42"), - -- ("(\\these -> case these of This a -> a | That _ -> 1000 | These a b -> a + b : These Int Int -> Int) (That 42 : These Int Int)", "1000"),--wildcards fuck it up for some reason - ("(case (This 42 : These Int Int) of This a -> a : Int)", "42") - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - - xdescribe "Nested datatypes (manually split cases)" $ do - let testVals = - [ ("let maybe = Just (Just 41) in 42", "42"), - ("let oneList = Cons 1 Nil in 42", "42"), - ("let twoList = Cons 1 (Cons 2 Nil) in 42", "42"), - ("(\\maybe -> case maybe of Just a -> (case a of Just aa -> aa + 1 | _ -> 0) | _ -> 0 : Maybe (Maybe Int) -> Int) (Just (Just 41))", "42") -- , - -- ("let nested = (20, (11,11)) in 42", "42"), - -- ("(\\nested -> case nested of (a,(b,c)) -> a + b + c : (Int, (Int, Int)) -> Int) (20,(11,11))", "42"), - -- ("(\\maybe -> case maybe of Just (a,b,c) -> a + b + c | Nothing -> 0 : Maybe (Int,Int,Int) -> Int) (Just (1,2,3))", "6") - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals - xdescribe "Nested datatypes (currently broken)" $ do - let testVals = - [ ("let maybe = Just (Just 41) in 42", "42"), - ("(\\maybe -> case maybe of Just (Just a) -> a + 1 | _ -> 0 : Maybe (Maybe Int) -> Int) (Just (Just 41))", "42"), - ("let nested = (20, (11,11)) in 42", "42"), - ("(\\nested -> case nested of (a,(b,c)) -> a + b + c : (Int, (Int, Int)) -> Int) (20,(11,11))", "42"), - ("(\\maybe -> case maybe of Just (a,b,c) -> a + b + c | Nothing -> 0 : Maybe (Int,Int,Int) -> Int) (Just (1,2,3))", "6") - ] - - describe "IR compile" $ do - traverse_ testCompileIR testVals diff --git a/smol-backend/test/Test/IR/PatternSpec.hs b/smol-backend/test/Test/IR/PatternSpec.hs deleted file mode 100644 index fca7f676..00000000 --- a/smol-backend/test/Test/IR/PatternSpec.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.IR.PatternSpec (spec) where - -import Control.Monad.State (evalState) -import Data.Bifunctor -import Data.Foldable (traverse_) -import qualified Data.List.NonEmpty as NE -import Smol.Backend.IR.FromExpr.Pattern (predicatesFromPattern) -import Smol.Backend.IR.FromExpr.Types (FromExprState (..)) -import Smol.Backend.Types.GetPath -import Smol.Backend.Types.PatternPredicate - ( PatternPredicate (PathEquals), - ) -import Smol.Core.ExprUtils -import Smol.Core.Types.ParseDep -import qualified Smol.Core.Types.Pattern as Smol - ( Pattern (PConstructor, PLiteral, PTuple, PWildcard), - ) -import Smol.Core.Types.Prim (Prim (PBool, PInt)) -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Type (Type (TPrim), TypePrim (TPInt)) -import Test.BuiltInTypes (builtInTypes) -import Test.Helpers (tyBool, tyCons) -import Test.Hspec (Spec, describe, it, shouldBe) - -env :: (Monoid ann) => FromExprState ann -env = - FromExprState - { fesDataTypes = builtInTypes LocalDefinition, - fesFreshInt = 0, - fesModuleParts = mempty, - fesVars = mempty - } - -parseDepToResolved :: Type ParseDep ann -> Type ResolvedDep ann -parseDepToResolved = mapTypeDep (\(ParseDep a _) -> LocalDefinition a) - -spec :: Spec -spec = do - describe "predicatesFromPattern" $ do - let ty = TPrim () TPInt - let testVals = - first (fmap parseDepToResolved) - <$> [ (Smol.PWildcard ty, []), - ( Smol.PLiteral ty (PBool True), - [PathEquals (GetPath [] GetValue) (PBool True)] - ), - ( Smol.PTuple - ty - (Smol.PLiteral ty (PBool True)) - ( NE.fromList - [Smol.PLiteral ty (PInt 1)] - ), - [ PathEquals (GetPath [0] GetValue) (PBool True), - PathEquals (GetPath [1] GetValue) (PInt 1) - ] - ), - ( Smol.PConstructor - (tyCons "Maybe" [tyBool]) - "Just" - [Smol.PLiteral ty (PBool True)], - [ PathEquals (GetPath [0] GetValue) (PInt 0), - PathEquals (GetPath [1] GetValue) (PBool True) - ] - ), - ( Smol.PConstructor - (tyCons "Maybe" [tyBool]) - "Nothing" - mempty, - [PathEquals (GetPath [0] GetValue) (PInt 1)] - ) - ] - traverse_ - ( \(input, result) -> it (show input) $ do - let predResult = evalState (predicatesFromPattern pure input) env - predResult `shouldBe` result - ) - testVals diff --git a/smol-backend/test/Test/IR/RawSamples.hs b/smol-backend/test/Test/IR/RawSamples.hs deleted file mode 100644 index 745fd994..00000000 --- a/smol-backend/test/Test/IR/RawSamples.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module Test.IR.RawSamples - ( print42, - useId42, - useAdd42, - useConst42Curried, - useBasicIf, - oneTuple42, - twoTuple42, - nestedTuple42, - either42, - ) -where - -import LLVM.AST hiding (function) -import qualified LLVM.AST.Constant as C -import qualified LLVM.AST.Operand as Op -import LLVM.AST.Type as AST -import qualified LLVM.IRBuilder.Constant as C -import LLVM.IRBuilder.Instruction -import qualified LLVM.IRBuilder.Instruction as L -import LLVM.IRBuilder.Module -import qualified LLVM.IRBuilder.Monad as L -import Smol.Backend.IR.ToLLVM.Helpers - --- print the number 42 -print42 :: Module -print42 = buildModule "exampleModule" $ mdo - pInt <- getPrintInt - - function "main" [] AST.i32 $ \_ -> do - _ <- call pInt [(C.int32 42, [])] - ret (C.int32 0) - --- print the number 42 after using id function -useId42 :: Module -useId42 = buildModule "exampleModule" $ mdo - pInt <- getPrintInt - - fnId <- function "id" [(AST.i32, "a")] AST.i32 $ \case - [a] -> ret a - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - a2 <- call fnId [(C.int32 42, [])] - _ <- call pInt [(a2, [])] - ret (C.int32 0) - --- print the number 42 after using the const function --- this version passes the env but calls it immediately -useAdd42 :: Module -useAdd42 = buildModule "exampleModule" $ mdo - pInt <- getPrintInt - - -- inputs for const2 - let const2Struct = AST.StructureType False [AST.i32] - - -- fn is (arg, env) - -- this is the continuation of `const` below - fnAdd2 <- function "add2" [(AST.i32, "b"), (pointerType const2Struct, "env")] AST.i32 $ \case - [b, env] -> do - -- %a = load i32, i32* %1 - a <- loadFromStruct env [0] - -- add them - res <- add a b - -- return a - ret res - other -> error (show other) - - fnAdd <- function "add" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \case - [a, b] -> do - -- allocate room for a struct - env2 <- allocLocal "const2-struct" const2Struct - - -- store a in slot1 - storePrimInStruct env2 [0] a - - -- run next function - result <- call fnAdd2 [(b, []), (env2, [])] - -- return result - ret result - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - a2 <- - call - fnAdd - [ (C.int32 20, []), - (C.int32 22, []) - ] - -- print output - _ <- call pInt [(a2, [])] - ret (C.int32 0) - --- make a one tuple, fetch from it, sum items -oneTuple42 :: Module -oneTuple42 = buildModule "exampleModule" $ do - pInt <- getPrintInt - - let tyOneTuple = AST.StructureType False [AST.i32] - - mkTuple <- function "mkTuple" [(AST.i32, "a"), (pointerType tyOneTuple, "sret")] AST.void $ \case - [a, sRet] -> do - -- store a in slot 0 - storePrimInStruct sRet [0] a - - -- output nothing - retVoid - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - oneTuple <- callWithReturnStruct mkTuple tyOneTuple [C.int32 42] - - -- get 1st - res <- loadFromStruct oneTuple [0] - - -- print output - _ <- call pInt [(res, [])] - ret (C.int32 0) - --- make a two tuple, fetch from it, sum items -twoTuple42 :: Module -twoTuple42 = buildModule "exampleModule" $ do - pInt <- getPrintInt - - let tyTwoTuple = AST.StructureType False [AST.i32, AST.i32] - - mkTuple <- function - "mkTuple" - [ (AST.i32, "a"), - (AST.i32, "b"), - (pointerType tyTwoTuple, "sRet") - ] - AST.void - $ \case - [a, b, sRet] -> do - llStruct <- allocLocal "mktuplestruct" tyTwoTuple - -- store a in slot1 - storePrimInStruct llStruct [0] a - - -- store b in slot2 - storePrimInStruct llStruct [1] b - - moveToStruct llStruct sRet - - retVoid - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - twoTuple <- callWithReturnStruct mkTuple tyTwoTuple [C.int32 20, C.int32 22] - - -- get 1st - var1 <- loadFromStruct twoTuple [0] - - -- get 2nd - var2 <- loadFromStruct twoTuple [1] - - -- sum the responses - res <- add var1 var2 - - -- print output - _ <- call pInt [(res, [])] - ret (C.int32 0) - --- make a nested tuple (10, (12, 20)) and adds it all -nestedTuple42 :: Module -nestedTuple42 = buildModule "exampleModule" $ do - pInt <- getPrintInt - - let tyNested = struct [AST.i32, struct [AST.i32, AST.i32]] - - mkNestedTuple <- function - "mkNestedTuple" - [ (AST.i32, "a"), - (AST.i32, "b"), - (AST.i32, "c"), - (pointerType tyNested, "sRet") - ] - AST.void - $ \case - [a, b, c, sRet] -> do - -- store a in slot1 - storePrimInStruct sRet [0] a - - -- store b in slot2 - storePrimInStruct sRet [1, 0] b - - -- store c - storePrimInStruct sRet [1, 1] c - - retVoid - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - nestedTuple <- - callWithReturnStruct - mkNestedTuple - tyNested - [ C.int32 10, - C.int32 12, - C.int32 20 - ] - - -- get (a, (_,_)) - varA <- loadFromStruct nestedTuple [0] - - -- get (_, (b,_)) - varB <- loadFromStruct nestedTuple [1, 0] - - -- get (_, (_, c)) - varC <- loadFromStruct nestedTuple [1, 1] - - -- sum the responses - res1 <- add varA varB - res2 <- add res1 varC - - -- print output - _ <- call pInt [(res2, [])] - ret (C.int32 0) - --- if True then 1 else 2 -useBasicIf :: Module -useBasicIf = buildModule "exampleModule" $ do - pInt <- getPrintInt - - function "main" [] AST.i32 $ \_ -> mdo - result <- alloca AST.i32 Nothing 0 - - let predVal = C.bit 1 -- True - L.condBr predVal thenBlock elseBlock - - thenBlock <- L.block `L.named` "then" - -- set result to 1 - store result 0 (C.int32 1) - L.br mergeBlock - - elseBlock <- L.block `L.named` "else" - -- set result to 2 - store result 0 (C.int32 2) - L.br mergeBlock - - mergeBlock <- L.block `L.named` "merge" - -- do bothing - - finalResult <- load result 0 - - _ <- call pInt [(finalResult, [])] - ret (C.int32 0) - --- print the number 42 after using the const function --- this version passes the env and returns the next function -useConst42Curried :: Module -useConst42Curried = buildModule "exampleModule" $ mdo - pInt <- getPrintInt - - -- inputs for const2 - let const2Struct = AST.StructureType False [AST.i32] - - -- fn is (arg, env) - -- this is the continuation of `const` below - -- (int, [int]) -> int - (_fnConst2, const2Func) <- functionAndType - "const2" - [ (AST.i32, "b"), - (pointerType const2Struct, "env") - ] - AST.i32 - $ \case - [_b, env] -> - loadFromStruct env [0] >>= ret - other -> error (show other) - - -- closure function type of const2 (fn*, env) - let const2ClosureType = - AST.StructureType - False - [ pointerType const2Func, - const2Struct - ] - - -- (int, (fn, [int])) -> void - fnConst <- function - "const" - [ (AST.i32, "a"), - (pointerType const2ClosureType, "sRet") - ] - AST.void - $ \case - [a, sRet] -> do - -- store a in slot1 of env - storePrimInStruct sRet [1, 0] a - - -- put fn in it - storePrimInStruct - sRet - [0] - ( Op.ConstantOperand - (C.GlobalReference (pointerType const2Func) "const2") - ) - - -- return nothing - retVoid - other -> error (show other) - - function "main" [] AST.i32 $ \_ -> do - closure <- callWithReturnStruct fnConst const2ClosureType [C.int32 42] - - -- call fn with env + arg - a2 <- callClosure closure (C.int32 43) - - -- print output - _ <- call pInt [(a2, [])] - ret (C.int32 0) - --- https://mapping-high-level-constructs-to-llvm-ir.readthedocs.io/en/latest/basic-constructs/unions.html?highlight=rust#tagged-unions --- make a maybe, get the value out again -either42 :: Module -either42 = buildModule "exampleModule" $ do - pInt <- getPrintInt - - -- this type is only here to stake out memory - let tyEitherBoolInt = AST.StructureType False [AST.i32, AST.ArrayType 1 AST.i32] - tyRightInt = pointerType (AST.StructureType False [AST.i32, AST.i32]) - tyLeftBool = pointerType (AST.StructureType False [AST.i32, AST.i1]) - - function "main" [] AST.i32 $ \_ -> do - -- CREATING RIGHT 41 - -- first we create an Either Bool Int and put Right Int in it - rStruct <- allocLocal "mkrightstruct" tyEitherBoolInt - - -- store 0 (for "Right") in slot1 - storePrimInStruct rStruct [0] (C.int32 0) - - -- case to Right Int - rStruct' <- bitcast rStruct tyRightInt - - -- store a in slot2 - storePrimInStruct rStruct' [1] (C.int32 41) - - -- turn it back into Right Int - rStruct'' <- bitcast rStruct' (pointerType tyEitherBoolInt) - - -- CREATING LEFT 1 - -- first we create an Either Bool Int and put Right Int in it - lStruct <- allocLocal "mkleftStruct" tyEitherBoolInt - - -- store 1 (for "Left") in slot1 - storePrimInStruct lStruct [0] (C.int32 1) - - -- cast to Left Bool - lStruct' <- bitcast lStruct tyLeftBool - - -- store a in slot2 - storePrimInStruct lStruct' [1] (C.bit 1) - - -- turn it back into Right Int - lStruct'' <- bitcast lStruct' (pointerType tyEitherBoolInt) - - -- (Either Bool Int -> Int) - fnDeconstruct <- function - "const" - [ (pointerType tyEitherBoolInt, "either") - ] - AST.i32 - $ \case - [input] -> mdo - -- now we pattern match - -- we're going to return this later - result <- alloca AST.i32 Nothing 0 - - -- get the constructor - discriminator <- loadFromStruct input [0] - - L.switch discriminator rightBlock [(C.Int 32 0, rightBlock), (C.Int 32 1, leftBlock)] - - rightBlock <- L.block `L.named` "right" - -- it's a Right Int - casted <- bitcast input tyRightInt - -- get the int out - myInt <- loadFromStruct casted [1] - -- set result to 1 - store result 0 myInt - -- and merge! - L.br mergeBlock - - leftBlock <- L.block `L.named` "left" - lCasted <- bitcast input tyLeftBool - myBool <- loadFromStruct lCasted [1] - intFromBool <- zext myBool AST.i32 - store result 0 intFromBool - L.br mergeBlock - - mergeBlock <- L.block `L.named` "merge" - -- do bothing - realResult <- load result 0 - ret realResult - other -> error (show other) - - rStructPointer <- gep rStruct'' [C.int32 0] - - rightResult <- call fnDeconstruct [(rStructPointer, mempty)] - - lStructPointer <- gep lStruct'' [C.int32 0] - - leftResult <- call fnDeconstruct [(lStructPointer, mempty)] - - finalResult <- add leftResult rightResult - _ <- call pInt [(finalResult, [])] - ret (C.int32 0) diff --git a/smol-backend/test/Test/IR/Samples.hs b/smol-backend/test/Test/IR/Samples.hs deleted file mode 100644 index 9ca70fc9..00000000 --- a/smol-backend/test/Test/IR/Samples.hs +++ /dev/null @@ -1,492 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.IR.Samples - ( irId42, - irPrint42, - irTwoTuple42, - irBasicIf, - irPatternMatch, - irRecursive, - irCurriedNoClosure, - irCurried, - ) -where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Smol.Backend.IR.IRExpr -import Smol.Backend.IR.ToLLVM.Patterns - -irPrintInt :: IRModulePart -irPrintInt = - IRExternDef - ( IRExtern - { ireName = "printint", - ireArgs = [IRInt32], - ireReturn = IRInt32 - } - ) - -tyPrintInt :: IRType -tyPrintInt = IRFunctionType [IRInt32] IRInt32 - --- this should print the number 42 -irPrint42 :: IRModule -irPrint42 = - IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard (IRApply tyPrintInt (IRFuncPointer "printint") [IRPrim $ IRPrimInt32 42]), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- print the number 42 after using id function -irId42 :: IRModule -irId42 = - IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "id", - irfArgs = [(IRInt32, "a")], - irfReturn = IRInt32, - irfBody = - [ IRRet IRInt32 (IRVar "a") - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard (IRApply tyPrintInt (IRFuncPointer "printint") [IRApply (IRFunctionType [IRInt32] IRInt32) (IRFuncPointer "id") [IRPrim $ IRPrimInt32 42]]), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- make a two tuple, fetch from it, sum items --- let tuple a = (a,1); case (tuple 41) of [b,c] -> b + c -irTwoTuple42 :: IRModule -irTwoTuple42 = - let tyStruct = IRStruct [IRInt32, IRInt32] - in IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "tuple", - irfArgs = [(IRInt32, "a")], - irfReturn = tyStruct, - irfBody = - [ IRRet - tyStruct - ( IRInitialiseDataType - (IRAlloc tyStruct) - tyStruct - tyStruct - [ IRSetTo - { irstPath = [0], - irstType = IRInt32, - irstExpr = IRVar "a" - }, - IRSetTo - { irstPath = [1], - irstType = IRInt32, - irstExpr = IRPrim $ IRPrimInt32 1 - } - ] - ) - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard - ( IRLet - "result" - ( IRApply - (IRFunctionType [IRInt32] (IRStruct [IRInt32, IRInt32])) - (IRFuncPointer "tuple") - [IRPrim (IRPrimInt32 41)] - ) - ( IRLet - "fst" - (IRStructPath [0] (IRVar "result")) - ( IRLet - "snd" - (IRStructPath [1] (IRVar "result")) - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRInfix - IRAdd - (IRVar "fst") - (IRVar "snd") - ] - ) - ) - ) - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- if True then 42 else 21 -irBasicIf :: IRModule -irBasicIf = - IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRMatch - (IRPrim (IRPrimInt2 True)) - IRInt32 - ( NE.fromList - [ IRMatchCase - { irmcType = IRInt2, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt2 True)], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 42) - }, - IRMatchCase - { irmcType = IRInt2, - irmcPatternPredicate = [PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt2 False)], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 21) - } - ] - ) - ] - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- case (Right 42) of Right 100 -> 41 | Right a -> a | Left e -> 69 -irPatternMatch :: IRModule -irPatternMatch = - let tyEitherBoolInt = IRStruct [IRInt32, IRArray 1 IRInt32] -- whole type - tyRightInt = IRStruct [IRInt32, IRInt32] - tyLeftBool = IRStruct [IRInt32, IRInt2] - in IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard $ - IRLet - "either" - ( IRInitialiseDataType - (IRAlloc tyEitherBoolInt) - tyRightInt - tyEitherBoolInt - [ IRSetTo - { irstPath = [0], - irstType = IRInt32, - irstExpr = IRPrim $ IRPrimInt32 0 - }, - IRSetTo - { irstPath = [1], - irstType = IRInt32, - irstExpr = IRPrim $ IRPrimInt32 42 - } -- 0 for Right, `a` is 42 - ] - ) - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRMatch - (IRVar "either") - IRInt32 - ( NE.fromList - [ IRMatchCase - { irmcType = tyRightInt, - irmcPatternPredicate = - [ PathEquals (GetPath [0] GetValue) (IRPrim $ IRPrimInt32 0), - PathEquals (GetPath [1] GetValue) (IRPrim $ IRPrimInt32 100) - ], - irmcGetPath = mempty, - irmcExpr = IRPrim (IRPrimInt32 41) - }, - IRMatchCase - { irmcType = tyRightInt, - irmcPatternPredicate = [PathEquals (GetPath [0] GetValue) (IRPrim $ IRPrimInt32 0)], - irmcGetPath = M.singleton "a" (GetPath [1] GetValue), - irmcExpr = IRVar "a" - }, - IRMatchCase - { irmcType = tyLeftBool, - irmcPatternPredicate = [PathEquals (GetPath [0] GetValue) (IRPrim $ IRPrimInt32 1)], - irmcGetPath = M.singleton "e" (GetPath [1] GetValue), - irmcExpr = IRPrim (IRPrimInt32 69) - } - ] - ) - ] - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- a recursive function --- let sum a = if a == 10 then 0 else a + sum (a +1 ); a 0; -irRecursive :: IRModule -irRecursive = - IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "sum", - irfArgs = [(IRInt32, "a")], - irfReturn = IRInt32, - irfBody = - [ IRRet - IRInt32 - ( IRMatch - (IRVar "a") - IRInt32 - ( NE.fromList - [ IRMatchCase - { irmcType = IRInt32, - irmcPatternPredicate = - [ PathEquals (GetPath [] GetValue) (IRPrim $ IRPrimInt32 10000) - ], - irmcGetPath = mempty, - irmcExpr = IRPrim $ IRPrimInt32 0 - }, - IRMatchCase - { irmcType = IRInt32, - irmcPatternPredicate = mempty, - irmcGetPath = mempty, - irmcExpr = - IRInfix - IRAdd - (IRVar "a") - ( IRApply - (IRFunctionType [IRInt32] IRInt32) - (IRFuncPointer "sum") - [ IRInfix - IRAdd - (IRVar "a") - (IRPrim $ IRPrimInt32 1) - ] - ) - } - ] - ) - ) - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRApply - (IRFunctionType [IRInt32] IRInt32) - (IRFuncPointer "sum") - [IRPrim (IRPrimInt32 0)] - ] - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- a flipped const function --- let flipConst =\a -> \b -> b; flipConst 20 22 -irCurriedNoClosure :: IRModule -irCurriedNoClosure = - let func2Type = IRFunctionType [IRInt32] IRInt32 - add1ReturnType = - IRStruct - [ IRPointer func2Type - ] - in IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "add2", - irfArgs = [(IRInt32, "b")], - irfReturn = IRInt32, - irfBody = - [ IRRet - IRInt32 - (IRVar "b") - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "add1", - irfArgs = [(IRInt32, "a")], - irfReturn = add1ReturnType, - irfBody = - [ IRRet - add1ReturnType - ( IRLet - "struct" - (IRAlloc add1ReturnType) - ( IRStatements - [ IRSet - [0] - func2Type - (IRFuncPointer "add2") - (IRVar "struct") -- function pointer - ] - (IRVar "struct") - ) - ) - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRLet - "closure" - (IRApply (IRFunctionType [IRInt32] add1ReturnType) (IRFuncPointer "add1") [IRPrim (IRPrimInt32 20)]) - ( IRApply - (IRFunctionType [IRInt32] IRInt32) - (IRStructPath [0] (IRVar "closure")) - [ IRPrim (IRPrimInt32 22) - ] - ) - ] - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] - --- a curried add function --- let add2 =\a -> \b -> a + b; add 20 22 -irCurried :: IRModule -irCurried = - let func2Env = IRStruct [IRInt32] - func2Type = IRFunctionType [IRInt32, func2Env] IRInt32 - add1ReturnType = - IRStruct - [ IRPointer func2Type, - func2Env - ] - in IRModule - [ irPrintInt, - IRFunctionDef - ( IRFunction - { irfName = "add2", - irfArgs = [(IRInt32, "b"), (func2Env, "env")], - irfReturn = IRInt32, - irfBody = - [ IRRet - IRInt32 - (IRInfix IRAdd (IRVar "b") (IRStructPath [0] (IRVar "env"))) - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "add1", - irfArgs = [(IRInt32, "a"), (IRStruct [], "env")], - irfReturn = add1ReturnType, - irfBody = - [ IRRet - add1ReturnType - ( IRInitialiseDataType - (IRAlloc add1ReturnType) - add1ReturnType - add1ReturnType - [ IRSetTo - [0] - func2Type - (IRFuncPointer "add2"), - IRSetTo [1, 0] IRInt32 (IRVar "a") - ] - ) - ] - } - ), - IRFunctionDef - ( IRFunction - { irfName = "main", - irfArgs = [], - irfReturn = IRInt32, - irfBody = - [ IRDiscard - ( IRApply - tyPrintInt - (IRFuncPointer "printint") - [ IRLet - "emptyenv" - (IRAlloc (IRStruct [])) - ( IRLet - "closure" - ( IRApply - (IRFunctionType [IRInt32] add1ReturnType) - (IRFuncPointer "add1") - [IRPrim (IRPrimInt32 20), IRVar "emptyenv"] - ) - ( IRApply - func2Type - (IRStructPath [0] (IRVar "closure")) - [ IRPrim (IRPrimInt32 22), - IRPointerTo [1] (IRVar "closure") - ] - ) - ) - ] - ), - IRRet IRInt32 $ IRPrim $ IRPrimInt32 0 - ] - } - ) - ] diff --git a/smol-core/.gitignore b/smol-core/.gitignore deleted file mode 100644 index 39dffb9e..00000000 --- a/smol-core/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -dist-newstyle -.direnv diff --git a/smol-core/CHANGELOG.md b/smol-core/CHANGELOG.md deleted file mode 100644 index fcf2589c..00000000 --- a/smol-core/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for nix-basic - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/smol-core/smol-core.cabal b/smol-core/smol-core.cabal deleted file mode 100644 index 72e910fb..00000000 --- a/smol-core/smol-core.cabal +++ /dev/null @@ -1,191 +0,0 @@ -cabal-version: 2.4 -name: smol-core -version: 0.1.0.0 - --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: -author: Daniel Harvey -maintainer: danieljamesharvey@gmail.com - --- A copyright notice. --- copyright: --- category: -extra-source-files: CHANGELOG.md - -common shared - ghc-options: - -threaded -rtsopts -with-rtsopts=-N -Wall - -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - - build-depends: - , aeson - , base - , builder - , bytestring - , containers - , diagnose - , megaparsec - , memory - , mtl >=2.3.0.0 - , nonempty-containers - , parser-combinators - , prettyprinter - , text - , transformers - -library - import: shared - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - hs-source-dirs: src - default-language: Haskell2010 - - -- Modules included in this executable, other than Main. - exposed-modules: - Smol.Core - Smol.Core.ExprUtils - Smol.Core.Helpers - Smol.Core.Interpreter - Smol.Core.Interpreter.App - Smol.Core.Interpreter.FindUses - Smol.Core.Interpreter.If - Smol.Core.Interpreter.Infix - Smol.Core.Interpreter.Interpret - Smol.Core.Interpreter.Let - Smol.Core.Interpreter.Monad - Smol.Core.Interpreter.PatternMatch - Smol.Core.Interpreter.RecordAccess - Smol.Core.Interpreter.Types - Smol.Core.Interpreter.Types.InterpreterError - Smol.Core.Interpreter.Types.Stack - Smol.Core.Modules.Check - Smol.Core.Modules.Dependencies - Smol.Core.Modules.FromParts - Smol.Core.Modules.Helpers - Smol.Core.Modules.Interpret - Smol.Core.Modules.Monad - Smol.Core.Modules.ResolveDeps - Smol.Core.Modules.RunTests - Smol.Core.Modules.Typecheck - Smol.Core.Modules.Types - Smol.Core.Modules.Types.DefIdentifier - Smol.Core.Modules.Types.DepType - Smol.Core.Modules.Types.Entity - Smol.Core.Modules.Types.Module - Smol.Core.Modules.Types.ModuleError - Smol.Core.Modules.Types.ModuleItem - Smol.Core.Modules.Types.ModuleName - Smol.Core.Modules.Types.Test - Smol.Core.Modules.Types.TestName - Smol.Core.Modules.Types.TopLevelExpression - Smol.Core.Modules.Uses - Smol.Core.Parser - Smol.Core.Parser.DataType - Smol.Core.Parser.Expr - Smol.Core.Parser.Identifiers - Smol.Core.Parser.Module - Smol.Core.Parser.Op - Smol.Core.Parser.Pattern - Smol.Core.Parser.Primitives - Smol.Core.Parser.Shared - Smol.Core.Parser.Type - Smol.Core.Parser.Typeclass - Smol.Core.Printer - Smol.Core.SourceSpan - Smol.Core.Transform - Smol.Core.Transform.BetaReduce - Smol.Core.Transform.EtaReduce - Smol.Core.Transform.FlattenLets - Smol.Core.Transform.FloatDown - Smol.Core.Typecheck - Smol.Core.Typecheck.Annotations - Smol.Core.Typecheck.Elaborate - Smol.Core.Typecheck.Errors - Smol.Core.Typecheck.Exhaustiveness - Smol.Core.Typecheck.FreeVars - Smol.Core.Typecheck.FromParsedExpr - Smol.Core.Typecheck.Pattern - Smol.Core.Typecheck.Shared - Smol.Core.Typecheck.Simplify - Smol.Core.Typecheck.Substitute - Smol.Core.Typecheck.Subtype - Smol.Core.Typecheck.Typecheck - Smol.Core.Typecheck.Typeclass - Smol.Core.Typecheck.Typeclass.Deduplicate - Smol.Core.Typecheck.Typeclass.Helpers - Smol.Core.Typecheck.Typeclass.KindChecker - Smol.Core.Typecheck.Typeclass.ToDictionaryPassing - Smol.Core.Typecheck.Typeclass.ToDictionaryPassing.Types - Smol.Core.Typecheck.Typeclass.Typecheck - Smol.Core.Typecheck.Typeclass.Types - Smol.Core.Typecheck.Typeclass.Types.Constraint - Smol.Core.Typecheck.Typeclass.Types.Instance - Smol.Core.Typecheck.Typeclass.Types.Kind - Smol.Core.Typecheck.Typeclass.Types.Typeclass - Smol.Core.Typecheck.Typeclass.Types.TypeclassError - Smol.Core.Typecheck.Typeclass.Types.TypeclassName - Smol.Core.Typecheck.Types - Smol.Core.Typecheck.Types.Substitution - Smol.Core.Typecheck.Types.TCError - Smol.Core.Typecheck.Types.TCState - Smol.Core.Typecheck.Types.TCWrite - Smol.Core.Types - Smol.Core.Types.Annotated - Smol.Core.Types.Annotation - Smol.Core.Types.Constructor - Smol.Core.Types.DataType - Smol.Core.Types.Expr - Smol.Core.Types.Identifier - Smol.Core.Types.Op - Smol.Core.Types.ParseDep - Smol.Core.Types.Pattern - Smol.Core.Types.PatternMatchError - Smol.Core.Types.Prim - Smol.Core.Types.ResolvedDep - Smol.Core.Types.SourceSpan - Smol.Core.Types.Spread - Smol.Core.Types.Type - Smol.Core.Types.TypeName - Smol.Core.TypeUtils - -test-suite smol-core-tests - import: shared - type: exitcode-stdio-1.0 - hs-source-dirs: test - hs-source-dirs: src - build-depends: - , file-embed - , hspec >=2.8.3 && <3 - , hspec-core >=2.8.3 && <3 - - other-modules: - Test.BuiltInTypes - Test.Helpers - Test.Interpreter.InterpreterSpec - Test.Modules.FromPartsSpec - Test.Modules.InterpreterSpec - Test.Modules.ResolveDepsSpec - Test.Modules.RunTestsSpec - Test.Modules.TypecheckSpec - Test.ParserSpec - Test.Typecheck.ExhaustivenessSpec - Test.Typecheck.NestingMonadSpec - Test.Typecheck.PatternSpec - Test.Typecheck.SubtypeSpec - Test.Typecheck.TypeclassSpec - Test.TypecheckSpec - - main-is: Main.hs - default-language: Haskell2010 diff --git a/smol-core/src/Smol/Core.hs b/smol-core/src/Smol/Core.hs deleted file mode 100644 index df3cad7f..00000000 --- a/smol-core/src/Smol/Core.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Smol.Core - ( module Smol.Core.Types, - module Smol.Core.Parser, - module Smol.Core.Typecheck, - module Smol.Core.ExprUtils, - module Smol.Core.TypeUtils, - module Smol.Core.Interpreter, - module Smol.Core.Printer, - ) -where - -import Smol.Core.ExprUtils -import Smol.Core.Interpreter -import Smol.Core.Parser -import Smol.Core.Printer -import Smol.Core.TypeUtils -import Smol.Core.Typecheck -import Smol.Core.Types diff --git a/smol-core/src/Smol/Core/ExprUtils.hs b/smol-core/src/Smol/Core/ExprUtils.hs deleted file mode 100644 index 938ee28b..00000000 --- a/smol-core/src/Smol/Core/ExprUtils.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} - -module Smol.Core.ExprUtils - ( typeIsStruct, - mapOuterExprAnnotation, - mapExpr, - bindExpr, - mapPattern, - patternMonoid, - mapExprDep, - mapTypeDep, - mapDataTypeDep, - withMonoid, - ) -where - -import Data.Bifunctor -import Data.Foldable (toList) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Smol.Core.Types - --- helper functions for manipulating Expr types --- -typeIsStruct :: Type dep ann -> Bool -typeIsStruct TPrim {} = False -typeIsStruct TLiteral {} = False -typeIsStruct TUnknown {} = False -typeIsStruct _ = True - --- | modify the outer annotation of an expression --- useful for adding line numbers during parsing -mapOuterExprAnnotation :: (ann -> ann) -> Expr dep ann -> Expr dep ann -mapOuterExprAnnotation f expr' = - case expr' of - EInfix ann a b c -> EInfix (f ann) a b c - EAnn ann expr mt -> EAnn (f ann) expr mt - EPrim ann a -> EPrim (f ann) a - EVar ann a -> EVar (f ann) a - EConstructor ann a -> EConstructor (f ann) a - ELet ann a b c -> ELet (f ann) a b c - ELambda ann a b -> ELambda (f ann) a b - EApp ann a b -> EApp (f ann) a b - EIf ann a b c -> EIf (f ann) a b c - ETuple ann a b -> ETuple (f ann) a b - EArray ann a -> EArray (f ann) a - ERecord ann a -> ERecord (f ann) a - ERecordAccess ann b c -> ERecordAccess (f ann) b c - EPatternMatch ann a b -> EPatternMatch (f ann) a b - -mapExpr :: (Expr dep ann -> Expr dep ann) -> Expr dep ann -> Expr dep ann -mapExpr f (EInfix ann op a b) = EInfix ann op (f a) (f b) -mapExpr f (EAnn ann mt expr) = EAnn ann mt (f expr) -mapExpr _ (EPrim ann a) = EPrim ann a -mapExpr _ (EVar ann a) = EVar ann a -mapExpr _ (EConstructor ann a) = EConstructor ann a -mapExpr f (ELet ann ident expr rest) = ELet ann ident (f expr) (f rest) -mapExpr f (ELambda ann ident body) = ELambda ann ident (f body) -mapExpr f (EApp ann fn arg) = EApp ann (f fn) (f arg) -mapExpr f (EIf ann predExp thenExp elseExp) = - EIf ann (f predExp) (f thenExp) (f elseExp) -mapExpr f (ETuple ann a as) = ETuple ann (f a) (f <$> as) -mapExpr f (EArray ann as) = EArray ann (f <$> as) -mapExpr f (ERecord ann as) = ERecord ann (f <$> as) -mapExpr f (ERecordAccess ann expr ident) = - ERecordAccess ann (f expr) ident -mapExpr f (EPatternMatch ann patExpr pats) = - EPatternMatch ann (f patExpr) (second f <$> pats) - -bindExpr :: (Applicative m) => (Expr dep ann -> m (Expr dep ann)) -> Expr dep ann -> m (Expr dep ann) -bindExpr f (EInfix ann op a b) = EInfix ann op <$> f a <*> f b -bindExpr f (EAnn ann mt expr) = EAnn ann mt <$> f expr -bindExpr _ (EPrim ann a) = pure $ EPrim ann a -bindExpr _ (EVar ann a) = pure $ EVar ann a -bindExpr _ (EConstructor ann a) = pure $ EConstructor ann a -bindExpr f (ELet ann ident expr rest) = ELet ann ident <$> f expr <*> f rest -bindExpr f (ELambda ann ident body) = ELambda ann ident <$> f body -bindExpr f (EApp ann fn arg) = EApp ann <$> f fn <*> f arg -bindExpr f (EIf ann predExp thenExp elseExp) = - EIf ann <$> f predExp <*> f thenExp <*> f elseExp -bindExpr f (ETuple ann a as) = ETuple ann <$> f a <*> traverse f as -bindExpr f (EArray ann as) = EArray ann <$> traverse f as -bindExpr f (ERecord ann as) = ERecord ann <$> traverse f as -bindExpr f (ERecordAccess ann expr ident) = - ERecordAccess ann <$> f expr <*> pure ident -bindExpr f (EPatternMatch ann patExpr pats) = - EPatternMatch ann <$> f patExpr <*> traverse (\(a, b) -> (,) a <$> f b) pats - -mapPattern :: (Pattern dep ann -> Pattern dep ann) -> Pattern dep ann -> Pattern dep ann -mapPattern _ (PLiteral ann l) = PLiteral ann l -mapPattern _ (PWildcard a) = PWildcard a -mapPattern f (PArray ann as spread) = PArray ann (f <$> as) spread -- do we need to map spread somehow -mapPattern _ (PVar ann a) = PVar ann a -mapPattern f (PTuple ann a as) = PTuple ann (f a) (f <$> as) -mapPattern f (PConstructor ann constructor as) = - PConstructor ann constructor (f <$> as) - -patternMonoid :: (Monoid a) => (Pattern dep ann -> a) -> Pattern dep ann -> a -patternMonoid _ PLiteral {} = mempty -patternMonoid _ PWildcard {} = mempty -patternMonoid _ PVar {} = mempty -patternMonoid f (PArray _ as _) = foldMap f as -patternMonoid f (PTuple _ a as) = - f a <> foldMap f (NE.toList as) -patternMonoid f (PConstructor _ _ as) = - foldMap f as - --- | `ParsedExpr` has module names --- | `ResolvedExpr` has module hashes and unique ids --- this is like NumberVars from main `mimsa`, but for now we'll bodge it --- to get things typechecking -mapExprDep :: - (Ord (depB Identifier)) => - (forall a. depA a -> depB a) -> - Expr depA ann -> - Expr depB ann -mapExprDep resolve = go - where - go (EInfix ann op a b) = EInfix ann op (go a) (go b) - go (EAnn ann mt expr) = EAnn ann (mapTypeDep resolve mt) (go expr) - go (EPrim ann a) = EPrim ann a - go (EVar ann a) = - EVar ann (resolve a) - go (EConstructor ann a) = - EConstructor ann (resolve a) - go (ELet ann ident expr rest) = - ELet ann (resolve ident) (go expr) (go rest) - go (ELambda ann ident body) = ELambda ann (resolve ident) (go body) - go (EApp ann fn arg) = EApp ann (go fn) (go arg) - go (EIf ann predExp thenExp elseExp) = - EIf ann (go predExp) (go thenExp) (go elseExp) - go (ETuple ann a as) = ETuple ann (go a) (go <$> as) - go (EArray ann as) = EArray ann (go <$> as) - go (ERecord ann as) = ERecord ann (go <$> as) - go (ERecordAccess ann expr ident) = - ERecordAccess ann (go expr) ident - go (EPatternMatch ann patExpr pats) = - EPatternMatch ann (go patExpr) (bimap (mapPatternDep resolve) go <$> pats) - -mapPatternDep :: (forall a. depA a -> depB a) -> Pattern depA ann -> Pattern depB ann -mapPatternDep resolve = go - where - go (PLiteral ann l) = PLiteral ann l - go (PWildcard a) = PWildcard a - go (PVar ann a) = PVar ann (resolve a) - go (PTuple ann a as) = PTuple ann (go a) (go <$> as) - go (PArray ann as spread) = PArray ann (go <$> as) (mapSpreadDep resolve spread) - go (PConstructor ann constructor as) = - PConstructor ann (resolve constructor) (go <$> as) - -mapSpreadDep :: (forall a. depA a -> depB a) -> Spread depA ann -> Spread depB ann -mapSpreadDep resolve = go - where - go NoSpread = NoSpread - go (SpreadWildcard ann) = SpreadWildcard ann - go (SpreadValue ann a) = SpreadValue ann (resolve a) - -mapTypeDep :: (Ord (depB Identifier)) => (forall a. depA a -> depB a) -> Type depA ann -> Type depB ann -mapTypeDep resolve = go - where - go (TVar ann v) = TVar ann (resolve v) - go (TInfix ann op a b) = TInfix ann op (go a) (go b) - go (TTuple ann a as) = TTuple ann (go a) (go <$> as) - go (TArray ann i as) = TArray ann i (go as) - go (TLiteral ann a) = TLiteral ann a - go (TPrim ann p) = TPrim ann p - go (TFunc ann env a b) = TFunc ann (M.mapKeys resolve $ go <$> env) (go a) (go b) - go (TUnknown ann i) = TUnknown ann i - go (TRecord ann as) = TRecord ann (go <$> as) - go (TApp ann a b) = TApp ann (go a) (go b) - go (TConstructor ann constructor) = TConstructor ann (resolve constructor) - -mapDataTypeDep :: - (Ord (depB Identifier)) => - (forall a. depA a -> depB a) -> - DataType depA ann -> - DataType depB ann -mapDataTypeDep resolve (DataType {dtName, dtVars, dtConstructors}) = - let newConstructors = (fmap . fmap) (mapTypeDep resolve) dtConstructors - in DataType {dtName, dtVars, dtConstructors = newConstructors} - --- | Given a function `f` that turns any piece of the expression in a Monoid --- `m`, flatten the entire expression into `m` -withMonoid :: - (Monoid m) => - (Expr var ann -> (Bool, m)) -> - Expr var ann -> - m -withMonoid f whole@(EPrim _ _) = snd (f whole) -withMonoid f whole@EVar {} = snd (f whole) -withMonoid f whole@(EAnn _ _ expr) = - let (go, m) = f whole - in if not go - then m - else m <> withMonoid f expr -withMonoid f whole@(ELet _ _ bindExpr' inExpr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f bindExpr' - <> withMonoid f inExpr -withMonoid f whole@(EInfix _ _ a b) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f a - <> withMonoid f b -withMonoid f whole@(ELambda _ _binder expr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f expr -withMonoid f whole@(EApp _ func arg) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f func - <> withMonoid f arg -withMonoid f whole@(EIf _ matchExpr thenExpr elseExpr) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f matchExpr - <> withMonoid f thenExpr - <> withMonoid f elseExpr -withMonoid f whole@(ETuple _ a as) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f a - <> mconcat (withMonoid f <$> NE.toList as) -withMonoid f whole@(ERecord _ items) = - let (go, m) = f whole - in if not go - then m - else - m - <> mconcat - ( snd <$> M.toList (withMonoid f <$> items) - ) -withMonoid f whole@(EArray _ items) = - let (go, m) = f whole - in if not go - then m - else - m - <> mconcat - (withMonoid f <$> toList items) -withMonoid f whole@(ERecordAccess _ expr _name) = - let (go, m) = f whole - in if not go then m else m <> withMonoid f expr -withMonoid f whole@EConstructor {} = snd (f whole) -withMonoid f whole@(EPatternMatch _ matchExpr matches) = - let (go, m) = f whole - in if not go - then m - else - m - <> withMonoid f matchExpr - <> mconcat - (withMonoid f <$> (snd <$> NE.toList matches)) diff --git a/smol-core/src/Smol/Core/Helpers.hs b/smol-core/src/Smol/Core/Helpers.hs deleted file mode 100644 index cf07da2e..00000000 --- a/smol-core/src/Smol/Core/Helpers.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Helpers - ( neZipWithM, - neUnzip, - mapInd, - traverseInd, - traverseIndNe, - mapFind, - mapToNumbered, - fromRight, - foldMapM, - filterMapKeys, - mapKey, - tracePrettyM, - tracePrettyId, - nTimes, - ) -where - -import Control.Monad -import Data.Bifunctor -import Data.Foldable (foldlM) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Debug.Trace (trace, traceM) -import Smol.Core.Printer - -neZipWithM :: - (Applicative m) => - (a -> b -> m c) -> - NE.NonEmpty a -> - NE.NonEmpty b -> - m (NE.NonEmpty c) -neZipWithM f as bs = - NE.fromList <$> zipWithM f (NE.toList as) (NE.toList bs) - -neUnzip :: NE.NonEmpty (a, b) -> (NE.NonEmpty a, NE.NonEmpty b) -neUnzip = bimap NE.fromList NE.fromList . unzip . NE.toList - -mapInd :: (a -> Integer -> b) -> [a] -> [b] -mapInd f l = zipWith f l [0 ..] - -traverseInd :: - (Applicative m) => - (a -> Integer -> m b) -> - [a] -> - m [b] -traverseInd f l = zipWithM f l [0 ..] - -traverseIndNe :: - (Applicative m) => - (a -> Integer -> m b) -> - NE.NonEmpty a -> - m (NE.NonEmpty b) -traverseIndNe f l = NE.fromList <$> traverseInd f (NE.toList l) - --- | find the first item that satisfies f -mapFind :: (a -> Maybe b) -> Map k a -> Maybe b -mapFind f = fmap fst . M.minView . M.mapMaybe f - -mapToNumbered :: (Ord k) => Map k a -> Map k Integer -mapToNumbered = - M.fromList - . (\as -> zip (fmap fst as) [0 ..]) - . M.toList - -fromRight :: (Show e) => Either e a -> a -fromRight = \case - Right a -> a - Left e -> error (show e) - --- useful to break apart maps where --- key is a sum type -filterMapKeys :: (Ord k2) => (k -> Maybe k2) -> Map k a -> Map k2 a -filterMapKeys f = - M.fromList . mapMaybe (\(k, a) -> (,) <$> f k <*> pure a) . M.toList - -------- - --- from https://hackage.haskell.org/package/rio-0.1.22.0/docs/src/RIO.Prelude.Extra.html#foldMapM - --- | Extend 'foldMap' to allow side effects. --- --- Internally, this is implemented using a strict left fold. This is used for --- performance reasons. It also necessitates that this function has a @Monad@ --- constraint and not just an @Applicative@ constraint. For more information, --- see --- . --- --- @since 0.1.3.0 -foldMapM :: - (Monad m, Monoid w, Foldable t) => - (a -> m w) -> - t a -> - m w -foldMapM f = - foldlM - ( \acc a -> do - w <- f a - return $! mappend acc w - ) - mempty - -mapKey :: (Ord k1) => (k -> k1) -> Map k a -> Map k1 a -mapKey f = M.fromList . fmap (first f) . M.toList - -tracePrettyId :: (Printer a) => String -> a -> a -tracePrettyId msg a = trace (msg <> ": " <> T.unpack (renderWithWidth 40 $ prettyDoc a)) a - -tracePrettyM :: (Printer a, Monad m) => String -> a -> m () -tracePrettyM msg a = traceM (msg <> ": " <> T.unpack (renderWithWidth 40 $ prettyDoc a)) - -nTimes :: Int -> (a -> a) -> a -> a -nTimes 0 _ x = x -nTimes n f x = nTimes (n - 1) f (f x) diff --git a/smol-core/src/Smol/Core/Interpreter.hs b/smol-core/src/Smol/Core/Interpreter.hs deleted file mode 100644 index 11d7b0f2..00000000 --- a/smol-core/src/Smol/Core/Interpreter.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Smol.Core.Interpreter - ( module Smol.Core.Interpreter.Interpret, - ) -where - -import Smol.Core.Interpreter.Interpret diff --git a/smol-core/src/Smol/Core/Interpreter/App.hs b/smol-core/src/Smol/Core/Interpreter/App.hs deleted file mode 100644 index f9e33f7a..00000000 --- a/smol-core/src/Smol/Core/Interpreter/App.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Smol.Core.Interpreter.App (interpretApp) where - -import Smol.Core.Interpreter.Monad -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types.Expr - -interpretApp :: - (Eq ann) => - InterpretFn ann -> - ExprData ann -> - InterpretExpr ann -> - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretApp interpretFn ann myFn value = - case myFn of - (ELambda (ExprData closure _ _) ident body) -> do - -- interpret arg first - intValue <- interpretFn value - -- add arg to context - let newStackFrame = addVarToFrame ident intValue closure - -- run body with closure + new arg - withNewStackFrame newStackFrame (interpretFn body) - (EConstructor ann' const') -> - EApp ann (EConstructor ann' const') - <$> interpretFn value - fn -> do - -- try and resolve it into something we recognise - intFn <- interpretFn fn - if intFn == fn -- if it hasn't changed, we don't want to end up looping so give up and error - then do - intValue <- interpretFn value - -- at least change the value - pure (EApp ann intFn intValue) - else interpretFn (EApp ann intFn value) diff --git a/smol-core/src/Smol/Core/Interpreter/FindUses.hs b/smol-core/src/Smol/Core/Interpreter/FindUses.hs deleted file mode 100644 index cdd1ab03..00000000 --- a/smol-core/src/Smol/Core/Interpreter/FindUses.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Interpreter.FindUses (findUses, memberInUses, numberOfUses, Uses (..)) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Monoid -import Smol.Core.ExprUtils -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier - -newtype Uses dep = Uses (Map (dep Identifier) (Sum Int)) - -deriving newtype instance (Eq (dep Identifier)) => Eq (Uses dep) - -deriving newtype instance (Ord (dep Identifier)) => Ord (Uses dep) - -deriving newtype instance (Show (dep Identifier)) => Show (Uses dep) - -instance (Ord (dep Identifier)) => Semigroup (Uses dep) where - (Uses a) <> (Uses b) = Uses (M.unionWith (<>) a b) - -instance (Ord (dep Identifier)) => Monoid (Uses dep) where - mempty = Uses mempty - -findUses :: (Ord (dep Identifier)) => Expr dep ann -> Uses dep -findUses = withMonoid f - where - f (ELet _ ident body expr) = - let usesInBody = clearVarFromUses ident (findUses body) - usesInExpr = findUses expr - in (False, usesInBody <> usesInExpr) - f (EVar _ ident) = (False, Uses $ M.singleton ident 1) - f _ = (True, mempty) - --- | remove recursive uses of a var from it's body -clearVarFromUses :: - (Ord (dep Identifier)) => - dep Identifier -> - Uses dep -> - Uses dep -clearVarFromUses var (Uses uses) = - Uses (M.insert var (Sum 0) uses) - --- var in use and used over 0 times -memberInUses :: (Ord (dep Identifier)) => dep Identifier -> Uses dep -> Bool -memberInUses var (Uses as) = - maybe - False - (\(Sum a) -> a > 0) - (M.lookup var as) - -numberOfUses :: (Ord (dep Identifier)) => dep Identifier -> Uses dep -> Int -numberOfUses var (Uses as) = maybe 0 getSum (M.lookup var as) diff --git a/smol-core/src/Smol/Core/Interpreter/If.hs b/smol-core/src/Smol/Core/Interpreter/If.hs deleted file mode 100644 index 258faaec..00000000 --- a/smol-core/src/Smol/Core/Interpreter/If.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Smol.Core.Interpreter.If (interpretIf) where - -import Control.Monad.Except -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types.Expr -import Smol.Core.Types.Prim - -interpretIf :: - InterpretFn ann -> - ExprData ann -> - InterpretExpr ann -> - InterpretExpr ann -> - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretIf interpretFn ann predicate true false = - case predicate of - (EPrim _ (PBool pred')) -> - if pred' - then interpretFn true - else interpretFn false - all'@EPrim {} -> - throwError $ PredicateForIfMustBeABoolean all' - pred' -> do - predExpr <- interpretFn pred' - interpretFn (EIf ann predExpr true false) diff --git a/smol-core/src/Smol/Core/Interpreter/Infix.hs b/smol-core/src/Smol/Core/Interpreter/Infix.hs deleted file mode 100644 index f3febf03..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Infix.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Smol.Core.Interpreter.Infix (interpretInfix) where - -import Control.Monad (void, (<=<)) -import Control.Monad.Except -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Typecheck.Shared -import Smol.Core.Types.Expr -import Smol.Core.Types.Op -import Smol.Core.Types.Prim - --- | this assumes that -interpretInfix :: - InterpretFn ann -> - Op -> - InterpretExpr ann -> - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretInfix interpretFn operator a b = do - plainA <- interpretFn <=< interpretFn $ a - plainB <- interpretFn <=< interpretFn $ b - case operator of - OpEquals -> do - let withBool = pure . EPrim (getExprAnnotation a) . PBool - if void plainA == void plainB - then withBool True - else withBool False - OpAdd -> addInts plainA plainB `catchError` \_ -> concatStrings plainA plainB - -addInts :: InterpretExpr ann -> InterpretExpr ann -> InterpreterM ann (InterpretExpr ann) -addInts plainA plainB = - let withInt = pure . EPrim (getExprAnnotation plainA) . PInt - getInt exp' = case exp' of - (EPrim _ (PInt i)) -> Right i - _ -> Left $ AdditionWithNonNumber plainA - in case (,) <$> getInt plainA <*> getInt plainB of - Right (a', b') -> withInt (a' + b') - Left e -> throwError e - -concatStrings :: InterpretExpr ann -> InterpretExpr ann -> InterpreterM ann (InterpretExpr ann) -concatStrings plainA plainB = - let withStr = pure . EPrim (getExprAnnotation plainA) . PString - getStr exp' = case exp' of - (EPrim _ (PString s)) -> Right s - _ -> Left $ AdditionWithNonNumber plainA - in case (,) <$> getStr plainA <*> getStr plainB of - Right (a', b') -> withStr (a' <> b') - Left e -> throwError e diff --git a/smol-core/src/Smol/Core/Interpreter/Interpret.hs b/smol-core/src/Smol/Core/Interpreter/Interpret.hs deleted file mode 100644 index b0b36731..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Interpret.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Smol.Core.Interpreter.Interpret (interpret, addEmptyStackFrames) where - -import Control.Monad.Reader -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import Smol.Core.Interpreter.App -import Smol.Core.Interpreter.If -import Smol.Core.Interpreter.Infix -import Smol.Core.Interpreter.Let -import Smol.Core.Interpreter.Monad -import Smol.Core.Interpreter.PatternMatch -import Smol.Core.Interpreter.RecordAccess -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types - -initialStack :: StackFrame ann -initialStack = StackFrame mempty - -addEmptyStackFrames :: - Expr dep ann -> - Expr dep (ExprData ann) -addEmptyStackFrames = - fmap - ( \ann -> - ExprData - { edIsRecursive = False, - edStackFrame = mempty, - edAnnotation = ann - } - ) - -interpret :: - (Eq ann, Show ann) => - Map (ResolvedDep Identifier) (InterpretExpr ann) -> - InterpretExpr ann -> - Either (InterpreterError ann) (InterpretExpr ann) -interpret deps expr = - runReaderT (interpretExpr expr) (InterpretReaderEnv initialStack deps) - --- somewhat pointless separate function to make debug logging each value out --- easier -interpretExpr :: - (Eq ann, Show ann) => - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretExpr = - interpretExpr' - -interpretExpr' :: - (Eq ann, Show ann) => - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretExpr' (EPrim ann val) = pure (EPrim ann val) -interpretExpr' (EAnn _ _ expr) = interpretExpr' expr -interpretExpr' (ELet exprData ident expr body) = - interpretLet interpretExpr (ident, exprData) expr body -interpretExpr' (EVar _ var) = - lookupVar var >>= interpretExpr -interpretExpr' (ELambda (ExprData current isRec ann) ident body) = do - -- capture current environment - stackFrame <- - getCurrentStackFrame - -- add it to already captured vars - let newExprData = - ExprData - (current <> stackFrame) - isRec - ann - -- return it - pure - (ELambda newExprData ident body) -interpretExpr' (ETuple ann a as) = - ETuple ann <$> interpretExpr a <*> traverse interpretExpr as -interpretExpr' (EInfix _ op a b) = - interpretInfix interpretExpr op a b -interpretExpr' (EIf ann predExpr thenExpr elseExpr) = - interpretIf interpretExpr ann predExpr thenExpr elseExpr -interpretExpr' (EApp ann fn a) = - interpretApp interpretExpr ann fn a -interpretExpr' (ERecordAccess ann expr name) = - interpretRecordAccess interpretExpr ann expr name -interpretExpr' (EPatternMatch _ matchExpr patterns) = do - interpretPatternMatch interpretExpr matchExpr (NE.toList patterns) -interpretExpr' (ERecord ann as) = - ERecord ann <$> traverse interpretExpr as -interpretExpr' (EArray ann as) = - EArray ann <$> traverse interpretExpr as -interpretExpr' (EConstructor as const') = - pure (EConstructor as const') diff --git a/smol-core/src/Smol/Core/Interpreter/Let.hs b/smol-core/src/Smol/Core/Interpreter/Let.hs deleted file mode 100644 index 7b614d30..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Let.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Smol.Core.Interpreter.Let (interpretLet) where - -import Smol.Core.Interpreter.FindUses -import Smol.Core.Interpreter.Monad -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Typecheck.Shared (getExprAnnotation) -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.ResolvedDep - --- need to interpret the expr in the let binding --- BUT it needs to refer to itself --- this is NOT the one, we need some form of indirection so the closure can say --- "and look up whatever 'var' is pls" -interpretLetExpr :: - InterpretFn ann -> - ResolvedDep Identifier -> - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretLetExpr interpretFn var expr = do - intExpr <- interpretFn expr - case intExpr of - lambdaExpr@ELambda {} -> - if isRecursive var lambdaExpr - then -- make this a function of \binding -> actualFunction - - let annotation = edAnnotation (getExprAnnotation lambdaExpr) - in interpretFn (ELambda (ExprData mempty True annotation) var lambdaExpr) - else -- non-recursive, run as normal - interpretFn lambdaExpr - _ -> pure intExpr - -interpretLet :: - InterpretFn ann -> - (ResolvedDep Identifier, ExprData ann) -> - InterpretExpr ann -> - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) -interpretLet interpretFn ident expr body = do - -- calc expr, including itself to sort recursion - intExpr <- - interpretLetExpr - interpretFn - (fst ident) - expr - - -- calc rest, with new binding added to the current stack frame - extendStackFrame - [(fst ident, intExpr)] - (interpretFn body) - -isRecursive :: ResolvedDep Identifier -> Expr ResolvedDep ann -> Bool -isRecursive var expr = - memberInUses var (findUses expr) diff --git a/smol-core/src/Smol/Core/Interpreter/Monad.hs b/smol-core/src/Smol/Core/Interpreter/Monad.hs deleted file mode 100644 index d2e3f49f..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Monad.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Smol.Core.Interpreter.Monad - ( withNewStackFrame, - extendStackFrame, - getCurrentStackFrame, - lookupVar, - addVarToFrame, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import qualified Data.Map.Strict as M -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.ResolvedDep - --- | run action with entirely new frame --- | useful for running functions from their closures -withNewStackFrame :: - StackFrame ann -> - InterpreterM ann a -> - InterpreterM ann a -withNewStackFrame sf = - local - (\ire -> ire {ireStack = sf}) - -extendStackFrame :: - [ ( ResolvedDep Identifier, - InterpretExpr ann - ) - ] -> - InterpreterM ann a -> - InterpreterM ann a -extendStackFrame bindings = - local - ( \ire -> - ire - { ireStack = - foldr (uncurry addVarToFrame) (ireStack ire) bindings - } - ) - -getCurrentStackFrame :: InterpreterM ann (StackFrame ann) -getCurrentStackFrame = asks ireStack - -lookupVar :: - (Show ann) => - ResolvedDep Identifier -> - InterpreterM ann (InterpretExpr ann) -lookupVar identifier = - lookupVarInStack identifier - `catchError` \_ -> lookupVarInDeps identifier - -lookupVarInDeps :: - ResolvedDep Identifier -> - InterpreterM ann (InterpretExpr ann) -lookupVarInDeps identifier = do - matchingDep <- asks (M.lookup identifier . ireGlobals) - case matchingDep of - Just a -> pure a - Nothing -> throwError (CouldNotFindVar mempty identifier) - -lookupVarInStack :: - (Show ann) => - ResolvedDep Identifier -> - InterpreterM ann (InterpretExpr ann) -lookupVarInStack identifier = do - (StackFrame entries) <- getCurrentStackFrame - case M.lookup identifier entries of - Just myLam@(ELambda ed@(ExprData _ isRec _) _ _) -> - -- when we save functions on the stack we save them as - -- \letName -> function - -- so that recursion works - -- therefore when fetching it we apply it to itself - -- like a fixpoint combinator thing - if isRec - then pure (EApp ed myLam myLam) - else pure myLam - -- if it's another var, fetch that - Just (EVar _ a) -> lookupVar a - -- otherwise return it - Just other -> pure other - -- could not find var - _ -> throwError (CouldNotFindVar entries identifier) - -addVarToFrame :: - ResolvedDep Identifier -> - InterpretExpr ann -> - StackFrame ann -> - StackFrame ann -addVarToFrame identifier expr (StackFrame entries) = - StackFrame (M.singleton identifier expr <> entries) diff --git a/smol-core/src/Smol/Core/Interpreter/PatternMatch.hs b/smol-core/src/Smol/Core/Interpreter/PatternMatch.hs deleted file mode 100644 index d86dec3c..00000000 --- a/smol-core/src/Smol/Core/Interpreter/PatternMatch.hs +++ /dev/null @@ -1,90 +0,0 @@ -module Smol.Core.Interpreter.PatternMatch - ( interpretPatternMatch, - ) -where - -import Control.Monad.Except -import Data.Foldable (toList) -import qualified Data.List.NonEmpty as NE -import Data.Monoid -import qualified Data.Sequence as Seq -import Smol.Core.Interpreter.Monad -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Types.Constructor -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Pattern -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Spread - -interpretPatternMatch :: - InterpretFn ann -> - InterpretExpr ann -> - [(InterpretPattern ann, InterpretExpr ann)] -> - InterpreterM ann (InterpretExpr ann) -interpretPatternMatch interpretFn expr' patterns = do - -- interpret match expression - intExpr <- interpretFn expr' - let foldF (pat, patExpr) = case patternMatches pat intExpr of - Just bindings -> First (Just (patExpr, bindings)) - _ -> First Nothing - -- get first matching pattern - case getFirst (foldMap foldF patterns) of - Just (patExpr, bindings) -> - do - -- run body with closure + new arg - extendStackFrame bindings (interpretFn patExpr) - _ -> - throwError $ PatternMatchFailure expr' - --- pull vars out of expr to match patterns -patternMatches :: - InterpretPattern ann -> - InterpretExpr ann -> - Maybe [(ResolvedDep Identifier, InterpretExpr ann)] -patternMatches (PWildcard _) _ = pure [] -patternMatches (PVar _ name) expr = pure [(name, expr)] -patternMatches (PTuple _ pA pAs) (ETuple _ a as) = do - matchA <- patternMatches pA a - matchAs <- - traverse - (uncurry patternMatches) - (zip (NE.toList pAs) (NE.toList as)) - pure $ matchA <> mconcat matchAs -patternMatches (PLiteral _ pB) (EPrim _ b) - | pB == b = pure mempty -patternMatches (PConstructor _ pTyCon []) (EConstructor _ tyCon) | pTyCon == tyCon = do - pure mempty -patternMatches (PConstructor _ pTyCon pArgs) (EApp ann fn val) = do - (tyCon, args) <- consAppToPattern (EApp ann fn val) - if tyCon /= pTyCon - then Nothing - else do - let allPairs = zip pArgs args - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs NoSpread) (EArray _ as) - | length pAs == length as = do - let allPairs = zip pAs (toList as) - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs (SpreadWildcard _)) (EArray _ as) - | length pAs <= length as = do - let allPairs = zip pAs (toList as) - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice) -patternMatches (PArray _ pAs (SpreadValue _ a)) (EArray ann as) - | length pAs <= length as = do - let binding = (a, EArray ann (Seq.fromList $ drop (length pAs) (toList as))) - let allPairs = zip pAs (toList as) - nice <- traverse (uncurry patternMatches) allPairs - pure (mconcat nice <> [binding]) -patternMatches _ _ = Nothing - -consAppToPattern :: InterpretExpr ann -> Maybe (ResolvedDep Constructor, [InterpretExpr ann]) -consAppToPattern (EApp _ fn val) = do - (tyCon, more) <- consAppToPattern fn - pure (tyCon, more <> [val]) -consAppToPattern (EConstructor _ tyCon) = pure (tyCon, mempty) -consAppToPattern _ = Nothing diff --git a/smol-core/src/Smol/Core/Interpreter/RecordAccess.hs b/smol-core/src/Smol/Core/Interpreter/RecordAccess.hs deleted file mode 100644 index 0cde1e0d..00000000 --- a/smol-core/src/Smol/Core/Interpreter/RecordAccess.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Smol.Core.Interpreter.RecordAccess (interpretRecordAccess) where - -import Control.Monad.Except -import qualified Data.Map.Strict as M -import Smol.Core.Interpreter.Types -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier - -interpretRecordAccess :: - InterpretFn ann -> - ExprData ann -> - InterpretExpr ann -> - Identifier -> - InterpreterM ann (InterpretExpr ann) -interpretRecordAccess interpretFn _ (ERecord _ record) name = - case M.lookup name record of - Just item -> interpretFn item - _ -> throwError $ CannotFindMemberInRecord record name -interpretRecordAccess interpretFn ann (EVar ann' a) name = do - intExpr <- interpretFn (EVar ann' a) - interpretFn (ERecordAccess ann intExpr name) -interpretRecordAccess interpretFn ann (ERecordAccess ann' a name') name = do - intExpr <- interpretFn (ERecordAccess ann' a name') - interpretFn (ERecordAccess ann intExpr name) -interpretRecordAccess interpretFn ann (EApp ann' fn arg) name = do - res <- interpretFn (EApp ann' fn arg) - interpretFn (ERecordAccess ann res name) -interpretRecordAccess _ _ recordExpr name = do - throwError $ CannotDestructureAsRecord recordExpr name diff --git a/smol-core/src/Smol/Core/Interpreter/Types.hs b/smol-core/src/Smol/Core/Interpreter/Types.hs deleted file mode 100644 index 01b810da..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Types.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Interpreter.Types - ( InterpreterM, - InterpretExpr, - InterpretFn, - InterpretReaderEnv (..), - InterpretPattern, - ) -where - -import Control.Monad.Reader -import Data.Map.Strict (Map) -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Pattern -import Smol.Core.Types.ResolvedDep - -type InterpreterM ann a = - ReaderT - (InterpretReaderEnv ann) - (Either (InterpreterError ann)) - a - -data InterpretReaderEnv ann = InterpretReaderEnv - { ireStack :: StackFrame ann, - ireGlobals :: Map (ResolvedDep Identifier) (InterpretExpr ann) - } - -type InterpretExpr ann = Expr ResolvedDep (ExprData ann) - -type InterpretPattern ann = - Pattern ResolvedDep (ExprData ann) - -type InterpretFn ann = - InterpretExpr ann -> - InterpreterM ann (InterpretExpr ann) diff --git a/smol-core/src/Smol/Core/Interpreter/Types/InterpreterError.hs b/smol-core/src/Smol/Core/Interpreter/Types/InterpreterError.hs deleted file mode 100644 index db0b5b5e..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Types/InterpreterError.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Interpreter.Types.InterpreterError (InterpreterError (..)) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Natural -import qualified Prettyprinter as PP -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Printer -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Op -import Smol.Core.Types.ResolvedDep - -type InterpretExpr ann = Expr ResolvedDep (ExprData ann) - -data InterpreterError ann - = UnknownInterpreterError - | CouldNotFindVar (Map (ResolvedDep Identifier) (InterpretExpr ann)) (ResolvedDep Identifier) - | AdditionWithNonNumber (InterpretExpr ann) - | SubtractionWithNonNumber (InterpretExpr ann) - | ComparisonWithNonNumber Op (InterpretExpr ann) - | StringConcatenationFailure (InterpretExpr ann) (InterpretExpr ann) - | ArrayConcatenationFailure (InterpretExpr ann) (InterpretExpr ann) - | PredicateForIfMustBeABoolean (InterpretExpr ann) - | CannotDestructureAsRecord (InterpretExpr ann) Identifier - | CannotDestructureAsTuple (InterpretExpr ann) Natural - | CannotFindMemberInRecord (Map Identifier (InterpretExpr ann)) Identifier - | CannotFindMemberInTuple [InterpretExpr ann] Natural - | PatternMatchFailure (InterpretExpr ann) - deriving stock (Eq, Ord, Show) - -instance Semigroup (InterpreterError ann) where - a <> _ = a - -instance Monoid (InterpreterError ann) where - mempty = UnknownInterpreterError - -commaSep :: (Printer a) => [a] -> PP.Doc ann -commaSep = - foldMap (\a -> prettyDoc a <> ", ") - -instance Printer (InterpreterError ann) where - prettyDoc (CouldNotFindVar items name) = - "Could not find var " <> prettyDoc name <> " in " <> itemList - where - itemList = "[ " <> commaSep (M.keys items) <> " ]" - prettyDoc UnknownInterpreterError = "Unknown interpreter 2 error" - prettyDoc (AdditionWithNonNumber a) = - "Addition expected number but got this: " <> prettyDoc a - prettyDoc (SubtractionWithNonNumber a) = - "Subtraction expected number but got this: " <> prettyDoc a - prettyDoc (ComparisonWithNonNumber op a) = - "Operator " <> prettyDoc op <> " expected number but got this: " <> prettyDoc a - prettyDoc (StringConcatenationFailure a b) = - "Concatenation expected string + string but got this: " <> prettyDoc a <> " and " <> prettyDoc b - prettyDoc (ArrayConcatenationFailure a b) = - "Concatenation expected array + array but got this: " <> prettyDoc a <> " and " <> prettyDoc b - prettyDoc (PredicateForIfMustBeABoolean expr) = - "Expected a boolean as a predicate. Cannot use: " <> prettyDoc expr - prettyDoc (CannotDestructureAsRecord expr name) = - "Expected a record with a member " <> prettyDoc name <> ". Cannot destructure: " <> prettyDoc expr - prettyDoc (CannotDestructureAsTuple expr index) = - "Expected a tuple with an index at " <> prettyDoc index <> ". Cannot destructure: " <> prettyDoc expr - prettyDoc (CannotFindMemberInRecord items name) = - "Could not find member " <> prettyDoc name <> " in " <> itemList - where - itemList = "[ " <> commaSep (M.keys items) <> " ]" - prettyDoc (CannotFindMemberInTuple items index) = - "Could not find index " <> prettyDoc index <> " in " <> itemList - where - itemList = "[ " <> prettyDoc items <> " ]" - prettyDoc (PatternMatchFailure expr') = - "Could not pattern match on value " <> prettyDoc expr' diff --git a/smol-core/src/Smol/Core/Interpreter/Types/Stack.hs b/smol-core/src/Smol/Core/Interpreter/Types/Stack.hs deleted file mode 100644 index 1b1d9bbc..00000000 --- a/smol-core/src/Smol/Core/Interpreter/Types/Stack.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Interpreter.Types.Stack (StackFrame (..), ExprData (..)) where - -import Data.Map.Strict (Map) -import Smol.Core.Printer -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.ResolvedDep - -newtype StackFrame ann = StackFrame - { sfVariables :: Map (ResolvedDep Identifier) (Expr ResolvedDep (ExprData ann)) - } - deriving stock (Eq, Ord, Show) - -instance Semigroup (StackFrame ann) where - (StackFrame varA) <> (StackFrame varB) = - StackFrame (varA <> varB) - -instance Monoid (StackFrame ann) where - mempty = StackFrame mempty - -instance Printer (StackFrame ann) where - prettyDoc (StackFrame sfVars) = prettyDoc sfVars - --- carried around in each node when interpreting -data ExprData ann = ExprData - { edStackFrame :: StackFrame ann, - edIsRecursive :: Bool, - edAnnotation :: ann - } - deriving stock (Eq, Ord, Show) - -instance (Semigroup ann) => Semigroup (ExprData ann) where - (ExprData sfA isRecA annA) <> (ExprData sfB isRecB annB) = - ExprData (sfA <> sfB) (isRecA || isRecB) (annA <> annB) - -instance (Monoid ann) => Monoid (ExprData ann) where - mempty = ExprData mempty False mempty diff --git a/smol-core/src/Smol/Core/Modules/Check.hs b/smol-core/src/Smol/Core/Modules/Check.hs deleted file mode 100644 index 567f2d1a..00000000 --- a/smol-core/src/Smol/Core/Modules/Check.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Smol.Core.Modules.Check - ( checkModule, - ) -where - -import Control.Monad.Except -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Text as T -import Smol.Core -import Smol.Core.Modules.FromParts -import Smol.Core.Modules.ResolveDeps -import Smol.Core.Modules.Typecheck -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Modules.Types.ModuleItem -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TopLevelExpression -import Smol.Core.Transform -import Smol.Core.Typecheck.Typeclass - --- this is the front door as such -checkModule :: - (MonadError (ModuleError Annotation) m) => - T.Text -> - [ModuleItem Annotation] -> - m (Module ResolvedDep (Type ResolvedDep Annotation)) -checkModule input moduleItems = do - myModule <- moduleFromModuleParts moduleItems - - let classes = resolveTypeclass <$> moClasses myModule - typeclassMethods = S.fromList . M.elems . fmap tcFuncName $ classes - - (resolvedModule, deps) <- - modifyError ErrorInResolveDeps (resolveModuleDeps typeclassMethods myModule) - - typedModule <- typecheckModule input resolvedModule deps - - dictModule <- passModuleDictionaries input typedModule - - pure (transformModule dictModule) - -transformModule :: (Ord (dep Identifier)) => Module dep ann -> Module dep ann -transformModule inputModule = - let transformTle tle = - tle {tleExpr = transform (tleExpr tle)} - in inputModule {moExpressions = transformTle <$> moExpressions inputModule} - -passModuleDictionaries :: - (MonadError (ModuleError Annotation) m) => - T.Text -> - Module ResolvedDep (Type ResolvedDep Annotation) -> - m (Module ResolvedDep (Type ResolvedDep Annotation)) -passModuleDictionaries input inputModule = do - let env = envFromTypecheckedModule inputModule - - let passDictToTopLevelExpression (ident, tle) = do - let constraints = constraintsFromTLE tle - expr = tleExpr tle - - let typedConstraints = addTypesToConstraint <$> constraints - dictEnv = - ToDictEnv - { tdeClasses = tceClasses env, - tdeInstances = moInstances inputModule, - tdeVars = getVarsInScope inputModule - } - newExpr <- - modifyError - (DictionaryPassingError input) - (toDictionaryPassing dictEnv mempty typedConstraints expr) - - pure (ident, tle {tleExpr = newExpr}) - - newExpressions <- M.fromList <$> traverse passDictToTopLevelExpression (M.toList $ moExpressions inputModule) - - let passDictToTest (UnitTest testName expr) = do - let constraints = mempty -- test should have no constraints to satisfy - let typedConstraints = addTypesToConstraint <$> constraints - dictEnv = - ToDictEnv - { tdeClasses = tceClasses env, - tdeInstances = moInstances inputModule, - tdeVars = getVarsInScope inputModule - } - newExpr <- - modifyError - (DictionaryPassingError input) - (toDictionaryPassing dictEnv mempty typedConstraints expr) - - pure (UnitTest testName newExpr) - - newTests <- traverse passDictToTest (moTests inputModule) - - pure $ inputModule {moExpressions = newExpressions, moTests = newTests} diff --git a/smol-core/src/Smol/Core/Modules/Dependencies.hs b/smol-core/src/Smol/Core/Modules/Dependencies.hs deleted file mode 100644 index 8e46e821..00000000 --- a/smol-core/src/Smol/Core/Modules/Dependencies.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Modules.Dependencies - ( getDependencies, - filterExprs, - filterDataTypes, - ) -where - --- work out the dependencies between definitions inside a module - -import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Monoid (First (..)) -import Data.Set (Set) -import qualified Data.Set as S -import Smol.Core -import Smol.Core.Modules.Types.DefIdentifier -import Smol.Core.Modules.Types.DepType -import qualified Smol.Core.Modules.Types.Entity as E -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TopLevelExpression -import Smol.Core.Modules.Uses - -filterExprs :: Map k (DepType dep ann) -> Map k (TopLevelExpression dep ann) -filterExprs = - M.mapMaybe - ( \case - (DTExpr tle) -> Just tle - _ -> Nothing - ) - -filterDataTypes :: Map k (DepType dep ann) -> Map k (DataType dep ann) -filterDataTypes = - M.mapMaybe - ( \case - (DTData dt) -> Just dt - _ -> Nothing - ) - -filterDefs :: Set E.Entity -> Set Identifier -filterDefs = - S.fromList - . mapMaybe - ( \case - E.EVar name -> Just name - _ -> Nothing - ) - . S.toList - -filterConstructors :: Set E.Entity -> Set Constructor -filterConstructors = - S.fromList - . mapMaybe - ( \case - E.EConstructor tyCon -> Just tyCon - _ -> Nothing - ) - . S.toList - -filterTypes :: Set E.Entity -> Set TypeName -filterTypes = - S.fromList - . mapMaybe - ( \case - E.EType typeName -> Just typeName - _ -> Nothing - ) - . S.toList - --- get the vars used by each def --- explode if there's not available -getDependencies :: - (MonadError ResolveDepsError m, Monoid ann) => - (Expr ParseDep ann -> Set E.Entity) -> - (Type ParseDep ann -> Set E.Entity) -> - Module ParseDep ann -> - m - ( Map - (DefIdentifier ParseDep) - ( DepType ParseDep ann, - Set (DefIdentifier ParseDep), - Set E.Entity - ) - ) -getDependencies getUses getTypeUses' mod' = do - exprDeps <- - M.mapKeys DIName - <$> traverse - (getTopLevelExprDependencies getUses mod') - (moExpressions mod') - typeDeps <- - M.mapKeys DIType - <$> traverse - (getTypeDependencies mod') - (moDataTypes mod') - instanceDeps <- - M.mapKeys DIInstance - <$> traverse - (getInstanceDependencies getUses getTypeUses' mod') - (addKeysToMap $ moInstances mod') - testDeps <- - M.mapKeys DITest - <$> traverse - (getTestDependencies getUses mod') - (M.fromList ((\(UnitTest testName expr) -> (testName, expr)) <$> moTests mod')) - pure (exprDeps <> typeDeps <> instanceDeps <> testDeps) - -addKeysToMap :: (Ord k) => M.Map k a -> M.Map k (k, a) -addKeysToMap = M.fromList . fmap (\(k, a) -> (k, (k, a))) . M.toList - --- get all dependencies of a type definition -getTypeDependencies :: - (MonadError ResolveDepsError m) => - Module ParseDep ann -> - DataType ParseDep ann -> - m (DepType ParseDep ann, Set (DefIdentifier ParseDep), Set E.Entity) -getTypeDependencies mod' dt = do - let allUses = extractDataTypeUses dt - typeDefIds <- getTypeUses mod' allUses - exprDefIds <- S.map DIName <$> getExprDeps mod' allUses - pure (DTData dt, typeDefIds <> exprDefIds, allUses) - -getTypeUses :: - ( MonadError ResolveDepsError m, - Ord (dep Constructor), - Ord (dep TypeName), - Ord (dep Identifier) - ) => - Module dep ann -> - Set E.Entity -> - m (Set (DefIdentifier dep)) -getTypeUses mod' uses = - let typeDeps = filterTypes uses - unknownTypeDeps = - S.filter - ( \typeName -> - S.notMember typeName (M.keysSet (moDataTypes mod')) - ) - typeDeps - in if S.null unknownTypeDeps - then - let localTypeDeps = - S.filter - ( \typeName -> - typeName `S.member` M.keysSet (moDataTypes mod') - ) - typeDeps - in pure (S.map DIType localTypeDeps) - else throwError (CannotFindTypes unknownTypeDeps) - -findTypenameInModule :: - Module dep ann -> - Constructor -> - Maybe TypeName -findTypenameInModule mod' tyCon = - let lookupInDataType (DataType typeName _ constructors) = - if M.member tyCon constructors - then First (Just typeName) - else First Nothing - in getFirst $ foldMap lookupInDataType (M.elems (moDataTypes mod')) - --- get typenames where we can, ignore missing ones as they're from another --- module --- (fingers crosseD!???!) -findTypesForConstructors :: - Module dep ann -> - Set Constructor -> - Set TypeName -findTypesForConstructors mod' = - S.fromList . mapMaybe (findTypenameInModule mod') . S.toList - -getConstructorUses :: - ( MonadError ResolveDepsError m, - Ord (dep Constructor), - Ord (dep Identifier), - Ord (dep TypeName) - ) => - Module dep ann -> - Set E.Entity -> - m (Set (DefIdentifier dep)) -getConstructorUses mod' uses = do - let typeDeps = findTypesForConstructors mod' (filterConstructors uses) - let unknownTypeDeps = - S.filter - ( \typeName -> - S.notMember typeName (M.keysSet (moDataTypes mod')) - ) - typeDeps - in if S.null unknownTypeDeps - then - let localTypeDeps = - S.filter - ( \typeName -> - typeName `S.member` M.keysSet (moDataTypes mod') - ) - typeDeps - in pure (S.map DIType localTypeDeps) - else throwError (CannotFindTypes unknownTypeDeps) - -getTopLevelExprDependencies :: - (MonadError ResolveDepsError m, Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => - (Expr dep ann -> Set E.Entity) -> - Module dep ann -> - TopLevelExpression dep ann -> - m (DepType dep ann, Set (DefIdentifier dep), Set E.Entity) -getTopLevelExprDependencies getUses mod' expr = do - (defIds, entities) <- getExprDependencies getUses mod' (tleExpr expr) - pure (DTExpr expr, defIds, entities) - -getTestDependencies :: - (MonadError ResolveDepsError m, Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => - (Expr dep ann -> Set E.Entity) -> - Module dep ann -> - Expr dep ann -> - m (DepType dep ann, Set (DefIdentifier dep), Set E.Entity) -getTestDependencies getUses mod' expr = do - (defIds, entities) <- getExprDependencies getUses mod' expr - pure (DTTest expr, defIds, entities) - -getExprDependencies :: - (MonadError ResolveDepsError m, Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => - (Expr dep ann -> Set E.Entity) -> - Module dep ann -> - Expr dep ann -> - m (Set (DefIdentifier dep), Set E.Entity) -getExprDependencies getUses mod' expr = do - let allUses = getUses expr - exprDefIds <- S.map DIName <$> getExprDeps mod' allUses - consDefIds <- getConstructorUses mod' allUses - typeDefIds <- getTypeUses mod' allUses - pure (exprDefIds <> typeDefIds <> consDefIds, allUses) - -getInstanceDependencies :: - ( MonadError ResolveDepsError m, - Monoid ann, - Ord (dep Constructor), - Ord (dep TypeName), - Ord (dep Identifier) - ) => - (Expr dep ann -> Set E.Entity) -> - (Type dep ann -> Set E.Entity) -> - Module dep ann -> - (Constraint dep (), Instance dep ann) -> - m (DepType dep ann, Set (DefIdentifier dep), Set E.Entity) -getInstanceDependencies getUses getTypeUses' mod' (constraint, inst) = do - -- get everything mentioned in instance expression - let allUses = getUses (inExpr inst) - exprDefIds <- S.map DIName <$> getExprDeps mod' allUses - consDefIds <- getConstructorUses mod' allUses - typeDefIds <- getTypeUses mod' allUses - -- get types mentioned in constraint - let typeUses = foldMap getTypeUses' ((fmap . fmap . fmap) (const mempty) conType constraint) - constraintDefIds <- getTypeUses mod' typeUses - pure (DTInstance inst, exprDefIds <> typeDefIds <> consDefIds <> constraintDefIds, allUses) - -getExprDeps :: - (Monad m) => - Module dep ann -> - Set E.Entity -> - m (Set Identifier) -getExprDeps mod' uses = - pure $ - S.filter - ( `S.member` - M.keysSet (moExpressions mod') - ) - (filterDefs uses) diff --git a/smol-core/src/Smol/Core/Modules/FromParts.hs b/smol-core/src/Smol/Core/Modules/FromParts.hs deleted file mode 100644 index a2295d1f..00000000 --- a/smol-core/src/Smol/Core/Modules/FromParts.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Smol.Core.Modules.FromParts (addModulePart, moduleFromModuleParts, exprAndTypeFromParts) where - -import Control.Monad (unless) -import Control.Monad.Except -import Data.Coerce -import Data.Functor (void) -import qualified Data.Map.Strict as M -import Data.Maybe (isJust, mapMaybe) -import Smol.Core -import Smol.Core.Modules.Monad -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Modules.Types.ModuleItem -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TopLevelExpression - -moduleFromModuleParts :: - ( MonadError (ModuleError ann) m, - Monoid ann - ) => - [ModuleItem ann] -> - m (Module ParseDep ann) -moduleFromModuleParts parts = - let addPart part output = do - mod' <- output - addModulePart parts part mod' - in foldr addPart (pure mempty) parts - -addModulePart :: - (MonadError (ModuleError ann) m, Monoid ann) => - [ModuleItem ann] -> - ModuleItem ann -> - Module ParseDep ann -> - m (Module ParseDep ann) -addModulePart allParts part mod' = - case part of - ModuleExpression name bits expr -> do - errorIfExpressionAlreadyDefined mod' name - let exp' = exprAndTypeFromParts allParts name bits expr - pure $ - mod' - { moExpressions = - M.singleton name exp' <> moExpressions mod' - } - ModuleExpressionType _name _ _ty -> do - pure mod' -- we sort these elsewhere - ModuleTest testName expr - | "" == testName -> - throwError (EmptyTestName expr) - ModuleTest testName expr -> - pure $ - mod' - { moTests = UnitTest testName expr : moTests mod' - } - ModuleClass tc -> - case M.lookup (tcName tc) (moClasses mod') of - Just _ -> throwError (DuplicateTypeclass (tcName tc)) - Nothing -> - pure $ - mod' - { moClasses = - M.singleton (tcName tc) tc <> moClasses mod' - } - ModuleInstance constraints constraint expr -> do - unless - (isJust $ findTypeclass (conTypeclass constraint) allParts) - (throwError $ MissingTypeclass (conTypeclass constraint)) - pure $ - mod' - { moInstances = - M.singleton - (void constraint) - ( Instance - { inConstraints = constraints, - inExpr = expr - } - ) - <> moInstances mod' - } - ModuleDataType dt@(DataType tyCon _ _) -> do - let typeName = coerce tyCon - checkDataType mod' dt - pure $ - mod' - { moDataTypes = - M.singleton typeName dt - <> moDataTypes mod' - } - --- given the bits of things, make a coherent type and expression --- 1) check we have any type annotations --- 2) if so - ensure we have a full set (error if not) and create annotation --- 3) if not, just return expr -exprAndTypeFromParts :: - (Monoid ann) => - [ModuleItem ann] -> - Identifier -> - [Identifier] -> - Expr ParseDep ann -> - TopLevelExpression ParseDep ann -exprAndTypeFromParts moduleItems ident idents expr = - let tleExpr = - foldr - (ELambda mempty . emptyParseDep) - expr - idents - (tleConstraints, tleType) = - case findTypeExpression ident moduleItems of - Just (constraints, ty) -> - (constraints, Just ty) - Nothing -> - (mempty, Nothing) - in TopLevelExpression {..} - -findTypeExpression :: Identifier -> [ModuleItem ann] -> Maybe ([Constraint ParseDep ann], Type ParseDep ann) -findTypeExpression ident moduleItems = - case mapMaybe - ( \case - ModuleExpressionType name constraints ty | name == ident -> Just (constraints, ty) - _ -> Nothing - ) - moduleItems of - [a] -> Just a - _ -> Nothing -- we should have better errors for multiple type declarations, but for now, chill out friend - -findTypeclass :: TypeclassName -> [ModuleItem ann] -> Maybe (Typeclass ParseDep ann) -findTypeclass tcn moduleItems = - case mapMaybe - ( \case - ModuleClass tc | tcName tc == tcn -> Just tc - _ -> Nothing - ) - moduleItems of - [a] -> Just a - _ -> Nothing -- we should have better errors for multiple type declarations, but for now, chill out friend diff --git a/smol-core/src/Smol/Core/Modules/Helpers.hs b/smol-core/src/Smol/Core/Modules/Helpers.hs deleted file mode 100644 index dcad17f2..00000000 --- a/smol-core/src/Smol/Core/Modules/Helpers.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Modules.Helpers - ( filterNameDefs, - filterTypeDefs, - ) -where - -import Data.Map.Strict (Map) -import Smol.Core -import Smol.Core.Helpers (filterMapKeys) -import Smol.Core.Modules.Types.DefIdentifier - -filterNameDefs :: Map (DefIdentifier dep) a -> Map Identifier a -filterNameDefs = - filterMapKeys - ( \case - DIName name -> Just name - _ -> Nothing - ) - -filterTypeDefs :: Map (DefIdentifier dep) a -> Map TypeName a -filterTypeDefs = - filterMapKeys - ( \case - DIType typeName -> Just typeName - _ -> Nothing - ) diff --git a/smol-core/src/Smol/Core/Modules/Interpret.hs b/smol-core/src/Smol/Core/Modules/Interpret.hs deleted file mode 100644 index edc9e2b6..00000000 --- a/smol-core/src/Smol/Core/Modules/Interpret.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Modules.Interpret (interpretModule) where - -import Control.Monad.Except -import Data.List (find) -import qualified Data.Map.Strict as M -import Smol.Core -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Modules.Types -import Smol.Core.Modules.Types.ModuleError - ---- interpret an expression in the context of a module (for now, the `main` --- function) -interpretModule :: - (Show ann, Eq ann, MonadError (ModuleError ann) m) => - DefIdentifier ResolvedDep -> - Module ResolvedDep ann -> - m (Expr ResolvedDep ann) -interpretModule (DIName exprName) inputModule = do - let expressions = addEmptyStackFrames . tleExpr <$> moExpressions inputModule - - let mainExpression = case M.lookup exprName expressions of - Just expr -> expr - Nothing -> error $ "could not find '" <> show exprName <> "'" - - let otherExpressions = M.mapKeys LocalDefinition (M.delete exprName expressions) - - interpretExpr <- - modifyError ErrorInInterpreter - . liftEither - . interpret otherExpressions - $ mainExpression - - -- return resolved value, with extra metadata mess removed - pure (edAnnotation <$> interpretExpr) -interpretModule (DITest testName) inputModule = do - let expressions = addEmptyStackFrames . tleExpr <$> moExpressions inputModule - - let mainExpression = case find (\(UnitTest tn _) -> tn == testName) (moTests inputModule) of - Just (UnitTest _ expr) -> addEmptyStackFrames expr - Nothing -> error $ "could not find test '" <> show testName <> "'" - - let otherExpressions = M.mapKeys LocalDefinition expressions - - interpretExpr <- - modifyError ErrorInInterpreter - . liftEither - . interpret otherExpressions - $ mainExpression - - -- return resolved value, with extra metadata mess removed - pure (edAnnotation <$> interpretExpr) -interpretModule defIdent _inputModule = error $ "interpretModule " <> show defIdent diff --git a/smol-core/src/Smol/Core/Modules/Monad.hs b/smol-core/src/Smol/Core/Modules/Monad.hs deleted file mode 100644 index ccae355c..00000000 --- a/smol-core/src/Smol/Core/Modules/Monad.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Modules.Monad - ( errorIfExpressionAlreadyDefined, - checkDataType, - ) -where - -import Control.Monad (when) -import Control.Monad.Except -import Data.Coerce -import Data.Foldable -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Smol.Core -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError - -errorIfExpressionAlreadyDefined :: - (MonadError (ModuleError ann) m) => - Module dep ann -> - Identifier -> - m () -errorIfExpressionAlreadyDefined mod' def = - when - ( M.member def (moExpressions mod') - ) - (throwError (DuplicateDefinition def)) - -checkDataType :: - (MonadError (ModuleError ann) m) => - Module dep ann -> - DataType dep ann -> - m () -checkDataType mod' (DataType typeName _ constructors) = do - errorIfTypeAlreadyDefined mod' (coerce typeName) - traverse_ (errorIfConstructorAlreadyDefined mod') (M.keys constructors) - -errorIfTypeAlreadyDefined :: - (MonadError (ModuleError ann) m) => - Module dep ann -> - TypeName -> - m () -errorIfTypeAlreadyDefined mod' typeName = - when - ( M.member typeName (moDataTypes mod') - ) - (throwError (DuplicateTypeName typeName)) - -errorIfConstructorAlreadyDefined :: - (MonadError (ModuleError ann) m) => - Module dep ann -> - Constructor -> - m () -errorIfConstructorAlreadyDefined mod' tyCon = - let allCons = mconcat (M.keysSet . dtConstructors <$> M.elems (moDataTypes mod')) - in when - (S.member tyCon allCons) - (throwError (DuplicateConstructor tyCon)) diff --git a/smol-core/src/Smol/Core/Modules/ResolveDeps.hs b/smol-core/src/Smol/Core/Modules/ResolveDeps.hs deleted file mode 100644 index 099c22d3..00000000 --- a/smol-core/src/Smol/Core/Modules/ResolveDeps.hs +++ /dev/null @@ -1,381 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Smol.Core.Modules.ResolveDeps - ( resolveModuleDeps, - resolveExprDeps, - resolveTypeclass, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import Smol.Core -import Smol.Core.Modules.Dependencies -import Smol.Core.Modules.Types.DefIdentifier -import Smol.Core.Modules.Types.DepType -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TopLevelExpression -import Smol.Core.Modules.Uses - -resolveExprDeps :: - (Show ann, MonadError ResolveDepsError m) => - Expr ParseDep ann -> - Set Identifier -> - Set (DefIdentifier ParseDep) -> - Set Constructor -> - m (Expr ResolvedDep ann) -resolveExprDeps expr typeclassMethods localDefs localTypes = - evalStateT (resolveExpr expr typeclassMethods localDefs localTypes) (ResolveState 0) - -resolveExpr :: - (Show ann, MonadError ResolveDepsError m, MonadState ResolveState m) => - Expr ParseDep ann -> - Set Identifier -> - Set (DefIdentifier ParseDep) -> - Set Constructor -> - m (Expr ResolvedDep ann) -resolveExpr expr typeclassMethods localDefs localTypes = - runReaderT - (resolveM expr) - initialEnv - where - initialEnv = ResolveEnv mempty localDefs localTypes typeclassMethods - -resolveModuleDeps :: - (Show ann, Eq ann, Monoid ann, MonadError ResolveDepsError m) => - Set Identifier -> - Module ParseDep ann -> - m (Module ResolvedDep ann, Map (DefIdentifier ResolvedDep) (Set (DefIdentifier ResolvedDep))) -resolveModuleDeps typeclassMethods parsedModule = do - map' <- getDependencies extractUses extractTypeUses parsedModule - let resolveIt (DTData dt, _, _) = - pure (DTData (resolveDataType dt)) - resolveIt (DTTest expr, defIds, _entities) = - DTTest <$> resolveExpr expr typeclassMethods defIds (allConstructors parsedModule) - resolveIt (DTExpr expr, defIds, _entities) = - DTExpr <$> resolveTopLevelExpression expr typeclassMethods defIds (allConstructors parsedModule) - resolveIt (DTInstance inst, defIds, _entities) = do - resolvedExpr <- resolveExpr (inExpr inst) typeclassMethods defIds (allConstructors parsedModule) - pure - ( DTInstance - ( Instance - { inConstraints = resolveConstraint <$> inConstraints inst, - inExpr = resolvedExpr - } - ) - ) - - resolvedMap <- evalStateT (traverse resolveIt map') (ResolveState 0) - - let resolvedExpressions = - mapMaybeWithKey - ( \k a -> case (k, a) of - (DIName identifier, DTExpr expr) -> Just (identifier, expr) - _ -> Nothing - ) - resolvedMap - - resolvedDataTypes = - mapMaybeWithKey - ( \k a -> case (k, a) of - (DIType typeName, DTData dt) -> Just (typeName, dt) - _ -> Nothing - ) - resolvedMap - - resolvedInstances = - mapMaybeWithKey - ( \k a -> case (k, a) of - (DIInstance constraint, DTInstance inst) -> Just (constraint, inst) - _ -> Nothing - ) - resolvedMap - - resolvedTests = - fmap (uncurry UnitTest) - . M.toList - . mapMaybeWithKey - ( \k a -> case (k, a) of - (DITest testName, DTTest expr) -> Just (testName, expr) - _ -> Nothing - ) - $ resolvedMap - - dependencies = - M.fromList $ - (\(k, (_, b, _)) -> (resolveDefIdentifier k, S.map resolveDefIdentifier b)) - <$> M.toList map' - in pure - ( Module - { moExpressions = resolvedExpressions, - moDataTypes = resolvedDataTypes, - moTests = resolvedTests, - moInstances = M.mapKeys resolveConstraint resolvedInstances, - moClasses = resolveTypeclass <$> moClasses parsedModule - }, - dependencies - ) - -mapMaybeWithKey :: (Ord k2) => (k -> a -> Maybe (k2, b)) -> Map k a -> Map k2 b -mapMaybeWithKey f = M.fromList . mapMaybe (uncurry f) . M.toList - -allConstructors :: Module dep ann -> Set Constructor -allConstructors Module {moDataTypes} = - foldMap (\(DataType {dtConstructors}) -> M.keysSet dtConstructors) moDataTypes - -resolveDefIdentifier :: DefIdentifier ParseDep -> DefIdentifier ResolvedDep -resolveDefIdentifier (DIName name) = DIName name -resolveDefIdentifier (DITest test) = DITest test -resolveDefIdentifier (DIType ty) = DIType ty -resolveDefIdentifier (DIInstance inst) = DIInstance (resolveConstraint inst) - -resolveTypeclass :: Typeclass ParseDep ann -> Typeclass ResolvedDep ann -resolveTypeclass (Typeclass {tcName, tcArgs, tcFuncName, tcFuncType}) = - Typeclass - { tcName, - tcArgs, - tcFuncName, - tcFuncType = resolveType tcFuncType - } - -resolveDataType :: DataType ParseDep ann -> DataType ResolvedDep ann -resolveDataType (DataType {dtName, dtVars, dtConstructors}) = - DataType dtName dtVars (resolveDataConstructor <$> dtConstructors) - where - resolveDataConstructor tys = - resolveType <$> tys - -resolveConstraint :: Constraint ParseDep ann -> Constraint ResolvedDep ann -resolveConstraint (Constraint tcn tys) = - Constraint tcn (resolveType <$> tys) - -resolveType :: Type ParseDep ann -> Type ResolvedDep ann -resolveType (TVar ann (ParseDep v _)) = TVar ann (LocalDefinition v) -resolveType (TConstructor ann c) = TConstructor ann (resolveTypeName c) -resolveType (TInfix ann op a b) = TInfix ann op (resolveType a) (resolveType b) -resolveType (TPrim ann p) = TPrim ann p -resolveType (TLiteral ann l) = TLiteral ann l -resolveType (TFunc ann closure from to) = - TFunc ann (M.mapKeys resolveId $ resolveType <$> closure) (resolveType from) (resolveType to) - where - resolveId (ParseDep v _) = LocalDefinition v -resolveType (TTuple ann a as) = - TTuple ann (resolveType a) (resolveType <$> as) -resolveType (TArray ann size a) = TArray ann size (resolveType a) -resolveType (TUnknown ann i) = TUnknown ann i -resolveType (TRecord ann as) = TRecord ann (resolveType <$> as) -resolveType (TApp ann fn arg) = TApp ann (resolveType fn) (resolveType arg) - --- resolve Expr (s) and Type pls -resolveTopLevelExpression :: - (Show ann, MonadState ResolveState m, MonadError ResolveDepsError m) => - TopLevelExpression ParseDep ann -> - Set Identifier -> - Set (DefIdentifier ParseDep) -> - Set Constructor -> - m (TopLevelExpression ResolvedDep ann) -resolveTopLevelExpression tle typeclassMethods localDefs localTypes = flip runReaderT initialEnv $ do - resolvedExpr <- resolveM (tleExpr tle) - let resolvedType = fmap resolveType (tleType tle) - - pure - ( TopLevelExpression - { tleConstraints = resolveConstraint <$> tleConstraints tle, - tleExpr = resolvedExpr, - tleType = resolvedType - } - ) - where - initialEnv = ResolveEnv mempty localDefs localTypes typeclassMethods - -resolveIdentifier :: - ( MonadReader ResolveEnv m, - MonadState ResolveState m, - MonadError ResolveDepsError m - ) => - ParseDep Identifier -> - m (ResolvedDep Identifier) -resolveIdentifier (ParseDep ident (Just modName)) = - error $ "could not resolve " <> show ident <> " in module " <> show modName -resolveIdentifier (ParseDep ident Nothing) = do - existingUnique <- asks (M.lookup ident . reExisting) - case existingUnique of - Just i -> pure (UniqueDefinition ident i) - Nothing -> do - isLocal <- asks (S.member (DIName ident) . reLocal) - if isLocal - then pure (LocalDefinition ident) - else do - isTypeclassMethod <- asks (S.member ident . reTypeclassMethods) - if isTypeclassMethod - then typeclassIdentifier ident - else throwError $ VarNotFound ident - -resolveConstructor :: - ( MonadReader ResolveEnv m - ) => - ParseDep Constructor -> - m (ResolvedDep Constructor) -resolveConstructor (ParseDep constructor (Just modName)) = - error $ "could not resolve " <> show constructor <> " in module " <> show modName -resolveConstructor (ParseDep constructor Nothing) = do - isLocal <- asks (S.member constructor . reLocalConstructor) - if isLocal - then pure (LocalDefinition constructor) - else error $ "Could not find constructor " <> show constructor - -resolveTypeName :: - ParseDep TypeName -> - ResolvedDep TypeName -resolveTypeName (ParseDep tn Nothing) = - LocalDefinition tn -resolveTypeName (ParseDep tn (Just a)) = - error $ "resolve type name for type " <> show a <> "." <> show tn - -freshInt :: (MonadState ResolveState m) => m Int -freshInt = - state - ( \rs -> - let newInt = rsUnique rs + 1 - in (newInt, rs {rsUnique = newInt}) - ) - -newIdentifier :: - (MonadState ResolveState m) => - ParseDep Identifier -> - m (Int, Identifier, ResolvedDep Identifier) -newIdentifier (ParseDep ident _) = do - i <- freshInt - pure (i, ident, UniqueDefinition ident i) - -typeclassIdentifier :: - (MonadState ResolveState m) => - Identifier -> - m (ResolvedDep Identifier) -typeclassIdentifier ident = - TypeclassCall ident <$> freshInt - -withNewIdentifier :: - (MonadReader ResolveEnv m) => - Int -> - Identifier -> - m a -> - m a -withNewIdentifier i ident = - local (\re -> re {reExisting = M.singleton ident i <> reExisting re}) - -withNewIdentifiers :: - (MonadReader ResolveEnv m) => - Map Identifier Int -> - m a -> - m a -withNewIdentifiers resolvedIdentifiers = - local (\re -> re {reExisting = resolvedIdentifiers <> reExisting re}) - -data ResolveEnv = ResolveEnv - { reExisting :: Map Identifier Int, - reLocal :: Set (DefIdentifier ParseDep), - reLocalConstructor :: Set Constructor, - reTypeclassMethods :: Set Identifier - } - deriving stock (Eq, Ord, Show) - -newtype ResolveState = ResolveState {rsUnique :: Int} - -resolveM :: - (Show ann, MonadReader ResolveEnv m, MonadState ResolveState m, MonadError ResolveDepsError m) => - Expr ParseDep ann -> - m (Expr ResolvedDep ann) -resolveM (EVar ann ident) = EVar ann <$> resolveIdentifier ident -resolveM (ELet ann ident body rest) = do - (unique, innerIdent, newIdent) <- newIdentifier ident - (body', rest') <- - withNewIdentifier - unique - innerIdent - ((,) <$> resolveM body <*> resolveM rest) - pure (ELet ann newIdent body' rest') -resolveM (EPrim ann prim) = pure (EPrim ann prim) -resolveM (EApp ann fn arg) = - EApp ann <$> resolveM fn <*> resolveM arg -resolveM (EConstructor ann constructor) = - EConstructor ann <$> resolveConstructor constructor -resolveM (ELambda ann ident body) = do - (unique, innerIdent, newIdent) <- newIdentifier ident - resolvedBody <- withNewIdentifier unique innerIdent (resolveM body) - pure $ ELambda ann newIdent resolvedBody -resolveM (EInfix ann op a b) = - EInfix ann op <$> resolveM a <*> resolveM b -resolveM (EIf ann predExpr thenExpr elseExpr) = - EIf ann - <$> resolveM predExpr - <*> resolveM thenExpr - <*> resolveM elseExpr -resolveM (EAnn ann ty expr) = - EAnn ann (resolveType ty) <$> resolveM expr -resolveM (ETuple ann a as) = - ETuple ann <$> resolveM a <*> traverse resolveM as -resolveM (EArray ann as) = - EArray ann <$> traverse resolveM as -resolveM (ERecord ann as) = - ERecord ann <$> traverse resolveM as -resolveM (ERecordAccess ann expr name) = - ERecordAccess ann <$> resolveM expr <*> pure name -resolveM (EPatternMatch ann expr pats) = do - EPatternMatch ann <$> resolveM expr <*> traverse (uncurry resolvePat) pats - where - resolvePat pat patExpr = do - (resolvedPat, idents) <- resolvePattern pat - (,) resolvedPat <$> withNewIdentifiers idents (resolveM patExpr) - -resolvePattern :: - forall m ann. - ( MonadReader ResolveEnv m, - MonadError ResolveDepsError m, - MonadState ResolveState m - ) => - Pattern ParseDep ann -> - m (Pattern ResolvedDep ann, Map Identifier Int) -resolvePattern = runWriterT . resolvePatternInner - where - resolvePatternInner :: - ( MonadError ResolveDepsError m, - MonadReader ResolveEnv m, - MonadWriter (Map Identifier Int) m, - MonadState ResolveState m - ) => - Pattern ParseDep ann -> - m (Pattern ResolvedDep ann) - resolvePatternInner (PVar ann ident) = do - (unique, innerIdent, newIdent) <- newIdentifier ident - tell (M.singleton innerIdent unique) - pure (PVar ann newIdent) - resolvePatternInner (PWildcard ann) = pure (PWildcard ann) - resolvePatternInner (PTuple ann a as) = - PTuple ann <$> resolvePatternInner a <*> traverse resolvePatternInner as - resolvePatternInner (PArray ann as spread) = - PArray ann - <$> traverse resolvePatternInner as - <*> case spread of - NoSpread -> pure NoSpread - SpreadWildcard ann' -> pure (SpreadWildcard ann') - SpreadValue ann' v -> SpreadValue ann' <$> resolveIdentifier v - resolvePatternInner (PLiteral ann l) = - pure $ PLiteral ann l - resolvePatternInner (PConstructor ann constructor args) = - PConstructor ann - <$> resolveConstructor constructor - <*> traverse resolvePatternInner args diff --git a/smol-core/src/Smol/Core/Modules/RunTests.hs b/smol-core/src/Smol/Core/Modules/RunTests.hs deleted file mode 100644 index 46b1a463..00000000 --- a/smol-core/src/Smol/Core/Modules/RunTests.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Smol.Core.Modules.RunTests (runTests) where - -import Smol.Core -import Smol.Core.Modules.Interpret -import Smol.Core.Modules.Types - --- just unit tests for now, ignore possibility of failure -runTests :: (Show ann, Eq ann) => Module ResolvedDep ann -> [(TestName, Bool)] -runTests wholeModule@(Module {moTests}) = - fmap runTest moTests - where - runTest (UnitTest testName _) = - case interpretModule (DITest testName) wholeModule of - Right (EPrim _ (PBool b)) -> (testName, b) - other -> error $ "Expected a boolean result, got " <> show other diff --git a/smol-core/src/Smol/Core/Modules/Typecheck.hs b/smol-core/src/Smol/Core/Modules/Typecheck.hs deleted file mode 100644 index 2a9ab9b1..00000000 --- a/smol-core/src/Smol/Core/Modules/Typecheck.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Modules.Typecheck (typecheckModule) where - -import qualified Builder as Build -import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Foldable (traverse_) -import Data.Functor (($>)) -import Data.List (nub) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) -import Data.Text (Text) -import Smol.Core -import Smol.Core.Helpers -import Smol.Core.Modules.Dependencies -import Smol.Core.Modules.Helpers (filterNameDefs, filterTypeDefs) -import Smol.Core.Modules.Types -import Smol.Core.Modules.Types.DepType -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Typecheck.Typecheck (typecheck) -import Smol.Core.Typecheck.Typeclass (addTypesToConstraint, checkInstance, lookupTypeclass) - --- go through the module, and wrap all the items in DefIdentifier keys and --- DepType for items -getModuleDefIdentifiers :: - (Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => - Map (DefIdentifier dep) (Set (DefIdentifier dep)) -> - Module dep ann -> - Map (DefIdentifier dep) (DefIdentifier dep, DepType dep ann, Set (DefIdentifier dep)) -getModuleDefIdentifiers depMap inputModule = - let getDeps di = fromMaybe mempty (M.lookup di depMap) - exprs = - M.fromList $ - ( \(name, expr) -> - let defId = DIName name - in (defId, (defId, DTExpr expr, getDeps defId)) - ) - <$> M.toList (moExpressions inputModule) - dataTypes = - M.fromList $ - ( \dt -> - let defId = DIType (dtName dt) - in (defId, (defId, DTData dt, getDeps defId)) - ) - <$> M.elems (moDataTypes inputModule) - instances = - M.fromList $ - ( \(constraint, inst) -> - let defId = DIInstance constraint - in (defId, (defId, DTInstance inst, getDeps defId)) - ) - <$> M.toList (moInstances inputModule) - tests = - M.fromList $ - ( \(UnitTest testName expr) -> - let defId = DITest testName - in (defId, (defId, DTTest expr, getDeps defId)) - ) - <$> moTests inputModule - in exprs <> dataTypes <> instances <> tests - -moduleFromDepTypes :: - Module ResolvedDep ann -> - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep ann)) -> - Module ResolvedDep (Type ResolvedDep ann) -moduleFromDepTypes oldModule definitions = - let firstMaybe f (a, b) = case f a of - Just fa -> Just (fa, b) - Nothing -> Nothing - - mapKeyMaybe f = - M.fromList . mapMaybe (firstMaybe f) . M.toList - - getTypeName (DIType tn) = Just tn - getTypeName _ = Nothing - - typedExpressions = - M.fromList $ - mapMaybe - ( \case - (DIName name, expr) -> Just (name, expr) - _ -> Nothing - ) - (M.toList $ filterExprs definitions) - - typedInstances = - M.fromList $ - mapMaybe - ( \case - (DIInstance constraint, DTInstance inst) -> Just (constraint, inst) - _ -> Nothing - ) - (M.toList definitions) - - typedClasses = - (\tc -> tc $> tcFuncType tc) - <$> moClasses oldModule - - typedTests = - mapMaybe - ( \case - (DITest testName, DTTest expr) -> Just (UnitTest testName expr) - _ -> Nothing - ) - (M.toList definitions) - in -- replace input module with typechecked versions - - oldModule - { moExpressions = typedExpressions, - moDataTypes = mapKeyMaybe getTypeName (filterDataTypes definitions), - moInstances = typedInstances, - moClasses = typedClasses, - moTests = typedTests - } - ---- typecheck a single module -typecheckModule :: - (MonadError (ModuleError Annotation) m) => - Text -> - Module ResolvedDep Annotation -> - Map (DefIdentifier ResolvedDep) (Set (DefIdentifier ResolvedDep)) -> - m (Module ResolvedDep (Type ResolvedDep Annotation)) -typecheckModule input inputModule depMap = do - let inputWithDepsAndName = getModuleDefIdentifiers depMap inputModule - - let stInputs = - ( \(name, expr, deps) -> - Build.Plan - { Build.jbDeps = deps, - Build.jbInput = (name, expr) - } - ) - <$> inputWithDepsAndName - - let state = - Build.State - { Build.stInputs = stInputs, - Build.stOutputs = mempty - } - - -- go! - typecheckedDefs <- - Build.stOutputs - <$> Build.doJobs (typecheckDef input inputModule) state - - -- replace input module with typechecked versions - let newModule = moduleFromDepTypes inputModule typecheckedDefs - - -- check tests are the right types - traverse_ (ensureTestsAreBooleans typecheckedDefs) (moTests newModule) - - pure newModule - --- our "typecheck" is "get the expression, typecheck it against `Boolean`" -ensureTestsAreBooleans :: - (MonadError (ModuleError Annotation) m) => - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep Annotation)) -> - Test ResolvedDep (Type ResolvedDep Annotation) -> - m () -ensureTestsAreBooleans _defs (UnitTest testName expr) = do - let ty = getExprAnnotation expr - case ty of - TPrim _ TPBool -> pure () - TLiteral _ (TLBool _) -> pure () - other -> - throwError - ( ErrorInTest - testName - ( TestDoesNotTypecheck - mempty - (TCTypeMismatch other (TPrim (getTypeAnnotation other) TPBool)) - ) - ) - --- given types for other required definition, typecheck a definition -typecheckDef :: - (MonadError (ModuleError Annotation) m) => - Text -> - Module ResolvedDep Annotation -> - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep Annotation)) -> - (DefIdentifier ResolvedDep, DepType ResolvedDep Annotation) -> - m (DepType ResolvedDep (Type ResolvedDep Annotation)) -typecheckDef input inputModule deps (def, dep) = - case dep of - DTExpr expr -> - DTExpr - <$> typecheckExprDef - input - inputModule - deps - (def, expr) - DTInstance inst -> - DTInstance <$> typecheckInstance input inputModule deps def inst - DTTest expr -> - DTTest . tleExpr <$> typecheckExprDef input inputModule deps (def, TopLevelExpression {tleConstraints = mempty, tleExpr = expr, tleType = Nothing}) - DTData dt -> - DTData - <$> typecheckTypeDef - input - inputModule - (filterDataTypes deps) - (def, dt) - -typecheckInstance :: - (MonadError (ModuleError Annotation) m) => - Text -> - Module ResolvedDep Annotation -> - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep Annotation)) -> - DefIdentifier ResolvedDep -> - Instance ResolvedDep Annotation -> - m (Instance ResolvedDep (Type ResolvedDep Annotation)) -typecheckInstance input inputModule deps def inst = do - -- where are we getting constraints from? - let exprTypeMap = - mapKey LocalDefinition $ - (\depTLE -> ((fmap . fmap) getTypeAnnotation (tleConstraints depTLE), getExprAnnotation (tleExpr depTLE))) - <$> filterNameDefs (filterExprs deps) - - let constraint = case def of - DIInstance c -> c - _ -> error "def is not constraint, yikes" - - let instances :: Map (Constraint ResolvedDep Annotation) (Instance ResolvedDep Annotation) - instances = mapKey (fmap (const mempty)) (moInstances inputModule) - - classes = moClasses inputModule - - -- initial typechecking environment - let env = - TCEnv - { tceVars = exprTypeMap, - tceDataTypes = getDataTypeMap deps, - tceClasses = classes, - tceInstances = instances, - tceConstraints = inConstraints inst - } - - typeclass <- - modifyError - (DefDoesNotTypeCheck input def) - (lookupTypeclass classes (conTypeclass constraint)) - - let typedConstraint = addTypesToConstraint (constraint $> mempty) - - modifyError (DefDoesNotTypeCheck input def) (checkInstance env typeclass typedConstraint inst) - --- typechecking in this context means "does this data type make sense" --- and "do we know about all external datatypes it mentions" -typecheckTypeDef :: - (MonadError (ModuleError Annotation) m) => - Text -> - Module ResolvedDep Annotation -> - Map (DefIdentifier ResolvedDep) (DataType ResolvedDep (Type ResolvedDep Annotation)) -> - (DefIdentifier ResolvedDep, DataType ResolvedDep Annotation) -> - m (DataType ResolvedDep (Type ResolvedDep Annotation)) -typecheckTypeDef _input _inputModule _typeDeps (_def, dt) = do - -- just put a bullshit type in for now - pure $ (`TPrim` TPBool) <$> dt - -{- --- ideally we'd attach annotations to the DefIdentifiers or something, so we --- can show the original code in errors -let ann = mempty - -let action = do - --validateConstructorsArentBuiltIns ann dt - validateDataTypeVariables ann dt - --- typecheck it -liftEither $ - first - ( DefDoesNotTypeCheck input def) - action - -pure dt --} - -getDataTypeMap :: - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep Annotation)) -> - Map (ResolvedDep TypeName) (DataType ResolvedDep Annotation) -getDataTypeMap = - (fmap . fmap) getTypeAnnotation - . mapKey LocalDefinition - . filterTypeDefs - . filterDataTypes - -resolveConstraint :: Constraint ResolvedDep ann -> Constraint ResolvedDep (Type ResolvedDep ann) -resolveConstraint (Constraint tcn tys) = - Constraint tcn (resolveTy <$> tys) - where - resolveTy ty = ty $> ty - --- given types for other required definition, typecheck a definition -typecheckExprDef :: - (MonadError (ModuleError Annotation) m) => - Text -> - Module ResolvedDep Annotation -> - Map (DefIdentifier ResolvedDep) (DepType ResolvedDep (Type ResolvedDep Annotation)) -> - (DefIdentifier ResolvedDep, TopLevelExpression ResolvedDep Annotation) -> - m (TopLevelExpression ResolvedDep (Type ResolvedDep Annotation)) -typecheckExprDef input inputModule deps (def, tle) = do - -- where are we getting constraints from? - let exprTypeMap = - mapKey LocalDefinition $ - (\depTLE -> ((fmap . fmap) getTypeAnnotation (tleConstraints depTLE), getExprAnnotation (tleExpr depTLE))) - <$> filterNameDefs (filterExprs deps) - - let instances :: Map (Constraint ResolvedDep Annotation) (Instance ResolvedDep Annotation) - instances = mapKey (fmap (const mempty)) (moInstances inputModule) - - classes = moClasses inputModule - - -- initial typechecking environment - let env = - TCEnv - { tceVars = exprTypeMap, - tceDataTypes = getDataTypeMap deps, - tceClasses = classes, - tceInstances = instances, - tceConstraints = tleConstraints tle - } - - -- if we have a type, add an annotation - let actualExpr = case tleType tle of - Nothing -> tleExpr tle - Just ty -> EAnn (getTypeAnnotation ty) ty (tleExpr tle) - - -- typecheck it - (constraints, newExpr) <- - liftEither $ - first - (DefDoesNotTypeCheck input def) - (typecheck env actualExpr) - - -- split the type out again - let (typedType, typedExpr) = case newExpr of - (EAnn _ ty expr) -> (Just ty, expr) - other -> (Nothing, other) - - -- add supplied constraints to any we discovered in typechecking - let allConstraints = nub (fmap resolveConstraint $ constraints <> tleConstraints tle) - - let typedTle = - TopLevelExpression - { tleConstraints = allConstraints, - tleExpr = typedExpr, - tleType = typedType - } - - pure typedTle diff --git a/smol-core/src/Smol/Core/Modules/Types.hs b/smol-core/src/Smol/Core/Modules/Types.hs deleted file mode 100644 index 99a6befc..00000000 --- a/smol-core/src/Smol/Core/Modules/Types.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Smol.Core.Modules.Types - ( module Smol.Core.Modules.Types.Entity, - module Smol.Core.Modules.Types.Module, - module Smol.Core.Modules.Types.ModuleName, - module Smol.Core.Modules.Types.ModuleItem, - module Smol.Core.Modules.Types.TestName, - module Smol.Core.Modules.Types.DefIdentifier, - module Smol.Core.Modules.Types.Test, - module Smol.Core.Modules.Types.TopLevelExpression, - ) -where - -import Smol.Core.Modules.Types.DefIdentifier -import Smol.Core.Modules.Types.Entity -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleItem -import Smol.Core.Modules.Types.ModuleName -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TestName -import Smol.Core.Modules.Types.TopLevelExpression diff --git a/smol-core/src/Smol/Core/Modules/Types/DefIdentifier.hs b/smol-core/src/Smol/Core/Modules/Types/DefIdentifier.hs deleted file mode 100644 index 62c76bca..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/DefIdentifier.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Modules.Types.DefIdentifier - ( DefIdentifier (..), - ) -where - -import GHC.Generics (Generic) -import Smol.Core.Modules.Types.TestName -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types.Constructor -import Smol.Core.Types.Identifier -import Smol.Core.Types.TypeName - --- | different kinds of top-level definitions -data DefIdentifier dep - = DIName Identifier - | DIType TypeName - | DITest TestName - | DIInstance (Constraint dep ()) - deriving stock (Generic) - -deriving stock instance - (Eq (dep Constructor), Eq (dep TypeName), Eq (dep Identifier)) => - Eq (DefIdentifier dep) - -deriving stock instance - (Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => - Ord (DefIdentifier dep) - -deriving stock instance - (Show (dep Constructor), Show (dep TypeName), Show (dep Identifier)) => - Show (DefIdentifier dep) - -instance (Printer (dep Identifier), Printer (dep TypeName)) => Printer (DefIdentifier dep) where - prettyDoc (DIName name) = prettyDoc name - -- prettyDoc (DIInfix infixOp) = prettyDoc infixOp - prettyDoc (DIType typeName) = prettyDoc typeName - prettyDoc (DITest testName) = "\"" <> prettyDoc testName <> "\"" - prettyDoc (DIInstance constraint) = - prettyDoc constraint diff --git a/smol-core/src/Smol/Core/Modules/Types/DepType.hs b/smol-core/src/Smol/Core/Modules/Types/DepType.hs deleted file mode 100644 index 8c3117b0..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/DepType.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Modules.Types.DepType - ( DepType (..), - ) -where - -import Smol.Core -import Smol.Core.Modules.Types.TopLevelExpression - -data DepType dep ann - = DTExpr (TopLevelExpression dep ann) - | DTInstance (Instance dep ann) - | DTData (DataType dep ann) - | DTTest (Expr dep ann) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep Constructor), - Eq (dep TypeName) - ) => - Eq (DepType dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep Constructor), - Show (dep TypeName) - ) => - Show (DepType dep ann) diff --git a/smol-core/src/Smol/Core/Modules/Types/Entity.hs b/smol-core/src/Smol/Core/Modules/Types/Entity.hs deleted file mode 100644 index e6ee7127..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/Entity.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Modules.Types.Entity where - --- a thing --- terrible, pls improve -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import Smol.Core.Modules.Types.ModuleName -import Smol.Core.Printer -import Smol.Core.Types.Constructor -import Smol.Core.Types.Identifier -import Smol.Core.Types.TypeName - -data Entity - = -- | a variable, `dog` - EVar Identifier - | {- | -- | an infix operator, `<|>` - EInfix InfixOp - -} - - -- | a namespaced var, `Prelude.id` - ENamespacedVar ModuleName Identifier - | -- | a typename, `Maybe` - EType TypeName - | -- | a namespaced typename, `Prelude.Either` - ENamespacedType ModuleName TypeName - | -- | a constructor, `Just` - EConstructor Constructor - | -- \| a namespaced constructor, `Maybe.Just` - ENamespacedConstructor ModuleName Constructor - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass - ( ToJSON, - ToJSONKey, - FromJSON, - FromJSONKey - ) - -instance Printer Entity where - prettyDoc (EVar name) = prettyDoc name - prettyDoc (ENamespacedVar modName name) = - prettyDoc modName <> "." <> prettyDoc name - prettyDoc (EType typeName) = prettyDoc typeName - prettyDoc (ENamespacedType modName typeName) = - prettyDoc modName <> "." <> prettyDoc typeName - prettyDoc (EConstructor tyCon) = - prettyDoc tyCon - prettyDoc (ENamespacedConstructor modName tyCon) = - prettyDoc modName <> "." <> prettyDoc tyCon diff --git a/smol-core/src/Smol/Core/Modules/Types/Module.hs b/smol-core/src/Smol/Core/Modules/Types/Module.hs deleted file mode 100644 index 85e2ce4a..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/Module.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Modules.Types.Module - ( Module (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics (Generic) -import Prettyprinter -import Smol.Core.Modules.Types.Test -import Smol.Core.Modules.Types.TopLevelExpression -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types.Constructor -import Smol.Core.Types.DataType -import Smol.Core.Types.Identifier -import Smol.Core.Types.ParseDep -import Smol.Core.Types.TypeName - --- a module is, broadly, one file --- it defines some datatypes, infixes and definitions --- and it probably exports one or more of those - --- this is the checked module, it contains no duplicates and we don't care --- about ordering --- should we care about ordering? it would allow us to pretty print? -data Module dep ann = Module - { moExpressions :: Map Identifier (TopLevelExpression dep ann), - moDataTypes :: Map TypeName (DataType dep ann), - moTests :: [Test dep ann], - moInstances :: Map (Constraint dep ()) (Instance dep ann), - moClasses :: Map TypeclassName (Typeclass dep ann) - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep TypeName), - Eq (dep Identifier), - Eq (dep Constructor) - ) => - Eq (Module dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep TypeName), - Ord (dep Constructor), - Ord (dep Identifier) - ) => - Ord (Module dep ann) - -deriving stock instance - ( Show ann, - Show (dep TypeName), - Show (dep Constructor), - Show (dep Identifier) - ) => - Show (Module dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep TypeName), - ToJSON (dep Constructor), - ToJSON (dep Identifier) - ) => - ToJSON (Module dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - Ord (dep Constructor), - Ord (dep TypeName), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep TypeName), - FromJSON (dep Constructor), - FromJSON (dep Identifier) - ) => - FromJSON (Module dep ann) - -instance Printer (Module ParseDep ann) where - prettyDoc mod' = - let printedDefs = - uncurry printDefinition - <$> M.toList (moExpressions mod') - printedTypes = - uncurry printTypeDef - <$> M.toList (moDataTypes mod') - in withDoubleLines - ( printedTypes - <> printedDefs - ) - -withDoubleLines :: [Doc a] -> Doc a -withDoubleLines = vsep . fmap (line <>) - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Int -> Doc style -> Doc style -indentMulti i doc = flatAlt (indent i doc) doc - -printTypeDef :: TypeName -> DataType ParseDep ann -> Doc style -printTypeDef _tn = - prettyDoc - -printDefinition :: Identifier -> TopLevelExpression ParseDep ann -> Doc a -printDefinition name (TopLevelExpression {tleType, tleExpr}) = - let prettyExpr = - "def" - <+> prettyDoc name - <+> "=" - <> line - <> indentMulti 2 (prettyDoc tleExpr) - prettyType = case tleType of - Just ty -> - "def" - <+> prettyDoc name - <+> ":" - <> line - <> indentMulti 2 (prettyDoc ty) - <> "\n" - Nothing -> "" - in prettyType <> prettyExpr - -instance (Ord (dep Constructor), Ord (dep TypeName), Ord (dep Identifier)) => Semigroup (Module dep ann) where - (Module a b c d e) <> (Module a' b' c' d' e') = - Module (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') - -instance (Ord (dep Constructor), Ord (dep Identifier), Ord (dep TypeName)) => Monoid (Module dep ann) where - mempty = - Module - mempty - mempty - mempty - mempty - mempty diff --git a/smol-core/src/Smol/Core/Modules/Types/ModuleError.hs b/smol-core/src/Smol/Core/Modules/Types/ModuleError.hs deleted file mode 100644 index c7411b29..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/ModuleError.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Modules.Types.ModuleError - ( ModuleError (..), - moduleErrorDiagnostic, - ResolveDepsError (..), - TestError (..), - ) -where - -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Error.Diagnose as Diag -import Smol.Core.Interpreter.Types.InterpreterError -import Smol.Core.Modules.Types.DefIdentifier -import Smol.Core.Modules.Types.ModuleName -import Smol.Core.Modules.Types.TestName -import Smol.Core.Typecheck -import Smol.Core.Types - -data TestError ann - = TestDoesNotTypecheck Text (TCError ann) - deriving stock (Eq, Ord, Show) - -testErrorDiagnostic :: TestError Annotation -> Diag.Diagnostic Text -testErrorDiagnostic (TestDoesNotTypecheck input typeErr) = - typeErrorDiagnostic input typeErr - -data ResolveDepsError - = VarNotFound Identifier - | CannotFindTypes (Set TypeName) - deriving stock (Eq, Ord, Show) - -resolveDepsErrorDiagnostic :: ResolveDepsError -> Diag.Diagnostic Text -resolveDepsErrorDiagnostic (VarNotFound ident) = - let report = - Diag.Err - Nothing - (T.pack $ "Variable not found: " <> show ident) - [] - [] - in Diag.addReport Diag.def report -resolveDepsErrorDiagnostic (CannotFindTypes tys) = - let report = - Diag.Err - Nothing - (T.pack $ "Types not found: " <> show tys) - [] - [] - in Diag.addReport Diag.def report - -data ModuleError ann - = DuplicateDefinition Identifier - | DuplicateTypeName TypeName - | DuplicateConstructor Constructor - | DuplicateTypeclass TypeclassName - | MissingTypeclass TypeclassName - | CannotFindValues (Set Identifier) - | CannotFindConstructors (Set Constructor) - | ErrorInResolveDeps ResolveDepsError - | DefDoesNotTypeCheck Text (DefIdentifier ResolvedDep) (TCError ann) - | DictionaryPassingError Text (TCError ann) - | NamedImportNotFound (Set ModuleName) ModuleName - | EmptyTestName (Expr ParseDep ann) - | ErrorInTest TestName (TestError ann) - | ErrorInInterpreter (InterpreterError ann) - deriving stock (Eq, Ord, Show) - -moduleErrorDiagnostic :: ModuleError Annotation -> Diag.Diagnostic Text -moduleErrorDiagnostic (DefDoesNotTypeCheck input _ typeErr) = - typeErrorDiagnostic input typeErr -moduleErrorDiagnostic (DictionaryPassingError input typeErr) = - typeErrorDiagnostic input typeErr -moduleErrorDiagnostic (ErrorInTest _ testErr) = - testErrorDiagnostic testErr -moduleErrorDiagnostic (ErrorInResolveDeps resolveErr) = - resolveDepsErrorDiagnostic resolveErr -moduleErrorDiagnostic other = - let report = - Diag.Err - Nothing - (T.pack (show other)) - [] - [] - in Diag.addReport Diag.def report diff --git a/smol-core/src/Smol/Core/Modules/Types/ModuleItem.hs b/smol-core/src/Smol/Core/Modules/Types/ModuleItem.hs deleted file mode 100644 index 65e22569..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/ModuleItem.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Modules.Types.ModuleItem - ( ModuleItem (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Generics (Generic) -import Prettyprinter -import Smol.Core.Modules.Types.TestName -import Smol.Core.Modules.Types.TopLevelExpression -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types.Constructor -import Smol.Core.Types.DataType -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.ParseDep -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - --- a module is, broadly, one file --- it defines some datatypes, infixes and definitions --- and it probably exports one or more of those - --- item parsed from file, kept like this so we can order them and have --- duplicates --- we will remove duplicates when we work out dependencies between everything --- TODO: add more annotations to everything so we can produce clearer errors --- when things don't make sense (duplicate defs etc) -data ModuleItem ann - = ModuleExpression Identifier [Identifier] (Expr ParseDep ann) - | ModuleExpressionType Identifier [Constraint ParseDep ann] (Type ParseDep ann) - | ModuleDataType (DataType ParseDep ann) - | ModuleTest TestName (Expr ParseDep ann) - | ModuleInstance [Constraint ParseDep ann] (Constraint ParseDep ann) (Expr ParseDep ann) - | ModuleClass (Typeclass ParseDep ann) - deriving stock (Eq, Ord, Functor) - -deriving stock instance - ( Show ann, - Show (DataType ParseDep ann) - ) => - Show (ModuleItem ann) - --- this is the checked module, it contains no duplicates and we don't care --- about ordering --- should we care about ordering? it would allow us to pretty print? -data Module dep ann = Module - { moExpressions :: Map Identifier (TopLevelExpression dep ann), - moDataTypes :: Map TypeName (DataType dep ann) - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep TypeName), - Eq (dep Identifier), - Eq (dep Constructor) - ) => - Eq (Module dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep TypeName), - Ord (dep Constructor), - Ord (dep Identifier) - ) => - Ord (Module dep ann) - -deriving stock instance - ( Show ann, - Show (dep TypeName), - Show (dep Constructor), - Show (dep Identifier) - ) => - Show (Module dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep TypeName), - ToJSON (dep Constructor), - ToJSON (dep Identifier) - ) => - ToJSON (Module dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep TypeName), - FromJSON (dep Constructor), - FromJSON (dep Identifier) - ) => - FromJSON (Module dep ann) - -instance Printer (Module ParseDep ann) where - prettyDoc mod' = - let printedDefs = - uncurry printDefinition - <$> M.toList (moExpressions mod') - printedTypes = - uncurry printTypeDef - <$> M.toList (moDataTypes mod') - in withDoubleLines - ( printedTypes - <> printedDefs - ) - -withDoubleLines :: [Doc a] -> Doc a -withDoubleLines = vsep . fmap (line <>) - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Int -> Doc style -> Doc style -indentMulti i doc = flatAlt (indent i doc) doc - -printTypeDef :: TypeName -> DataType ParseDep ann -> Doc style -printTypeDef _tn = - prettyDoc - -printDefinition :: Identifier -> TopLevelExpression ParseDep ann -> Doc a -printDefinition name (TopLevelExpression {tleType, tleExpr}) = - let prettyExpr = - "def" - <+> prettyDoc name - <+> "=" - <> line - <> indentMulti 2 (prettyDoc tleExpr) - prettyType = case tleType of - Just ty -> - "def" - <+> prettyDoc name - <+> ":" - <> line - <> indentMulti 2 (prettyDoc ty) - <> "\n" - Nothing -> "" - in prettyType <> prettyExpr - -instance Semigroup (Module dep ann) where - (Module a b) <> (Module a' b') = - Module (a <> a') (b <> b') - -instance Monoid (Module dep ann) where - mempty = - Module - mempty - mempty diff --git a/smol-core/src/Smol/Core/Modules/Types/ModuleName.hs b/smol-core/src/Smol/Core/Modules/Types/ModuleName.hs deleted file mode 100644 index 1cf3cc9b..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/ModuleName.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Modules.Types.ModuleName - ( ModuleName (..), - getModuleName, - validModuleName, - safeMkModuleName, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Prettyprinter -import Smol.Core.Printer - --- | A ModuleName is like `Either` or `Maybe`. --- It must start with a capital letter. -newtype ModuleName = ModuleName Text - deriving stock (Eq, Ord, Generic) - deriving newtype - ( Show, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance JSON.FromJSON ModuleName where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkModuleName txt of - Just tyCon' -> pure tyCon' - _ -> fail "Text is not a valid ModuleName" - -instance IsString ModuleName where - fromString = mkModuleName . T.pack - -getModuleName :: ModuleName -> Text -getModuleName (ModuleName t) = t - -validModuleName :: Text -> Bool -validModuleName a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkModuleName :: Text -> ModuleName -mkModuleName a = - if validModuleName a - then ModuleName a - else error $ T.unpack $ "ModuleName validation fail for '" <> a <> "'" - -safeMkModuleName :: Text -> Maybe ModuleName -safeMkModuleName a = - if validModuleName a - then Just (ModuleName a) - else Nothing - -instance Printer ModuleName where - prettyDoc = pretty . getModuleName diff --git a/smol-core/src/Smol/Core/Modules/Types/Test.hs b/smol-core/src/Smol/Core/Modules/Types/Test.hs deleted file mode 100644 index 3860f1e9..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/Test.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Modules.Types.Test where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import Smol.Core.Modules.Types.TestName -import Smol.Core.Types.Constructor -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.TypeName - -data Test dep ann - = UnitTest TestName (Expr dep ann) - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep TypeName), - Eq (dep Identifier), - Eq (dep Constructor) - ) => - Eq (Test dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep TypeName), - Ord (dep Constructor), - Ord (dep Identifier) - ) => - Ord (Test dep ann) - -deriving stock instance - ( Show ann, - Show (dep TypeName), - Show (dep Constructor), - Show (dep Identifier) - ) => - Show (Test dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep TypeName), - ToJSON (dep Constructor), - ToJSON (dep Identifier) - ) => - ToJSON (Test dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - Ord (dep Constructor), - Ord (dep TypeName), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep TypeName), - FromJSON (dep Constructor), - FromJSON (dep Identifier) - ) => - FromJSON (Test dep ann) diff --git a/smol-core/src/Smol/Core/Modules/Types/TestName.hs b/smol-core/src/Smol/Core/Modules/Types/TestName.hs deleted file mode 100644 index d14bf4fa..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/TestName.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Smol.Core.Modules.Types.TestName - ( TestName (..), - ) -where - -import Data.Aeson (FromJSON, ToJSON) -import Data.String -import Data.Text (Text) -import Smol.Core.Printer - -newtype TestName = TestName Text - deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) - -instance Printer TestName where - prettyDoc (TestName tn) = prettyDoc tn - -instance IsString TestName where - fromString = TestName . fromString diff --git a/smol-core/src/Smol/Core/Modules/Types/TopLevelExpression.hs b/smol-core/src/Smol/Core/Modules/Types/TopLevelExpression.hs deleted file mode 100644 index 348cb873..00000000 --- a/smol-core/src/Smol/Core/Modules/Types/TopLevelExpression.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Modules.Types.TopLevelExpression - ( TopLevelExpression (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import Smol.Core.Typecheck.Types -import Smol.Core.Types.Constructor -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - --- a module is, broadly, one file --- it defines some datatypes, infixes and definitions --- and it probably exports one or more of those - --- a single expression of zero or more exprs and an optional type -data TopLevelExpression dep ann = TopLevelExpression - { tleConstraints :: [Constraint dep ann], - tleExpr :: Expr dep ann, - tleType :: Maybe (Type dep ann) - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep Constructor), - Eq (dep TypeName) - ) => - Eq (TopLevelExpression dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep Constructor), - Ord (dep TypeName) - ) => - Ord (TopLevelExpression dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep Constructor), - Show (dep TypeName) - ) => - Show (TopLevelExpression dep ann) - -deriving anyclass instance - ( ToJSON ann, - ToJSONKey (dep Identifier), - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSON (TopLevelExpression dep ann) - -deriving anyclass instance - ( ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName), - ToJSONKey ann, - ToJSONKey (dep Identifier), - ToJSONKey (dep Constructor), - ToJSONKey (dep TypeName) - ) => - ToJSONKey (TopLevelExpression dep ann) - -deriving anyclass instance - ( FromJSONKey (dep Identifier), - Ord (dep Identifier), - FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep Constructor), - FromJSON (dep TypeName) - ) => - FromJSON (TopLevelExpression dep ann) diff --git a/smol-core/src/Smol/Core/Modules/Uses.hs b/smol-core/src/Smol/Core/Modules/Uses.hs deleted file mode 100644 index 3b02d930..00000000 --- a/smol-core/src/Smol/Core/Modules/Uses.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Modules.Uses - ( extractUses, - extractUsesTyped, - extractDataTypeUses, - extractTypeUses, - ) -where - -import Data.Foldable (toList) -import qualified Data.List.NonEmpty as NE -import Data.Set (Set) -import qualified Data.Set as S -import Smol.Core -import qualified Smol.Core.Modules.Types.Entity as E - -extractUses :: (Eq ann) => Expr ParseDep ann -> Set E.Entity -extractUses expr = - let typeNames = dataTypeNames expr - in S.filter - (\ent -> not $ S.member ent typeNames) - ( extractUses_ expr - ) - --- | extract uses in an expression annotated with types -extractUsesTyped :: (Eq ann) => Expr ParseDep (Type ParseDep ann) -> Set E.Entity -extractUsesTyped expr = - let typeNames = dataTypeNames expr - in S.filter - (\ent -> not $ S.member ent typeNames) - ( extractUses_ expr - <> foldMap extractTypeUses expr - ) - --- | find all uses of external vars, types, infix operators etc --- used in dependency analysis --- important - we must not count variables brought in via lambdas or let --- bindings as those aren't external deps -extractUses_ :: (Eq ann) => Expr ParseDep ann -> Set E.Entity -extractUses_ (EVar _ (ParseDep a (Just modName))) = - S.singleton (E.ENamespacedVar modName a) -extractUses_ (EVar _ (ParseDep a Nothing)) = - S.singleton (E.EVar a) -extractUses_ (EAnn _ mt expr) = - extractUses_ expr <> extractTypeUses mt -extractUses_ (EArray _ as) = mconcat $ extractUses_ <$> toList as -extractUses_ (EIf _ a b c) = - extractUses_ a <> extractUses_ b <> extractUses_ c -extractUses_ (ELet _ ident a b) = - S.difference - (extractUses_ a <> extractUses_ b) - (extractIdentUses ident) -extractUses_ (EInfix _ _ a b) = - extractUses_ a - <> extractUses_ b -extractUses_ (ELambda _ ident a) = - S.difference (extractUses_ a) (extractIdentUses ident) -extractUses_ (EApp _ a b) = extractUses_ a <> extractUses_ b -extractUses_ (EPrim _ _) = mempty -extractUses_ (ETuple _ a as) = extractUses_ a <> foldMap extractUses_ as -extractUses_ (ERecord _ map') = foldMap extractUses_ map' -extractUses_ (ERecordAccess _ a _) = extractUses_ a -extractUses_ (EConstructor _ (ParseDep tyCon (Just modName))) = - S.singleton (E.ENamespacedConstructor modName tyCon) -extractUses_ (EConstructor _ (ParseDep tyCon Nothing)) = - S.singleton (E.EConstructor tyCon) -extractUses_ (EPatternMatch _ match patterns) = - extractUses match <> mconcat patternUses - where - patternUses :: [Set E.Entity] - patternUses = - ( \(pat, expr) -> - filterVarsIntroducedInPatterns - (extractPatternUses pat) - (extractUses expr) - ) - <$> NE.toList patterns - --- for vars, remove any vars introduced in patterns in the expressions --- for everything else, keep both -filterVarsIntroducedInPatterns :: Set E.Entity -> Set E.Entity -> Set E.Entity -filterVarsIntroducedInPatterns patUses exprUses = - let patVarUses = - S.filter - ( \case - E.EVar _ -> True - _ -> False - ) - patUses - in S.filter (`S.notMember` patVarUses) (patUses <> exprUses) - -extractIdentUses :: ParseDep Identifier -> Set E.Entity -extractIdentUses (ParseDep name _) = S.singleton (E.EVar name) - -extractPatternUses :: (Eq ann) => Pattern ParseDep ann -> Set E.Entity -extractPatternUses (PWildcard _) = mempty -extractPatternUses (PLiteral _ _) = mempty -extractPatternUses (PVar _ (ParseDep a _)) = S.singleton (E.EVar a) -extractPatternUses (PTuple _ a as) = - extractPatternUses a <> foldMap extractPatternUses as -extractPatternUses (PArray _ as spread) = - foldMap extractPatternUses as <> case spread of - NoSpread -> mempty - SpreadWildcard {} -> mempty - SpreadValue _ (ParseDep a _) -> S.singleton (E.EVar a) -extractPatternUses (PConstructor _ (ParseDep tyCon maybeMod) args) = - let modEntity = case maybeMod of - Just modName -> S.singleton (E.ENamespacedConstructor modName tyCon) - _ -> S.singleton (E.EConstructor tyCon) - in modEntity <> mconcat (extractPatternUses <$> args) - --- extract uses in a type -extractTypeUses :: Type ParseDep ann -> Set E.Entity -extractTypeUses (TConstructor _ (ParseDep typeName (Just modName))) = - S.singleton (E.ENamespacedType modName typeName) -extractTypeUses (TConstructor _ (ParseDep typeName Nothing)) = - S.singleton (E.EType typeName) -extractTypeUses other = monoidType extractTypeUses other - --- | find other types used in the declaration of a datatype -extractDataTypeUses :: DataType ParseDep ann -> Set E.Entity -extractDataTypeUses (DataType typeName _ constructors) = - S.filter - (\entity -> entity /= E.EType typeName) - ( foldMap (foldMap extractTypeUses) constructors - ) - -dataTypeNames :: Expr ParseDep ann -> Set E.Entity -dataTypeNames (ELet _ _ expr body) = dataTypeNames expr <> dataTypeNames body -dataTypeNames _ = mempty diff --git a/smol-core/src/Smol/Core/Parser.hs b/smol-core/src/Smol/Core/Parser.hs deleted file mode 100644 index 23b1f17f..00000000 --- a/smol-core/src/Smol/Core/Parser.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser - ( parseAndFormat, - parseExpr, - parseExprAndFormatError, - parseTypeAndFormatError, - parseType, - parseModule, - parseConstraint, - parseModuleAndFormatError, - parseDataTypeAndFormatError, - parseConstraintAndFormatError, - ParseErrorType, - ) -where - -import Data.Bifunctor (first) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import Smol.Core.Modules.Types -import Smol.Core.Parser.DataType (dataTypeParser) -import Smol.Core.Parser.Expr -import Smol.Core.Parser.Module -import Smol.Core.Parser.Type -import Smol.Core.Parser.Typeclass -import Smol.Core.Typecheck.Types -import Smol.Core.Types -import Text.Megaparsec -import Text.Megaparsec.Char - -type Parser = Parsec Void Text - -type ParseErrorType = ParseErrorBundle Text Void - -type ParserExpr = Expr ParseDep Annotation - -parseAndFormat :: Parser a -> Text -> Either Text a -parseAndFormat p = first (T.pack . errorBundlePretty) . parse (p <* eof) "repl" - --- parse expr, using it all up -parseExpr :: Text -> Either ParseErrorType ParserExpr -parseExpr = parse (space *> expressionParser <* eof) "repl" - -parseExprAndFormatError :: Text -> Either Text ParserExpr -parseExprAndFormatError = parseAndFormat (space *> expressionParser <* eof) - -parseModule :: Text -> Either ParseErrorType [ModuleItem Annotation] -parseModule = parse (space *> moduleParser <* eof) "repl" - -parseConstraint :: Text -> Either ParseErrorType (Constraint ParseDep Annotation) -parseConstraint = parse (space *> constraintParser <* eof) "repl" - -parseModuleAndFormatError :: Text -> Either Text [ModuleItem Annotation] -parseModuleAndFormatError = parseAndFormat (space *> moduleParser <* eof) - -parseDataTypeAndFormatError :: Text -> Either Text (DataType ParseDep Annotation) -parseDataTypeAndFormatError = parseAndFormat (space *> dataTypeParser <* eof) - -parseConstraintAndFormatError :: Text -> Either Text (Constraint ParseDep Annotation) -parseConstraintAndFormatError = parseAndFormat (space *> constraintParser <* eof) diff --git a/smol-core/src/Smol/Core/Parser/DataType.hs b/smol-core/src/Smol/Core/Parser/DataType.hs deleted file mode 100644 index 9cfe9753..00000000 --- a/smol-core/src/Smol/Core/Parser/DataType.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.DataType (dataTypeParser) where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import Data.Void (Void) -import Smol.Core.Parser.Identifiers -import Smol.Core.Parser.Shared -import Smol.Core.Parser.Type -import Smol.Core.Types -import Text.Megaparsec - -type Parser = Parsec Void Text - -dataTypeParser :: Parser (DataType ParseDep Annotation) -dataTypeParser = - try typeDeclParserWithCons - <|> typeDeclParserEmpty - --- it's your "type Void in ..." -typeDeclParserEmpty :: Parser (DataType ParseDep Annotation) -typeDeclParserEmpty = do - myString "type" - tyName <- plainTypeNameParser - pure (DataType tyName mempty mempty) - --- it's your more complex cases -typeDeclParserWithCons :: Parser (DataType ParseDep Annotation) -typeDeclParserWithCons = do - myString "type" - tyName <- plainTypeNameParser - tyArgs <- many identifierParser - myString "=" - DataType tyName tyArgs <$> manyTypeConstructors - --------- - -manyTypeConstructors :: Parser (Map Constructor [ParsedType Annotation]) -manyTypeConstructors = do - tyCons <- - sepBy - oneTypeConstructor - (myString "|") - pure (mconcat tyCons) - ------ - -oneTypeConstructor :: Parser (Map Constructor [ParsedType Annotation]) -oneTypeConstructor = do - constructor <- myLexeme constructorParserInternal - args <- - some (try simpleTypeParser <|> inBrackets typeParser) - <|> pure mempty - pure (M.singleton constructor args) diff --git a/smol-core/src/Smol/Core/Parser/Expr.hs b/smol-core/src/Smol/Core/Parser/Expr.hs deleted file mode 100644 index 381e016d..00000000 --- a/smol-core/src/Smol/Core/Parser/Expr.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Expr (expressionParser) where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Sequence as Seq -import Data.Text (Text) -import Data.Void -import Smol.Core.Parser.Identifiers -import Smol.Core.Parser.Op -import Smol.Core.Parser.Pattern -import Smol.Core.Parser.Primitives -import Smol.Core.Parser.Shared -import Smol.Core.Parser.Type -import Smol.Core.Types -import Text.Megaparsec - -type Parser = Parsec Void Text - -type ParserExpr = Expr ParseDep Annotation - -expressionParser :: Parser ParserExpr -expressionParser = - label "expression" $ - let parsers = - infixParser - <|> try literalParser - <|> try complexParser - <|> annotationParser - <|> try varParser - <|> constructorParser - in orInBrackets parsers - -complexParser :: Parser ParserExpr -complexParser = - arrayParser - <|> try letParser - -- <|> letPatternParser - <|> try appParser - <|> ifParser - <|> try tupleParser - <|> try recordAccessParser - <|> recordParser - <|> lambdaParser - -- <|> typeParser - <|> patternMatchParser - --- <|> typedHoleParser --- <|> defineInfixParser - ----- - -lambdaParser :: Parser ParserExpr -lambdaParser = - label "lambda" $ - addLocation $ do - _ <- myString "\\" - ident <- emptyParseDep <$> identifierParser - _ <- myString "->" - ELambda mempty ident <$> expressionParser - ------ - -appFunc :: Parser ParserExpr -appFunc = - try recordAccessParser - <|> try varParser - <|> constructorParser - <|> try annotationParser - <|> try lambdaParser - -- <|> typedHoleParser - <|> inBrackets appParser - --- we don't want to include infix stuff here -argParser :: Parser ParserExpr -argParser = - let parsers = - literalParser - -- <|> arrayParser - <|> letParser - -- <|> letPatternParser - <|> ifParser - <|> tupleParser - <|> try recordAccessParser - <|> recordParser - <|> lambdaParser - -- <|> typeParser - -- <|> typedHoleParser - <|> try varParser - <|> constructorParser - in try (inBrackets infixParser) - <|> try (inBrackets appParser) - <|> try annotationParser - <|> orInBrackets parsers - -appParser :: Parser ParserExpr -appParser = label "app" $ - addLocation $ do - func <- orInBrackets appFunc - let argParser' :: Parser [ParserExpr] - argParser' = (: []) <$> argParser - args <- chainl1 argParser' (pure (<>)) - pure $ foldl (EApp mempty) func args - ------ - -ifParser :: Parser ParserExpr -ifParser = label "if" $ - addLocation $ do - _ <- myString "if" - predP <- expressionParser - _ <- myString "then" - thenP <- expressionParser - _ <- myString "else" - EIf mempty predP thenP <$> expressionParser - ------ - -tupleParser :: Parser ParserExpr -tupleParser = label "tuple" $ - addLocation $ do - _ <- myString "(" - neArgs <- commaSep expressionParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - _ <- myString ")" - pure (ETuple mempty (NE.head neArgs) neTail) - ------ - -arrayParser :: Parser ParserExpr -arrayParser = withLocation EArray $ do - myString "[" - args <- Seq.fromList <$> sepBy expressionParser (myString ",") - myString "]" - pure args - ------ - -annotationParser :: Parser ParserExpr -annotationParser = - let innerParser = do - expr <- expressionParser - myString ":" - EAnn mempty <$> typeParser <*> pure expr - in label "annotation" $ addLocation (inBrackets innerParser) - -literalParser :: Parser ParserExpr -literalParser = - boolParser - <|> intParser - <|> stringParser - <|> unitExprParser - --- <|> try stringParser - -unitExprParser :: Parser ParserExpr -unitExprParser = label "unit" $ myLexeme (withLocation EPrim $ PUnit <$ unitParser) - ----- - -intParser :: Parser ParserExpr -intParser = label "integer" $ myLexeme (withLocation EPrim intPrimParser) - ---- - -stringParser :: Parser ParserExpr -stringParser = label "string" $ myLexeme (withLocation EPrim stringPrimParser) - ---- - -boolParser :: Parser ParserExpr -boolParser = - label "boolean" $ - myLexeme - ( withLocation - EPrim - (truePrimParser <|> falsePrimParser) - ) - ------ - -letParser :: Parser ParserExpr -letParser = addLocation $ do - _ <- myString "let" - ident <- emptyParseDep <$> identifierParser - _ <- myString "=" - boundExpr <- expressionParser - _ <- try (myString ";") <|> myString "in" - ELet mempty ident boundExpr <$> expressionParser - -{- - textPrim :: Parser Text -textPrim = T.pack <$> (char '\"' *> manyTill L.charLiteral (char '\"')) --} - -{- -stringPrim :: Parser Prim -stringPrim = - MyString . StringType <$> textPrim - -stringParser :: Parser ParserExpr -stringParser = - myLexeme - ( withLocation - EPrim - stringPrim - ) --} - ----- - --- - -recordParser :: Parser ParserExpr -recordParser = withLocation ERecord $ do - let itemParser = - try recordItemParser - <|> punnedRecordItemParser - myString "{" - args <- sepBy itemParser (myString ",") - myString "}" - pure (M.fromList args) - -recordItemParser :: Parser (Identifier, ParserExpr) -recordItemParser = do - name <- identifierParser - myString ":" - expr <- expressionParser - pure (name, expr) - -punnedRecordItemParser :: Parser (Identifier, ParserExpr) -punnedRecordItemParser = do - name <- identifierParser - pure (name, EVar mempty (emptyParseDep name)) - ------ - -recordAccessParser :: Parser ParserExpr -recordAccessParser = - let combine location (record, names) = - foldl (ERecordAccess location) record names - in withLocation combine $ do - record <- try varParser <|> recordParser - names <- some dotName - pure (record, names) - -dotName :: Parser Identifier -dotName = myString "." >> identifierParser - --- we don't allow super complicate exprs to be used around infix --- just because it makes awful code and it's slow to parse -infixExpr :: Parser ParserExpr -infixExpr = - let parsers = - try literalParser - <|> try complexParser - <|> try varParser - <|> try annotationParser - in -- <|> try constructorParser - orInBrackets parsers - -infixParser :: Parser ParserExpr -infixParser = - addLocation - ( chainl1 - infixExpr - ( EInfix mempty <$> opParser - ) - ) - -{- -pattern matches are of form - -match a with - (Just b) -> b - _ -> False - --} - -patternMatchParser :: Parser ParserExpr -patternMatchParser = addLocation $ do - matchExpr <- matchExprWithParser - patterns <- - try patternMatchesParser - <|> pure - <$> patternCaseParser - case NE.nonEmpty patterns of - (Just nePatterns) -> pure $ EPatternMatch mempty matchExpr nePatterns - _ -> error "need at least one pattern" - -matchExprWithParser :: Parser ParserExpr -matchExprWithParser = do - myString "case" - sumExpr <- expressionParser - myString "of" - pure sumExpr - -patternMatchesParser :: Parser [(ParserPattern, ParserExpr)] -patternMatchesParser = - sepBy - patternCaseParser - (myString "|") - -patternCaseParser :: Parser (ParserPattern, ParserExpr) -patternCaseParser = do - pat <- orInBrackets patternParser - myString "->" - patExpr <- expressionParser - pure (pat, patExpr) diff --git a/smol-core/src/Smol/Core/Parser/Identifiers.hs b/smol-core/src/Smol/Core/Parser/Identifiers.hs deleted file mode 100644 index 2fe153b7..00000000 --- a/smol-core/src/Smol/Core/Parser/Identifiers.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Identifiers - ( identifierParser, - varParser, - constructorParser, - constructorParserInternal, - innerConstructorParser, - moduleNameParser, - typeNameParser, - plainTypeNameParser, - typeclassNameParser, - testNameParser, - ) -where - -import Control.Monad -import qualified Data.Char as Char -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import Data.Void -import Smol.Core.Modules.Types.ModuleName -import Smol.Core.Modules.Types.TestName -import Smol.Core.Parser.Primitives (textPrim) -import Smol.Core.Parser.Shared -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types -import Text.Megaparsec - -type Parser = Parsec Void Text - -type ParserExpr = Expr ParseDep Annotation - -protectedNames :: Set Text -protectedNames = - S.fromList - [ "let", - "in", - "if", - "then", - "else", - "type", - "case", - "of", - "infix", - "True", - "False", - "Unit", - "def", - "test", - "instance", - "class" - ] - -filterProtectedNames :: Text -> Maybe Text -filterProtectedNames tx = - if S.member tx protectedNames - then Nothing - else Just tx - --- `dog`, `log`, `a`, `Prelude.id` -varParser :: Parser ParserExpr -varParser = - try namespacedVarParser <|> try plainVarParser - --- `dog`, `log`, `a` -plainVarParser :: Parser ParserExpr -plainVarParser = - myLexeme - ( withLocation - ( \ann var -> - EVar ann (ParseDep var Nothing) - ) - identifierParser - ) - --- `Dog.log`, `Maybe.fmap` -namespacedVarParser :: Parser ParserExpr -namespacedVarParser = - let inner = do - (var, mName) <- withNamespace identifierParser - pure $ EVar mempty (ParseDep var (Just mName)) - in myLexeme (addLocation inner) - ---------------------- - --- `Dog`, `Log`, `A` -constructorParser :: Parser ParserExpr -constructorParser = - try namespacedConstructorParser <|> try plainConstructorParser - -plainConstructorParser :: Parser ParserExpr -plainConstructorParser = - myLexeme (withLocation EConstructor (emptyParseDep <$> constructorParserInternal)) - --- `Maybe.Just`, `Either.Right` -namespacedConstructorParser :: Parser ParserExpr -namespacedConstructorParser = - let inner = do - (cons, mName) <- withNamespace constructorParserInternal - pure $ EConstructor mempty (ParseDep cons (Just mName)) - in myLexeme (addLocation inner) - --- just the constructor (you'll need to add Lexeme, location etc) -innerConstructorParser :: Parser (ParseDep Constructor) -innerConstructorParser = - try withModule <|> try withoutModule - where - withModule = do - (cons, mName) <- withNamespace constructorParserInternal - pure $ ParseDep cons (Just mName) - withoutModule = - emptyParseDep <$> constructorParserInternal - ------------------------ - -typeNameParser :: Parser (ParseDep TypeName) -typeNameParser = - try namespacedTypeNameParser <|> try (emptyParseDep <$> plainTypeNameParser) - --- `Maybe`, `Either` etc -plainTypeNameParser :: Parser TypeName -plainTypeNameParser = myLexeme (TypeName <$> constructorParserInternal) - -namespacedTypeNameParser :: Parser (ParseDep TypeName) -namespacedTypeNameParser = - let inner = do - (cons, mName) <- withNamespace (TypeName <$> constructorParserInternal) - pure $ ParseDep cons (Just mName) - in myLexeme inner - --- identifier - -identifier :: Parser Text -identifier = takeWhile1P (Just "variable name") Char.isAlphaNum - -identifierParser :: Parser Identifier -identifierParser = - myLexeme identifierParserInternal - --- use this when you are going to wrap myLexeme yourself -identifierParserInternal :: Parser Identifier -identifierParserInternal = - maybePred - identifier - (filterProtectedNames >=> safeMkIdentifier) - --- constructor - -constructor :: Parser Text -constructor = takeWhile1P (Just "constructor") Char.isAlphaNum - --- use this when you are going to wrap myLexeme yourself -constructorParserInternal :: Parser Constructor -constructorParserInternal = - maybePred - constructor - (filterProtectedNames >=> safeMkConstructor) - ----- - -moduleName :: Parser Text -moduleName = takeWhile1P (Just "constructor") Char.isAlphaNum - -moduleNameParser :: Parser ModuleName -moduleNameParser = - myLexeme $ - maybePred - moduleName - (filterProtectedNames >=> safeMkModuleName) - ----- - -typeclassName :: Parser Text -typeclassName = takeWhile1P (Just "constructor") Char.isAlphaNum - -typeclassNameParser :: Parser TypeclassName -typeclassNameParser = - myLexeme $ - maybePred - typeclassName - (filterProtectedNames >=> safeMkTypeclassName) - --------- - -withNamespace :: Parser a -> Parser (a, ModuleName) -withNamespace p = do - mName <- moduleNameParser - myString "." - a <- p - pure (a, mName) - ------ - -testNameParser :: Parser TestName -testNameParser = myLexeme $ TestName <$> textPrim diff --git a/smol-core/src/Smol/Core/Parser/Module.hs b/smol-core/src/Smol/Core/Parser/Module.hs deleted file mode 100644 index ca8f403b..00000000 --- a/smol-core/src/Smol/Core/Parser/Module.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Module - ( moduleParser, - ) -where - -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Data.Void -import Smol.Core.Modules.Types.ModuleItem -import Smol.Core.Parser.DataType (dataTypeParser) -import Smol.Core.Parser.Expr -import Smol.Core.Parser.Identifiers -import Smol.Core.Parser.Shared -import Smol.Core.Parser.Type -import Smol.Core.Parser.Typeclass -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types -import Text.Megaparsec hiding (parseTest) - -type Parser = Parsec Void Text - --- currently fails at the first hurdle --- since we can parse each thing separately, maybe --- we should be making each throw errors for later, but returning `mempty` so --- we can collect all of the separate parse errors at once? --- use `registerParseError` from https://hackage.haskell.org/package/megaparsec-9.2.1/docs/Text-Megaparsec.html -moduleParser :: Parser [ModuleItem Annotation] -moduleParser = - mconcat - <$> ( chainl1 ((\a -> [[a]]) <$> parseModuleItem) (pure (<>)) - <|> pure mempty - ) - --- we've excluded Export here -parseModuleItem :: Parser (ModuleItem Annotation) -parseModuleItem = - try moduleTypeDefinitionParser - <|> try moduleDefinitionParser - <|> try moduleTypeDeclarationParser - <|> parseTest - <|> parseInstance - <|> parseClass - -------- - --- type definitions --- type Maybe a = Just a | Nothing --- type Tree a = Branch (Tree a) a (Tree a) | Leaf a -moduleTypeDeclarationParser :: Parser (ModuleItem Annotation) -moduleTypeDeclarationParser = ModuleDataType <$> dataTypeParser - -------- - --- definitions --- def oneHundred = 100 --- def id a = a --- def const a b = a --- --- top level definition -moduleDefinitionParser :: Parser (ModuleItem Annotation) -moduleDefinitionParser = do - myString "def" - name <- identifierParser - parts <- - chainl1 ((: []) <$> identifierParser) (pure (<>)) - <|> pure mempty - myString "=" - ModuleExpression name parts <$> expressionParser - --- top level type definition --- def id : a -> a --- def compose : (b -> c) -> (a -> b) -> (a -> c) -moduleTypeDefinitionParser :: Parser (ModuleItem Annotation) -moduleTypeDefinitionParser = do - myString "def" - name <- identifierParser - myString ":" - constraints <- try typeConstraintParser <|> pure mempty - ModuleExpressionType name constraints <$> typeParser - -typeConstraintParser :: Parser [Constraint ParseDep Annotation] -typeConstraintParser = do - myString "(" - constraints <- commaSep constraintParser - myString ")" - myString "=>" - pure (NE.toList constraints) - --- `test "everything is fine" = 1 + 1 == 2` -parseTest :: Parser (ModuleItem Annotation) -parseTest = do - myString "test" - testName <- testNameParser - myString "=" - ModuleTest testName <$> expressionParser - --- `instance Eq Int = \a -> \b -> a == b` -parseInstance :: Parser (ModuleItem Annotation) -parseInstance = do - myString "instance" - constraints <- try typeConstraintParser <|> pure mempty - mainConstraint <- constraintParser - myString "=" - ModuleInstance constraints mainConstraint <$> expressionParser - -parseClass :: Parser (ModuleItem Annotation) -parseClass = do - myString "class" - typeclassName <- typeclassNameParser - parts <- - chainl1 ((: []) <$> identifierParser) (pure (<>)) - <|> pure mempty - myString "{" - fnName <- identifierParser - myString ":" - ty <- typeParser - myString "}" - - pure $ - ModuleClass - ( Typeclass - { tcName = typeclassName, - tcArgs = parts, - tcFuncName = fnName, - tcFuncType = ty - } - ) diff --git a/smol-core/src/Smol/Core/Parser/Op.hs b/smol-core/src/Smol/Core/Parser/Op.hs deleted file mode 100644 index 54a7242c..00000000 --- a/smol-core/src/Smol/Core/Parser/Op.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Op (opParser) where - -import Data.Functor (($>)) -import Data.Text (Text) -import Data.Void -import Smol.Core.Parser.Shared -import Smol.Core.Types -import Text.Megaparsec - -type Parser = Parsec Void Text - -opParser :: Parser Op -opParser = - {- try - ( Custom <$> infixOpParser - ) -} - try - ( myString "==" - $> OpEquals - ) {- - <|> try - ( myString "-" - $> Subtract - ) - <|> try - ( myString "<>" - $> ArrayConcat - ) - <|> try - ( myString ">=" - $> GreaterThanOrEqualTo - ) - <|> try - ( myString "<=" - $> LessThanOrEqualTo - ) - <|> try - ( myString ">" - $> GreaterThan - ) - <|> try - ( myString "<" - $> LessThan - ) - <|> try - ( myString "++" - $> StringConcat - ) - -} - <|> try - ( myString "+" - $> OpAdd - ) diff --git a/smol-core/src/Smol/Core/Parser/Pattern.hs b/smol-core/src/Smol/Core/Parser/Pattern.hs deleted file mode 100644 index 41b98ade..00000000 --- a/smol-core/src/Smol/Core/Parser/Pattern.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Pattern - ( patternParser, - ParserPattern, - ) -where - -import Data.Either (partitionEithers) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Data.Void -import qualified Smol.Core.Parser.Identifiers as Identifiers -import Smol.Core.Parser.Primitives -import Smol.Core.Parser.Shared -import Smol.Core.Types -import Text.Megaparsec -import Text.Megaparsec.Char - -type Parser = Parsec Void Text - -type ParserPattern = Pattern ParseDep Annotation - -type ParserSpread = Spread ParseDep Annotation - -patternParser :: Parser ParserPattern -patternParser = - label - "pattern match" - ( orInBrackets - ( -- try stringParser - try tupleParser - <|> try wildcardParser - <|> try variableParser - <|> try litParser - -- <|> try recordParser - <|> try constructorParser - <|> try arrayParser - ) - ) - ----- - -wildcardParser :: Parser ParserPattern -wildcardParser = - myLexeme $ - withLocation - (\loc _ -> PWildcard loc) - (string "_") - ----- - -variableParser :: Parser ParserPattern -variableParser = - myLexeme $ withLocation PVar (emptyParseDep <$> Identifiers.identifierParser) - ----- - -tupleParser :: Parser ParserPattern -tupleParser = label "tuple" $ - withLocation (\loc (pHead, pTail) -> PTuple loc pHead pTail) $ do - _ <- myString "(" - neArgs <- commaSep patternParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - _ <- myString ")" - pure (NE.head neArgs, neTail) - ----- - -litParser :: Parser ParserPattern -litParser = withLocation PLiteral primParser - ---- -{- -recordParser :: Parser ParserPattern -recordParser = withLocation PRecord $ do - let itemParser = - try recordItemParser - <|> punnedRecordItemParser - _ <- myString "{" - args <- sepBy itemParser (myString ",") - _ <- myString "}" - pure (M.fromList args) - -recordItemParser :: Parser (Name, ParserPattern) -recordItemParser = do - name <- nameParser - myString ":" - expr <- patternParser - pure (name, expr) - -punnedRecordItemParser :: Parser (Name, ParserPattern) -punnedRecordItemParser = do - name <- nameParser - pure (name, PVar mempty name) --} ---- - -argsParser :: Parser [ParserPattern] -argsParser = try someP <|> pure [] - where - someP = some patternParser - -constructorParser :: Parser ParserPattern -constructorParser = - let parser = do - cons <- myLexeme Identifiers.innerConstructorParser - args <- try argsParser - pure (cons, args) - in withLocation - ( \loc (cons, args) -> - PConstructor loc cons args - ) - parser - ---- - -arrayParser :: Parser ParserPattern -arrayParser = - let itemParser = - try (Right <$> patternParser) - <|> try (Left <$> spreadParser) - <|> fail "Expected pattern or a spread operator" - parser = do - myString "[" - args <- sepBy itemParser (myString ",") - myString "]" - case getParts args of - Right parts -> pure parts - Left e -> fail e - in withLocation (\loc (as, spread) -> PArray loc as spread) parser - -getParts :: - [Either ParserSpread ParserPattern] -> - Either String ([ParserPattern], ParserSpread) -getParts as = case reverse as of - ((Left spr) : rest) -> - case partitionEithers rest of - ([], pats) | not (null pats) -> pure (reverse pats, spr) - ([], _) -> Left "There must be at least one pattern to use a spread" - _ -> Left "Cannot have more than one spread in an array pattern" - es -> case partitionEithers es of - ([], pats) -> pure (reverse pats, NoSpread) - _ -> Left "Cannot have more than one spread in an array pattern" - ---- - -spreadParser :: Parser ParserSpread -spreadParser = - try spreadValueParser - <|> try spreadWildcardParser - -spreadWildcardParser :: Parser ParserSpread -spreadWildcardParser = - let parser = - myString "..." - in withLocation (\loc _ -> SpreadWildcard loc) parser - -spreadValueParser :: Parser ParserSpread -spreadValueParser = - let parser = do - myString "..." - emptyParseDep <$> Identifiers.identifierParser - in withLocation SpreadValue parser - ---- - -{- -stringParser :: Parser (Pattern Name Annotation) -stringParser = - let parser = do - a <- stringPartParser - myString "++" - as <- stringPartParser - pure (a, as) - in withLocation (\loc (a, as) -> PString loc a as) parser - -stringPartParser :: Parser (StringPart Name Annotation) -stringPartParser = - try stringWildcard <|> try stringValue - -stringWildcard :: Parser (StringPart Name Annotation) -stringWildcard = - let parser = myString "_" - in withLocation (\loc _ -> StrWildcard loc) parser - -stringValue :: Parser (StringPart Name Annotation) -stringValue = - withLocation StrValue nameParser --} diff --git a/smol-core/src/Smol/Core/Parser/Primitives.hs b/smol-core/src/Smol/Core/Parser/Primitives.hs deleted file mode 100644 index 8a5a98f2..00000000 --- a/smol-core/src/Smol/Core/Parser/Primitives.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Primitives - ( primParser, - typeLiteralParser, - intPrimParser, - truePrimParser, - falsePrimParser, - stringPrimParser, - unitParser, - textPrim, - ) -where - -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Set.NonEmpty as NES -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import Smol.Core.Parser.Shared -import Smol.Core.Types -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -type Parser = Parsec Void Text - -primParser :: Parser Prim -primParser = - myLexeme - ( intPrimParser - <|> truePrimParser - <|> falsePrimParser - <|> PUnit - <$ unitParser - <|> stringPrimParser - ) - -typeLiteralParser :: Parser TypeLiteral -typeLiteralParser = - myLexeme - ( TLInt - <$> multiIntParser - <|> TLBool - <$> trueParser - <|> TLBool - <$> falseParser - <|> TLUnit - <$ unitParser - <|> TLString - <$> multiStringParser - ) - --- 2, -2, +2 -intPrimParser :: Parser Prim -intPrimParser = PInt <$> intParser - -intParser :: Parser Integer -intParser = - L.signed (string "" $> ()) L.decimal - -unionParser :: (Ord a) => Parser a -> Parser (NES.NESet a) -unionParser parseA = do - ints <- - sepBy1 - (myLexeme parseA) - (myString "|") - pure (NES.fromList (NE.fromList ints)) - -multiIntParser :: Parser (NES.NESet Integer) -multiIntParser = unionParser intParser - ---- - -truePrimParser :: Parser Prim -truePrimParser = PBool <$> trueParser - -trueParser :: Parser Bool -trueParser = myString "True" $> True - -falsePrimParser :: Parser Prim -falsePrimParser = PBool <$> falseParser - -falseParser :: Parser Bool -falseParser = myString "False" $> False - ----- - -unitParser :: Parser () -unitParser = myString "Unit" $> () - ---- - -stringPrimParser :: Parser Prim -stringPrimParser = - PString <$> textPrim - -textPrim :: Parser Text -textPrim = T.pack <$> (char '"' *> manyTill L.charLiteral (char '"')) - -multiStringParser :: Parser (NES.NESet Text) -multiStringParser = unionParser textPrim diff --git a/smol-core/src/Smol/Core/Parser/Shared.hs b/smol-core/src/Smol/Core/Parser/Shared.hs deleted file mode 100644 index b9c3f383..00000000 --- a/smol-core/src/Smol/Core/Parser/Shared.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Shared - ( emptyParseDep, - inBrackets, - orInBrackets, - myLexeme, - withLocation, - myString, - addLocation, - mapOuterExprAnnotation, - maybePred, - chainl1, - commaSep, - ) -where - -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import Smol.Core.ExprUtils -import Smol.Core.Types -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -type Parser = Parsec Void Text - -type ParserExpr = Expr ParseDep Annotation - -between2 :: Char -> Char -> Parser a -> Parser a -between2 a b parser = do - _ <- myLexeme (char a) - val <- parser - _ <- myLexeme (char b) - pure val - -withLocation :: (Annotation -> a -> b) -> Parser a -> Parser b -withLocation withP p = do - start <- getOffset - value <- p - end <- getOffset - pure (withP (Location start end) value) - --- | wraps any parser of Exprs and adds location information -addLocation :: Parser ParserExpr -> Parser ParserExpr -addLocation = withLocation (mapOuterExprAnnotation . const) - -inBrackets :: Parser a -> Parser a -inBrackets = between2 '(' ')' - -orInBrackets :: Parser a -> Parser a -orInBrackets parser = try parser <|> try (inBrackets parser) - -maybePred :: (Show a) => Parser a -> (a -> Maybe b) -> Parser b -maybePred parser predicate' = try $ do - a <- parser - case predicate' a of - Just b -> pure b - _ -> fail $ T.unpack $ "Predicate did not hold for " <> T.pack (show a) - --- | stolen from Parsec, allows parsing infix expressions without recursion --- death -chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a -chainl1 p op = do x <- p; rest x - where - rest x = - do - f <- op - y <- p - rest (f x y) - <|> return x - -myLexeme :: Parser a -> Parser a -myLexeme = - L.lexeme - ( L.space - space1 - (L.skipLineComment "//") - (L.skipBlockComment "/*" "*/") - ) - -myString :: Text -> Parser () -myString s = myLexeme (string s) $> () - -commaSep :: Parser p -> Parser (NE.NonEmpty p) -commaSep p = NE.fromList <$> p `sepBy1` myString "," diff --git a/smol-core/src/Smol/Core/Parser/Type.hs b/smol-core/src/Smol/Core/Parser/Type.hs deleted file mode 100644 index 431b667f..00000000 --- a/smol-core/src/Smol/Core/Parser/Type.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Parser.Type (parseTypeAndFormatError, parseType, typeParser, simpleTypeParser) where - -import Control.Monad ((>=>)) -import Control.Monad.Combinators.Expr - ( Operator (InfixR), - makeExprParser, - ) -import Data.Bifunctor (first) -import qualified Data.Char as Char -import Data.Foldable (foldl') -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void (Void) -import Smol.Core.Parser.Identifiers - ( identifierParser, - typeNameParser, - ) -import Smol.Core.Parser.Op -import qualified Smol.Core.Parser.Primitives as Prim -import Smol.Core.Parser.Shared - ( chainl1, - commaSep, - inBrackets, - maybePred, - myLexeme, - myString, - orInBrackets, - withLocation, - ) -import Smol.Core.Types.Annotation (Annotation) -import Smol.Core.Types.Identifier -import Smol.Core.Types.ParseDep -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName (TypeName (..)) -import Text.Megaparsec - ( MonadParsec (eof, label, takeWhile1P, try), - ParseErrorBundle, - Parsec, - errorBundlePretty, - parse, - sepBy, - some, - (<|>), - ) -import Text.Megaparsec.Char (space) - -type Parser = Parsec Void Text - -type ParseErrorType = ParseErrorBundle Text Void - -parseAndFormat :: Parser a -> Text -> Either Text a -parseAndFormat p = first (T.pack . errorBundlePretty) . parse (p <* eof) "repl" - -parseType :: Text -> Either ParseErrorType (ParsedType Annotation) -parseType = parse (space *> typeParser <* eof) "type" - -parseTypeAndFormatError :: Text -> Either Text (ParsedType Annotation) -parseTypeAndFormatError = parseAndFormat (space *> typeParser <* eof) - --- | currently lets assume we only want globals at the start -typeParser :: Parser (ParsedType Annotation) -typeParser = - typeInnerParser - --- | top-level parser for type signatures -typeInnerParser :: Parser (ParsedType Annotation) -typeInnerParser = - try (orInBrackets tyFunctionParser) - <|> try tyAppParser - <|> try typeInfixParser - <|> simpleTypeParser - --- | all the types except functions -simpleTypeParser :: Parser (ParsedType Annotation) -simpleTypeParser = - let parsers = - try tyTupleParser - <|> typeLiteralParser - <|> try tVarParser - <|> try tyPrimitiveParser - <|> try tyRecordParser - <|> tyArrayParser - <|> try adtParser - in orInBrackets parsers - -typeInfixParser :: Parser (ParsedType Annotation) -typeInfixParser = - chainl1 - simpleTypeParser - ( TInfix mempty <$> opParser - ) - -adtParser :: Parser (ParsedType Annotation) -adtParser = - try multiDataTypeParser - <|> monoDataTypeParser - -multiDataTypeParser :: Parser (ParsedType Annotation) -multiDataTypeParser = do - tyName <- typeNameParser - tyArgs <- some appArgParser - pure (dataTypeWithVars mempty tyName tyArgs) - -monoDataTypeParser :: Parser (ParsedType Annotation) -monoDataTypeParser = do - tyName <- typeNameParser - pure (dataTypeWithVars mempty tyName mempty) - -dataTypeWithVars :: - (Monoid ann) => - ann -> - ParseDep TypeName -> - [ParsedType ann] -> - ParsedType ann -dataTypeWithVars ann tyName = - foldl' - (TApp mempty) - (TConstructor ann tyName) - ----- -typeLiteralParser :: Parser (ParsedType Annotation) -typeLiteralParser = - label "type literal" $ myLexeme (withLocation TLiteral Prim.typeLiteralParser) - -tyPrimitiveParser :: Parser (ParsedType Annotation) -tyPrimitiveParser = TPrim mempty <$> tyPrimParser - where - tyPrimParser = - try (myString "String" $> TPString) - <|> try (myString "Bool" $> TPBool) - <|> try (myString "Int" $> TPInt) - -tyAppParser :: Parser (ParsedType Annotation) -tyAppParser = label "type app" $ do - func <- orInBrackets (TVar mempty . emptyParseDep <$> tyVarParser) - let argParser' :: Parser [ParsedType Annotation] - argParser' = (: []) <$> appArgParser - args <- chainl1 argParser' (pure (<>)) - pure $ foldl (TApp mempty) func args - --- | used where a function or type must be inside brackets for clarity -appArgParser :: Parser (ParsedType Annotation) -appArgParser = - try (inBrackets tyAppParser) - <|> try simpleTypeParser - <|> try (inBrackets tyFunctionParser) - -tyFunctionParser :: Parser (ParsedType Annotation) -tyFunctionParser = do - let arrParse :: Operator Parser (ParsedType Annotation) - arrParse = InfixR $ do - myString "->" - pure (TFunc mempty mempty) - - val <- makeExprParser functionArgParser [[arrParse]] - case val of - TFunc {} -> pure val - _ -> fail "don't use function for parsing non-function values" - --- | used where a function or type must be inside brackets for clarity -functionArgParser :: Parser (ParsedType Annotation) -functionArgParser = - try (orInBrackets tyAppParser) - <|> try typeInfixParser - <|> try simpleTypeParser - <|> try (inBrackets tyFunctionParser) - -tyTupleParser :: Parser (ParsedType Annotation) -tyTupleParser = do - myString "(" - neArgs <- commaSep typeInnerParser - neTail <- case NE.nonEmpty (NE.tail neArgs) of - Just ne -> pure ne - _ -> fail "Expected at least two items in a tuple" - myString ")" - pure (TTuple mempty (NE.head neArgs) neTail) - -tyIdentifier :: Parser Text -tyIdentifier = myLexeme (takeWhile1P (Just "type variable name") Char.isAlphaNum) - -inProtectedTypes :: Text -> Maybe Text -inProtectedTypes tx = - if S.member tx protectedTypeNames - then Nothing - else Just tx - --- these names cannot be used as type variables -protectedTypeNames :: Set Text -protectedTypeNames = - S.fromList - [ "String", - "Int", - "Bool", - "Unit", - "True", - "False", - "in", - "def", - "type", - "infix", - "test", - "instance", - "class" - ] - -tyVarParser :: Parser Identifier -tyVarParser = - myLexeme $ - maybePred - tyIdentifier - (inProtectedTypes >=> safeMkIdentifier) - -tVarParser :: Parser (ParsedType Annotation) -tVarParser = do - TVar mempty . emptyParseDep <$> tyVarParser - -tyRecordParser :: Parser (ParsedType Annotation) -tyRecordParser = withLocation TRecord $ do - args <- tyRecordArgs - myString "}" - pure args - -tyRecordArgs :: Parser (Map Identifier (ParsedType Annotation)) -tyRecordArgs = do - myString "{" - args <- sepBy tyRecordItemParser (myString ",") - pure (M.fromList args) - -tyRecordItemParser :: Parser (Identifier, ParsedType Annotation) -tyRecordItemParser = do - name <- identifierParser - myString ":" - expr <- typeInnerParser - pure (name, expr) - -tyArrayParser :: Parser (ParsedType Annotation) -tyArrayParser = withLocation (`TArray` 0) $ do - myString "[" - arg <- typeInnerParser - myString "]" - pure arg - -{- -tyRecordRowParser :: Parser (ParsedType Annotation) -tyRecordRowParser = - withLocation - (\loc (args, rest) -> TRecordRow loc args rest) - ( do - args <- recordArgs - myString "|" - rest <- typeInnerParser - myString "}" - pure (args, rest) - ) --} diff --git a/smol-core/src/Smol/Core/Parser/Typeclass.hs b/smol-core/src/Smol/Core/Parser/Typeclass.hs deleted file mode 100644 index cc7f7b5c..00000000 --- a/smol-core/src/Smol/Core/Parser/Typeclass.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Smol.Core.Parser.Typeclass - ( constraintParser, - ) -where - -import Data.Text (Text) -import Data.Void -import Smol.Core.Parser.Identifiers -import Smol.Core.Parser.Type -import Smol.Core.Typecheck.Types -import Smol.Core.Types -import Text.Megaparsec hiding (parseTest) - -type Parser = Parsec Void Text - -constraintParser :: Parser (Constraint ParseDep Annotation) -constraintParser = do - tcn <- typeclassNameParser - tys <- many typeParser - - pure $ Constraint tcn tys diff --git a/smol-core/src/Smol/Core/Printer.hs b/smol-core/src/Smol/Core/Printer.hs deleted file mode 100644 index 9b2797e1..00000000 --- a/smol-core/src/Smol/Core/Printer.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Printer - ( Printer (..), - renderWithWidth, - ) -where - --- the Printer type class is used for internal debugging --- prettyDoc returns a Prettyprinter doc for nicer output - -import Control.Monad.Identity -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Data.Text (Text) -import GHC.Natural -import Prettyprinter -import Prettyprinter.Render.Text - -renderWithWidth :: Int -> Doc ann -> Text -renderWithWidth w doc = renderStrict (layoutPretty layoutOptions (unAnnotate doc)) - where - layoutOptions = LayoutOptions {layoutPageWidth = AvailablePerLine w 1} - -class Printer a where - prettyDoc :: a -> Doc ann - -instance (Printer a) => Printer (Identity a) where - prettyDoc (Identity a) = prettyDoc a - -instance (Printer e, Printer a) => Printer (Either e a) where - prettyDoc (Left e) = prettyDoc e - prettyDoc (Right a) = prettyDoc a - -instance Printer () where - prettyDoc = const "" - -instance (Printer a) => Printer (Maybe a) where - prettyDoc (Just a) = prettyDoc a - prettyDoc _ = mempty - -instance {-# OVERLAPPING #-} Printer [Char] where - prettyDoc = pretty - -instance Printer Text where - prettyDoc = pretty - -instance Printer Bool where - prettyDoc = pretty - -instance Printer Int where - prettyDoc = pretty - -instance Printer Natural where - prettyDoc = pretty - -instance (Printer a) => Printer [a] where - prettyDoc = sep . fmap prettyDoc - -instance (Printer k, Printer v) => Printer (Map k v) where - prettyDoc map' = - let printRow (k, v) = " " <> prettyDoc k <> ":" <+> prettyDoc v - in encloseSep lbrace rbrace comma (printRow <$> M.toList map') - -instance (Printer a, Printer b) => Printer (a, b) where - prettyDoc (a, b) = tupled [prettyDoc a, prettyDoc b] - -instance (Printer a, Printer b, Printer c) => Printer (a, b, c) where - prettyDoc (a, b, c) = - tupled [prettyDoc a, prettyDoc b, prettyDoc c] - -instance (Printer a, Printer b, Printer c, Printer d) => Printer (a, b, c, d) where - prettyDoc (a, b, c, d) = - tupled - [prettyDoc a, prettyDoc b, prettyDoc c, prettyDoc d] - -instance (Printer a) => Printer (Set a) where - prettyDoc as = list (prettyDoc <$> S.toList as) - -instance (Printer a) => Printer (NES.NESet a) where - prettyDoc as = prettyDoc (NES.toSet as) diff --git a/smol-core/src/Smol/Core/SourceSpan.hs b/smol-core/src/Smol/Core/SourceSpan.hs deleted file mode 100644 index 14352ae9..00000000 --- a/smol-core/src/Smol/Core/SourceSpan.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Smol.Core.SourceSpan (sourceSpan, SourceSpan (..)) where - -import Data.Text (Text) -import qualified Data.Text as T -import Smol.Core.Types -import Smol.Core.Types.SourceSpan - -lineLengths :: Text -> [Int] -lineLengths tx = T.length <$> T.lines tx - -toColumnAndRow :: [Int] -> Int -> (Int, Int) -toColumnAndRow = go 1 - where - go row [] col = - (row, col) - go row (line : rest) col - | (col - 1) >= line = - go (row + 1) rest (col - line - 1) - go row _ col = (row, col) - -sourceSpan :: Text -> Annotation -> Maybe SourceSpan -sourceSpan tx (Location start end) = - let (startRow, startCol) = - toColumnAndRow (lineLengths tx) start - (endRow, endCol) = - toColumnAndRow (lineLengths tx) end - in Just - ( SourceSpan - { ssRowStart = startRow, - ssRowEnd = endRow, - ssColStart = startCol + 1, - ssColEnd = endCol + 1 - } - ) diff --git a/smol-core/src/Smol/Core/Transform.hs b/smol-core/src/Smol/Core/Transform.hs deleted file mode 100644 index e2979897..00000000 --- a/smol-core/src/Smol/Core/Transform.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Smol.Core.Transform (transform) where - -import Smol.Core.Transform.BetaReduce -import Smol.Core.Transform.EtaReduce -import Smol.Core.Transform.FlattenLets -import Smol.Core.Transform.FloatDown -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier - -transform :: - (Ord (dep Identifier)) => - Expr dep ann -> - Expr dep ann -transform = etaReduce . betaReduce . floatDown . flattenLets diff --git a/smol-core/src/Smol/Core/Transform/BetaReduce.hs b/smol-core/src/Smol/Core/Transform/BetaReduce.hs deleted file mode 100644 index aca1b8e7..00000000 --- a/smol-core/src/Smol/Core/Transform/BetaReduce.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Smol.Core.Transform.BetaReduce (betaReduce) where - -import qualified Data.Map.Strict as M -import Smol.Core - -betaReduce :: Expr dep ann -> Expr dep ann -betaReduce = betaReduceInternal - --- | turn (\x -> e) a into `let x = a in e` -betaReduceInternal :: Expr dep ann -> Expr dep ann -betaReduceInternal (EApp ann (ELambda _ ident body) val) = - betaReduceInternal $ ELet ann ident val (betaReduceInternal body) -betaReduceInternal (EApp ann (EAnn _ _ (ELambda _ann ident body)) val) = - betaReduceInternal $ ELet ann ident val (betaReduceInternal body) -betaReduceInternal (EApp annA (EApp annB (ELambda _ identA (ELambda _ identB body)) valA) valB) = - betaReduceInternal $ ELet annA identA valA (ELet annB identB valB (betaReduceInternal body)) -betaReduceInternal (EIf _ (EPrim _ (PBool True)) thenExpr _) = - betaReduceInternal thenExpr -betaReduceInternal (EIf _ (EPrim _ (PBool False)) _ elseExpr) = - betaReduceInternal elseExpr -betaReduceInternal (ERecordAccess ann myRec@(ERecord _ as) name) = - case M.lookup name as of - Just inner -> inner - _ -> ERecordAccess ann (betaReduceInternal myRec) name -betaReduceInternal other = mapExpr betaReduceInternal other diff --git a/smol-core/src/Smol/Core/Transform/EtaReduce.hs b/smol-core/src/Smol/Core/Transform/EtaReduce.hs deleted file mode 100644 index 35c5d781..00000000 --- a/smol-core/src/Smol/Core/Transform/EtaReduce.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Smol.Core.Transform.EtaReduce (etaReduce) where - -import Smol.Core - -etaReduce :: (Eq (dep Identifier)) => Expr dep ann -> Expr dep ann -etaReduce = etaReduceInternal - --- | turn `\a -> id a` into `id` -etaReduceInternal :: - (Eq (dep Identifier)) => - Expr dep ann -> - Expr dep ann -etaReduceInternal (ELambda _ varA (EApp _ fn (EVar _ varA'))) - | varA == varA' = - etaReduceInternal fn -etaReduceInternal - ( ELambda - _ - varA - (ELambda _ varB (EApp _ (EApp _ fn (EVar _ varA')) (EVar _ varB'))) - ) - | varA == varA' && varB == varB' = - etaReduceInternal fn -etaReduceInternal - ( ELambda - _ - varA - ( ELambda - _ - varB - ( ELambda - _ - varC - ( EApp - _ - (EApp _ (EApp _ fn (EVar _ varA')) (EVar _ varB')) - (EVar _ varC') - ) - ) - ) - ) - | varA == varA' && varB == varB' && varC == varC' = - etaReduceInternal fn -etaReduceInternal other = mapExpr etaReduceInternal other diff --git a/smol-core/src/Smol/Core/Transform/FlattenLets.hs b/smol-core/src/Smol/Core/Transform/FlattenLets.hs deleted file mode 100644 index faaab5f9..00000000 --- a/smol-core/src/Smol/Core/Transform/FlattenLets.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Smol.Core.Transform.FlattenLets (flattenLets) where - -import Smol.Core - --- | We don't want `let a = (let b = 1 in b + 1) in a + 1` --- instead we want `let b = 1; let a = b + 1; a + 1 -flattenLets :: Expr var ann -> Expr var ann -flattenLets (ELet ann ident (ELet ann' ident' expr' body') body) = - flattenLets $ - ELet - ann' - ident' - (flattenLets expr') - ( ELet - ann - ident - (flattenLets body') - (flattenLets body) - ) -flattenLets other = mapExpr flattenLets other diff --git a/smol-core/src/Smol/Core/Transform/FloatDown.hs b/smol-core/src/Smol/Core/Transform/FloatDown.hs deleted file mode 100644 index 96d33055..00000000 --- a/smol-core/src/Smol/Core/Transform/FloatDown.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Smol.Core.Transform.FloatDown (floatDown) where - -import Data.Bifunctor (second) -import Smol.Core -import Smol.Core.Helpers -import Smol.Core.Interpreter.FindUses - -floatDown :: - ( Ord (dep Identifier) - ) => - Expr dep ann -> - Expr dep ann -floatDown = nTimes 5 floatDownInternal - --- if a let is above a pattern, it pushes it down into each branch of the --- pattern match --- this is so that it can be removed by dead code elimination on branches that --- don't use it -floatDownInternal :: (Ord (dep Identifier)) => Expr dep ann -> Expr dep ann -floatDownInternal - original@( ELet - ann - ident - expr - (EPatternMatch pAnn matchExpr pats) - ) = - if memberInUses ident (findUses matchExpr) -- if let var is in the matchExpr, don't float down - then original - else - let newPatterns = second (ELet ann ident expr) <$> pats - in EPatternMatch pAnn matchExpr newPatterns -floatDownInternal - original@( ELet - ann - ident - expr - (EIf ifAnn predExpr thenExpr elseExpr) - ) = - if memberInUses ident (findUses predExpr) -- if let var is in the matchExpr, don't float down - then original - else - let newThenExpr = floatDownInternal (ELet ann ident expr thenExpr) - newElseExpr = floatDownInternal (ELet ann ident expr elseExpr) - in EIf ifAnn predExpr newThenExpr newElseExpr -floatDownInternal other = mapExpr floatDownInternal other diff --git a/smol-core/src/Smol/Core/TypeUtils.hs b/smol-core/src/Smol/Core/TypeUtils.hs deleted file mode 100644 index 045b269b..00000000 --- a/smol-core/src/Smol/Core/TypeUtils.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Smol.Core.TypeUtils (mapType, bindType, monoidType) where - -import Smol.Core.Types - --- helper functions for manipulating Types -mapType :: (Type dep ann -> Type dep ann) -> Type dep ann -> Type dep ann -mapType f (TFunc ann env fn arg) = - TFunc ann (mapType f <$> env) (f fn) (f arg) -mapType f (TTuple ann tHead tTail) = - TTuple ann (mapType f tHead) (mapType f <$> tTail) -mapType f (TInfix ann op a b) = - TInfix ann op (mapType f a) (mapType f b) -mapType f (TArray ann i as) = TArray ann i (f as) -mapType _ (TLiteral ann l) = TLiteral ann l -mapType _ (TPrim ann p) = TPrim ann p -mapType _ (TVar ann v) = TVar ann v -mapType _ (TUnknown ann i) = TUnknown ann i -mapType f (TRecord ann parts) = TRecord ann (mapType f <$> parts) -mapType f (TApp ann fn arg) = - TApp ann (f fn) (f arg) -mapType _ (TConstructor ann c) = TConstructor ann c - --- helper functions for manipulating Types -bindType :: (Applicative m) => (Type dep ann -> m (Type dep ann)) -> Type dep ann -> m (Type dep ann) -bindType f (TFunc ann env fn arg) = - TFunc ann <$> traverse (bindType f) env <*> f fn <*> f arg -bindType f (TTuple ann tHead tTail) = - TTuple ann <$> bindType f tHead <*> traverse (bindType f) tTail -bindType f (TInfix ann op a b) = - TInfix ann op <$> bindType f a <*> bindType f b -bindType f (TArray ann i as) = TArray ann i <$> f as -bindType _ (TLiteral ann l) = pure $ TLiteral ann l -bindType _ (TPrim ann p) = pure $ TPrim ann p -bindType _ (TVar ann v) = pure $ TVar ann v -bindType _ (TUnknown ann i) = pure $ TUnknown ann i -bindType f (TRecord ann parts) = TRecord ann <$> traverse (bindType f) parts -bindType f (TApp ann fn arg) = - TApp ann <$> f fn <*> f arg -bindType _ (TConstructor ann c) = pure $ TConstructor ann c - -monoidType :: (Monoid a) => (Type dep ann -> a) -> Type dep ann -> a -monoidType _ TVar {} = mempty -monoidType _ TLiteral {} = mempty -monoidType _ TPrim {} = mempty -monoidType _ TUnknown {} = mempty -monoidType _ TConstructor {} = mempty -monoidType f (TInfix _ _ a b) = f a <> f b -monoidType f (TFunc _ closure from to) = - foldMap f closure <> f from <> f to -monoidType f (TArray _ _ as) = - f as -monoidType f (TTuple _ a as) = - f a <> foldMap f as -monoidType f (TRecord _ as) = - foldMap f as -monoidType f (TApp _ fn arg) = f fn <> f arg diff --git a/smol-core/src/Smol/Core/Typecheck.hs b/smol-core/src/Smol/Core/Typecheck.hs deleted file mode 100644 index 014af5c9..00000000 --- a/smol-core/src/Smol/Core/Typecheck.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Smol.Core.Typecheck - ( module Smol.Core.Typecheck.Elaborate, - module Smol.Core.Typecheck.FreeVars, - module Smol.Core.Typecheck.Types, - module Smol.Core.Typecheck.Exhaustiveness, - module Smol.Core.Typecheck.Subtype, - module Smol.Core.Typecheck.Substitute, - module Smol.Core.Typecheck.Shared, - module Smol.Core.Typecheck.Errors, - ) -where - -import Smol.Core.Typecheck.Elaborate -import Smol.Core.Typecheck.Errors -import Smol.Core.Typecheck.Exhaustiveness -import Smol.Core.Typecheck.FreeVars -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Subtype -import Smol.Core.Typecheck.Types diff --git a/smol-core/src/Smol/Core/Typecheck/Annotations.hs b/smol-core/src/Smol/Core/Typecheck/Annotations.hs deleted file mode 100644 index 850ad3d8..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Annotations.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Annotations - ( getExprAnnotation, - getPatternAnnotation, - getSpreadAnnotation, - getTypeAnnotation, - ) -where - -import Smol.Core.Types - -getExprAnnotation :: Expr dep ann -> ann -getExprAnnotation (EInfix ann _ _ _) = ann -getExprAnnotation (EConstructor ann _) = ann -getExprAnnotation (ELet ann _ _ _) = ann -getExprAnnotation (ELambda ann _ _) = ann -getExprAnnotation (EPrim ann _) = ann -getExprAnnotation (EApp ann _ _) = ann -getExprAnnotation (EIf ann _ _ _) = ann -getExprAnnotation (EAnn ann _ _) = ann -getExprAnnotation (EVar ann _) = ann -getExprAnnotation (ETuple ann _ _) = ann -getExprAnnotation (EArray ann _) = ann -getExprAnnotation (ERecord ann _) = ann -getExprAnnotation (ERecordAccess ann _ _) = ann -getExprAnnotation (EPatternMatch ann _ _) = ann - -getPatternAnnotation :: Pattern dep ann -> ann -getPatternAnnotation (PVar ann _) = ann -getPatternAnnotation (PWildcard ann) = ann -getPatternAnnotation (PTuple ann _ _) = ann -getPatternAnnotation (PLiteral ann _) = ann -getPatternAnnotation (PConstructor ann _ _) = ann -getPatternAnnotation (PArray ann _ _) = ann - -getSpreadAnnotation :: Spread dep ann -> Maybe ann -getSpreadAnnotation NoSpread = Nothing -getSpreadAnnotation (SpreadValue ann _) = Just ann -getSpreadAnnotation (SpreadWildcard ann) = Just ann - -getTypeAnnotation :: Type dep ann -> ann -getTypeAnnotation (TPrim ann _) = ann -getTypeAnnotation (TInfix ann _ _ _) = ann -getTypeAnnotation (TUnknown ann _) = ann -getTypeAnnotation (TConstructor ann _) = ann -getTypeAnnotation (TApp ann _ _) = ann -getTypeAnnotation (TFunc ann _ _ _) = ann -getTypeAnnotation (TTuple ann _ _) = ann -getTypeAnnotation (TArray ann _ _) = ann -getTypeAnnotation (TVar ann _) = ann -getTypeAnnotation (TLiteral ann _) = ann -getTypeAnnotation (TRecord ann _) = ann diff --git a/smol-core/src/Smol/Core/Typecheck/Elaborate.hs b/smol-core/src/Smol/Core/Typecheck/Elaborate.hs deleted file mode 100644 index 699ed597..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Elaborate.hs +++ /dev/null @@ -1,405 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Smol.Core.Typecheck.Elaborate - ( elaborate, - getExprAnnotation, - checkPattern, - ) -where - -import Control.Monad (when) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Writer.CPS (runWriterT) -import Control.Monad.Writer.CPS -import Data.Foldable (toList) -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Smol.Core.ExprUtils -import Smol.Core.Helpers -import Smol.Core.Typecheck.Pattern (checkPattern) -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Simplify -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Subtype -import Smol.Core.Typecheck.Typeclass.Helpers -import Smol.Core.Typecheck.Types -import Smol.Core.Types - -elaborate :: - ( Ord ann, - Show ann, - Monoid ann, - MonadError (TCError ann) m - ) => - TCEnv ann -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann), M.Map (ResolvedDep Identifier) (Constraint ResolvedDep ann)) -elaborate env expr = - runReaderT - ( runWriterT - ( evalStateT - (infer expr) - (TCState mempty 0 mempty) - ) - ) - env - >>= \(typedExpr, events) -> do - -- apply substitutions - let simpleExpr = simplifyType . substituteMany (filterSubstitutions events) <$> typedExpr - - let typeclassUses = recoverTypeclassUses events - - pure (simpleExpr, typeclassUses) - -inferInfix :: - ( Ord ann, - Show ann, - MonadState (TCState ann) m, - MonadReader (TCEnv ann) m, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m - ) => - ann -> - Op -> - ResolvedExpr ann -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -inferInfix ann OpAdd a b = do - elabA <- infer a - elabB <- infer b - let tyA = getExprAnnotation elabA - tyB = getExprAnnotation elabB - - -- throw if these things are totally incompatible (we use `censor` to stop - -- "learning" anything about the oversimplified types) - _ <- - censor (const mempty) $ - generaliseLiteral tyA `isSubtypeOf` generaliseLiteral tyB - - let addTy = TInfix ann OpAdd tyA tyB - - pure (EInfix addTy OpAdd elabA elabB) --- equality is certainly a big bucket of worms --- for now, we'll concentrate on Int/Nat/Bool equality making sense -inferInfix ann OpEquals a b = do - elabA <- infer a - elabB <- infer b - let tyA = getExprAnnotation elabA - tyB = getExprAnnotation elabB - - -- throw if they're not the same - _ <- generaliseLiteral tyA `isSubtypeOf` generaliseLiteral tyB - - -- check left is primitive - when - (typeIsStruct (simplifyType tyA)) - (throwError (TCCompoundTypeInEquality tyA)) - -- check right is primitive - when - (typeIsStruct (simplifyType tyB)) - (throwError (TCCompoundTypeInEquality tyB)) - pure (EInfix (TInfix ann OpEquals tyA tyB) OpEquals elabA elabB) - --- | infer synthesizes values --- from introduction forms -infer :: - ( Ord ann, - Show ann, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m - ) => - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -infer inferExpr = do - case inferExpr of - (EPrim ann prim) -> - pure (EPrim (TLiteral ann (typeLiteralFromPrim prim)) prim) - (EAnn _ typ expr) -> do - typedExpr <- check typ expr - pure (EAnn (getExprAnnotation typedExpr) (typ $> typ) typedExpr) - (EInfix ann op a b) -> - inferInfix ann op a b - (EVar ann ident) -> do - typ <- lookupVar ann ident - pure (EVar typ ident) - (ELambda ann ident body) -> inferLambda ann ident body - (ELet ann ident expr body) -> - withRecursiveFn (ELambda ann ident body) expr $ do - tyUnknown <- getUnknown ann - typedExpr <- withVar ident tyUnknown (infer expr) - let tyExpr = - substituteMany - [ Substitution - (SubType tyUnknown) - (getExprAnnotation typedExpr) - ] - (getExprAnnotation typedExpr) - typedBody <- withVar ident tyExpr (infer body) - pure $ ELet (getExprAnnotation typedBody) ident typedExpr typedBody - (EApp ann fn arg) -> inferApplication ann Nothing fn arg - (EIf _ predExpr thenExpr elseExpr) -> do - typedPred <- check (TPrim (getExprAnnotation predExpr) TPBool) predExpr - typedThen <- infer thenExpr - typedElse <- infer elseExpr - agreedType <- - combineMany - ( getExprAnnotation typedThen - NE.:| [ getExprAnnotation typedElse - ] - ) - pure (EIf agreedType typedPred typedThen typedElse) - (ETuple ann fstExpr restExpr) -> do - typedFst <- infer fstExpr - typedRest <- traverse infer restExpr - let typ = - TTuple - ann - (getExprAnnotation typedFst) - (getExprAnnotation <$> typedRest) - pure $ ETuple typ typedFst typedRest - (EArray ann as) -> do - typedAs <- traverse infer as - let size = fromIntegral (length as) - ty <- case NE.nonEmpty (reverse $ toList typedAs) of - Nothing -> error "what type is empty list" - Just tyAs -> combineMany (getExprAnnotation <$> tyAs) - pure (EArray (TArray ann size ty) typedAs) - (ERecord ann items) -> do - tyItems <- traverse infer items - pure $ ERecord (TRecord ann (getExprAnnotation <$> tyItems)) tyItems - (ERecordAccess _ expr ident) -> do - typedExpr <- infer expr - tyResult <- case getExprAnnotation typedExpr of - TRecord _ tyItems -> case M.lookup ident tyItems of - Just ty -> pure ty - Nothing -> throwError (TCRecordMissingItems (S.singleton ident)) - other -> throwError (TCExpectedRecord other) - pure (ERecordAccess tyResult typedExpr ident) - (EPatternMatch _ matchExpr pats) -> do - elabExpr <- infer matchExpr - let withPair (pat, patExpr) = do - (elabPat, newVars) <- checkPattern (getExprAnnotation elabExpr) pat - elabPatExpr <- withNewVars newVars (infer patExpr) - pure (elabPat, elabPatExpr) - elabPats <- traverse withPair pats - let allTypes = getExprAnnotation . snd <$> elabPats - typ <- combineMany allTypes - pure (EPatternMatch typ elabExpr elabPats) - (EConstructor ann constructor) -> do - (typeName, vars, _, args) <- lookupConstructor constructor - - tyConstructor <- typeForConstructor ann typeName vars args - - pure (EConstructor tyConstructor constructor) - -inferApplication :: - ( Ord ann, - Show ann, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m - ) => - ann -> - Maybe (ResolvedType ann) -> - ResolvedExpr ann -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -inferApplication ann maybeCheckType fn arg = withRecursiveFn fn arg $ do - typedArg <- infer arg - - -- if we are applying to a variable, then we need to be a bit clever and - -- do some substitution etc. if not, just infer it as usual and yolo - let inferFn exprFn = do - typedFn <- infer exprFn -- get type of fn - (freshTyVar, undoSubs) <- freshen (getExprAnnotation typedFn) - - case freshTyVar of - (TFunc tAnn tClosure tArg tBody) -> do - -- if this is a func, it may be ready to be applied - maybeArg <- popArg - case maybeArg of - Just pushedArg -> do - -- this is a func looking to be applied - (tyArg, subs) <- listen (pushedArg `isSubtypeOf` tArg) - - -- use substitutions to replace what we have learned - -- the `undoSubs` put back any generalised vars to what they - -- were so that any unchanged type vars don't get turned into - -- unknowns unnecessarily - let realType = - substituteMany - (filterSubstitutions subs <> undoSubs) - (TFunc tAnn tClosure tyArg tBody) - - pure (mapOuterExprAnnotation (const realType) typedFn) -- replace type with clever one - Nothing -> pure typedFn - _ -> pure typedFn - - typedFn <- - pushArg (getExprAnnotation typedArg) - >> inferFn fn - - maybeReturnType <- getApplyReturnType (getExprAnnotation typedFn) - - finalReturnType <- case maybeReturnType of - Nothing -> case maybeCheckType of - Just typ -> pure typ - Nothing -> getUnknown ann - Just retType -> case maybeCheckType of - Just typ -> retType `isSubtypeOf` typ - Nothing -> pure retType - - pure (EApp finalReturnType typedFn typedArg) - --- | if a function is annotated, we can use it in it's own --- body, for recursion -withRecursiveFn :: - (MonadReader (TCEnv ann) m) => - ResolvedExpr ann -> - ResolvedExpr ann -> - m a -> - m a -withRecursiveFn (ELambda _ ident _) (EAnn _ fnTyp _) = - withVar ident fnTyp -withRecursiveFn _ _ = id - -checkLambda :: - ( MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - Show ann, - Ord ann - ) => - ResolvedType ann -> - ResolvedDep Identifier -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -checkLambda (TFunc tAnn _ tFrom tTo) ident body = do - maybeArg <- popArg - realFrom <- case maybeArg of - Just arg -> arg `isSubtypeOf` tFrom - Nothing -> pure tFrom - (typedBody, typedClosure, subs) <- withVar ident realFrom $ do - (tBody, subs) <- listen (check tTo body) - tClosure <- M.delete ident <$> getClosureType tAnn tBody - pure (tBody, tClosure, subs) - let lambdaType = - substituteMany - (filterSubstitutions subs) - ( TFunc - tAnn - typedClosure - realFrom - (getExprAnnotation typedBody) - ) - pure (ELambda lambdaType ident typedBody) -checkLambda other@(TUnknown {}) ident body = do - -- unknown type - make a new unknown and keep smashing - let tAnn = getTypeAnnotation other - tyFrom <- getUnknown tAnn - (typedBody, typedClosure, subs) <- withVar ident tyFrom $ do - (tBody, subs) <- listen (infer body) - tClosure <- M.delete ident <$> getClosureType tAnn tBody - pure (tBody, tClosure, subs) - let lambdaType = - substituteMany - (filterSubstitutions subs) - ( TFunc - tAnn - typedClosure - tyFrom - (getExprAnnotation typedBody) - ) - pure (ELambda lambdaType ident typedBody) -checkLambda other _ _ = throwError (TCExpectedFunction other) - -inferLambda :: - ( Ord ann, - Show ann, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m - ) => - ann -> - ResolvedDep Identifier -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -inferLambda ann ident body = do - maybeTyp <- popArg - tyArg <- case maybeTyp of - Just typ -> pure typ - Nothing -> getUnknown ann - (typedBody, typedClosure, subs) <- withVar ident tyArg $ do - (tBody, subs) <- listen (infer body) - tClosure <- M.delete ident <$> getClosureType ann tBody - pure (tBody, tClosure, subs) - let lambdaType = - substituteMany - (filterSubstitutions subs) - (TFunc ann typedClosure tyArg (getExprAnnotation typedBody)) - pure (ELambda lambdaType ident typedBody) - --- | given an expected type --- check it makes sense -check :: - ( Ord ann, - Show ann, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m - ) => - ResolvedType ann -> - ResolvedExpr ann -> - m (ResolvedExpr (ResolvedType ann)) -check typ expr = do - case expr of - ELambda _ ident body -> - checkLambda typ ident body - EIf _ predExpr thenExpr elseExpr -> do - typedPred <- check (TPrim (getExprAnnotation predExpr) TPBool) predExpr - typedThen <- check typ thenExpr - typedElse <- check typ elseExpr - pure (EIf typ typedPred typedThen typedElse) - EApp ann fn arg -> - inferApplication ann (Just typ) fn arg - ETuple _ fstExpr restExpr -> - case typ of - TTuple tAnn tFst tRest -> do - when - (length tRest /= length restExpr) - (throwError $ TCTupleSizeMismatch (length restExpr + 1) typ) - typedFst <- check tFst fstExpr - typedRest <- neZipWithM check tRest restExpr - realType <- - TTuple tAnn (getExprAnnotation typedFst) (getExprAnnotation <$> typedRest) `isSubtypeOf` typ - pure $ ETuple realType typedFst typedRest - _ -> throwError (TCExpectedTuple typ) - EInfix _ OpAdd a b -> do - elabA <- check typ a - elabB <- check typ b - pure (EInfix typ OpAdd elabA elabB) - EPatternMatch _ matchExpr pats -> do - elabExpr <- infer matchExpr - let withPair (pat, patExpr) = do - (elabPat, newVars) <- checkPattern (getExprAnnotation elabExpr) pat - elabPatExpr <- withNewVars newVars (check typ patExpr) - pure (elabPat, elabPatExpr) - elabPats <- traverse withPair pats - pure (EPatternMatch typ elabExpr elabPats) - other -> do - inferredExpr <- infer other - (realType, subs) <- listen (getExprAnnotation inferredExpr `isSubtypeOf` typ) - pure $ inferredExpr $> substituteMany (filterSubstitutions subs) realType diff --git a/smol-core/src/Smol/Core/Typecheck/Errors.hs b/smol-core/src/Smol/Core/Typecheck/Errors.hs deleted file mode 100644 index 2d81d2bc..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Errors.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Smol.Core.Typecheck.Errors - ( typeErrorDiagnostic, - ) -where - -import Data.Maybe (catMaybes, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Error.Diagnose -import Smol.Core.Printer -import Smol.Core.SourceSpan (sourceSpan) -import qualified Smol.Core.Typecheck.Shared as Smol -import Smol.Core.Typecheck.Types -import qualified Smol.Core.Types as Smol -import Smol.Core.Types.SourceSpan - --- use the derived Foldable instance to get all annotations in an error -getAllAnnotations :: TCError ann -> [ann] -getAllAnnotations = foldMap pure - -positionFromAnnotation :: - String -> - Text -> - Smol.Annotation -> - Maybe Position -positionFromAnnotation path input ann = - let toPos ss = - Position - (ssRowStart ss, ssColStart ss) - (ssRowEnd ss, ssColEnd ss) - path - in toPos <$> sourceSpan input ann - -prettyPrint :: (Printer a) => a -> Text -prettyPrint = renderWithWidth 40 . prettyDoc - -typeErrorDiagnostic :: - Text -> - TCError Smol.Annotation -> - Diagnostic Text -typeErrorDiagnostic input e = - let filename = "" - diag = addFile def filename (T.unpack input) - in case e of - (TCTypeMismatch a b) -> - let report = - Err - Nothing - ( "Unification error! Expected matching types but found " - <> prettyPrint a - <> " and " - <> prettyPrint b - <> "." - ) - ( catMaybes - [ (,) - <$> positionFromAnnotation - filename - input - (Smol.getTypeAnnotation a) - <*> pure - ( This ("This has type " <> prettyPrint a) - ), - (,) - <$> positionFromAnnotation - filename - input - (Smol.getTypeAnnotation b) - <*> pure (Where ("This has type " <> prettyPrint b)) - ] - ) - ["These two values should be of the same type"] - in addReport diag report - other -> - let positions = - mapMaybe - (positionFromAnnotation filename input) - (getAllAnnotations other) - report = - Err - Nothing - (T.pack (show other)) - ((,Where "") <$> positions) - [] - in addReport diag report diff --git a/smol-core/src/Smol/Core/Typecheck/Exhaustiveness.hs b/smol-core/src/Smol/Core/Typecheck/Exhaustiveness.hs deleted file mode 100644 index 52d37004..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Exhaustiveness.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Exhaustiveness - ( isExhaustive, - redundantCases, - annihilate, - validatePatterns, - noDuplicateVariables, - smallerListVersions, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Data.Bifunctor (first) -import Data.Foldable -import Data.Functor -import Data.List (nub) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Monoid -import qualified Data.Set as S -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Types -import Smol.Core.Types -import Smol.Core.Types.PatternMatchError - -validatePatterns :: - ( MonadError (TCError Annotation) m, - MonadReader (TCEnv Annotation) m - ) => - ResolvedType Annotation -> - [Pattern ResolvedDep (ResolvedType Annotation)] -> - m () -validatePatterns ann patterns = do - traverse_ noDuplicateVariables patterns - missing <- isExhaustive patterns - _ <- case missing of - [] -> pure () - _ -> - throwError (TCPatternMatchError $ MissingPatterns ann missing) - redundant <- redundantCases patterns - case redundant of - [] -> pure () - _ -> - throwError (TCPatternMatchError $ RedundantPatterns ann redundant) - -noDuplicateVariables :: - ( MonadError (TCError Annotation) m - ) => - Pattern ResolvedDep (ResolvedType Annotation) -> - m () -noDuplicateVariables pat = do - let dupes = - M.keysSet - . M.filter (> 1) - . getVariables - $ pat - in if S.null dupes - then pure () - else - throwError - ( TCPatternMatchError $ - DuplicateVariableUse - (getPatternAnnotation pat) - dupes - ) - -getVariables :: - Pattern ResolvedDep (ResolvedType Annotation) -> - Map (ResolvedDep Identifier) Int -getVariables (PWildcard _) = mempty -getVariables (PLiteral _ _) = mempty -getVariables (PVar _ a) = M.singleton a 1 -getVariables (PTuple _ a as) = - M.unionWith (+) (getVariables a) (foldMap getVariables as) -{-getVariables (PRecord _ as) = -foldr (M.unionWith (+)) mempty (getVariables <$> as) -} -getVariables (PArray _ as spread) = - let vars = [getSpreadVariables spread] <> (getVariables <$> as) - in foldr (M.unionWith (+)) mempty vars -getVariables (PConstructor _ _ args) = - foldr (M.unionWith (+)) mempty (getVariables <$> args) - -{-getVariables (PString _ a as) = - M.unionWith (+) (getStringPartVariables a) (getStringPartVariables as) --} - -getSpreadVariables :: - Spread ResolvedDep (ResolvedType Annotation) -> - Map (ResolvedDep Identifier) Int -getSpreadVariables (SpreadValue _ a) = M.singleton a 1 -getSpreadVariables _ = mempty - -{- -getStringPartVariables :: (Ord var) => StringPart var Annotation -> Map var Int -getStringPartVariables (StrWildcard _) = mempty -getStringPartVariables (StrValue _ a) = M.singleton a 1 --} - --- | given a list of patterns, return a list of missing patterns -isExhaustive :: - ( MonadError (TCError Annotation) m, - MonadReader (TCEnv Annotation) m - ) => - [Pattern ResolvedDep (ResolvedType Annotation)] -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -isExhaustive patterns = do - generated <- mconcat <$> traverse generate patterns - pure $ filterMissing patterns generated - -generate :: - ( MonadError (TCError Annotation) m, - MonadReader (TCEnv Annotation) m - ) => - Pattern ResolvedDep (ResolvedType Annotation) -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -generate pat = (<>) [pat] <$> generateFromPattern pat - --- | Given a pattern, generate others required for it -generateFromPattern :: - ( MonadError (TCError Annotation) m, - MonadReader (TCEnv Annotation) m - ) => - Pattern ResolvedDep (ResolvedType Annotation) -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -generateFromPattern (PLiteral ty _) = generateFromType ty -generateFromPattern (PWildcard _) = pure mempty -generateFromPattern (PVar _ _) = pure mempty -generateFromPattern (PArray {}) = error "generateFromPattern PArray" -generateFromPattern (PTuple ty a as) = do - genAs <- traverse (\pat -> NE.toList <$> generateAlways (getPatternAnnotation pat) pat) (NE.cons a as) - let tuple ne = PTuple ty (NE.head ne) (NE.fromList $ NE.tail ne) - pure (tuple <$> sequence genAs) -generateFromPattern (PConstructor ty _constructor args) = do - (typeName, _args) <- liftEither $ first TCExpectedConstructorType $ flattenConstructorType ty - dt <- lookupTypeName typeName - _newFromArgs <- traverse generateFromPattern args - newDataTypes <- requiredFromDataType dt - let newCons = mempty -- PConstructor mempty tyCon <$> sequence newFromArgs - pure (newCons <> newDataTypes) - --- | used for tuples and constructors args --- (any "product" really) --- given (a,b) , return [(a, gennedForB1), (a, gennedForB), (gennedForA1, b), --- (gennedForA2, b)] -_generateMany :: - NE.NonEmpty (Pattern ResolvedDep (ResolvedType Annotation)) -> - m [NE.NonEmpty (Pattern ResolvedDep (ResolvedType Annotation))] -_generateMany = undefined - --- | Given a type, generate patterns, useful for literals where the type is --- most important -generateFromType :: - ( MonadError (TCError Annotation) m -- , - -- MonadReader (TCEnv Annotation) m - ) => - ResolvedType Annotation -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -generateFromType ty@(TLiteral _ literal) = - pure $ PLiteral ty <$> primsFromTypeLiteral literal -generateFromType ty@(TPrim _ TPBool) = - pure - [ PLiteral ty (PBool True), - PLiteral ty (PBool False) - ] -generateFromType ty@(TPrim _ TPInt) = - pure [PWildcard ty] -generateFromType _ = pure mempty - -generateAlways :: - (MonadError (TCError Annotation) m, MonadReader (TCEnv Annotation) m) => - ResolvedType Annotation -> - Pattern ResolvedDep (ResolvedType Annotation) -> - m (NE.NonEmpty (Pattern ResolvedDep (ResolvedType Annotation))) -generateAlways ty pat = do - generated <- generateFromPattern pat - case NE.nonEmpty generated of - Nothing -> pure (NE.singleton (PWildcard ty)) - Just other -> pure other - --- given a list [[1,2,3]], return [[1,2,3], [1,2], [1]] -smallerListVersions :: [[a]] -> [[a]] -smallerListVersions aas = - let get x = case x of - [] -> [] - (_ : as) -> get as <> [x] - in get =<< aas - -requiredFromDataType :: - (MonadError (TCError Annotation) m) => - DataType ResolvedDep Annotation -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -requiredFromDataType (DataType _ _ cons) = - if length cons < 2 -- if there is only one constructor don't generate more - then pure mempty - else do - let wrongValueThatTypechecks = TPrim mempty TPInt -- TODO: wrong, we need to apply args to type - new (n, as) = - [ PConstructor - wrongValueThatTypechecks - n - (PWildcard wrongValueThatTypechecks <$ as) - ] - pure $ mconcat (new . first LocalDefinition <$> M.toList cons) - --- filter outstanding items -filterMissing :: - (Eq ann) => - [Pattern ResolvedDep (ResolvedType ann)] -> - [Pattern ResolvedDep (ResolvedType ann)] -> - [Pattern ResolvedDep (ResolvedType ann)] -filterMissing patterns required = - nub $ foldr annihiliatePattern required patterns - where - annihiliatePattern pat = - filter - ( not - . annihilate - (removeAnn pat) - . removeAnn - ) - -removeAnn :: Pattern ResolvedDep ann -> Pattern ResolvedDep () -removeAnn p = p $> () - --- does left pattern satisfy right pattern? -annihilateAll :: - [(Pattern ResolvedDep (), Pattern ResolvedDep ())] -> - Bool -annihilateAll = - foldr - (\(a, b) keep -> keep && annihilate a b) - True - --- | if left is on the right, should we get rid? -annihilate :: Pattern ResolvedDep () -> Pattern ResolvedDep () -> Bool -annihilate l r = - case (l, r) of - (a, b) | a == b -> True - (PWildcard _, _) -> True -- wildcard trumps all - (PVar _ _, _) -> True -- as does var - (PTuple _ a as, PTuple _ b bs) -> - let allPairs = zip ([a] <> NE.toList as) ([b] <> NE.toList bs) - in annihilateAll allPairs - (PConstructor _ tyConA argsA, PConstructor _ tyConB argsB) -> - (tyConA == tyConB) - && annihilateAll - (zip argsA argsB) - (PTuple _ a as, _) -> - isComplete a && getAll (foldMap (All . isComplete) as) - _ -> False - --- is this item total, as such, ie, is it always true? -isComplete :: Pattern ResolvedDep ann -> Bool -isComplete (PWildcard _) = True -isComplete (PVar _ _) = True -isComplete (PTuple _ a as) = isComplete a && getAll (foldMap (All . isComplete) (NE.toList as)) -isComplete _ = False - -redundantCases :: - ( MonadError (TCError Annotation) m, - MonadReader (TCEnv Annotation) m - ) => - [Pattern ResolvedDep (ResolvedType Annotation)] -> - m [Pattern ResolvedDep (ResolvedType Annotation)] -redundantCases patterns = do - generated <- mconcat <$> traverse generate patterns - let annihiliatePattern pat = - filter - ( not - . annihilate - (removeAnn pat) - . removeAnn - ) - -- add index, the first pattern is never redundant - let patternsWithIndex = zip patterns ([0 ..] :: [Int]) - pure $ - snd $ - foldl' - ( \(remaining, redundant) (pat, i) -> - let rest = annihiliatePattern pat remaining - in if length rest == length remaining && i > 0 - then (rest, redundant <> [pat]) - else (rest, redundant) - ) - (generated, mempty) - patternsWithIndex diff --git a/smol-core/src/Smol/Core/Typecheck/FreeVars.hs b/smol-core/src/Smol/Core/Typecheck/FreeVars.hs deleted file mode 100644 index 3c8136f5..00000000 --- a/smol-core/src/Smol/Core/Typecheck/FreeVars.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.FreeVars - ( freeVars, - freeTypeVars, - ) -where - -import Data.Foldable (toList) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Set (Set) -import qualified Data.Set as S -import Smol.Core.TypeUtils (monoidType) -import Smol.Core.Types.Expr (Expr (..)) -import Smol.Core.Types.Identifier (Identifier) -import Smol.Core.Types.Type (Type (TVar)) - -freeVars :: - ( Ord ann, - Ord (dep Identifier) - ) => - Expr dep (Type dep ann) -> - Set (dep Identifier) -freeVars (EVar _ a) = S.singleton a -freeVars EConstructor {} = mempty -freeVars (ELambda _ ident body) = S.delete ident (freeVars body) -freeVars (ELet _ ident expr body) = freeVars expr <> S.delete ident (freeVars body) -freeVars (EInfix _ _ a b) = freeVars a <> freeVars b -freeVars EPrim {} = mempty -freeVars (EApp _ f a) = freeVars f <> freeVars a -freeVars (EIf _ a b c) = freeVars a <> freeVars b <> freeVars c -freeVars (EAnn _ _ a) = freeVars a -freeVars (ETuple _ a as) = - freeVars a <> mconcat (NE.toList $ freeVars <$> as) -freeVars (EArray _ as) = mconcat (freeVars <$> toList as) -freeVars (ERecord _ as) = mconcat (M.elems $ freeVars <$> as) -freeVars (ERecordAccess _ a _) = freeVars a -freeVars (EPatternMatch _ expr pats) = - let getPatRequire (_pat, _patExpr) = - mempty -- fucked - skipped test because cant be arsed right now - in freeVars expr <> mconcat (NE.toList $ getPatRequire <$> pats) - -freeTypeVars :: - (Ord (dep Identifier)) => - Type dep ann -> - Set (dep Identifier) -freeTypeVars (TVar _ ident) = S.singleton ident -freeTypeVars other = monoidType freeTypeVars other diff --git a/smol-core/src/Smol/Core/Typecheck/FromParsedExpr.hs b/smol-core/src/Smol/Core/Typecheck/FromParsedExpr.hs deleted file mode 100644 index 6a02bf10..00000000 --- a/smol-core/src/Smol/Core/Typecheck/FromParsedExpr.hs +++ /dev/null @@ -1,21 +0,0 @@ --- don't use this! -module Smol.Core.Typecheck.FromParsedExpr (fromParsedExpr, fromParsedType) where - -import Smol.Core.ExprUtils -import Smol.Core.Types.Expr -import Smol.Core.Types.ParseDep -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Type - -resolve :: ParseDep a -> ResolvedDep a -resolve (ParseDep a _) = emptyResolvedDep a - --- | `ParsedExpr` has module names --- | `ResolvedExpr` has module hashes and unique ids --- this is like NumberVars from main `mimsa`, but for now we'll bodge it --- to get things typechecking -fromParsedExpr :: ParsedExpr ann -> ResolvedExpr ann -fromParsedExpr = mapExprDep resolve - -fromParsedType :: Type ParseDep ann -> Type ResolvedDep ann -fromParsedType = mapTypeDep resolve diff --git a/smol-core/src/Smol/Core/Typecheck/Pattern.hs b/smol-core/src/Smol/Core/Typecheck/Pattern.hs deleted file mode 100644 index a9ca102c..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Pattern.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Smol.Core.Typecheck.Pattern - ( checkPattern, - ) -where - -import Control.Monad (when, zipWithM) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set.NonEmpty as NES -import Smol.Core.Helpers -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Simplify -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Types -import Smol.Core.Types - --- given the type of the expression in a pattern match, --- check that the pattern makes sense with it -checkPattern :: - ( Show ann, - Eq ann, - MonadError (TCError ann) m, - MonadReader (TCEnv ann) m, - MonadState (TCState ann) m, - MonadWriter [TCWrite ann] m - ) => - ResolvedType ann -> - Pattern ResolvedDep ann -> - m - ( Pattern ResolvedDep (ResolvedType ann), - Map (ResolvedDep Identifier) (ResolvedType ann) - ) -checkPattern checkTy checkPat = - case (simplifyType checkTy, checkPat) of - (TTuple _ tA tRest, PTuple ann pA pRest) | length tRest == length pRest -> do - (patA, envA) <- checkPattern tA pA - (patRest, envRest) <- neUnzip <$> neZipWithM checkPattern tRest pRest - let ty = TTuple ann (getPatternAnnotation patA) (getPatternAnnotation <$> patRest) - env = envA <> mconcat (NE.toList envRest) - pure (PTuple ty patA patRest, env) - (TUnknown _ a, PTuple ann pA pRest) -> do - tA <- getUnknown (getPatternAnnotation pA) - (patA, envA) <- checkPattern tA pA - tRest <- traverse (getUnknown . getPatternAnnotation) pRest - (patRest, envRest) <- neUnzip <$> neZipWithM checkPattern tRest pRest - let ty = TTuple ann tA tRest - env = envA <> mconcat (NE.toList envRest) - -- we have learned that our unknown type equals the tuple of new unknowns - -- we have created - tell [TCWSubstitution $ Substitution (SubUnknown a) ty] - pure (PTuple ty patA patRest, env) - (ty, PVar _ ident) -> - pure (PVar ty ident, M.singleton ident ty) - (ty, PWildcard _) -> pure (PWildcard ty, mempty) - (ty@(TLiteral _ (TLInt as)), PLiteral _ (PInt i)) - | NES.member i as -> - pure (PLiteral ty (PInt i), mempty) - (ty@(TLiteral _ tPrim), PLiteral _ pPrim) - | tPrim == typeLiteralFromPrim pPrim -> - pure (PLiteral ty pPrim, mempty) - (ty@(TPrim _ TPBool), PLiteral _ (PBool b)) -> - pure (PLiteral ty (PBool b), mempty) - (ty@(TPrim _ TPInt), PLiteral _ (PInt b)) -> - pure (PLiteral ty (PInt b), mempty) - (ty@(TPrim _ TPString), PLiteral _ (PString s)) -> - pure (PLiteral ty (PString s), mempty) - (ty@(TArray _ arrSize tyArr), PArray ann items spread) -> do - inferEverything <- traverse (checkPattern tyArr) items - (inferSpread, env2) <- case spread of - SpreadValue _ binder -> do - let env = M.singleton binder ty - pure - ( SpreadValue ty binder, - env - ) - NoSpread -> pure (NoSpread, mempty) - SpreadWildcard _ -> do - pure (SpreadWildcard ty, mempty) - - let newEnv = mconcat (snd <$> inferEverything) <> env2 - - pure - ( PArray - ( TArray - ann - arrSize - tyArr - ) - (fst <$> inferEverything) - inferSpread, - newEnv - ) - (ty, PConstructor ann constructor args) -> do - -- we don't check the constructor is valid yet - let flattened = flattenConstructorType ty - - -- lookup the constructor itself (ie, `Just`, `Nothing`) - (patTypeName, dtArgs, otherConstructors, consArgs) <- - lookupConstructor constructor - - case flattened of - Left _ -> do - (patArgs, envArgs) <- - unzip <$> zipWithM checkPattern consArgs args - - -- check number of args matches what constructor expects - when - (length patArgs /= length consArgs) - $ throwError - (TCConstructorArgumentMismatch constructor (length consArgs) (length patArgs)) - - let constructorTy = dataTypeWithVars ann patTypeName consArgs - pure (PConstructor constructorTy constructor patArgs, mconcat envArgs) - Right (typeName, tyArgs) -> do - -- check constructor lives in type - when (typeName /= patTypeName) $ - throwError (TCUnknownConstructor constructor otherConstructors) - - let pairs = zipWith (Substitution . SubId . LocalDefinition) dtArgs tyArgs - resolvedArgs = substituteMany pairs <$> consArgs - - (patArgs, envArgs) <- - unzip <$> zipWithM checkPattern resolvedArgs args -- tyArgs was consArgs - - -- check number of args matches what constructor expects - when - (length patArgs /= length consArgs) - $ throwError - (TCConstructorArgumentMismatch constructor (length consArgs) (length patArgs)) - - let constructorTy = dataTypeWithVars ann patTypeName tyArgs - pure (PConstructor constructorTy constructor patArgs, mconcat envArgs) - (otherTy, otherPat) -> throwError (TCPatternMismatch otherPat otherTy) diff --git a/smol-core/src/Smol/Core/Typecheck/Shared.hs b/smol-core/src/Smol/Core/Typecheck/Shared.hs deleted file mode 100644 index d846db5a..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Shared.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Typecheck.Shared - ( module Smol.Core.Typecheck.Annotations, - getUnknown, - getClosureType, - reduceType, - lookupVar, - popArg, - flattenConstructorType, - flattenConstructorApplication, - withVar, - dataTypeWithVars, - withNewVars, - pushArg, - getApplyReturnType, - lookupConstructor, - lookupTypeName, - typeForConstructor, - freshen, - primsFromTypeLiteral, - typeLiteralFromPrim, - isNatLiteral, - isIntLiteral, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Foldable (foldl') -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe, mapMaybe) -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Smol.Core.Helpers -import Smol.Core.Typecheck.Annotations -import Smol.Core.Typecheck.FreeVars -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Types -import Smol.Core.Types - -lookupTypeName :: - ( MonadReader (TCEnv ann) m - ) => - ResolvedDep TypeName -> - m (DataType ResolvedDep ann) -lookupTypeName tn = do - maybeDt <- asks (M.lookup tn . tceDataTypes) - case maybeDt of - Just dt -> pure dt - Nothing -> error $ "couldn't find datatype for " <> show tn - -primsFromTypeLiteral :: TypeLiteral -> [Prim] -primsFromTypeLiteral (TLInt is) = PInt <$> S.toList (NES.toSet is) -primsFromTypeLiteral (TLString strs) = PString <$> S.toList (NES.toSet strs) -primsFromTypeLiteral (TLBool b) = [PBool b] -primsFromTypeLiteral TLUnit = [PUnit] - -getUnknown :: (MonadState (TCState ann) m) => ann -> m (ResolvedType ann) -getUnknown ann = do - count <- gets tcsUnknown - modify (\s -> s {tcsUnknown = count + 1}) - pure (TUnknown ann count) - --- | this needs some thought. Our closures shouldn't contain any external deps, --- but we do want to ensure uniqueness, so our Identifier type should probably --- be `(Identifier, Maybe Int)` or something -getClosureType :: - ( MonadState (TCState ann) m, - MonadReader (TCEnv ann) m, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m, - Ord ann - ) => - ann -> - ResolvedExpr (ResolvedType ann) -> - m (Map (ResolvedDep Identifier) (ResolvedType ann)) -getClosureType ann body = - mconcat - <$> traverse - ( \ident -> - M.singleton ident <$> lookupVar ann ident - ) - (S.toList (freeVars body)) - --- reduce TApp (TFunc a b) etc -reduceType :: (Eq (dep Identifier)) => Type dep ann -> Type dep ann -reduceType = reduceTypeInner - where - reduceTypeInner (TApp ann (TApp _ (TFunc _ _ (TVar _ varA) body) a) b) = - reduceTypeInner (TApp ann (substituteMany [Substitution (SubId varA) a] body) b) - reduceTypeInner (TApp _ (TFunc _ _ (TVar _ var) body) a) = - reduceTypeInner (substituteMany [Substitution (SubId var) a] body) - reduceTypeInner (TApp ann (TApp _ (TFunc _ _ (TUnknown _ iA) body) a) b) = - reduceTypeInner (TApp ann (substituteMany [Substitution (SubUnknown iA) a] body) b) - reduceTypeInner (TApp _ (TFunc _ _ (TUnknown _ iB) body) a) = - reduceTypeInner (substituteMany [Substitution (SubUnknown iB) a] body) - reduceTypeInner other = other - -getApplyReturnType :: - (MonadError (TCError ann) m) => - ResolvedType ann -> - m (Maybe (ResolvedType ann)) -getApplyReturnType (TFunc _ _ _ typ) = pure (Just typ) -getApplyReturnType tApp@TApp {} = pure (Just tApp) -getApplyReturnType (TUnknown {}) = - pure Nothing -getApplyReturnType other = - throwError $ TCExpectedFunction other - --- | given the constructor name, see where it lives and gather details -lookupConstructor :: - ( MonadReader (TCEnv ann) m, - MonadError (TCError ann) m - ) => - ResolvedDep Constructor -> - m (ResolvedDep TypeName, [Identifier], [Constructor], [ResolvedType ann]) -lookupConstructor constructor = do - maybeDt <- - asks - ( mapFind - ( \(DataType typeName vars constructors) -> - (,,,) - (emptyResolvedDep typeName) - vars - (M.keys constructors) - <$> M.lookup (rdIdentifier constructor) constructors - ) - . tceDataTypes - ) - case maybeDt of - Just dtInfo -> pure dtInfo - Nothing -> do - allDataTypes <- asks tceDataTypes - let availableConstructors = concatMap (\(DataType _ _ as) -> M.keys as) (M.elems allDataTypes) - throwError (TCUnknownConstructor constructor availableConstructors) - -dataTypeWithVars :: - ann -> - ResolvedDep TypeName -> - [ResolvedType ann] -> - ResolvedType ann -dataTypeWithVars ann tyName = - foldl' - (TApp ann) - (TConstructor ann tyName) - -typeForConstructor :: - (MonadState (TCState ann) m) => - ann -> - ResolvedDep TypeName -> - [Identifier] -> - [ResolvedType ann] -> - m (ResolvedType ann) -typeForConstructor ann typeName vars args = do - -- replace variables with fresh boys - subs <- traverse (\var -> Substitution (SubId (emptyResolvedDep var)) <$> getUnknown ann) vars - - pure $ - substituteMany subs $ - foldr - (TFunc ann mempty) - (dataTypeWithVars ann typeName (TVar ann . emptyResolvedDep <$> vars)) - args - -lookupVar :: - ( MonadState (TCState ann) m, - MonadReader (TCEnv ann) m, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m - ) => - ann -> - ResolvedDep Identifier -> - m (ResolvedType ann) -lookupVar ann ident = do - maybeVar <- asks (M.lookup ident . tceVars) - case maybeVar of - Just (_constraints, expr) -> - -- TODO: raise constraints used maybe? - pure expr - Nothing -> do - classes <- asks tceClasses - - let getInnerIdent (TypeclassCall i _) = Just i - getInnerIdent (LocalDefinition i) = Just i -- not sure if this should happen but it makes testing waaaay easier - getInnerIdent _ = Nothing - - -- if name matches typeclass instance, return freshened type - case listToMaybe $ M.elems $ M.filter (\tc -> Just (tcFuncName tc) == getInnerIdent ident) classes of - -- need to turn Type Identity ann into Type ResolvedDep ann - Just tc -> do - (newType, undoSubs) <- freshen (tcFuncType tc) - tell [TCWTypeclassUse ident (tcName tc) (pairFromSubs undoSubs)] - pure newType - Nothing -> throwError (TCCouldNotFindVar ann ident) - -pairFromSubs :: [Substitution ResolvedDep ann] -> [(Identifier, Integer)] -pairFromSubs = - mapMaybe - ( \case - (Substitution (SubUnknown i) (TVar _ (LocalDefinition var))) -> Just (var, i) - _ -> Nothing - ) - -withVar :: - (MonadReader (TCEnv ann) m) => - ResolvedDep Identifier -> - ResolvedType ann -> - m a -> - m a -withVar ident expr = - local - ( \env -> - env {tceVars = M.singleton ident (mempty, expr) <> tceVars env} - ) - -pushArg :: - (MonadState (TCState ann) m) => - ResolvedType ann -> - m () -pushArg typ = do - modify - ( \st -> - st {tcsArgStack = typ : tcsArgStack st} - ) - --- | pass stack arg to action and remove it -popArg :: (MonadState (TCState ann) m) => m (Maybe (ResolvedType ann)) -popArg = do - topVal <- gets (listToMaybe . tcsArgStack) - modify - ( \st -> - st - { tcsArgStack = case tcsArgStack st of - [] -> [] - as -> tail as - } - ) - pure topVal - --- | replace TVar with new TUnknown --- | we also return the subs so they can be undone, as such, if needed -freshen :: - (MonadState (TCState ann) m) => - ResolvedType ann -> - m (ResolvedType ann, [Substitution ResolvedDep ann]) -freshen ty = do - pairs <- - traverse - ( \var -> do - unknown <- getUnknown (getTypeAnnotation ty) - pure (var, unknown) - ) - (S.toList $ freeTypeVars ty) - let subs = (\(var, unknown) -> Substitution (SubId var) unknown) <$> pairs - undo = - mapMaybe - ( \(var, unknown) -> - let varType = TVar (getTypeAnnotation ty) var - in case unknown of - TUnknown _ uid -> Just (Substitution (SubUnknown uid) varType) - _ -> Nothing - ) - pairs - pure (substituteMany subs ty, undo) - --- untangle a bunch of TApp (TApp (TConstructor typeName) 1) True into `(typeName, [1, True])` --- to make it easier to match up with patterns -flattenConstructorType :: - (Show (dep Identifier), Show (dep TypeName)) => - Type dep ann -> - Either (Type dep ann) (dep TypeName, [Type dep ann]) -flattenConstructorType (TApp _ f a) = do - (typeName, as) <- flattenConstructorType f - pure (typeName, as <> [a]) -flattenConstructorType (TConstructor _ typeName) = - pure (typeName, mempty) -flattenConstructorType ty = throwError ty - --- untangle a bunch of TApp (TApp (TConstructor typeName) 1) True into `(typeName, [1, True])` --- to make it easier to match up with patterns -flattenConstructorApplication :: - Expr dep ann -> Maybe (dep Constructor, [Expr dep ann]) -flattenConstructorApplication (EApp _ f a) = do - (constructor, as) <- flattenConstructorApplication f - pure (constructor, as <> [a]) -flattenConstructorApplication (EConstructor _ constructor) = - pure (constructor, mempty) -flattenConstructorApplication _ = Nothing - --- given a map of identifiers to types, run the enclosed action --- useful for typechecking the right hand side of a pattern match, where --- we add in the bound variables (but they don't exist outside this context) -withNewVars :: - (MonadReader (TCEnv ann) m) => - Map (ResolvedDep Identifier) (ResolvedType ann) -> - m a -> - m a -withNewVars vars = - local (\env -> env {tceVars = ((,) mempty <$> vars) <> tceVars env}) - -typeLiteralFromPrim :: Prim -> TypeLiteral -typeLiteralFromPrim (PBool b) = TLBool b -typeLiteralFromPrim (PInt a) = TLInt (NES.singleton a) -typeLiteralFromPrim (PString str) = TLString (NES.singleton str) -typeLiteralFromPrim PUnit = TLUnit - --- | this is a sign we're encoding unions all wrong I think, but let's just --- follow this through -isNatLiteral :: Type dep ann -> Bool -isNatLiteral (TLiteral _ (TLInt a)) | all (>= 0) a = True -isNatLiteral _ = False - -isIntLiteral :: Type dep ann -> Bool -isIntLiteral (TLiteral _ (TLInt _)) = True -isIntLiteral _ = False diff --git a/smol-core/src/Smol/Core/Typecheck/Simplify.hs b/smol-core/src/Smol/Core/Typecheck/Simplify.hs deleted file mode 100644 index 2d988341..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Simplify.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Simplify (simplifyType) where - -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Smol.Core.TypeUtils -import Smol.Core.Typecheck.Shared -import Smol.Core.Types - --- reduce infix into result if possible, if not, leave as infix -simplifyAdd :: - ann -> - Type dep ann -> - Type dep ann -> - Type dep ann -simplifyAdd ann (TLiteral _ (TLInt as)) (TLiteral _ (TLInt bs)) = - TLiteral ann (TLInt allLiterals) - where - allLiterals = - NES.unsafeFromSet $ - S.map (uncurry (+)) $ - S.cartesianProduct (NES.toSet as) (NES.toSet bs) -simplifyAdd ann (TLiteral _ (TLString as)) (TLiteral _ (TLString bs)) = - TLiteral ann (TLString allLiterals) - where - allLiterals = - NES.unsafeFromSet $ - S.map (uncurry (<>)) $ - S.cartesianProduct (NES.toSet as) (NES.toSet bs) -simplifyAdd ann (TPrim _ primA) (TPrim _ primB) | primA == primB = TPrim ann primA -- collapse matching prims -simplifyAdd ann (TLiteral _ (TLString _)) (TPrim _ TPString) = TPrim ann TPString -simplifyAdd ann (TPrim _ TPString) (TLiteral _ (TLString _)) = TPrim ann TPString -simplifyAdd ann a (TPrim _ TPInt) | isIntLiteral a = TPrim ann TPInt -simplifyAdd ann (TPrim _ TPInt) b | isIntLiteral b = TPrim ann TPInt -simplifyAdd ann a b = TInfix ann OpAdd a b - -simplifyEquals :: ann -> Type dep ann -> Type dep ann -> Type dep ann -simplifyEquals ann (TLiteral _ litA) (TLiteral _ litB) = - TLiteral ann (TLBool $ litA == litB) -simplifyEquals ann _ _ = TPrim ann TPBool - -simplifyType :: - ( Show (dep Identifier), - Show (dep TypeName), - Show ann - ) => - Type dep ann -> - Type dep ann -simplifyType (TInfix ann OpAdd a b) = - simplifyAdd ann (simplifyType a) (simplifyType b) -simplifyType (TInfix ann OpEquals a b) = - simplifyEquals ann (simplifyType a) (simplifyType b) -simplifyType other = - mapType simplifyType other diff --git a/smol-core/src/Smol/Core/Typecheck/Substitute.hs b/smol-core/src/Smol/Core/Typecheck/Substitute.hs deleted file mode 100644 index 721d7011..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Substitute.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Smol.Core.Typecheck.Substitute - ( Substitution (..), - SubstitutionMatcher (..), - substituteMany, - getUnknownId, - ) -where - -import Smol.Core.Typecheck.Types.Substitution -import Smol.Core.Types - -getSubId :: SubstitutionMatcher dep ann -> Maybe (dep Identifier) -getSubId (SubId subId) = Just subId -getSubId _ = Nothing - -getUnknownId :: SubstitutionMatcher dep ann -> Maybe Integer -getUnknownId (SubUnknown i) = Just i -getUnknownId _ = Nothing - -substituteMany :: (Eq (dep Identifier)) => [Substitution dep ann] -> Type dep ann -> Type dep ann -substituteMany subs ty = - foldl (flip substitute) ty subs - -substitute :: - (Eq (dep Identifier)) => - Substitution dep ann -> - Type dep ann -> - Type dep ann -substitute sub@(Substitution i ty) = \case - TVar _ a | Just a == getSubId i -> ty - TVar ann a -> TVar ann a - TUnknown _ a | Just a == getUnknownId i -> ty - TUnknown ann a -> TUnknown ann a - TConstructor ann a -> TConstructor ann a - TFunc ann closure fn arg -> - TFunc ann (substitute sub <$> closure) (substitute sub fn) (substitute sub arg) - TInfix ann op a b -> - TInfix ann op (substitute sub a) (substitute sub b) - TApp ann a b -> - TApp ann (substitute sub a) (substitute sub b) - TArray ann size as -> - TArray ann size (substitute sub as) - TTuple ann tFst tRest -> - TTuple ann (substitute sub tFst) (substitute sub <$> tRest) - TRecord ann items -> - TRecord ann (fmap (substitute sub) items) - prim@TPrim {} -> prim - lit@TLiteral {} -> lit diff --git a/smol-core/src/Smol/Core/Typecheck/Subtype.hs b/smol-core/src/Smol/Core/Typecheck/Subtype.hs deleted file mode 100644 index c540369e..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Subtype.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Subtype - ( isSubtypeOf, - combineMany, - combineTypeMaps, - generaliseLiteral, - isNatLiteral, - isIntLiteral, - typeAddition, - ) -where - -import Control.Monad (when, zipWithM) -import Control.Monad.Except -import Control.Monad.Writer.CPS -import Data.Bifunctor (first) -import Data.Foldable (foldl', foldrM) -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Smol.Core.Helpers -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Simplify -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Types -import Smol.Core.Types - -combineTypeMaps :: - ( Eq ann, - Show ann, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m - ) => - GlobalMap ann -> - GlobalMap ann -> - m (GlobalMap ann) -combineTypeMaps (GlobalMap mapA) (GlobalMap mapB) = do - let combineTypes (a, b) = - -- this should probably use combine also - isSubtypeOf a b - mapBoth <- traverse combineTypes (M.intersectionWith (,) mapA mapB) - pure $ GlobalMap (mapBoth <> mapA <> mapB) - --- given a literal, get the "rough" type of it -generaliseLiteral :: - ResolvedType ann -> - ResolvedType ann -generaliseLiteral (TLiteral ann (TLInt _)) = - TPrim ann TPInt -generaliseLiteral (TLiteral ann (TLBool _)) = - TPrim ann TPBool -generaliseLiteral (TLiteral ann (TLString _)) = - TPrim ann TPString -generaliseLiteral a = a - --- | used to combine branches of if or case matches -combineMany :: - ( MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m, - Show ann, - Eq ann - ) => - NE.NonEmpty (ResolvedType ann) -> - m (ResolvedType ann) -combineMany types = - foldrM combine (NE.head types) (NE.tail types) - --- | when calculating type for addition, we try and do the actual sum, --- otherwise treat literals as their more generic types (int, nat, etc) and --- then subtype as usual to check for errors -typeAddition :: - ( Eq ann, - Show ann, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m - ) => - ResolvedType ann -> - ResolvedType ann -> - m (ResolvedType ann) -typeAddition (TLiteral ann (TLInt as)) (TLiteral _ (TLInt bs)) = - pure $ TLiteral ann (TLInt allLiterals) - where - allLiterals = - NES.unsafeFromSet $ - S.map (uncurry (+)) $ - S.cartesianProduct (NES.toSet as) (NES.toSet bs) -typeAddition (TLiteral ann (TLString as)) (TLiteral _ (TLString bs)) = - pure $ TLiteral ann (TLString allLiterals) - where - allLiterals = - NES.unsafeFromSet $ - S.map (uncurry (<>)) $ - S.cartesianProduct (NES.toSet as) (NES.toSet bs) -typeAddition (TLiteral ann (TLString _)) b = - isSubtypeOf (TPrim ann TPString) b -typeAddition a (TLiteral ann (TLString _)) = - isSubtypeOf a (TPrim ann TPString) -typeAddition a b - | isIntLiteral a = - isSubtypeOf (TPrim (getTypeAnnotation a) TPInt) b -typeAddition a b - | isIntLiteral b = - isSubtypeOf a (TPrim (getTypeAnnotation b) TPInt) -typeAddition a b = - isSubtypeOf a b `catchError` const (isSubtypeOf b a) - --- try and combine two types, either by getting the subtype or union-ing --- literals together -combine :: - ( Eq ann, - Show ann, - MonadError (TCError ann) m, - MonadWriter [TCWrite ann] m - ) => - ResolvedType ann -> - ResolvedType ann -> - m (ResolvedType ann) -combine a b = - isSubtypeOf a b - `catchError` const (isSubtypeOf b a) - `catchError` const asUnion - where - asUnion = case (a, b) of - (TLiteral ann (TLInt as), TLiteral _ (TLInt bs)) -> - pure $ TLiteral ann (TLInt $ as <> bs) - (TLiteral ann (TLString as), TLiteral _ (TLString bs)) -> - pure $ TLiteral ann (TLString $ as <> bs) - (TLiteral ann (TLBool bA), TLiteral _ (TLBool bB)) - | bA /= bB -> - pure $ TPrim ann TPBool -- don't have True | False, it's silly - _ -> throwError (TCTypeMismatch a b) - -typeEquals :: ResolvedType ann -> ResolvedType ann -> Bool -typeEquals a b = (a $> ()) == (b $> ()) - --- | is the RHS an equal or more general expression of the LHS? --- | expressed like this so we can try both sides quickly -isLiteralSubtypeOf :: ResolvedType ann -> ResolvedType ann -> Bool -isLiteralSubtypeOf a b | a `typeEquals` b = True -isLiteralSubtypeOf (TLiteral _ (TLBool _)) (TPrim _ TPBool) = True -- a Bool literal is a Bool -isLiteralSubtypeOf (TLiteral _ (TLInt as)) (TLiteral _ (TLInt bs)) | NES.isSubsetOf as bs = True -isLiteralSubtypeOf (TLiteral _ (TLInt _)) (TPrim _ TPInt) = True -- a Nat literal is also an Int -isLiteralSubtypeOf (TLiteral _ (TLString _)) (TPrim _ TPString) = True -- any string literal is a String -isLiteralSubtypeOf union (TPrim _ TPInt) | isIntLiteral union = True -isLiteralSubtypeOf _ _ = False - -isSubtypeOf :: - ( MonadWriter [TCWrite ann] m, - MonadError (TCError ann) m, - Eq ann, - Show ann - ) => - ResolvedType ann -> - ResolvedType ann -> - m (ResolvedType ann) -isSubtypeOf a b = isSubtypeInner (simplifyType a) (simplifyType b) - --- smash two types together, learn something --- Repeat after me, Duck is a subtype of Bird --- 1 is a subtype of 1 | 2 --- 1 | 2 is a subtype of Nat --- Nat is a subtype of Int -isSubtypeInner :: - ( MonadWriter [TCWrite ann] m, - MonadError (TCError ann) m, - Eq ann, - Show ann - ) => - ResolvedType ann -> - ResolvedType ann -> - m (ResolvedType ann) -isSubtypeInner a b | isLiteralSubtypeOf a b = pure b -- choose the more general of the two types -isSubtypeInner (TRecord annA itemsA) (TRecord _annB itemsB) = - let missing = M.difference itemsB itemsA - in if M.null missing - then do - (GlobalMap allItems) <- combineTypeMaps (GlobalMap itemsA) (GlobalMap itemsB) - pure (TRecord annA allItems) - else throwError (TCRecordMissingItems $ M.keysSet missing) -isSubtypeInner (TVar ann a) (TVar ann' b) = - if a == b - then pure (TVar ann a) - else throwError (TCTypeMismatch (TVar ann a) (TVar ann' b)) --- unknowns go before vars because they are weaker, as such -isSubtypeInner (TUnknown _ i) b = - tell [TCWSubstitution $ Substitution (SubUnknown i) b] - >> pure b -isSubtypeInner a (TUnknown _ i) = - tell [TCWSubstitution $ Substitution (SubUnknown i) a] - >> pure a -isSubtypeInner (TVar _ ident) b = - tell [TCWSubstitution $ Substitution (SubId ident) b] - >> pure b -isSubtypeInner a (TVar _ ident) = - tell [TCWSubstitution $ Substitution (SubId ident) a] - >> pure a -isSubtypeInner (TInfix ann op a b) c = - TInfix ann op <$> isSubtypeInner a c <*> isSubtypeInner b c -isSubtypeInner (TTuple annA fstA restA) (TTuple _annB fstB restB) = - do - tyFst <- isSubtypeInner fstA fstB - tyRest <- neZipWithM isSubtypeInner restA restB - pure (TTuple annA tyFst tyRest) -isSubtypeInner (TArray ann i a) (TArray _ _ b) = do - inner <- isSubtypeInner a b - pure (TArray ann i inner) -- should we checking array length? -isSubtypeInner tA@(TApp tyAnn lA lB) tB@(TApp _ rA rB) = do - -- need to check for variables in here - let result = - first - TCExpectedConstructorType - ((,) <$> flattenConstructorType tA <*> flattenConstructorType tB) - case result of - Right ((typeNameA, argsA), (typeNameB, argsB)) -> do - when (typeNameA /= typeNameB) $ throwError (TCTypeMismatch tA tB) - tyArgs <- zipWithM isSubtypeInner argsA argsB - let ann = getTypeAnnotation tA - pure $ foldl' (TApp ann) (TConstructor ann typeNameA) tyArgs - Left _ -> do - -- this might be type vars instead of a concrete TConstructor etc, - -- so just split and subtype as normal - tyA <- isSubtypeInner lA rA - tyB <- isSubtypeInner lB rB - pure (TApp tyAnn tyA tyB) -isSubtypeInner (TFunc ann lClosure lA lB) (TFunc _ rClosure rA rB) = do - tyA <- isSubtypeInner lA rA - tyB <- isSubtypeInner rB lB - pure (TFunc ann (lClosure <> rClosure) tyA tyB) -isSubtypeInner a b = - if (a $> ()) == (b $> ()) - then pure a - else throwError (TCTypeMismatch a b) diff --git a/smol-core/src/Smol/Core/Typecheck/Typecheck.hs b/smol-core/src/Smol/Core/Typecheck/Typecheck.hs deleted file mode 100644 index a495a2a7..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typecheck.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Typecheck - ( typecheck, - ) -where - -import Control.Monad.Except -import Smol.Core.Typecheck.Elaborate (elaborate) -import Smol.Core.Typecheck.Typeclass.Deduplicate (deduplicateConstraints) -import Smol.Core.Typecheck.Types -import Smol.Core.Types - --- elaborate an expression, returning it along with constraints, --- with `\instances -> ...` where there are constraints -typecheck :: - (MonadError (TCError ann) m, Monoid ann, Show ann, Ord ann) => - TCEnv ann -> - ResolvedExpr ann -> - m ([Constraint ResolvedDep ann], ResolvedExpr (ResolvedType ann)) -typecheck env expr = do - (typedExpr, typeclassUses) <- elaborate env expr - - -- deduplicate constraints, and match them to the variables that use them - pure (deduplicateConstraints typeclassUses typedExpr) diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass.hs deleted file mode 100644 index 68035015..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Smol.Core.Typecheck.Typeclass - ( module Smol.Core.Typecheck.Typeclass.Helpers, - module Smol.Core.Typecheck.Typeclass.Deduplicate, - module Smol.Core.Typecheck.Typeclass.Typecheck, - module Smol.Core.Typecheck.Typeclass.ToDictionaryPassing, - ) -where - -import Smol.Core.Typecheck.Typeclass.Deduplicate -import Smol.Core.Typecheck.Typeclass.Helpers -import Smol.Core.Typecheck.Typeclass.ToDictionaryPassing -import Smol.Core.Typecheck.Typeclass.Typecheck diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Deduplicate.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Deduplicate.hs deleted file mode 100644 index 10b7f110..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Deduplicate.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Typecheck.Typeclass.Deduplicate - ( deduplicateConstraints, - findDedupedConstraints, - identForConstraint, - ) -where - -import Data.Foldable (foldl') -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Smol.Core.ExprUtils -import Smol.Core.Typecheck.Typeclass.Helpers (isConcrete) -import Smol.Core.Typecheck.Types -import Smol.Core.Types - --- | find deduplicated constraints and apply them to expr -deduplicateConstraints :: - (Ord ann) => - M.Map (ResolvedDep Identifier) (Constraint ResolvedDep ann) -> - Expr ResolvedDep (Type ResolvedDep ann) -> - ([Constraint ResolvedDep ann], Expr ResolvedDep (Type ResolvedDep ann)) -deduplicateConstraints constraints expr = do - let (dedupedConstraints, nameSwaps) = findDedupedConstraints constraints - in (dedupedConstraints, swapExprVarnames nameSwaps expr) - -identForConstraint :: Integer -> ResolvedDep Identifier -identForConstraint = TypeclassCall "valuefromdictionary" . fromIntegral - --- just because we use a method twice doesn't mean we want to pass it in twice --- returns a new ordered set of constraints with fresh names, --- and a list of substitutions to change in the expression to make everything --- work -findDedupedConstraints :: - (Ord ann) => - M.Map (ResolvedDep Identifier) (Constraint ResolvedDep ann) -> - ([Constraint ResolvedDep ann], M.Map (ResolvedDep Identifier) (ResolvedDep Identifier)) -findDedupedConstraints dupes = - let initial = (mempty, mempty, 0) - deduped = - foldl' - ( \(found, swaps, count) (ident, constraint) -> - if isConcrete constraint - then (found, swaps, count) - else case M.lookup constraint found of - Just foundIdent -> - ( found, - swaps <> M.singleton ident foundIdent, - count - ) - Nothing -> - let newCount = count + 1 - newIdent = identForConstraint count - in ( found <> M.singleton constraint newIdent, - swaps <> M.singleton ident newIdent, - newCount - ) - ) - initial - (M.toList dupes) - (finalFound, finalSwaps, _) = deduped - in (fst <$> M.toList finalFound, finalSwaps) - --- | swap var names of typeclass calls for their new deduped ones -swapExprVarnames :: - M.Map (ResolvedDep Identifier) (ResolvedDep Identifier) -> - Expr ResolvedDep ann -> - Expr ResolvedDep ann -swapExprVarnames swappies = - go - where - newIdent ident = fromMaybe ident (M.lookup ident swappies) - - go (EVar ann ident) = - EVar ann (newIdent ident) - go (ELambda ann ident body) = - ELambda ann (newIdent ident) (go body) - go other = mapExpr go other diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Helpers.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Helpers.hs deleted file mode 100644 index 9dd7f82e..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Helpers.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Smol.Core.Typecheck.Typeclass.Helpers - ( recoverTypeclassUses, - constraintsFromTLE, - lookupTypeclassInstance, - matchType, - lookupTypeclass, - instanceMatchesType, - isConcrete, - recoverInstance, - specialiseConstraint, - substituteConstraint, - envFromTypecheckedModule, - addTypesToConstraint, - removeTypesFromConstraint, - applyConstraintTypes, - getTypeclassMethodNames, - getVarsInScope, - ) -where - -import Control.Monad (zipWithM) -import Control.Monad.Except -import Data.Foldable (traverse_) -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe, mapMaybe) -import Data.Monoid -import qualified Data.Set as S -import Smol.Core.Helpers -import Smol.Core.Modules.Types -import Smol.Core.TypeUtils -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Substitute -import Smol.Core.Typecheck.Types -import Smol.Core.Types - --- let's get all the method names from the Typeclasses --- mentioned in the instance constraints -getTypeclassMethodNames :: TCEnv ann -> S.Set Identifier -getTypeclassMethodNames tcEnv = - S.fromList $ - tcFuncName <$> M.elems (tceClasses tcEnv) - --- this just chucks types in any order and will break on multi-parameter type --- classes -recoverTypeclassUses :: - (Monoid ann) => - [TCWrite ann] -> - M.Map (ResolvedDep Identifier) (Constraint ResolvedDep ann) -recoverTypeclassUses events = - let allSubs = filterSubstitutions events - allTCs = filterTypeclassUses events - substituteMatch (ident, unknownId) = - (ident, substituteMany allSubs (TUnknown mempty unknownId)) - fixTC (identifier, name, matches) = - (identifier, name, substituteMatch <$> matches) - toConstraint (identifier, name, fixedMatches) = - M.singleton identifier (Constraint name (snd <$> fixedMatches)) - in mconcat $ toConstraint . fixTC <$> allTCs - --- thing we're matching, typeclass we're checking --- pretty sure this is still incomplete -matchType :: - (Eq (dep TypeName)) => - Type dep ann -> - Type dep ann -> - Either - (Type dep ann, Type dep ann) - [Substitution dep ann] -matchType ty (TVar _ ident) = - Right [Substitution (SubId ident) ty] -matchType (TTuple _ a as) (TTuple _ b bs) = do - match <- matchType a b - matches <- zipWithM matchType (NE.toList as) (NE.toList bs) - pure (match <> mconcat matches) -matchType (TConstructor _ conA) (TConstructor _ conB) | conA == conB = do - pure mempty -matchType (TApp _ lFn lArg) (TApp _ rFn rArg) = do - matchA <- matchType lFn rFn - matchB <- matchType lArg rArg - pure (matchA <> matchB) -matchType (TArray _ _ a) (TArray _ _ b) = - matchType a b -matchType (TFunc _ _ lArg lTo) (TFunc _ _ rArg rTo) = do - matchArg <- matchType lArg rArg - matchTo <- matchType lTo rTo - pure (matchArg <> matchTo) -matchType (TPrim _ lPrim) (TPrim _ rPrim) | lPrim == rPrim = pure mempty -matchType a b = Left (a, b) - -instanceMatchesType :: - (Eq (dep TypeName)) => - [Type dep ann] -> - [Type dep ann] -> - Either - (Type dep ann, Type dep ann) - [Substitution dep ann] -instanceMatchesType needleTys haystackTys = - mconcat <$> zipWithM matchType needleTys haystackTys - --- | wipe out annotations when looking for instances --- this is fragile and depends on us manually creating instances with `mempty` --- annotations in the first place -lookupConcreteInstance :: - (Monoid ann, Ord ann) => - TCEnv ann -> - Constraint ResolvedDep ann -> - Maybe (Instance ResolvedDep ann) -lookupConcreteInstance env constraint = - M.lookup (constraint $> mempty) (tceInstances env) - --- | do we have a matching instance? if we're looking for a concrete type and --- it's not there, explode (ie, there is no `Eq Bool`) --- or return it -lookupTypeclassInstance :: - (MonadError (TCError ann) m, Monoid ann, Ord ann, Show ann) => - TCEnv ann -> - Constraint ResolvedDep ann -> - m (Instance ResolvedDep ann) -lookupTypeclassInstance env constraint@(Constraint name tys) = do - -- first, do we have a concrete instance? - case lookupConcreteInstance env constraint of - Just tcInstance -> pure tcInstance - Nothing -> do - case mapMaybe - ( \(Constraint innerName innerTys) -> do - case (innerName == name, instanceMatchesType tys innerTys) of - (True, Right matches) -> Just (Constraint innerName innerTys, matches) - _ -> Nothing - ) - (M.keys (tceInstances env)) of - -- we deliberately fail if we find more than one matching instance - [(foundConstraint, subs)] -> do - -- a) look up main instance - case lookupConcreteInstance env foundConstraint of - Just (Instance {inConstraints, inExpr}) -> do - -- specialise contraints to found types - let subbedConstraints = substituteConstraint subs <$> inConstraints - -- see if found types exist - traverse_ (lookupTypeclassInstance env) subbedConstraints - -- return new instance - pure (Instance {inConstraints = subbedConstraints, inExpr}) - Nothing -> - throwError (TCTypeclassError $ TypeclassInstanceNotFound name tys (M.keys $ tceInstances env)) - [] -> - throwError (TCTypeclassError $ TypeclassInstanceNotFound name tys (M.keys $ tceInstances env)) - multiple -> - throwError (TCTypeclassError $ ConflictingTypeclassInstancesFound (fst <$> multiple)) - -substituteConstraint :: - (Eq (dep Identifier)) => - [Substitution dep ann] -> - Constraint dep ann -> - Constraint dep ann -substituteConstraint subs (Constraint name tys) = - Constraint name (substituteMany subs <$> tys) - --- look for vars, if no, then it's concrete -isConcrete :: Constraint dep ann -> Bool -isConcrete (Constraint _ tys) = - not $ getAny $ foldMap containsVars tys - where - containsVars (TVar {}) = Any True - containsVars other = monoidType containsVars other - --- given a func name and type, find the typeclass instance (if applicable) -recoverInstance :: - (MonadError (TCError ann) m, Monoid ann) => - M.Map TypeclassName (Typeclass ResolvedDep ann) -> - ResolvedDep Identifier -> - Type ResolvedDep ann -> - m (Maybe (Constraint ResolvedDep ann)) -recoverInstance typeClasses ident ty = do - let getInnerIdent (TypeclassCall i _) = Just i - getInnerIdent (LocalDefinition i) = Just i -- not sure if this should happen but it makes testing waaaay easier - getInnerIdent _ = Nothing - - -- if name matches typeclass instance, return freshened type - case listToMaybe $ M.elems $ M.filter (\tc -> Just (tcFuncName tc) == getInnerIdent ident) typeClasses of - Just tc -> Just <$> applyTypeToConstraint tc ty - Nothing -> pure Nothing - --- find Typeclass in env or explode -lookupTypeclass :: - (MonadError (TCError ann) m) => - M.Map TypeclassName (Typeclass ResolvedDep ann) -> - TypeclassName -> - m (Typeclass ResolvedDep ann) -lookupTypeclass classes tcn = - case M.lookup tcn classes of - Just tc -> pure tc - Nothing -> throwError (TCTypeclassError $ TypeclassNotFound tcn) - --- given a Typeclass (ie `Eq a`) and a type calling it (ie `Int -> Int -> --- Bool`), recover the instance we want, `Eq Int`. -applyTypeToConstraint :: - (Monoid ann, MonadError (TCError ann) m) => - Typeclass ResolvedDep ann -> - Type ResolvedDep ann -> - m (Constraint ResolvedDep ann) -applyTypeToConstraint tc ty = - case matchType ty (tcFuncType tc) of - Right subs -> do - let applySubs = substituteMany subs . TVar mempty . emptyResolvedDep - pure $ Constraint (tcName tc) (applySubs <$> tcArgs tc) - Left (l, r) -> throwError (TCTypeMismatch l r) - --- given I have a constraint and a type for it's callsite --- substitute the type onto the constraint to get the actual constraint. --- For instance, I am calling a function `useEquals` that has constraint `Eq a` --- with the values `(1 : Int) (2: Int)`. Therefore my type is `Int -> Int -> --- Bool` and I can use that to specialise the constraint to `Eq Int` and thus --- dispatch the correct `Eq` instance -specialiseConstraint :: - (MonadError (TCError ann) m, Monoid ann) => - M.Map TypeclassName (Typeclass ResolvedDep ann) -> - Type ResolvedDep ann -> - Constraint ResolvedDep ann -> - m (Constraint ResolvedDep ann) -specialiseConstraint classes ty (Constraint tcn _tys) = do - -- lookup typeclass - tc <- lookupTypeclass classes tcn - -- apply types - applyTypeToConstraint tc ty - -constraintsFromTLE :: - TopLevelExpression ResolvedDep (Type ResolvedDep ann) -> - [Constraint ResolvedDep ann] -constraintsFromTLE tle = - (fmap . fmap) getTypeAnnotation (tleConstraints tle) - --- get input for typechecker from module -getVarsInScope :: - Module ResolvedDep (Type ResolvedDep ann) -> - M.Map (ResolvedDep Identifier) ([Constraint ResolvedDep ann], ResolvedType ann) -getVarsInScope = - M.fromList - . fmap go - . M.toList - . moExpressions - where - go (ident, tle) = - ( LocalDefinition ident, - (constraintsFromTLE tle, getExprAnnotation (tleExpr tle)) - ) - --- make a typechecking env from a module --- this means throwing away all the types which seems silly -envFromTypecheckedModule :: (Ord ann, Monoid ann) => Module ResolvedDep (Type ResolvedDep ann) -> TCEnv ann -envFromTypecheckedModule inputModule = - let instances = - mapKey (fmap (const mempty)) - . (fmap . fmap) getTypeAnnotation - . moInstances - $ inputModule - - classes = (fmap . fmap) getTypeAnnotation (moClasses inputModule) - - dataTypes = - (fmap . fmap) - getTypeAnnotation - (M.mapKeys LocalDefinition (moDataTypes inputModule)) - in TCEnv - { tceVars = getVarsInScope inputModule, - tceDataTypes = dataTypes, - tceInstances = instances, - tceClasses = classes, - tceConstraints = mempty - } - -addTypesToConstraint :: Constraint dep ann -> Constraint dep (Type dep ann) -addTypesToConstraint (Constraint tcn tys) = - Constraint tcn (f <$> tys) - where - f ty = ty $> ty - -removeTypesFromConstraint :: Constraint dep (Type dep ann) -> Constraint dep ann -removeTypesFromConstraint (Constraint tcn tys) = - Constraint tcn (getTypeAnnotation <$> tys) - -applyConstraintTypes :: - Typeclass ResolvedDep ann -> - Constraint ResolvedDep (Type ResolvedDep ann) -> - Type ResolvedDep ann -applyConstraintTypes (Typeclass {tcArgs, tcFuncType}) constraint = - let (Constraint _ tys) = removeTypesFromConstraint constraint - subs = - ( \(ident, tySub) -> - Substitution (SubId $ LocalDefinition ident) tySub - ) - <$> zip tcArgs tys - in substituteMany subs tcFuncType diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/KindChecker.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/KindChecker.hs deleted file mode 100644 index 7c174e39..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/KindChecker.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Typecheck.Typeclass.KindChecker - ( module Smol.Core.Typecheck.Typeclass.Types.Kind, - fromKind, - toKind, - unifyKinds, - typeKind, - lookupKindInType, - ) -where - -import Control.Monad.Except -import Control.Monad.State -import Data.Foldable -import qualified Data.Map as M -import Data.Maybe (listToMaybe) -import Smol.Core.TypeUtils (monoidType) -import Smol.Core.Typecheck.Annotations -import Smol.Core.Typecheck.Typeclass.Types.Kind -import Smol.Core.Types.DataType -import Smol.Core.Types.Identifier -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - -data KindState dep ann = KindState - { ksDataTypes :: M.Map (dep TypeName) (DataType dep ann), - ksInt :: Int, - ksEnv :: [(UKind Int, UKind Int)] -- unique, what it is - } - -fromKind :: Kind -> UKind i -fromKind Star = UStar -fromKind (KindFn a b) = UKindFn (fromKind a) (fromKind b) - -toKind :: (Show i) => UKind i -> Kind -toKind UStar = Star -toKind (UKindFn a b) = KindFn (toKind a) (toKind b) -toKind (UVar _i) = Star -- yolo, if we've not found any better news, assume its a Type - -typeKind :: - ( MonadError (KindError dep Int) m, - Ord (dep TypeName), - Show (dep TypeName), - Show (dep Identifier) - ) => - M.Map (dep TypeName) (DataType dep ann) -> - Type dep ann -> - m (Type dep Kind) -typeKind dts ty = do - (ty', ks) <- runStateT (inferKinds ty) (KindState dts 1 mempty) - subs <- solve (ksEnv ks) - unifyType subs ty' - --- given a bunch of substitutions --- run them all -unifyType :: - (MonadError (KindError dep Int) m) => - M.Map Int (UKind Int) -> - Type dep (UKind Int) -> - m (Type dep Kind) -unifyType subs ty = do - let tyWithKinds = applySubstitutions subs <$> ty - - pure $ fmap toKind tyWithKinds - -applySubstitution :: (Eq i) => (i, UKind i) -> UKind i -> UKind i -applySubstitution (i, sub) (UVar i') | i == i' = sub -applySubstitution sub (UKindFn a b) = - UKindFn (applySubstitution sub a) (applySubstitution sub b) -applySubstitution _ other = other - -applySubstitutions :: (Ord i) => M.Map i (UKind i) -> UKind i -> UKind i -applySubstitutions subs kind = - foldl' (flip applySubstitution) kind (M.toList subs) - -solve :: - ( MonadError (KindError dep i) m, - Ord i - ) => - [(UKind i, UKind i)] -> - m (M.Map i (UKind i)) -solve = go mempty - where - go s [] = pure s - go s1 (constraint : rest) = - case constraint of - (a, b) -> do - s2 <- unifyKinds a b - go (s2 <> s1) (applyToConstraint (s2 <> s1) <$> rest) - -applyToConstraint :: (Ord i) => M.Map i (UKind i) -> (UKind i, UKind i) -> (UKind i, UKind i) -applyToConstraint subs (a, b) = - (applySubstitutions subs a, applySubstitutions subs b) - -unifyKinds :: (MonadError (KindError dep i) m, Ord i) => UKind i -> UKind i -> m (M.Map i (UKind i)) -unifyKinds a b | a == b = pure mempty -unifyKinds (UVar i) b = pure $ M.singleton i b -unifyKinds a (UVar i) = pure $ M.singleton i a -unifyKinds (UKindFn argA retA) (UKindFn argB retB) = do - (<>) <$> unifyKinds argA argB <*> unifyKinds retA retB -unifyKinds a b = throwError (KindMismatch a b) - -getUnique :: (MonadState (KindState dep ann) m) => m Int -getUnique = do - i <- gets ksInt - modify (\ks -> ks {ksInt = i + 1}) - pure i - -addConstraint :: (MonadState (KindState dep ann) m) => UKind Int -> UKind Int -> m () -addConstraint expected actual = - modify (\ks -> ks {ksEnv = (expected, actual) : ksEnv ks}) - -inferKinds :: - ( MonadState (KindState dep ann) m, - MonadError (KindError dep Int) m, - Ord (dep TypeName), - Show (dep TypeName), - Show (dep Identifier) - ) => - Type dep ann -> - m (Type dep (UKind Int)) -inferKinds (TPrim _ p) = pure $ TPrim UStar p -inferKinds (TApp _ fn arg) = do - argKind <- checkKinds arg - - fnKind <- inferKinds fn - - resultKind <- UVar <$> getUnique - - let lhs = UKindFn (getTypeAnnotation argKind) resultKind - rhs = getTypeAnnotation fnKind - - -- tell whatever we guessed fn was that in fact it's some kind of `UKindFn` - addConstraint lhs rhs - - pure $ TApp resultKind fnKind argKind -inferKinds (TConstructor _ constructor) = do - dts <- gets ksDataTypes - k <- case M.lookup constructor dts of - Just dt -> pure $ foldl' (\kind _ -> UKindFn UStar kind) UStar (dtVars dt) - Nothing -> throwError (MissingDataType constructor) - pure $ TConstructor k constructor -inferKinds (TVar _ var) = do - i <- getUnique - pure $ TVar (UVar i) var -inferKinds (TLiteral _ l) = pure (TLiteral UStar l) -inferKinds (TFunc _ env a b) = - TFunc UStar <$> traverse checkKinds env <*> checkKinds a <*> checkKinds b -inferKinds (TTuple _ a as) = - TTuple UStar <$> checkKinds a <*> traverse checkKinds as -inferKinds (TArray _ a as) = TArray UStar a <$> checkKinds as -inferKinds (TUnknown _ a) = pure (TUnknown UStar a) -inferKinds (TRecord _ as) = TRecord UStar <$> traverse checkKinds as -inferKinds (TInfix _ op a b) = TInfix UStar op <$> checkKinds a <*> checkKinds b - --- infer and emit constraint that this is always Star -checkKinds :: - ( Ord (dep TypeName), - Show (dep TypeName), - Show (dep Identifier), - MonadState (KindState dep ann) m, - MonadError (KindError dep Int) m - ) => - Type dep ann -> - m (Type dep (UKind Int)) -checkKinds ty = do - tyKind <- inferKinds ty - addConstraint UStar (getTypeAnnotation tyKind) - pure tyKind - -lookupKindInType :: - ( Eq (dep Identifier) - ) => - Type dep Kind -> - dep Identifier -> - Maybe Kind -lookupKindInType ty identifier = - listToMaybe $ go ty - where - go (TVar k a) | a == identifier = [k] - go other = monoidType go other diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing.hs deleted file mode 100644 index ddf6f5e9..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing.hs +++ /dev/null @@ -1,360 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Smol.Core.Typecheck.Typeclass.ToDictionaryPassing - ( convertExprToUseTypeclassDictionary, - getTypeclassMethodNames, - createTypeclassDict, - toDictionaryPassing, - passDictionaries, - lookupTypecheckedTypeclassInstance, - module Smol.Core.Typecheck.Typeclass.ToDictionaryPassing.Types, - ) -where - -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.Char as Char -import Data.Foldable (foldl', traverse_) -import Data.Functor -import Data.List (elemIndex) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Smol.Core.ExprUtils -import Smol.Core.Helpers -import Smol.Core.Printer -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Typeclass.Deduplicate -import Smol.Core.Typecheck.Typeclass.Helpers -import Smol.Core.Typecheck.Typeclass.ToDictionaryPassing.Types -import Smol.Core.Typecheck.Types -import Smol.Core.Typecheck.Types.Substitution -import Smol.Core.Types - --- create an instance using the already typechecked instances we already have -lookupTypecheckedTypeclassInstance :: - forall m ann. - ( MonadError (TCError ann) m, - MonadReader PassDictEnv m, - Monoid ann, - Ord ann, - Show ann - ) => - ToDictEnv ann -> - Constraint ResolvedDep (Type ResolvedDep ann) -> - m ([Substitution ResolvedDep ann], Instance ResolvedDep (Type ResolvedDep ann)) -lookupTypecheckedTypeclassInstance env constraint = do - let instances = tdeInstances env - case M.lookup (void constraint) instances of - Just tcInstance -> pure (mempty, tcInstance) - Nothing -> do - (foundConstraint, subs) <- - findMatchingConstraint (M.keys instances) (removeTypesFromConstraint constraint) - - -- we can't actually provide an instance so what to do? - -- a) look up main instance - case M.lookup (void foundConstraint) instances of - Just (Instance {inConstraints, inExpr}) -> do - -- specialise contraints to found types - let subbedConstraints = - substituteConstraint subs - . removeTypesFromConstraint - <$> inConstraints - - -- see if found types exist - traverse_ - (lookupTypecheckedTypeclassInstance env) - (addTypesToConstraint <$> subbedConstraints) - - -- return new instance - pure - ( subs, - Instance - { inConstraints = addTypesToConstraint <$> subbedConstraints, - inExpr - } - ) - Nothing -> - let constraintsWithAnn = (fmap . fmap) (const mempty) (M.keys instances) - (Constraint name tys) = constraint - in throwError (TCTypeclassError $ TypeclassInstanceNotFound name (getTypeAnnotation <$> tys) constraintsWithAnn) - --- | given a pile of constraints, find the matching one and return --- substitutions required to make it match --- TODO: this needs to accept TCEnv and lookup constraints in there too thx --- TODO: make our own error types for this crap so it's less confusing what is --- a type error or not -findMatchingConstraint :: - forall m ann. - (MonadError (TCError ann) m, Monoid ann) => - [Constraint ResolvedDep ()] -> - Constraint ResolvedDep ann -> - m (Constraint ResolvedDep ann, [Substitution ResolvedDep ann]) -findMatchingConstraint constraints (Constraint name tys) = - let constraintsWithAnn :: [Constraint ResolvedDep ann] - constraintsWithAnn = (fmap . fmap) (const mempty) constraints - - lookupConstraint (Constraint innerName innerTys) = - case (innerName == name, instanceMatchesType tys innerTys) of - (True, Right matches) -> Just (Constraint innerName innerTys, matches) - _ -> Nothing - in case mapMaybe lookupConstraint constraintsWithAnn of - -- we deliberately fail if we find more than one matching instance - [(foundConstraint, subs)] -> pure (foundConstraint, subs) - [] -> - throwError (TCTypeclassError $ TypeclassInstanceNotFound name tys constraintsWithAnn) - multiple -> - throwError (TCTypeclassError $ ConflictingTypeclassInstancesFound (fst <$> multiple)) - -getTypeForDictionary :: - ( MonadError (TCError ann) m, - MonadReader PassDictEnv m, - Monoid ann, - Ord ann, - Show ann - ) => - ToDictEnv ann -> - [Constraint ResolvedDep (Type ResolvedDep ann)] -> - m (Maybe (Pattern ResolvedDep (Type ResolvedDep ann))) -getTypeForDictionary env constraints = do - let getConstraintPattern constraint i = do - let ident = identForConstraint (i + 1) - result <- tryError (lookupTypecheckedTypeclassInstance env constraint) - ty <- case result of - -- we found the instance, return it's type - Right (_, Instance _ instanceExpr) -> pure (getExprAnnotation instanceExpr) - -- we didn't find an instance, but we can get the type from the - -- constraint - Left e -> case typeForConstraint (tdeClasses env) constraint of - Just ty -> pure ty - Nothing -> throwError e - pure (PVar ty ident) - - case constraints of - [] -> pure Nothing - [one] -> Just <$> getConstraintPattern one (-1) - (one : rest) -> do - pOne <- getConstraintPattern one (-1) - pRest <- NE.fromList <$> traverseInd getConstraintPattern rest - let ty = TTuple mempty (getPatternAnnotation pOne) (getPatternAnnotation <$> pRest) - pure $ Just $ PTuple ty pOne pRest - --- | when typechecking instances we can look them up and literally typecheck --- them, however for constraints we don't have concrete code yet --- however, we can just substitute the types from the Constraint to the Typeclass --- to see what type we should get -typeForConstraint :: M.Map TypeclassName (Typeclass ResolvedDep ann) -> Constraint ResolvedDep (Type ResolvedDep ann) -> Maybe (Type ResolvedDep ann) -typeForConstraint typeClasses constraint@(Constraint tcn _) = do - M.lookup tcn typeClasses - <&> \typeclass -> applyConstraintTypes typeclass constraint - --- | 10x typeclasses implementation - given an `expr` that calls typeclass --- methods, we inline all the instances as Let bindings --- `let equals_1 = \a -> \b -> a == b in equals_1 10 11` -convertExprToUseTypeclassDictionary :: - ( MonadError (TCError ann) m, - MonadReader PassDictEnv m, - Monoid ann, - Ord ann, - Show ann - ) => - ToDictEnv ann -> - [Constraint ResolvedDep (Type ResolvedDep ann)] -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m (Expr ResolvedDep (Type ResolvedDep ann)) -convertExprToUseTypeclassDictionary env constraints expr = do - -- if our constraints are concrete we'll inline them rather than passing them - -- through, as such - maybePattern <- getTypeForDictionary env (filterNotConcrete constraints) - - case maybePattern of - Just pat -> do - let dictType = getPatternAnnotation pat - exprType = getExprAnnotation expr - pure $ - ELambda - (TFunc mempty mempty dictType exprType) - "instances" - ( EPatternMatch - (getExprAnnotation expr) - (EAnn dictType (dictType $> dictType) (EVar dictType "instances")) - (NE.fromList [(pat, expr)]) - ) - Nothing -> pure expr - --- | create a typeclass dictionary --- return either solid instances or use vars from constraints if not available --- (ie "pass them through", as such) -createTypeclassDict :: - ( Show ann, - Ord ann, - Monoid ann, - MonadReader PassDictEnv m, - MonadError (TCError ann) m - ) => - ToDictEnv ann -> - NE.NonEmpty (Constraint ResolvedDep (Type ResolvedDep ann)) -> - m (Expr ResolvedDep (Type ResolvedDep ann)) -createTypeclassDict env constraints = do - foundInstances <- - traverse - ( \constraint -> do - result <- tryError (lookupTypecheckedTypeclassInstance env constraint) - case result of - Right (subs, Instance newConstraints expr) -> do - -- found a concrete instance - toDictionaryPassingInternal env subs newConstraints expr - Left e -> do - -- no concrete instance, maybe we can pass through a constraint - -- from the current function - case (,) - <$> elemIndex (removeTypesFromConstraint constraint) (removeTypesFromConstraint <$> NE.toList constraints) - <*> typeForConstraint (tdeClasses env) constraint of - Just (index, ty) -> pure (EVar ty (identForConstraint $ fromIntegral index)) - Nothing -> throwError e - ) - constraints - case NE.uncons foundInstances of - (one, Nothing) -> pure one - (theFirst, Just theRest) -> - let ty = TTuple mempty (getExprAnnotation theFirst) (getExprAnnotation <$> theRest) - in pure $ ETuple ty theFirst theRest - -filterNotConcrete :: [Constraint ResolvedDep ann] -> [Constraint ResolvedDep ann] -filterNotConcrete = filter (not . isConcrete) - -storeInstance :: - (MonadState (PassDictState ann) m) => - Constraint ResolvedDep () -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m (ResolvedDep Identifier) -storeInstance constraint instanceExpr = do - modify (\pds -> pds {pdsInstances = pdsInstances pds <> M.singleton constraint instanceExpr}) - pure (identifierFromConstraint constraint) - -lookupInstance :: - ( MonadReader PassDictEnv m, - MonadState (PassDictState ann) m - ) => - Constraint ResolvedDep () -> - m (Maybe (ResolvedDep Identifier)) -lookupInstance constraint = do - maybeCurrentConstraint <- asks pdeCurrentConstraint - if maybeCurrentConstraint == Just constraint - then pure $ Just $ identifierFromConstraint constraint -- this is the current instance, so return its own name - else do - maybeInstance <- gets (M.lookup constraint . pdsInstances) - case maybeInstance of - Just _ -> pure $ Just $ identifierFromConstraint constraint - Nothing -> pure Nothing - --- make a nice name for an instance -identifierFromConstraint :: Constraint ResolvedDep () -> ResolvedDep Identifier -identifierFromConstraint (Constraint (TypeclassName tcn) tys) = LocalDefinition . Identifier $ toBasic $ tcn <> "_" <> foldMap tshowType tys - where - toBasic :: T.Text -> T.Text - toBasic = T.toLower . T.filter Char.isAlpha - - tshowType :: Type ResolvedDep ann -> T.Text - tshowType ty = - renderWithWidth 100 (prettyDoc ty) - --- given we know the types of all our deps --- pass dictionaries to them all -passDictionaries :: - ( Monoid ann, - Ord ann, - Show ann, - MonadReader PassDictEnv m, - MonadError (TCError ann) m - ) => - ToDictEnv ann -> - [Substitution ResolvedDep ann] -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m (Expr ResolvedDep (Type ResolvedDep ann)) -passDictionaries env subs expr = do - (finalExpr, dictState) <- - runStateT (go expr) emptyPassDictState - pure $ - foldl' - ( \totalExpr (constraint, instanceExpr) -> - ELet (TPrim mempty TPBool) (identifierFromConstraint constraint) instanceExpr totalExpr - ) - finalExpr - (M.toList $ pdsInstances dictState) - where - go (EVar ann ident) = - case M.lookup ident (tdeVars env) of - Just (constraints, _defExpr) -> do - -- need to specialise constraint to actual type here - case NE.nonEmpty constraints of - Just neConstraints -> do - -- use the call type to specialise to the instance we need - specialisedConstraints <- traverse (specialiseConstraint (tdeClasses env) ann) neConstraints - EApp ann (EVar ann ident) <$> createTypeclassDict env (addTypesToConstraint <$> specialisedConstraints) - Nothing -> pure (EVar ann ident) - Nothing -> do - result <- recoverInstance (tdeClasses env) ident ann - case result of - Just constraint -> do - -- specialise contraints to found types - let subbedConstraint = - substituteConstraint subs constraint - - -- have we already created this instance? - maybeFound <- lookupInstance (void subbedConstraint) - case maybeFound of - -- if so, return it - Just identifier -> pure (EVar ann identifier) - Nothing -> do - (newSubs, Instance fnConstraints fnExpr) <- - lookupTypecheckedTypeclassInstance env (addTypesToConstraint subbedConstraint) - - -- convert instance to dictionary passing then return it inlined - toInline <- - local - (const (PassDictEnv $ Just $ void subbedConstraint)) - (toDictionaryPassingInternal env newSubs fnConstraints fnExpr) - - -- need to push this to state with a fresh name, and put a var to - -- the fresh name - identifier <- storeInstance (void subbedConstraint) toInline - - pure (EVar ann identifier) - Nothing -> pure (EVar ann ident) - go other = bindExpr go other - --- | well well well lets put it all together -toDictionaryPassingInternal :: - ( MonadError (TCError ann) m, - MonadReader PassDictEnv m, - Show ann, - Ord ann, - Monoid ann - ) => - ToDictEnv ann -> - [Substitution ResolvedDep ann] -> - [Constraint ResolvedDep (Type ResolvedDep ann)] -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m (Expr ResolvedDep (Type ResolvedDep ann)) -toDictionaryPassingInternal env subs constraints expr = do - passDictionaries env subs - <=< convertExprToUseTypeclassDictionary env constraints - $ expr - --- | well well well lets put it all together -toDictionaryPassing :: - (MonadError (TCError ann) m, Show ann, Ord ann, Monoid ann) => - ToDictEnv ann -> - [Substitution ResolvedDep ann] -> - [Constraint ResolvedDep (Type ResolvedDep ann)] -> - Expr ResolvedDep (Type ResolvedDep ann) -> - m (Expr ResolvedDep (Type ResolvedDep ann)) -toDictionaryPassing env subs constraints expr = - runReaderT (toDictionaryPassingInternal env subs constraints expr) emptyPassDictEnv diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing/Types.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing/Types.hs deleted file mode 100644 index d38eb0c2..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/ToDictionaryPassing/Types.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Smol.Core.Typecheck.Typeclass.ToDictionaryPassing.Types - ( emptyPassDictEnv, - emptyPassDictState, - ToDictEnv (..), - PassDictEnv (..), - PassDictState (..), - ) -where - -import qualified Data.Map.Strict as M -import Smol.Core.Typecheck.Types -import Smol.Core.Types - -data ToDictEnv ann = ToDictEnv - { tdeClasses :: M.Map TypeclassName (Typeclass ResolvedDep ann), - tdeInstances :: M.Map (Constraint ResolvedDep ()) (Instance ResolvedDep (Type ResolvedDep ann)), - tdeVars :: M.Map (ResolvedDep Identifier) ([Constraint ResolvedDep ann], ResolvedType ann) - } - --- | Are we currently creating an instance? If so, include it's constraint --- so it is able to refer to itself -newtype PassDictEnv = PassDictEnv - { pdeCurrentConstraint :: Maybe (Constraint ResolvedDep ()) - } - deriving newtype (Eq, Ord, Show) - -emptyPassDictEnv :: PassDictEnv -emptyPassDictEnv = PassDictEnv Nothing - --- | the instances we've accumulated whilst traversing the expr -newtype PassDictState ann = PassDictState - { pdsInstances :: M.Map (Constraint ResolvedDep ()) (Expr ResolvedDep (Type ResolvedDep ann)) - } - deriving newtype (Eq, Ord, Show) - -emptyPassDictState :: PassDictState ann -emptyPassDictState = PassDictState mempty diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Typecheck.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Typecheck.hs deleted file mode 100644 index 69534787..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Typecheck.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- everything used to typecheck typeclasses -module Smol.Core.Typecheck.Typeclass.Typecheck - ( checkInstance, - lookupInstanceAndCheck, - ) -where - -import Control.Monad.Except -import Data.Foldable (traverse_) -import qualified Data.Map.Strict as M -import Data.Maybe -import Smol.Core.Typecheck.Elaborate (elaborate) -import Smol.Core.Typecheck.Shared -import Smol.Core.Typecheck.Typeclass.Helpers -import Smol.Core.Typecheck.Typeclass.KindChecker -import Smol.Core.Typecheck.Types -import Smol.Core.Types - -lookupInstanceAndCheck :: - (Ord ann, Monoid ann, Show ann, MonadError (TCError ann) m) => - TCEnv ann -> - Constraint ResolvedDep (Type ResolvedDep ann) -> - m (Instance ResolvedDep (Type ResolvedDep ann)) -lookupInstanceAndCheck env constraint@(Constraint typeclassName _) = do - tcInstance <- lookupTypeclassInstance env (removeTypesFromConstraint constraint) - typeclass <- case M.lookup typeclassName (tceClasses env) of - Just tc -> pure tc - Nothing -> error "fuck" - checkInstance env typeclass constraint tcInstance - -checkInstance :: - (MonadError (TCError ann) m, Monoid ann, Ord ann, Show ann) => - TCEnv ann -> - Typeclass ResolvedDep ann -> - Constraint ResolvedDep (Type ResolvedDep ann) -> - Instance ResolvedDep ann -> - m (Instance ResolvedDep (Type ResolvedDep ann)) -checkInstance tcEnv typeclass constraint (Instance constraints expr) = - do - let subbedType = applyConstraintTypes typeclass constraint - - -- we add the instance's constraints (so typechecker forgives a missing `Eq a` etc) - let typecheckEnv = tcEnv {tceConstraints = constraints} - annotatedExpr = EAnn (getExprAnnotation expr) subbedType expr - - dataTypes = tceDataTypes tcEnv - typeclassKinds = kindsForTypeclass dataTypes typeclass - constraintKinds = kindsForConstraint dataTypes constraint - - liftEither (kindcheckInstance typeclassKinds constraintKinds) - - -- we `elaborate` rather than `typecheck` as we don't want the names - -- mangled - (typedExpr, _newConstraints) <- elaborate typecheckEnv annotatedExpr - - let allConstraints = constraints -- nub (constraints <> newConstraints) - pure $ Instance (addTypesToConstraint <$> allConstraints) typedExpr - --- | check that each item in an instance kind checks -kindcheckInstance :: [(Identifier, Kind)] -> [Kind] -> Either (TCError ann) () -kindcheckInstance typeclassKinds constraintKinds = do - let everything = zip typeclassKinds constraintKinds - let kindcheckPair ((ident, lhsKind), rhsKind) = - case unifyKinds (fromKind lhsKind) (fromKind rhsKind) of - Right _ -> pure () - Left (KindMismatch a b) -> - Left (TCTypeclassError $ InstanceKindMismatch ident (toKind a) (toKind b)) - Left kindError -> - Left (TCKindError kindError) - traverse_ kindcheckPair everything - --- | what kinds does the actual type have? -kindsForConstraint :: - M.Map (ResolvedDep TypeName) (DataType ResolvedDep ann) -> - Constraint ResolvedDep (Type ResolvedDep ann) -> - [Kind] -kindsForConstraint dataTypes (Constraint {conType}) = - case traverse (typeKind dataTypes) (getTypeAnnotation <$> conType) of - Right yes -> getTypeAnnotation <$> yes - Left e -> error (show e) - --- | what kinds are expected? -kindsForTypeclass :: - M.Map (ResolvedDep TypeName) (DataType ResolvedDep ann) -> - Typeclass ResolvedDep ann -> - [(Identifier, Kind)] -kindsForTypeclass dataTypes (Typeclass {tcArgs, tcFuncType}) = do - case typeKind dataTypes tcFuncType of - Left e -> error (show e) - Right tyKind -> - mapMaybe - ( \ident -> - (,) ident - <$> ( lookupKindInType tyKind - . emptyResolvedDep - $ ident - ) - ) - tcArgs diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types.hs deleted file mode 100644 index 4ac41656..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Smol.Core.Typecheck.Typeclass.Types - ( module Smol.Core.Typecheck.Typeclass.Types.Typeclass, - module Smol.Core.Typecheck.Typeclass.Types.Constraint, - module Smol.Core.Typecheck.Typeclass.Types.Instance, - module Smol.Core.Typecheck.Typeclass.Types.TypeclassName, - ) -where - -import Smol.Core.Typecheck.Typeclass.Types.Constraint -import Smol.Core.Typecheck.Typeclass.Types.Instance -import Smol.Core.Typecheck.Typeclass.Types.Typeclass -import Smol.Core.Typecheck.Typeclass.Types.TypeclassName diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Constraint.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Constraint.hs deleted file mode 100644 index adca463d..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Constraint.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Typecheck.Typeclass.Types.Constraint - ( Constraint (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types.TypeclassName -import Smol.Core.Types - -data Constraint dep ann = Constraint - { conTypeclass :: TypeclassName, - conType :: [Type dep ann] - } - deriving stock (Functor, Foldable, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep Constructor), - Eq (dep TypeName), - Eq (dep Identifier) - ) => - Eq (Constraint dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Constructor), - Ord (dep TypeName), - Ord (dep Identifier) - ) => - Ord (Constraint dep ann) - -deriving stock instance - ( Show ann, - Show (dep Constructor), - Show (dep TypeName), - Show (dep Identifier) - ) => - Show (Constraint dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSON (Constraint dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSONKey (Constraint dep ann) - -deriving anyclass instance - ( FromJSON ann, - FromJSON (dep Constructor), - FromJSON (dep Identifier), - FromJSONKey (dep Identifier), - Ord (dep Identifier), - FromJSON (dep TypeName) - ) => - FromJSON (Constraint dep ann) - -deriving anyclass instance - ( FromJSON ann, - FromJSON (dep Constructor), - FromJSON (dep Identifier), - FromJSONKey (dep Identifier), - FromJSON (dep TypeName), - Ord (dep Constructor), - Ord (dep Identifier) - ) => - FromJSONKey (Constraint dep ann) - -instance - ( Printer (dep Identifier), - Printer (dep TypeName) - ) => - Printer (Constraint dep ann) - where - prettyDoc (Constraint tcn tys) = - prettyDoc tcn - PP.<+> PP.concatWith - (\a b -> a <> " " <> b) - (prettyDoc <$> tys) diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Instance.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Instance.hs deleted file mode 100644 index 923e6f0b..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Instance.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Typecheck.Typeclass.Types.Instance - ( Instance (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types.Constraint -import Smol.Core.Types - -data Instance dep ann = Instance - { inConstraints :: [Constraint dep ann], - inExpr :: Expr dep ann - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep Constructor), - Eq (dep TypeName), - Eq (dep Identifier) - ) => - Eq (Instance dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Constructor), - Ord (dep TypeName), - Ord (dep Identifier) - ) => - Ord (Instance dep ann) - -deriving stock instance - ( Show ann, - Show (dep Constructor), - Show (dep TypeName), - Show (dep Identifier) - ) => - Show (Instance dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSON (Instance dep ann) - -deriving anyclass instance - ( FromJSON ann, - FromJSON (dep Constructor), - FromJSON (dep Identifier), - FromJSONKey (dep Identifier), - Ord (dep Identifier), - FromJSON (dep TypeName) - ) => - FromJSON (Instance dep ann) - -instance - ( Printer (dep Constructor), - Printer (dep TypeName), - Printer (dep Identifier) - ) => - Printer (Instance dep ann) - where - prettyDoc (Instance [] expr) = prettyDoc expr - prettyDoc (Instance constraints expr) = - "(" <> PP.concatWith (\a b -> a <> ", " <> b) (prettyDoc <$> constraints) <> ") => " <> prettyDoc expr diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Kind.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Kind.hs deleted file mode 100644 index c08bfb79..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Kind.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Typecheck.Typeclass.Types.Kind - ( KindError (..), - Kind (..), - UKind (..), - ) -where - -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Types.TypeName - -data Kind - = Star - | KindFn Kind Kind - deriving stock (Eq, Ord, Show) - --- | Unresolved Kind -data UKind i - = UStar - | UKindFn (UKind i) (UKind i) - | UVar i - deriving stock (Eq, Ord, Show) - -instance (Show i) => Printer (UKind i) where - prettyDoc = PP.pretty . show - -data KindError dep i - = KindMismatch (UKind i) (UKind i) - | UnassignedVar i - | MissingDataType (dep TypeName) - -deriving stock instance - (Eq i, Eq (dep TypeName)) => - Eq (KindError dep i) - -deriving stock instance - (Ord i, Ord (dep TypeName)) => - Ord (KindError dep i) - -deriving stock instance - (Show i, Show (dep TypeName)) => - Show (KindError dep i) diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Typeclass.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Typeclass.hs deleted file mode 100644 index 51f6fffd..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/Typeclass.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Typecheck.Typeclass.Types.Typeclass - ( Typeclass (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import GHC.Generics (Generic) -import Smol.Core.Typecheck.Typeclass.Types.TypeclassName -import Smol.Core.Types - --- | the typeclass described in it's most general form, ie --- class Show a where show :: a -> String -data Typeclass dep ann = Typeclass - { tcName :: TypeclassName, - tcArgs :: [Identifier], - tcFuncName :: Identifier, - tcFuncType :: Type dep ann - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep Constructor), - Eq (dep TypeName), - Eq (dep Identifier) - ) => - Eq (Typeclass dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Constructor), - Ord (dep TypeName), - Ord (dep Identifier) - ) => - Ord (Typeclass dep ann) - -deriving stock instance - ( Show ann, - Show (dep Constructor), - Show (dep TypeName), - Show (dep Identifier) - ) => - Show (Typeclass dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSON (Typeclass dep ann) - -deriving anyclass instance - ( FromJSON ann, - FromJSON (dep Constructor), - FromJSON (dep Identifier), - FromJSONKey (dep Identifier), - Ord (dep Identifier), - FromJSON (dep TypeName) - ) => - FromJSON (Typeclass dep ann) diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassError.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassError.hs deleted file mode 100644 index d14adbba..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassError.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Typecheck.Typeclass.Types.TypeclassError - ( TypeclassError (..), - Kind (..), - ) -where - -import Smol.Core.Typecheck.Typeclass.KindChecker -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Types - -data TypeclassError ann - = TypeclassNotFound TypeclassName - | TypeclassInstanceNotFound TypeclassName [Type ResolvedDep ann] [Constraint ResolvedDep ann] - | ConflictingTypeclassInstancesFound [Constraint ResolvedDep ann] - | InstanceKindMismatch Identifier Kind Kind -- expected, actual - deriving stock (Eq, Ord, Show, Foldable) diff --git a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassName.hs b/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassName.hs deleted file mode 100644 index 4f7a6b1a..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Typeclass/Types/TypeclassName.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Typecheck.Typeclass.Types.TypeclassName - ( TypeclassName (..), - getTypeclassName, - validTypeclassName, - safeMkTypeclassName, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Prettyprinter -import Smol.Core.Printer - --- | A TypeclassName is like `Either` or `Maybe`. --- It must start with a capital letter. -newtype TypeclassName = TypeclassName Text - deriving stock (Eq, Ord, Generic) - deriving newtype - ( Show, - JSON.FromJSONKey, - JSON.ToJSON, - JSON.ToJSONKey - ) - -instance JSON.FromJSON TypeclassName where - parseJSON json = - JSON.parseJSON json >>= \txt -> case safeMkTypeclassName txt of - Just tyCon' -> pure tyCon' - _ -> fail "Text is not a valid TypeclassName" - -instance IsString TypeclassName where - fromString = mkTypeclassName . T.pack - -getTypeclassName :: TypeclassName -> Text -getTypeclassName (TypeclassName t) = t - -validTypeclassName :: Text -> Bool -validTypeclassName a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkTypeclassName :: Text -> TypeclassName -mkTypeclassName a = - if validTypeclassName a - then TypeclassName a - else error $ T.unpack $ "TypeclassName validation fail for '" <> a <> "'" - -safeMkTypeclassName :: Text -> Maybe TypeclassName -safeMkTypeclassName a = - if validTypeclassName a - then Just (TypeclassName a) - else Nothing - -instance Printer TypeclassName where - prettyDoc = pretty . getTypeclassName diff --git a/smol-core/src/Smol/Core/Typecheck/Types.hs b/smol-core/src/Smol/Core/Typecheck/Types.hs deleted file mode 100644 index 7e92882f..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Types.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Smol.Core.Typecheck.Types - ( TCEnv (..), - module Smol.Core.Typecheck.Typeclass.Types, - module Smol.Core.Typecheck.Types.TCError, - module Smol.Core.Typecheck.Types.TCState, - module Smol.Core.Typecheck.Types.TCWrite, - ) -where - -import Data.Map.Strict (Map) -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Typecheck.Types.TCError -import Smol.Core.Typecheck.Types.TCState -import Smol.Core.Typecheck.Types.TCWrite -import Smol.Core.Types - -data TCEnv ann = TCEnv - { tceVars :: Map (ResolvedDep Identifier) ([Constraint ResolvedDep ann], ResolvedType ann), - tceDataTypes :: Map (ResolvedDep TypeName) (DataType ResolvedDep ann), - tceClasses :: Map TypeclassName (Typeclass ResolvedDep ann), - tceInstances :: Map (Constraint ResolvedDep ann) (Instance ResolvedDep ann), - tceConstraints :: [Constraint ResolvedDep ann] - } diff --git a/smol-core/src/Smol/Core/Typecheck/Types/Substitution.hs b/smol-core/src/Smol/Core/Typecheck/Types/Substitution.hs deleted file mode 100644 index cf611413..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Types/Substitution.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Typecheck.Types.Substitution - ( Substitution (..), - SubstitutionMatcher (..), - ) -where - -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Types - -data SubstitutionMatcher dep ann - = SubId (dep Identifier) - | SubUnknown Integer - | SubType (Type dep ann) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep TypeName) - ) => - Eq (SubstitutionMatcher dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep TypeName) - ) => - Ord (SubstitutionMatcher dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep TypeName) - ) => - Show (SubstitutionMatcher dep ann) - ---------------------- - -data Substitution dep ann - = Substitution (SubstitutionMatcher dep ann) (Type dep ann) - -instance (Show ann, Show (dep Identifier), Show (dep TypeName)) => Printer (Substitution dep ann) where - prettyDoc a = PP.pretty (show a) - -deriving stock instance - (Eq ann, Eq (dep Identifier), Eq (dep TypeName)) => - Eq (Substitution dep ann) - -deriving stock instance - (Ord ann, Ord (dep Identifier), Ord (dep TypeName)) => - Ord (Substitution dep ann) - -deriving stock instance - (Show ann, Show (dep Identifier), Show (dep TypeName)) => - Show (Substitution dep ann) diff --git a/smol-core/src/Smol/Core/Typecheck/Types/TCError.hs b/smol-core/src/Smol/Core/Typecheck/Types/TCError.hs deleted file mode 100644 index ce56ce11..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Types/TCError.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Typecheck.Types.TCError - ( TCError (..), - module Smol.Core.Typecheck.Typeclass.Types.TypeclassError, - ) -where - -import Data.Set (Set) -import Smol.Core.Typecheck.Typeclass.Types.Kind -import Smol.Core.Typecheck.Typeclass.Types.TypeclassError -import Smol.Core.Types -import Smol.Core.Types.PatternMatchError (PatternMatchError) - -data TCError ann - = TCUnknownError - | TCCouldNotFindVar ann (ResolvedDep Identifier) - | TCTypeMismatch (ResolvedType ann) (ResolvedType ann) - | TCTupleSizeMismatch Int (ResolvedType ann) - | TCExpectedTuple (ResolvedType ann) - | TCExpectedFunction (ResolvedType ann) - | TCRecordMissingItems (Set Identifier) - | TCExpectedRecord (ResolvedType ann) - | TCInfixMismatch Op (ResolvedType ann) (ResolvedType ann) - | TCPatternMismatch (Pattern ResolvedDep ann) (ResolvedType ann) - | TCUnknownConstructor (ResolvedDep Constructor) [Constructor] - | TCConstructorArgumentMismatch (ResolvedDep Constructor) Int Int -- expected, actual - | TCExpectedConstructorType (ResolvedType ann) - | TCCompoundTypeInEquality (ResolvedType ann) -- for now we only do primitive equality - | TCPatternMatchError (PatternMatchError (ResolvedType ann)) - | TCTypeclassError (TypeclassError ann) - | TCKindError (KindError ResolvedDep Int) - deriving stock (Eq, Ord, Show, Foldable) diff --git a/smol-core/src/Smol/Core/Typecheck/Types/TCState.hs b/smol-core/src/Smol/Core/Typecheck/Types/TCState.hs deleted file mode 100644 index d78c3459..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Types/TCState.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Smol.Core.Typecheck.Types.TCState - ( TCState (..), - GlobalMap (..), - filterIdent, - globalMapIsNull, - ) -where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Smol.Core.Types - -newtype GlobalMap ann = GlobalMap {getGlobalMap :: Map Identifier (ResolvedType ann)} - deriving newtype (Eq, Ord, Show, Semigroup, Monoid) - -globalMapIsNull :: GlobalMap ann -> Bool -globalMapIsNull (GlobalMap m) = M.null m - -filterIdent :: Identifier -> GlobalMap ann -> GlobalMap ann -filterIdent ident (GlobalMap m) = - GlobalMap $ - M.delete ident m - -data TCState ann = TCState - { tcsArgStack :: [ResolvedType ann], - tcsUnknown :: Integer, - tcsGlobals :: [GlobalMap ann] - } diff --git a/smol-core/src/Smol/Core/Typecheck/Types/TCWrite.hs b/smol-core/src/Smol/Core/Typecheck/Types/TCWrite.hs deleted file mode 100644 index f61e1050..00000000 --- a/smol-core/src/Smol/Core/Typecheck/Types/TCWrite.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Typecheck.Types.TCWrite (TCWrite (..), filterSubstitutions, filterTypeclassUses) where - -import Data.Maybe (mapMaybe) -import Data.String -import Smol.Core.Printer -import Smol.Core.Typecheck.Typeclass.Types -import Smol.Core.Typecheck.Types.Substitution -import Smol.Core.Types.Identifier -import Smol.Core.Types.ResolvedDep - --- stuff emitted during typechecking -data TCWrite ann - = TCWSubstitution - (Substitution ResolvedDep ann) - | TCWTypeclassUse - (ResolvedDep Identifier) - TypeclassName - [(Identifier, Integer)] - deriving stock (Eq, Ord, Show) - -instance (Show ann) => Printer (TCWrite ann) where - prettyDoc (TCWTypeclassUse _ tcn matches) = - prettyDoc tcn <> " : " <> fromString (show matches) - prettyDoc (TCWSubstitution sub) = prettyDoc sub - -filterSubstitutions :: [TCWrite ann] -> [Substitution ResolvedDep ann] -filterSubstitutions = - mapMaybe - ( \case - TCWSubstitution sub -> Just sub - _ -> Nothing - ) - -filterTypeclassUses :: [TCWrite ann] -> [(ResolvedDep Identifier, TypeclassName, [(Identifier, Integer)])] -filterTypeclassUses = - mapMaybe - ( \case - TCWTypeclassUse ident s matches -> Just (ident, s, matches) - _ -> Nothing - ) diff --git a/smol-core/src/Smol/Core/Types.hs b/smol-core/src/Smol/Core/Types.hs deleted file mode 100644 index c6ee82b0..00000000 --- a/smol-core/src/Smol/Core/Types.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Smol.Core.Types - ( module Smol.Core.Types.Annotation, - module Smol.Core.Types.Annotated, - module Smol.Core.Types.Constructor, - module Smol.Core.Types.DataType, - module Smol.Core.Types.Op, - module Smol.Core.Types.Expr, - module Smol.Core.Types.Identifier, - module Smol.Core.Types.ParseDep, - module Smol.Core.Types.Pattern, - module Smol.Core.Types.Prim, - module Smol.Core.Types.ResolvedDep, - module Smol.Core.Types.Spread, - module Smol.Core.Types.Type, - module Smol.Core.Types.TypeName, - ) -where - -import Smol.Core.Types.Annotated -import Smol.Core.Types.Annotation -import Smol.Core.Types.Constructor -import Smol.Core.Types.DataType -import Smol.Core.Types.Expr -import Smol.Core.Types.Identifier -import Smol.Core.Types.Op -import Smol.Core.Types.ParseDep -import Smol.Core.Types.Pattern -import Smol.Core.Types.Prim -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Spread -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName diff --git a/smol-core/src/Smol/Core/Types/Annotated.hs b/smol-core/src/Smol/Core/Types/Annotated.hs deleted file mode 100644 index 31f78694..00000000 --- a/smol-core/src/Smol/Core/Types/Annotated.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Types.Annotated (Annotated (..)) where - -data Annotated a ann = Annotated ann a - deriving stock (Eq, Ord, Show, Functor) diff --git a/smol-core/src/Smol/Core/Types/Annotation.hs b/smol-core/src/Smol/Core/Types/Annotation.hs deleted file mode 100644 index c29f014a..00000000 --- a/smol-core/src/Smol/Core/Types/Annotation.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Smol.Core.Types.Annotation - ( Annotation (..), - ) -where - -data Annotation = Location Int Int - deriving stock (Eq, Ord, Show) - --- | bullshit instance -instance Semigroup Annotation where - a <> _ = a - --- bullshit instance -instance Monoid Annotation where - mempty = Location 0 0 diff --git a/smol-core/src/Smol/Core/Types/Constructor.hs b/smol-core/src/Smol/Core/Types/Constructor.hs deleted file mode 100644 index f8f8d2ad..00000000 --- a/smol-core/src/Smol/Core/Types/Constructor.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Types.Constructor - ( Constructor (..), - safeMkConstructor, - mkConstructor, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import qualified Prettyprinter as PP -import Smol.Core.Printer - -newtype Constructor = Constructor Text - deriving newtype - ( Eq, - Ord, - Show, - JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON, - JSON.FromJSONKey, - Semigroup - ) - -instance Printer Constructor where - prettyDoc (Constructor c) = PP.pretty c - -instance IsString Constructor where - fromString = Constructor . T.pack - -validConstructor :: Text -> Bool -validConstructor a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isUpper (T.head a) - -mkConstructor :: Text -> Constructor -mkConstructor a = - if validConstructor a - then Constructor a - else error $ T.unpack $ "Constructor validation fail for '" <> a <> "'" - -safeMkConstructor :: Text -> Maybe Constructor -safeMkConstructor a = - if validConstructor a - then Just (Constructor a) - else Nothing diff --git a/smol-core/src/Smol/Core/Types/DataType.hs b/smol-core/src/Smol/Core/Types/DataType.hs deleted file mode 100644 index 7db27aba..00000000 --- a/smol-core/src/Smol/Core/Types/DataType.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Types.DataType - ( DataType (..), - ) -where - -import Data.Aeson -import Data.Map.Strict -import qualified Data.Map.Strict as M -import GHC.Generics (Generic) -import Prettyprinter -import Smol.Core.Printer -import Smol.Core.Types.Constructor -import Smol.Core.Types.Identifier -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - -data DataType dep ann = DataType - { dtName :: TypeName, - dtVars :: [Identifier], - dtConstructors :: Map Constructor [Type dep ann] - } - deriving stock (Functor, Generic) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep TypeName) - ) => - Eq (DataType dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep TypeName) - ) => - Ord (DataType dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep TypeName) - ) => - Show (DataType dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep TypeName) - ) => - ToJSON (DataType dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep TypeName) - ) => - FromJSON (DataType dep ann) - -instance - ( Printer (dep Identifier), - Printer (dep TypeName) - ) => - Printer (DataType dep ann) - where - prettyDoc = renderDataType - -renderDataType :: - (Printer (dep Identifier), Printer (dep TypeName)) => - DataType dep ann -> - Doc style -renderDataType (DataType tyCon vars' constructors') = - "type" - <+> prettyDoc tyCon - <> printVars vars' - <+> if M.null constructors' - then mempty - else - group $ - line - <> indent - 2 - ( align $ - vsep $ - zipWith - (<+>) - ("=" : repeat "|") - (printCons <$> M.toList constructors') - ) - where - printVars [] = mempty - printVars as = space <> sep (prettyDoc <$> as) - printCons (consName, []) = prettyDoc consName - printCons (consName, args) = - prettyDoc consName - <> softline - <> hang - 0 - ( align $ - vsep (prettyMt <$> args) - ) - prettyMt mt = case mt of - mtApp@TApp {} -> "(" <> prettyDoc mtApp <> ")" - mtFunc@TFunc {} -> "(" <> prettyDoc mtFunc <> ")" - other -> prettyDoc other diff --git a/smol-core/src/Smol/Core/Types/Expr.hs b/smol-core/src/Smol/Core/Types/Expr.hs deleted file mode 100644 index ac6a0230..00000000 --- a/smol-core/src/Smol/Core/Types/Expr.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Types.Expr - ( Expr (..), - ParsedExpr, - ResolvedExpr, - IdentityExpr, - ) -where - -import Control.Monad.Identity -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import Data.Foldable (toList) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import GHC.Generics (Generic) -import Prettyprinter ((<+>)) -import qualified Prettyprinter as PP -import Smol.Core.Helpers -import Smol.Core.Printer -import Smol.Core.Types.Constructor -import Smol.Core.Types.Identifier -import Smol.Core.Types.Op -import Smol.Core.Types.ParseDep -import Smol.Core.Types.Pattern -import Smol.Core.Types.Prim -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.Type -import Smol.Core.Types.TypeName - ---------------------------- - -type ParsedExpr ann = Expr ParseDep ann - ---------------------------- - -type ResolvedExpr ann = Expr ResolvedDep ann - ---------------------------- - -type IdentityExpr ann = Expr Identity ann - ---------------------------- - -data Expr dep ann - = ELambda ann (dep Identifier) (Expr dep ann) - | ELet ann (dep Identifier) (Expr dep ann) (Expr dep ann) - | EInfix ann Op (Expr dep ann) (Expr dep ann) - | EPrim ann Prim - | EApp ann (Expr dep ann) (Expr dep ann) - | EIf ann (Expr dep ann) (Expr dep ann) (Expr dep ann) - | EAnn ann (Type dep ann) (Expr dep ann) - | EVar ann (dep Identifier) - | EConstructor ann (dep Constructor) - | ETuple ann (Expr dep ann) (NE.NonEmpty (Expr dep ann)) - | EArray ann (Seq (Expr dep ann)) - | ERecord ann (Map Identifier (Expr dep ann)) - | ERecordAccess ann (Expr dep ann) Identifier - | EPatternMatch - ann - (Expr dep ann) - ( NE.NonEmpty - (Pattern dep ann, Expr dep ann) - ) - deriving stock (Functor, Foldable, Generic, Traversable) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep Constructor), - Eq (dep TypeName) - ) => - Eq (Expr dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep Constructor), - Ord (dep TypeName) - ) => - Ord (Expr dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep Constructor), - Show (dep TypeName) - ) => - Show (Expr dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor), - ToJSON (dep TypeName) - ) => - ToJSON (Expr dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep Constructor), - FromJSON (dep TypeName) - ) => - FromJSON (Expr dep ann) - -instance - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Printer (Expr dep ann) - where - prettyDoc = prettyExpr - ------- printing shit - -data InfixBit dep ann - = IfStart (Expr dep ann) - | IfMore Op (Expr dep ann) - -deriving stock instance - ( Show ann, - Show (dep TypeName), - Show (dep Constructor), - Show (dep Identifier) - ) => - Show (InfixBit dep ann) - -getInfixList :: Expr dep ann -> NE.NonEmpty (InfixBit dep ann) -getInfixList expr = case expr of - (EInfix _ op a b) -> - let start = getInfixList a - in start <> NE.fromList [IfMore op b] - other -> NE.fromList [IfStart other] - -prettyInfixList :: - (Printer (dep Constructor), Printer (dep Identifier), Printer (dep TypeName)) => - NE.NonEmpty (InfixBit dep ann) -> - PP.Doc style -prettyInfixList (ifHead NE.:| ifRest) = - let printInfixBit (IfMore op expr') = prettyDoc op <+> printSubExpr expr' - printInfixBit (IfStart expr') = printSubExpr expr' - in printInfixBit ifHead <+> PP.align (PP.vsep (printInfixBit <$> ifRest)) - --- when on multilines, indent by `i`, if not then nothing -indentMulti :: Integer -> PP.Doc style -> PP.Doc style -indentMulti i doc = PP.flatAlt (PP.indent (fromIntegral i) doc) doc - -prettyLet :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - dep Identifier -> - Expr dep ann -> - Expr dep ann -> - PP.Doc style -prettyLet var expr1 expr2 = - let (args, letExpr, maybeMt) = splitExpr expr1 - prettyVar = case maybeMt of - Just mt -> - "(" <> prettyDoc var <> ":" <+> prettyDoc mt <> ")" - Nothing -> - prettyDoc var - in PP.group - ( "let" - <+> prettyVar - <> prettyArgs args - <+> "=" - <> PP.line - <> indentMulti 2 (prettyDoc letExpr) - <> newlineOrIn - <> prettyDoc expr2 - ) - where - prettyArgs [] = "" - prettyArgs as = PP.space <> PP.hsep (prettyDoc <$> as) - - splitExpr expr = - case expr of - (ELambda _ a rest) -> - let (as, expr', mt) = splitExpr rest - in ([a] <> as, expr', mt) - (EAnn _ mt annExpr) -> - let (as, expr', _) = splitExpr annExpr - in (as, expr', Just mt) - other -> ([], other, Nothing) - -newlineOrIn :: PP.Doc style -newlineOrIn = PP.flatAlt (";" <> PP.line <> PP.line) " in " - -prettyTuple :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Expr dep ann -> - NE.NonEmpty (Expr dep ann) -> - PP.Doc style -prettyTuple a as = - PP.group - ( "(" - <> PP.align - ( PP.vsep - ( PP.punctuate - "," - (printSubExpr <$> ([a] <> NE.toList as)) - ) - ) - <> ")" - ) - -prettyLambda :: - (Printer (dep Constructor), Printer (dep Identifier), Printer (dep TypeName)) => - dep Identifier -> - Expr dep ann -> - PP.Doc style -prettyLambda binder expr = - PP.group - ( PP.vsep - [ "\\" - <> prettyDoc binder - <+> "->", - indentMulti 2 $ - prettyDoc expr - ] - ) - -prettyRecord :: - (Printer (dep Constructor), Printer (dep Identifier), Printer (dep TypeName)) => - Map Identifier (Expr dep ann) -> - PP.Doc style -prettyRecord map' = - let items = M.toList map' - printRow (name, val) i = - let item = - prettyDoc name - <> ":" - <+> printSubExpr val - in item <> if fromIntegral i < length items then "," else "" - in case items of - [] -> "{}" - rows -> - let prettyRows = mapInd printRow rows - in PP.group - ( "{" - <+> PP.align - ( PP.vsep - prettyRows - ) - <+> "}" - ) - -prettyIf :: - ( Printer (dep Constructor), - Printer - ( dep Identifier - ), - Printer (dep TypeName) - ) => - Expr dep ann -> - Expr dep ann -> - Expr dep ann -> - PP.Doc style -prettyIf if' then' else' = - PP.group - ( PP.vsep - [ "if" - <+> wrapInfix if', - "then", - indentMulti 2 (printSubExpr then'), - "else", - indentMulti 2 (printSubExpr else') - ] - ) - -prettyPatternMatch :: - (Printer (dep Constructor), Printer (dep Identifier), Printer (dep TypeName)) => - Expr dep ann -> - NE.NonEmpty (Pattern dep ann, Expr dep ann) -> - PP.Doc style -prettyPatternMatch sumExpr matches = - "match" - <+> printSubExpr sumExpr - <+> "with" - <+> PP.line - <> PP.indent - 2 - ( PP.align $ - PP.vsep - ( zipWith - (<+>) - (" " : repeat "|") - (printMatch <$> NE.toList matches) - ) - ) - where - printMatch (construct, expr') = - printSubPattern construct - <+> "->" - <+> PP.line - <> indentMulti 4 (printSubExpr expr') - -prettyArray :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Seq (Expr dep ann) -> - PP.Doc style -prettyArray items = - let printRow val i = - printSubExpr val - <> if i < fromIntegral (length items) then "," else "" - in case items of - rows - | not (Seq.null rows) -> - let prettyRows = mapInd printRow (toList rows) - in PP.group - ( "[" - <+> PP.align - ( PP.vsep - prettyRows - ) - <+> "]" - ) - _ -> "[]" - -prettyExpr :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Expr dep ann -> - PP.Doc doc -prettyExpr (EPrim _ l) = - prettyDoc l -prettyExpr (EAnn _ mt expr) = - "(" <> prettyExpr expr <+> ":" <+> renderType mt <> ")" -prettyExpr (EVar _ var) = - prettyDoc var -prettyExpr (ELet _ var expr1 expr2) = - prettyLet var expr1 expr2 -prettyExpr wholeExpr@EInfix {} = - PP.group (prettyInfixList (getInfixList wholeExpr)) -prettyExpr (ELambda _ binder expr) = - prettyLambda binder expr -prettyExpr (EApp _ func arg) = - prettyExpr func <+> wrapInfix arg -prettyExpr (ERecordAccess _ expr name) = - prettyExpr expr <> "." <> prettyDoc name -prettyExpr (EIf _ if' then' else') = - prettyIf if' then' else' -prettyExpr (ETuple _ a b) = - prettyTuple a b -prettyExpr (ERecord _ map') = - prettyRecord map' -prettyExpr (EConstructor _ name) = - prettyDoc name -prettyExpr (EPatternMatch _ expr matches) = - prettyPatternMatch expr matches -prettyExpr (EArray _ as) = - prettyArray as - -wrapInfix :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Expr dep ann -> - PP.Doc style -wrapInfix val = case val of - val'@EInfix {} -> inParens val' - other -> printSubExpr other - -inParens :: - ( Printer (dep Constructor), - Printer (dep Identifier), - Printer (dep TypeName) - ) => - Expr dep ann -> - PP.Doc style -inParens = PP.parens . prettyExpr - --- print simple things with no brackets, and complex things inside brackets -printSubExpr :: (Printer (dep Constructor), Printer (dep Identifier), Printer (dep TypeName)) => Expr dep ann -> PP.Doc style -printSubExpr expr = case expr of - all'@ELet {} -> inParens all' - all'@ELambda {} -> inParens all' - all'@EIf {} -> inParens all' - all'@EApp {} -> inParens all' - all'@ETuple {} -> inParens all' - all'@EPatternMatch {} -> inParens all' - a -> prettyDoc a diff --git a/smol-core/src/Smol/Core/Types/Identifier.hs b/smol-core/src/Smol/Core/Types/Identifier.hs deleted file mode 100644 index feb606f0..00000000 --- a/smol-core/src/Smol/Core/Types/Identifier.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Types.Identifier - ( Identifier (..), - safeMkIdentifier, - mkIdentifier, - ) -where - -import qualified Data.Aeson as JSON -import qualified Data.Char as Ch -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import qualified Prettyprinter as PP -import Smol.Core.Printer - -newtype Identifier = Identifier Text - deriving newtype - ( Eq, - Ord, - Show, - JSON.ToJSON, - JSON.ToJSONKey, - JSON.FromJSON, - JSON.FromJSONKey, - Semigroup - ) - -instance Printer Identifier where - prettyDoc (Identifier i) = PP.pretty i - -instance IsString Identifier where - fromString = Identifier . T.pack - -validIdentifier :: Text -> Bool -validIdentifier a = - T.length a > 0 - && T.filter Ch.isAlphaNum a == a - && not (Ch.isDigit (T.head a)) - && Ch.isLower (T.head a) - -mkIdentifier :: Text -> Identifier -mkIdentifier a = - if validIdentifier a - then Identifier a - else error $ T.unpack $ "Identifier validation fail for '" <> a <> "'" - -safeMkIdentifier :: Text -> Maybe Identifier -safeMkIdentifier a = - if validIdentifier a - then Just (Identifier a) - else Nothing diff --git a/smol-core/src/Smol/Core/Types/Op.hs b/smol-core/src/Smol/Core/Types/Op.hs deleted file mode 100644 index a2be4e3a..00000000 --- a/smol-core/src/Smol/Core/Types/Op.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Types.Op - ( Op (..), - ) -where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) -import Smol.Core.Printer - -data Op = OpAdd | OpEquals - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Printer Op where - prettyDoc OpAdd = "+" - prettyDoc OpEquals = "==" diff --git a/smol-core/src/Smol/Core/Types/ParseDep.hs b/smol-core/src/Smol/Core/Types/ParseDep.hs deleted file mode 100644 index a109fe6e..00000000 --- a/smol-core/src/Smol/Core/Types/ParseDep.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - -module Smol.Core.Types.ParseDep - ( ParseDep (..), - emptyParseDep, - ) -where - -import Data.Aeson (FromJSON, ToJSON) -import Data.String -import GHC.Generics (Generic) -import Smol.Core.Modules.Types.ModuleName -import Smol.Core.Printer - ---------------------------- - -data ParseDep identifier = ParseDep - { pdIdentifier :: identifier, - pdModules :: Maybe ModuleName - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance (Printer identifier) => Printer (ParseDep identifier) where - prettyDoc (ParseDep ident _) = prettyDoc ident -- we'll print modules later - -instance (IsString a) => IsString (ParseDep a) where - fromString = emptyParseDep . fromString - -emptyParseDep :: a -> ParseDep a -emptyParseDep a = ParseDep a Nothing diff --git a/smol-core/src/Smol/Core/Types/Pattern.hs b/smol-core/src/Smol/Core/Types/Pattern.hs deleted file mode 100644 index 20eca865..00000000 --- a/smol-core/src/Smol/Core/Types/Pattern.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Types.Pattern - ( Pattern (..), - printSubPattern, - ) -where - -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List.NonEmpty as NE -import GHC.Generics (Generic) -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Types.Constructor -import Smol.Core.Types.Identifier -import Smol.Core.Types.Prim -import Smol.Core.Types.Spread - -data Pattern dep ann - = PWildcard ann - | PVar ann (dep Identifier) - | PTuple ann (Pattern dep ann) (NE.NonEmpty (Pattern dep ann)) - | PArray ann [Pattern dep ann] (Spread dep ann) - | PLiteral ann Prim - | PConstructor ann (dep Constructor) [Pattern dep ann] - deriving stock (Functor, Foldable, Generic, Traversable) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep Constructor) - ) => - Eq (Pattern dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep Constructor) - ) => - Ord (Pattern dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep Constructor) - ) => - Show (Pattern dep ann) - -deriving anyclass instance - ( FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep Constructor) - ) => - FromJSON (Pattern dep ann) - -deriving anyclass instance - ( ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep Constructor) - ) => - ToJSON (Pattern dep ann) - -inParens :: (Printer a) => a -> PP.Doc style -inParens = PP.parens . prettyDoc - --- print simple things with no brackets, and complex things inside brackets -printSubPattern :: - ( Printer (dep Constructor), - Printer (dep Identifier) - ) => - Pattern dep ann -> - PP.Doc style -printSubPattern pat = case pat of - all'@PConstructor {} -> inParens all' - a -> prettyDoc a - -instance - ( Printer (dep Constructor), - Printer (dep Identifier) - ) => - Printer (Pattern dep ann) - where - prettyDoc (PWildcard _) = "_" - prettyDoc (PVar _ a) = prettyDoc a - prettyDoc (PLiteral _ lit) = prettyDoc lit - prettyDoc (PConstructor _ tyCon args) = - let prettyArgs = case args of - [] -> mempty - _ -> foldr (\a b -> " " <> a <> b) mempty (printSubPattern <$> args) - in prettyDoc tyCon <> prettyArgs - prettyDoc (PTuple _ a as) = - "(" <> PP.hsep (PP.punctuate ", " (prettyDoc <$> ([a] <> NE.toList as))) <> ")" - prettyDoc (PArray _ as spread) = - "[" - <> PP.concatWith - (\a b -> a <> ", " <> b) - (prettyDoc <$> as) - <> prettyDoc spread - <> "]" - -{- - prettyDoc (PRecord _ map') = - let items = M.toList map' - printRow i (name, val) = - let item = case val of - (PVar _ vName) | vName == name -> prettyDoc name - _ -> - prettyDoc name - <> ":" - <+> printSubPattern val - in item <> if i < length items then "," else "" - in case items of - [] -> "{}" - rows -> - let prettyRows = mapWithIndex printRow rows - in group - ( "{" - <+> align - ( vsep - prettyRows - ) - <+> "}" - ) - --} -{- - prettyDoc (PString _ a as) = - prettyDoc a <> " ++ " <> prettyDoc as --} diff --git a/smol-core/src/Smol/Core/Types/PatternMatchError.hs b/smol-core/src/Smol/Core/Types/PatternMatchError.hs deleted file mode 100644 index 2d731fe8..00000000 --- a/smol-core/src/Smol/Core/Types/PatternMatchError.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} - -module Smol.Core.Types.PatternMatchError - ( PatternMatchError (..), - renderPatternMatchError, - ) -where - -import Data.Set (Set) -import qualified Data.Text as T -import Prettyprinter -import Smol.Core.Printer -import Smol.Core.Types -import Text.Megaparsec - -data PatternMatchError ann - = -- | No patterns provided - EmptyPatternMatch ann - | -- | "Just 1 2" or "Nothing 3", for instance - -- | ann, offending tyCon, expected, actual - ConstructorArgumentLengthMismatch ann Constructor Int Int - | -- | Cases not covered in pattern matches - -- | ann, [missing patterns] - MissingPatterns ann [Pattern ResolvedDep ann] - | -- | Unnecessary cases covered by previous matches - RedundantPatterns ann [Pattern ResolvedDep ann] - | -- | Multiple instances of the same variable - DuplicateVariableUse ann (Set (ResolvedDep Identifier)) - deriving stock (Eq, Ord, Show, Foldable) - ------- - -instance Semigroup (PatternMatchError ann) where - a <> _ = a - -instance Printer (PatternMatchError ann) where - prettyDoc = vsep . renderPatternMatchError - -instance ShowErrorComponent (PatternMatchError Annotation) where - showErrorComponent = T.unpack . renderWithWidth 40 . prettyDoc - errorComponentLen pmErr = let (_, len) = getErrorPos pmErr in len - -type Start = Int - -type Length = Int - --- | Single combined error area for Megaparsec -fromAnnotation :: Annotation -> (Start, Length) -fromAnnotation (Location a b) = (a, b - a) - -getErrorPos :: PatternMatchError Annotation -> (Start, Length) -getErrorPos = fromAnnotation . mconcat . getAllAnnotations - -getAllAnnotations :: PatternMatchError ann -> [ann] -getAllAnnotations = foldMap pure - ------ - -renderPatternMatchError :: - PatternMatchError ann -> - [Doc a] -renderPatternMatchError (EmptyPatternMatch _) = - ["Pattern match needs at least one pattern to match"] -renderPatternMatchError - ( ConstructorArgumentLengthMismatch - _ - tyCon - expected - actual - ) = - [ "Constructor argument length mismatch. " - <> prettyDoc tyCon - <> " expected " - <> prettyDoc expected - <> " but got " - <> prettyDoc actual - ] -renderPatternMatchError (MissingPatterns _ missing) = - ["Pattern match is not exhaustive. These patterns are missing:"] - <> (prettyDoc <$> missing) -renderPatternMatchError (RedundantPatterns _ redundant) = - ["Pattern match has unreachable patterns, you should remove them"] <> (prettyDoc <$> redundant) -renderPatternMatchError (DuplicateVariableUse _ vars) = - [ "Pattern match variables must be unique.", - "Variables " <> prettyDoc vars <> " are used multiple times" - ] diff --git a/smol-core/src/Smol/Core/Types/Prim.hs b/smol-core/src/Smol/Core/Types/Prim.hs deleted file mode 100644 index aa5e32d6..00000000 --- a/smol-core/src/Smol/Core/Types/Prim.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Core.Types.Prim - ( Prim (..), - ) -where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) -import qualified Prettyprinter as PP -import Smol.Core.Printer - -data Prim - = PUnit - | PInt Integer - | PBool Bool - | PString Text - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Printer Prim where - prettyDoc = renderPrim - -renderPrim :: Prim -> PP.Doc doc -renderPrim (PInt i) = PP.pretty i -renderPrim (PBool True) = "True" -renderPrim (PBool False) = "False" -renderPrim (PString txt) = PP.pretty txt -renderPrim PUnit = "Unit" diff --git a/smol-core/src/Smol/Core/Types/ResolvedDep.hs b/smol-core/src/Smol/Core/Types/ResolvedDep.hs deleted file mode 100644 index 0ee37077..00000000 --- a/smol-core/src/Smol/Core/Types/ResolvedDep.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - -module Smol.Core.Types.ResolvedDep - ( ResolvedDep (..), - emptyResolvedDep, - ) -where - -import Data.String -import GHC.Generics (Generic) -import Smol.Core.Printer - -data ResolvedDep identifier - = LocalDefinition - { rdIdentifier :: identifier - } - | UniqueDefinition - { rdIdentifier :: identifier, - rdUnique :: Int - } - | TypeclassCall - { rdIdentifier :: identifier, - rdUnique :: Int - } - deriving stock (Eq, Ord, Show, Generic) - -instance - (Printer identifier) => - Printer (ResolvedDep identifier) - where - prettyDoc rd = prettyDoc (rdIdentifier rd) - -instance (IsString a) => IsString (ResolvedDep a) where - fromString = emptyResolvedDep . fromString - -emptyResolvedDep :: a -> ResolvedDep a -emptyResolvedDep = LocalDefinition diff --git a/smol-core/src/Smol/Core/Types/SourceSpan.hs b/smol-core/src/Smol/Core/Types/SourceSpan.hs deleted file mode 100644 index 00f565d8..00000000 --- a/smol-core/src/Smol/Core/Types/SourceSpan.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - -module Smol.Core.Types.SourceSpan (SourceSpan (..)) where - -import GHC.Generics (Generic) - -data SourceSpan = SourceSpan - { ssRowStart :: Int, - ssRowEnd :: Int, - ssColStart :: Int, - ssColEnd :: Int - } - deriving stock (Eq, Ord, Show, Generic) diff --git a/smol-core/src/Smol/Core/Types/Spread.hs b/smol-core/src/Smol/Core/Types/Spread.hs deleted file mode 100644 index 9b2d7d88..00000000 --- a/smol-core/src/Smol/Core/Types/Spread.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Types.Spread - ( Spread (..), - ) -where - -import qualified Data.Aeson as JSON -import GHC.Generics -import Smol.Core.Printer -import Smol.Core.Types.Identifier - -data Spread dep ann - = NoSpread - | SpreadWildcard - { sprAnn :: ann - } - | SpreadValue - { sprAnn :: ann, - sprVar :: dep Identifier - } - deriving stock - ( Functor, - Foldable, - Generic, - Traversable - ) - -deriving stock instance - (Eq ann, Eq (dep Identifier)) => - Eq (Spread dep ann) - -deriving stock instance - (Ord ann, Ord (dep Identifier)) => - Ord (Spread dep ann) - -deriving stock instance - (Show ann, Show (dep Identifier)) => - Show (Spread dep ann) - -deriving anyclass instance - (JSON.FromJSON ann, JSON.FromJSON (dep Identifier)) => - JSON.FromJSON (Spread dep ann) - -deriving anyclass instance - (JSON.ToJSON ann, JSON.ToJSON (dep Identifier)) => - JSON.ToJSON (Spread dep ann) - -instance (Printer (dep Identifier)) => Printer (Spread dep ann) where - prettyDoc NoSpread = "" - prettyDoc (SpreadWildcard _) = ", ..." - prettyDoc (SpreadValue _ a) = ", ..." <> prettyDoc a diff --git a/smol-core/src/Smol/Core/Types/Type.hs b/smol-core/src/Smol/Core/Types/Type.hs deleted file mode 100644 index f6977ccd..00000000 --- a/smol-core/src/Smol/Core/Types/Type.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Smol.Core.Types.Type - ( Type (..), - TypePrim (..), - TypeLiteral (..), - ParsedType, - ResolvedType, - renderType, - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Data.Text (Text) -import Data.Word (Word64) -import GHC.Generics (Generic) -import Prettyprinter ((<+>)) -import qualified Prettyprinter as PP -import Smol.Core.Printer -import Smol.Core.Types.Identifier -import Smol.Core.Types.Op -import Smol.Core.Types.ParseDep -import Smol.Core.Types.ResolvedDep -import Smol.Core.Types.TypeName - -type ParsedType ann = Type ParseDep ann - -type ResolvedType ann = Type ResolvedDep ann - -data TypePrim = TPInt | TPBool | TPString - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Printer TypePrim where - prettyDoc TPInt = "Int" - prettyDoc TPBool = "Bool" - prettyDoc TPString = "String" - -data TypeLiteral - = TLBool Bool - | TLInt (NES.NESet Integer) - | TLString (NES.NESet Text) - | TLUnit - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Printer TypeLiteral where - prettyDoc (TLBool b) = PP.pretty b - prettyDoc (TLInt neInts) = - PP.hsep (PP.punctuate "| " (PP.pretty <$> S.toList (NES.toSet neInts))) - prettyDoc (TLString neStrs) = - PP.hsep (PP.punctuate "| " (PP.pretty <$> S.toList (NES.toSet neStrs))) - prettyDoc TLUnit = "Unit" - -data Type dep ann - = TLiteral ann TypeLiteral - | TPrim ann TypePrim - | TFunc ann (Map (dep Identifier) (Type dep ann)) (Type dep ann) (Type dep ann) - | TTuple ann (Type dep ann) (NE.NonEmpty (Type dep ann)) - | TArray ann Word64 (Type dep ann) - | TVar ann (dep Identifier) - | TUnknown ann Integer - | TRecord ann (Map Identifier (Type dep ann)) - | TApp ann (Type dep ann) (Type dep ann) - | TConstructor ann (dep TypeName) - | TInfix ann Op (Type dep ann) (Type dep ann) - deriving stock (Functor, Foldable, Generic, Traversable) - -deriving stock instance - ( Eq ann, - Eq (dep Identifier), - Eq (dep TypeName) - ) => - Eq (Type dep ann) - -deriving stock instance - ( Ord ann, - Ord (dep Identifier), - Ord (dep TypeName) - ) => - Ord (Type dep ann) - -deriving stock instance - ( Show ann, - Show (dep Identifier), - Show (dep TypeName) - ) => - Show (Type dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - FromJSONKey (dep Identifier), - FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep TypeName) - ) => - FromJSON (Type dep ann) - -deriving anyclass instance - ( ToJSONKey (dep Identifier), - ToJSON ann, - ToJSON (dep Identifier), - ToJSON (dep TypeName) - ) => - ToJSON (Type dep ann) - -deriving anyclass instance - ( Ord (dep Identifier), - FromJSON ann, - FromJSON (dep Identifier), - FromJSON (dep TypeName), - FromJSONKey ann, - FromJSONKey (dep Identifier), - FromJSONKey (dep TypeName) - ) => - FromJSONKey (Type dep ann) - -instance (Printer (dep Identifier), Printer (dep TypeName)) => Printer (Type dep ann) where - prettyDoc = renderType - -renderType :: - ( Printer (dep Identifier), - Printer (dep TypeName) - ) => - Type dep ann -> - PP.Doc style -renderType (TPrim _ a) = prettyDoc a -renderType (TInfix _ op a b) = prettyDoc a <+> prettyDoc op <+> prettyDoc b -renderType (TLiteral _ l) = prettyDoc l -renderType (TUnknown _ i) = "U" <> PP.pretty i -renderType (TArray _ _ as) = "[" <> prettyDoc as <> "]" -renderType (TFunc _ _ a b) = - withParens a <+> "->" <+> renderType b -renderType (TTuple _ a as) = - "(" <> PP.hsep (PP.punctuate "," (renderType <$> ([a] <> NE.toList as))) <> ")" -renderType (TRecord _ as) = - renderRecord as --- renderType (TArray _ a) = "[" <+> renderType a <+> "]" -renderType (TVar _ a) = prettyDoc a -renderType (TConstructor _ tyCon) = - prettyDoc tyCon -renderType mt@(TApp _ func arg) = - case varsFromDataType mt of - Just (tyCon, vars) -> - let typeName = prettyDoc tyCon - in PP.align $ PP.sep ([typeName] <> (withParens <$> vars)) - Nothing -> - PP.align $ PP.sep [renderType func, renderType arg] - -renderRecord :: - (Printer (dep Identifier), Printer (dep TypeName)) => - Map Identifier (Type dep ann) -> - PP.Doc style -renderRecord as = - PP.group $ - "{" - <> PP.nest - 2 - ( PP.line - <> mconcat - ( PP.punctuate - ("," <> PP.line) - ( renderItem - <$> M.toList as - ) - ) - ) - <> PP.line - <> "}" - where - renderItem (k, v) = prettyDoc k <> ":" <+> withParens v - --- turn nested shit back into something easy to pretty print (ie, easy to --- bracket) -varsFromDataType :: Type dep ann -> Maybe (dep TypeName, [Type dep ann]) -varsFromDataType mt = - let getInner mt' = - case mt' of - (TConstructor _ tyCon) -> - Just (tyCon, mempty) - (TApp _ f a) -> - ( \(tyCon, vars) -> - (tyCon, vars <> [a]) - ) - <$> getInner f - _ -> Nothing - in getInner mt - -withParens :: (Printer (dep Identifier), Printer (dep TypeName)) => Type dep ann -> PP.Doc a -withParens ma@TFunc {} = PP.parens (renderType ma) -withParens mta@TApp {} = PP.parens (renderType mta) -withParens other = renderType other diff --git a/smol-core/src/Smol/Core/Types/TypeName.hs b/smol-core/src/Smol/Core/Types/TypeName.hs deleted file mode 100644 index 856509b4..00000000 --- a/smol-core/src/Smol/Core/Types/TypeName.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} - -module Smol.Core.Types.TypeName - ( TypeName (..), - ) -where - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import Data.String -import qualified Data.Text as T -import Smol.Core.Printer -import Smol.Core.Types.Constructor - -newtype TypeName = TypeName Constructor - deriving newtype - ( Eq, - Ord, - Show, - ToJSON, - ToJSONKey, - FromJSON, - FromJSONKey - ) - -instance Printer TypeName where - prettyDoc (TypeName n) = prettyDoc n - -instance IsString TypeName where - fromString = TypeName . Constructor . T.pack diff --git a/smol-core/test/Main.hs b/smol-core/test/Main.hs deleted file mode 100644 index 13de740f..00000000 --- a/smol-core/test/Main.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Main (main) where - -import Test.Hspec -import qualified Test.Interpreter.InterpreterSpec -import qualified Test.Modules.CheckSpec -import qualified Test.Modules.FromPartsSpec -import qualified Test.Modules.InterpreterSpec -import qualified Test.Modules.ResolveDepsSpec -import qualified Test.Modules.RunTestsSpec -import qualified Test.Modules.TypecheckSpec -import qualified Test.ParserSpec -import qualified Test.TransformSpec -import qualified Test.Typecheck.ExhaustivenessSpec -import qualified Test.Typecheck.NestingMonadSpec -import qualified Test.Typecheck.PatternSpec -import qualified Test.Typecheck.SubtypeSpec -import qualified Test.Typecheck.ToDictionaryPassingSpec -import qualified Test.Typecheck.TypeclassSpec -import qualified Test.TypecheckSpec - -main :: IO () -main = hspec $ parallel $ do - Test.TypecheckSpec.spec - Test.Typecheck.SubtypeSpec.spec - Test.Typecheck.NestingMonadSpec.spec - Test.Typecheck.ExhaustivenessSpec.spec - Test.Typecheck.PatternSpec.spec - Test.Typecheck.TypeclassSpec.spec - Test.Typecheck.ToDictionaryPassingSpec.spec - Test.ParserSpec.spec - Test.Interpreter.InterpreterSpec.spec - Test.Modules.CheckSpec.spec - Test.Modules.FromPartsSpec.spec - Test.Modules.InterpreterSpec.spec - Test.Modules.ResolveDepsSpec.spec - Test.Modules.RunTestsSpec.spec - Test.Modules.TypecheckSpec.spec - Test.TransformSpec.spec diff --git a/smol-core/test/Test/BuiltInTypes.hs b/smol-core/test/Test/BuiltInTypes.hs deleted file mode 100644 index d62fa34a..00000000 --- a/smol-core/test/Test/BuiltInTypes.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Test.BuiltInTypes - ( builtInTypes, - ) -where - -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Smol.Core.Types - --- | these should move to the test suite, and instead we should rely on types --- defined in module -builtInTypes :: - (Monoid ann, Ord (dep TypeName), Ord (dep Identifier)) => - (forall a. a -> dep a) -> - Map (dep TypeName) (DataType dep ann) -builtInTypes liftDep = - let identityDt = - DataType - "Identity" - ["a"] - (M.singleton "Identity" [TVar mempty $ liftDep "a"]) - maybeDt = - DataType - "Maybe" - ["a"] - (M.fromList [("Just", [TVar mempty $ liftDep "a"]), ("Nothing", [])]) - eitherDt = - DataType - "Either" - ["e", "a"] - ( M.fromList - [ ("Left", [TVar mempty $ liftDep "e"]), - ("Right", [TVar mempty $ liftDep "a"]) - ] - ) - theseDt = - DataType - "These" - ["a", "b"] - ( M.fromList - [ ("This", [TVar mempty $ liftDep "a"]), - ("That", [TVar mempty $ liftDep "b"]), - ("These", [TVar mempty $ liftDep "a", TVar mempty $ liftDep "b"]) - ] - ) - ordDt = - DataType - "Ord" - [] - ( M.fromList [("LT", mempty), ("EQ", mempty), ("GT", mempty)] - ) - - stateDt = - DataType - "State" - ["s", "a"] - ( M.singleton - "State" - [ TFunc - mempty - mempty - (TVar mempty (liftDep "s")) - ( TTuple - mempty - (TVar mempty (liftDep "a")) - (NE.fromList [TVar mempty (liftDep "s")]) - ) - ] - ) - - listDt = - DataType - "List" - ["a"] - ( M.fromList - [ ( "Cons", - [ TVar mempty (liftDep "a"), - TApp mempty (TConstructor mempty (liftDep "List")) (TVar mempty (liftDep "a")) - ] - ), - ("Nil", mempty) - ] - ) - exprDt = - DataType - "Expr" - ["ann"] - ( M.fromList - [ ( "EInt", - [ TVar mempty (liftDep "ann"), - TPrim mempty TPInt - ] - ) - ] - ) - naturalDt = - DataType - "Natural" - [] - ( M.fromList - [ ( "Suc", - [ TConstructor mempty (liftDep "Natural") - ] - ), - ("Zero", mempty) - ] - ) - in M.fromList - [ (liftDep "Maybe", maybeDt), - (liftDep "Either", eitherDt), - (liftDep "Ord", ordDt), - (liftDep "These", theseDt), - (liftDep "Identity", identityDt), - (liftDep "List", listDt), - (liftDep "State", stateDt), - (liftDep "Expr", exprDt), - (liftDep "Natural", naturalDt) - ] diff --git a/smol-core/test/Test/Helpers.hs b/smol-core/test/Test/Helpers.hs deleted file mode 100644 index 36f6a540..00000000 --- a/smol-core/test/Test/Helpers.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Helpers - ( tyBool, - tyBoolLit, - tyInt, - tyIntLit, - tyStrLit, - tyUnit, - tyVar, - tyUnknown, - tyTuple, - tyCons, - tyFunc, - tyString, - tyApp, - bool, - int, - var, - tuple, - array, - unit, - identifier, - constructor, - patternMatch, - getRight, - unsafeParseExpr, - unsafeParseModule, - unsafeParseModuleItems, - unsafeParseType, - unsafeParseTypedExpr, - joinText, - runTypecheckM, - typecheckEnv, - showTypeclass, - eqTypeclass, - functorTypeclass, - unsafeParseInstanceExpr, - tcVar, - typeForComparison, - testModule, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Foldable (foldl') -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Sequence as Seq -import qualified Data.Set as S -import qualified Data.Set.NonEmpty as NES -import Data.Text (Text) -import qualified Data.Text as T -import Smol.Core -import Smol.Core.Modules.FromParts -import Smol.Core.Modules.ResolveDeps -import Smol.Core.Modules.Typecheck -import Smol.Core.Modules.Types.Module -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Modules.Types.ModuleItem -import Smol.Core.Typecheck.FromParsedExpr -import Test.BuiltInTypes (builtInTypes) - -typedModule :: - (MonadError (ModuleError Annotation) m) => - T.Text -> - m (Module ResolvedDep (Type ResolvedDep Annotation)) -typedModule input = do - let moduleItems = case parseModuleAndFormatError input of - Right a -> a - _ -> error "parsing module for typeclass spec" - myModule <- moduleFromModuleParts moduleItems - - let typeClasses = resolveTypeclass <$> moClasses myModule - typeclassMethods = S.fromList . M.elems . fmap tcFuncName $ typeClasses - - (resolvedModule, deps) <- - modifyError ErrorInResolveDeps (resolveModuleDeps typeclassMethods myModule) - - typecheckModule input resolvedModule deps - -getRight :: (Show e) => Either e a -> a -getRight (Right a) = a -getRight (Left e) = error (show e) - -testModule :: Module ResolvedDep (Type ResolvedDep Annotation) -testModule = - getRight $ - typedModule $ - joinText - [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "instance Eq Bool = \\a -> \\b -> a == b", - "instance Eq String = \\a -> \\b -> a == b", - "instance (Eq a, Eq b) => Eq (a,b) = ", - "\\pairA -> \\pairB -> case (pairA, pairB) of ((a1, b1), (a2, b2)) -> ", - "if equals a1 a2 then equals b1 b2 else False", - "type Natural = Suc Natural | Zero", - "class Show a { show: a -> String }", - "instance Show Natural = \\nat -> case nat of Suc n -> \"S \" + show n | _ -> \"\"" - ] - -tyBool :: (Monoid ann) => Type dep ann -tyBool = TPrim mempty TPBool - -tyBoolLit :: (Monoid ann) => Bool -> Type dep ann -tyBoolLit = TLiteral mempty . TLBool - -tyInt :: (Monoid ann) => Type dep ann -tyInt = TPrim mempty TPInt - -tyUnit :: (Monoid ann) => Type dep ann -tyUnit = TLiteral mempty TLUnit - -tyString :: (Monoid ann) => Type dep ann -tyString = TPrim mempty TPString - -tyIntLit :: (Monoid ann) => [Integer] -> Type dep ann -tyIntLit = TLiteral mempty . TLInt . NES.fromList . NE.fromList - -tyStrLit :: (Monoid ann) => [Text] -> Type dep ann -tyStrLit = TLiteral mempty . TLString . NES.fromList . NE.fromList - -tyVar :: (Monoid ann) => Text -> Type ParseDep ann -tyVar = TVar mempty . emptyParseDep . Identifier - -tyUnknown :: (Monoid ann) => Integer -> Type dep ann -tyUnknown = TUnknown mempty - -tyTuple :: - (Monoid ann) => - Type dep ann -> - [Type dep ann] -> - Type dep ann -tyTuple a as = TTuple mempty a (NE.fromList as) - -tyCons :: - (Monoid ann) => - dep TypeName -> - [Type dep ann] -> - Type dep ann -tyCons typeName = - foldl' (TApp mempty) (TConstructor mempty typeName) - -tyFunc :: (Monoid ann, Ord (dep Identifier)) => Type dep ann -> Type dep ann -> Type dep ann -tyFunc = TFunc mempty mempty - -tyApp :: (Monoid ann) => Type dep ann -> Type dep ann -> Type dep ann -tyApp = TApp mempty - -unit :: (Monoid ann) => Expr dep ann -unit = EPrim mempty PUnit - -bool :: (Monoid ann) => Bool -> Expr dep ann -bool = EPrim mempty . PBool - -int :: (Monoid ann) => Integer -> Expr dep ann -int = EPrim mempty . PInt - -var :: (Monoid ann) => Text -> Expr ParseDep ann -var = EVar mempty . emptyParseDep . Identifier - -tuple :: - (Monoid ann) => - Expr dep ann -> - [Expr dep ann] -> - Expr dep ann -tuple a as = ETuple mempty a (NE.fromList as) - -constructor :: - (Monoid ann) => - Text -> - Expr ParseDep ann -constructor lbl = EConstructor mempty (emptyParseDep (Constructor lbl)) - -identifier :: Text -> ParseDep Identifier -identifier = emptyParseDep . Identifier - -patternMatch :: - (Monoid ann) => - Expr dep ann -> - [(Pattern dep ann, Expr dep ann)] -> - Expr dep ann -patternMatch expr pats = - EPatternMatch mempty expr (NE.fromList pats) - -array :: (Monoid ann) => [Expr dep ann] -> Expr dep ann -array as = EArray mempty (Seq.fromList as) - ------- - -unsafeParseExpr :: Text -> Expr ParseDep () -unsafeParseExpr input = case parseExprAndFormatError input of - Right expr -> expr $> () - Left e -> error (show e) - -unsafeParseType :: Text -> Type ParseDep () -unsafeParseType input = case parseTypeAndFormatError input of - Right ty -> ty $> () - Left e -> error (show e) - -unsafeParseModule :: Text -> Module ParseDep () -unsafeParseModule input = - case moduleFromModuleParts (unsafeParseModuleItems input) of - Right a -> a $> () - Left e -> error (show e) - -unsafeParseModuleItems :: Text -> [ModuleItem ()] -unsafeParseModuleItems input = case parseModuleAndFormatError input of - Right parts -> fmap void parts - Left e -> error (show e) - --- | parse a typed expr, ie parse it and fill the type with crap -unsafeParseTypedExpr :: Text -> ResolvedExpr (Type ResolvedDep Annotation) -unsafeParseTypedExpr input = case parseExprAndFormatError input of - Right expr -> fromParsedExpr expr $> TPrim mempty TPBool - Left e -> error (show e) - -joinText :: [T.Text] -> T.Text -joinText = T.intercalate "\n" - ----- - -runTypecheckM :: - (Monad m) => - TCEnv ann -> - StateT (TCState ann) (WriterT [TCWrite ann] (ReaderT (TCEnv ann) m)) a -> - m a -runTypecheckM env action = - fst - <$> runReaderT - ( runWriterT - ( evalStateT - action - (TCState mempty 0 mempty) - ) - ) - env - ------- - -tcVar :: (Monoid ann) => Identifier -> Type ResolvedDep ann -tcVar = TVar mempty . LocalDefinition - -showTypeclass :: (Monoid ann) => Typeclass ResolvedDep ann -showTypeclass = - Typeclass - { tcName = "Show", - tcArgs = ["a"], - tcFuncName = "show", - tcFuncType = tyFunc (tcVar "a") tyString - } - -eqTypeclass :: (Monoid ann) => Typeclass ResolvedDep ann -eqTypeclass = - Typeclass - { tcName = "Eq", - tcArgs = ["a"], - tcFuncName = "equals", - tcFuncType = tyFunc (tcVar "a") (tyFunc (tcVar "a") tyBool) - } - -functorTypeclass :: (Monoid ann) => Typeclass ResolvedDep ann -functorTypeclass = - Typeclass - { tcName = "Functor", - tcArgs = ["f"], - tcFuncName = "fmap", - tcFuncType = - -- (a -> b) -> f a -> f b - tyFunc - (tyFunc (tcVar "a") (tcVar "b")) - ( tyFunc - (tyApp (tcVar "f") (tcVar "a")) - (tyApp (tcVar "f") (tcVar "b")) - ) - } - -classes :: (Monoid ann) => M.Map TypeclassName (Typeclass ResolvedDep ann) -classes = - M.fromList - [ ("Eq", eqTypeclass), - ("Show", showTypeclass), - ("Functor", functorTypeclass) - ] - -unsafeParseInstanceExpr :: (Monoid ann) => Text -> Expr ResolvedDep ann -unsafeParseInstanceExpr = - fmap (const mempty) . fromParsedExpr . unsafeParseExpr - -instances :: (Ord ann, Monoid ann) => M.Map (Constraint ResolvedDep ann) (Instance ResolvedDep ann) -instances = - M.fromList - [ ( Constraint "Eq" [tyInt], - Instance {inExpr = unsafeParseInstanceExpr "\\a -> \\b -> a == b", inConstraints = []} - ), - ( Constraint "Eq" [tyTuple (tcVar "a") [tcVar "b"]], - Instance - { inExpr = - unsafeParseInstanceExpr "\\a -> \\b -> case (a,b) of ((a1, a2), (b1, b2)) -> if equals a1 b1 then equals a2 b2 else False", - inConstraints = - [ Constraint "Eq" [tcVar "a"], - Constraint "Eq" [tcVar "b"] - ] - } - ), - ( Constraint "Functor" [tyCons "Maybe" [tcVar "a"]], - Instance - { inExpr = - unsafeParseInstanceExpr "\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing", - inConstraints = mempty - } - ) - ] - -typecheckEnv :: (Monoid ann, Ord ann) => TCEnv ann -typecheckEnv = - TCEnv - mempty - (builtInTypes emptyResolvedDep) - classes - instances - mempty - ----- - --- simplify type for equality check --- remove anything that can't be described in a type signature -typeForComparison :: (Ord (dep Identifier)) => Type dep ann -> Type dep ann -typeForComparison (TFunc ann _ fn arg) = - TFunc ann mempty (typeForComparison fn) (typeForComparison arg) -typeForComparison (TArray ann _ as) = TArray ann 0 (typeForComparison as) -typeForComparison other = mapType typeForComparison other diff --git a/smol-core/test/Test/Interpreter/InterpreterSpec.hs b/smol-core/test/Test/Interpreter/InterpreterSpec.hs deleted file mode 100644 index cb952dac..00000000 --- a/smol-core/test/Test/Interpreter/InterpreterSpec.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Interpreter.InterpreterSpec (spec) where - -import Control.Monad (void) -import Control.Monad.Reader -import Data.Foldable (traverse_) -import Data.Text (Text) -import Smol.Core -import Smol.Core.Interpreter.Types.Stack -import Smol.Core.Modules.Types.Module -import Smol.Core.Typecheck.FromParsedExpr -import Smol.Core.Typecheck.Typecheck (typecheck) -import Smol.Core.Typecheck.Typeclass -import Test.Helpers -import Test.Hspec - --- | interpret without typechecking etc -doBasicInterpret :: Text -> Expr ResolvedDep () -doBasicInterpret = - fmap edAnnotation - . discardLeft - . interpret mempty - . addEmptyStackFrames - . fromParsedExpr - . unsafeParseExpr - -discardLeft :: (Show e) => Either e a -> a -discardLeft (Left e) = error (show e) -discardLeft (Right a) = a - -runDictEnv :: ReaderT PassDictEnv m a -> m a -runDictEnv = flip runReaderT emptyPassDictEnv - --- | typecheck, resolve typeclasses, interpret, profit -doInterpret :: Text -> Expr ResolvedDep () -doInterpret input = - let dictEnv = - ToDictEnv - { tdeClasses = tceClasses typecheckEnv, - tdeInstances = fmap void <$> moInstances testModule, - tdeVars = mempty - } - in case typecheck typecheckEnv (fromParsedExpr (unsafeParseExpr input)) of - Right (_constraints, typedExpr) -> - fmap edAnnotation - . discardLeft - . interpret mempty - . addEmptyStackFrames - . void - . discardLeft - . runDictEnv - . passDictionaries dictEnv mempty - $ typedExpr - Left e -> error (show e) - -spec :: Spec -spec = do - describe "InterpreterSpec" $ do - describe "interpret" $ do - let cases = - [ ("1 + 1", "2"), - ("-11 + 1", "-10"), - ("(\\a -> a + 1) 41", "42"), - ("(\\a -> if a then 1 else 2) False", "2"), - ("(\\a -> if a then 1 else 2) True", "1"), - ("let a = 41 in a + 1", "42"), - ("Just (1 + 1)", "Just 2"), - ("case (Just 1) of Just a -> a + 41 | Nothing -> 0", "42"), - ("case Nothing of Just a -> a + 41 | Nothing -> 0", "0"), - ("let stuff = { x: 1, y : 2 }; stuff.x + stuff.y", "3"), - ("let id = \\a -> a; (id 1, id 2, id 3)", "(1,2,3)"), - ("[1,2 + 3]", "[1,5]"), - ("case [1,2,3] of [_, ...rest] -> rest | _ -> [42]", "[2,3]"), - ("let f = \\a -> if a == 10 then a else a + f (a + 1); f 0", "55") - ] - traverse_ - ( \(input, expect) -> - it (show input <> " = " <> show expect) $ do - doBasicInterpret input - `shouldBe` fromParsedExpr (unsafeParseExpr expect) - ) - cases - - -- not sure this is the way - describe "interpret with typeclasses" $ do - let cases = - [ ("equals (1 : Int) (1 : Int)", "True"), -- use Eq Int - ("equals (2 : Int) (1 : Int)", "False"), -- use Eq Int - ("equals ((1 : Int),(1 : Int)) ((1 : Int), (2 : Int))", "False") -- use Eq (a,b) and Eq Int - ] - traverse_ - ( \(input, expect) -> - it (show input <> " = " <> show expect) $ do - doInterpret input - `shouldBe` fromParsedExpr (unsafeParseExpr expect) - ) - cases diff --git a/smol-core/test/Test/Modules/CheckSpec.hs b/smol-core/test/Test/Modules/CheckSpec.hs deleted file mode 100644 index a7f793c8..00000000 --- a/smol-core/test/Test/Modules/CheckSpec.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | test evaluating and running tests for a module -module Test.Modules.CheckSpec (spec) where - -import Data.Bifunctor (second) -import Data.FileEmbed -import Data.Foldable (traverse_) -import Data.Functor -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Smol.Core -import Smol.Core.Modules.Check -import Smol.Core.Modules.RunTests -import Smol.Core.Modules.Types.ModuleError -import Test.Hspec - --- these are saved in a file that is included in compilation -testInputs :: [(FilePath, Text)] -testInputs = - fmap (second T.decodeUtf8) $(makeRelativeToProject "test/static/" >>= embedDir) - -testsAllPass :: [(a, Bool)] -> Bool -testsAllPass = getAll . foldMap (All . snd) - --- read a file, check if it is OK etc -testCheckModule :: Text -> Either (ModuleError Annotation) () -testCheckModule input = - case parseModuleAndFormatError input of - Left e -> error (show e) - Right moduleParts -> - checkModule input moduleParts <&> \tcModule -> - let testResults = runTests tcModule - in if testsAllPass testResults - then () - else error (show testResults) - -spec :: Spec -spec = do - describe "Modules" $ do - describe "Check" $ do - let testModule (filepath, input) = - it ("Checks " <> filepath <> " successfully") $ - testCheckModule input `shouldBe` Right () - traverse_ testModule testInputs diff --git a/smol-core/test/Test/Modules/FromPartsSpec.hs b/smol-core/test/Test/Modules/FromPartsSpec.hs deleted file mode 100644 index cb0aed8f..00000000 --- a/smol-core/test/Test/Modules/FromPartsSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.FromPartsSpec (spec) where - -import Smol.Core.Modules.FromParts -import Smol.Core.Modules.Types.ModuleError -import Test.Helpers -import Test.Hspec - --- | tests for checking modules make sense -spec :: Spec -spec = do - describe "Modules" $ do - describe "FromParts" $ do - it "Can't have an empty test name" $ do - let modParts = unsafeParseModuleItems (joinText ["def yes = True", "test \"\" = yes"]) - expected = EmptyTestName (unsafeParseExpr "yes") - - moduleFromModuleParts modParts `shouldBe` Left expected - - it "Can't have duplicate typeclasses" $ do - let modParts = - unsafeParseModuleItems $ - joinText - [ "class Eq { equals : a -> a -> Bool }", - "class Eq { eq: a -> Bool }" - ] - expected = DuplicateTypeclass "Eq" - - moduleFromModuleParts modParts `shouldBe` Left expected - - it "Missing typeclass for instance" $ do - let modParts = - unsafeParseModuleItems $ - joinText - [ "instance Eq Int = \\a -> \\b -> a == b" - ] - expected = MissingTypeclass "Eq" - - moduleFromModuleParts modParts `shouldBe` Left expected diff --git a/smol-core/test/Test/Modules/InterpreterSpec.hs b/smol-core/test/Test/Modules/InterpreterSpec.hs deleted file mode 100644 index 89f29892..00000000 --- a/smol-core/test/Test/Modules/InterpreterSpec.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.InterpreterSpec (spec) where - -import Control.Monad (void) -import Data.Foldable (traverse_) -import Data.Text (Text) -import Error.Diagnose (defaultStyle, printDiagnostic, stdout) -import Smol.Core -import Smol.Core.Modules.Check -import Smol.Core.Modules.Interpret -import Smol.Core.Modules.Types.DefIdentifier -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Typecheck.FromParsedExpr -import Test.Helpers -import Test.Hspec - -showModuleError :: ModuleError Annotation -> IO () -showModuleError modErr = - printDiagnostic stdout True True 2 defaultStyle (moduleErrorDiagnostic modErr) - -testInterpret :: - Text -> - Either - (ModuleError Annotation) - (Expr ResolvedDep ()) -testInterpret input = - case parseModuleAndFormatError input of - Right moduleParts -> do - goodModule <- checkModule input moduleParts - fmap void (interpretModule (DIName "main") (fmap getTypeAnnotation goodModule)) - Left e -> error (show e) - -spec :: Spec -spec = do - describe "Module InterpreterSpec" $ do - describe "interpret" $ do - let cases = - [ ( ["def main = 1 + 1"], - "2" - ), - ( [ "def id a = a", - "def main = id -10" - ], - "-10" - ), - ( [ "def id a = a", - "def useId a = id a", - "def main = useId 100" - ], - "100" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def main = equals (1: Int) (2: Int)" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def useEquals = equals (1: Int) (2: Int)", - "def main = useEquals" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def useEquals : Int -> Bool", - "def useEquals a = equals a (1: Int)", - "def main : Bool", - "def main = useEquals 2" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def useEquals : Bool -> Bool", - "def useEquals a = equals (2: Int) (1: Int)", - "def main : Bool", - "def main = useEquals True" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "instance (Eq a, Eq b) => Eq (a,b) = \\a -> \\b -> case (a,b) of ((a1, b1), (a2, b2)) -> if equals a1 a2 then equals b1 b2 else False", - "def main = equals ((1:Int), (2: Int)) ((1: Int), (2: Int))" - ], - "True" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def main : Bool", - "def main = useEquals (1: Int) (2: Int)", - "def useEquals : (Eq a) => a -> a -> Bool", - "def useEquals a b = equals a b" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "def main : Bool", - "def main = notEquals (1: Int) (2: Int)", - "def notEquals : (Eq a) => a -> a -> Bool", - "def notEquals a b = if isEquals a b then False else True", - "def isEquals : (Eq a) => a -> a -> Bool", - "def isEquals a b = equals a b" - ], - "True" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq String = \\a -> \\b -> a == b", - "def main : Bool", - "def main = equals (\"cat\" : String) (\"cat\" : String)" - ], - "True" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "class Semigroup a { mappend: a -> a -> a }", - "instance Semigroup Int = \\a -> \\b -> a + b", - "def main : Bool", - "def main = equals (mappend (20 : Int) (22 : Int)) (42 : Int)" - ], - "True" - ), - ( [ "type Pet = Dog | Cat | Rat", - "class Eq a { equals: a -> a -> Bool }", - "instance Eq Pet = \\a -> \\b -> case (a,b) of (Dog, Dog) -> True | (Cat, Cat) -> True | (Rat, Rat) -> True | _ -> False", - "def main : Bool", - "def main = equals Dog Rat" - ], - "False" - ), - ( [ "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = \\a -> \\b -> a == b", - "type Maybe a = Just a | Nothing", - "instance (Eq a) => Eq (Maybe a) = \\ma -> \\mb -> case (ma, mb) of (Just a, Just b) -> equals a b | (Nothing, Nothing) -> True | _ -> False", - "def main : Bool", - "def main = equals (Just (1: Int)) Nothing" - ], - "False" - ), - ( [ "type Natural = Suc Natural | Zero", - "class Show a { show: a -> String }", - "instance Show Natural = \\nat -> ", - "case nat of Suc n -> \"S \" + show n ", - "| _ -> \"Z\"", - "def main : String", - "def main = show (Suc Zero)" - ], - "\"S Z\"" - ) - ] - traverse_ - ( \(parts, expect) -> - let input = joinText parts - in it (show input <> " = " <> show expect) $ do - let expected :: Expr ResolvedDep () - expected = void (fromParsedExpr (unsafeParseExpr expect)) - - let result = testInterpret input - case result of - Left e -> showModuleError e - _ -> pure () - - result `shouldBe` Right expected - ) - cases diff --git a/smol-core/test/Test/Modules/ResolveDepsSpec.hs b/smol-core/test/Test/Modules/ResolveDepsSpec.hs deleted file mode 100644 index e6ea5f06..00000000 --- a/smol-core/test/Test/Modules/ResolveDepsSpec.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.ResolveDepsSpec (spec) where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Smol.Core -import Smol.Core.Modules.ResolveDeps -import Smol.Core.Modules.Types hiding (Entity (..)) -import Test.Helpers -import Test.Hspec - -spec :: Spec -spec = do - describe "Modules" $ do - describe "ResolvedDeps" $ do - it "No deps, marks var as unique" $ do - let mod' = unsafeParseModule "def main = let a = 123 in a" - expr = - ELet - () - (UniqueDefinition "a" 1) - (int 123) - (EVar () (UniqueDefinition "a" 1)) - - expected = - mempty - { moExpressions = M.singleton "main" (TopLevelExpression mempty expr Nothing) - } - - fst <$> resolveModuleDeps mempty mod' `shouldBe` Right expected - - it "Marks a typeclass usage as TypeclassCall with unique number" $ do - let mod' = unsafeParseModule "def main = equals 1 2" - expr = - EApp - () - ( EApp - () - (EVar () (TypeclassCall "equals" 1)) - (int 1) - ) - (int 2) - - typeclassMethods = S.singleton "equals" - expected = - mempty - { moExpressions = M.singleton "main" (TopLevelExpression mempty expr Nothing) - } - - fst <$> resolveModuleDeps typeclassMethods mod' `shouldBe` Right expected - - it "No deps, marks two different `a` values correctly" $ do - let mod' = unsafeParseModule "def main = let a = 123 in let a = 456 in a" - expr = - ELet - () - (UniqueDefinition "a" 1) - (int 123) - ( ELet - () - (UniqueDefinition "a" 2) - (int 456) - (EVar () (UniqueDefinition "a" 2)) - ) - - expected = - mempty - { moExpressions = M.singleton "main" (TopLevelExpression mempty expr Nothing) - } - - fst <$> resolveModuleDeps mempty mod' `shouldBe` Right expected - - it "Lambdas add new variables" $ do - let mod' = unsafeParseModule "def main = \\a -> a" - expr = ELambda () (UniqueDefinition "a" 1) (EVar () (UniqueDefinition "a" 1)) - - expected = - mempty - { moExpressions = M.singleton "main" (TopLevelExpression mempty expr Nothing) - } - - fst <$> resolveModuleDeps mempty mod' `shouldBe` Right expected - - it "Variables added in pattern matches are unique" $ do - let mod' = unsafeParseModule "def main pair = case pair of (a,_) -> a" - expr = - ELambda - () - (UniqueDefinition "pair" 1) - ( EPatternMatch - () - (EVar () (UniqueDefinition "pair" 1)) - ( NE.fromList [(PTuple () (PVar () (UniqueDefinition "a" 2)) (NE.singleton (PWildcard ())), EVar () (UniqueDefinition "a" 2))] - ) - ) - expected = - mempty - { moExpressions = M.singleton "main" (TopLevelExpression mempty expr Nothing) - } - - fst <$> resolveModuleDeps mempty mod' `shouldBe` Right expected - - it "'main' uses a dep from 'dep'" $ do - let mod' = unsafeParseModule "def main = let a = dep in let a = 456 in a\ndef dep = 1" - depExpr = int 1 - mainExpr = - ELet - () - (UniqueDefinition "a" 1) - (EVar () (LocalDefinition "dep")) - ( ELet - () - (UniqueDefinition "a" 2) - (int 456) - (EVar () (UniqueDefinition "a" 2)) - ) - - expected = - mempty - { moExpressions = - M.fromList - [ ("main", TopLevelExpression mempty mainExpr Nothing), - ("dep", TopLevelExpression mempty depExpr Nothing) - ] - } - - fst <$> resolveModuleDeps mempty mod' `shouldBe` Right expected - - it "'main' uses a type dep from 'Moybe'" $ do - let mod' = unsafeParseModule "type Moybe a = Jost a | Noothing\ndef main = let a = 456 in Jost a" - mainExpr = - ELet - () - (UniqueDefinition "a" 1) - (int 456) - ( EApp - () - (EConstructor () (LocalDefinition "Jost")) - (EVar () (UniqueDefinition "a" 1)) - ) - - expected = - mempty - { moExpressions = - M.singleton "main" (TopLevelExpression mempty mainExpr Nothing), - moDataTypes = - M.singleton - "Moybe" - ( DataType - { dtName = "Moybe", - dtVars = ["a"], - dtConstructors = - M.fromList - [ ("Jost", [TVar () (LocalDefinition "a")]), - ("Noothing", mempty) - ] - } - ) - } - - depMap = - M.fromList - [ (DIName "main", S.fromList [DIType "Moybe"]), - (DIType "Moybe", mempty) - ] - - resolveModuleDeps mempty mod' `shouldBe` Right (expected, depMap) diff --git a/smol-core/test/Test/Modules/RunTestsSpec.hs b/smol-core/test/Test/Modules/RunTestsSpec.hs deleted file mode 100644 index f8b982c6..00000000 --- a/smol-core/test/Test/Modules/RunTestsSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Modules.RunTestsSpec (spec) where - -import qualified Data.Text as T -import Smol.Core -import Smol.Core.Modules.Check -import Smol.Core.Modules.RunTests -import Smol.Core.Modules.Types -import Smol.Core.Modules.Types.ModuleError -import Test.Helpers -import Test.Hspec - --- this should probably become shared code -testTypecheck :: - T.Text -> - Either - (ModuleError Annotation) - (Module ResolvedDep (Type ResolvedDep Annotation)) -testTypecheck input = - case parseModuleAndFormatError input of - Right moduleParts -> checkModule input moduleParts - Left e -> error (show e) - --- | tests for checking modules make sense -spec :: Spec -spec = do - describe "Modules" $ do - describe "Run tests" $ do - it "No tests, no results" $ do - let typedMod = testTypecheck (joinText ["def id a = a"]) - runTests <$> typedMod `shouldBe` Right mempty - - it "Two tests, one pass, one fail, no deps" $ do - let typedMod = - testTypecheck - ( joinText - [ "def yes = True", - "def no = False", - "test \"pass\" = yes", - "test \"fail\" = no" - ] - ) - runTests <$> typedMod `shouldBe` Right [("fail", False), ("pass", True)] - - it "Two tests, one pass, one fail, with deps" $ do - let typedMod = - testTypecheck - ( joinText - [ "def id a = a", - "def yes = id True", - "def no = id False", - "test \"pass\" = yes", - "test \"fail\" = no" - ] - ) - runTests <$> typedMod `shouldBe` Right [("fail", False), ("pass", True)] diff --git a/smol-core/test/Test/Modules/TypecheckSpec.hs b/smol-core/test/Test/Modules/TypecheckSpec.hs deleted file mode 100644 index 1d236210..00000000 --- a/smol-core/test/Test/Modules/TypecheckSpec.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Test.Modules.TypecheckSpec (spec) where - -import Data.Bifunctor (second) -import Data.Either (isRight) -import Data.FileEmbed -import Data.Foldable (traverse_) -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Smol.Core -import Smol.Core.Modules.Check -import Smol.Core.Modules.Types hiding (Entity (..)) -import Smol.Core.Modules.Types.ModuleError -import Test.Helpers -import Test.Hspec - --- these are saved in a file that is included in compilation -testInputs :: [(FilePath, Text)] -testInputs = - fmap (second T.decodeUtf8) $(makeRelativeToProject "test/static/" >>= embedDir) - -testTypecheck :: - Text -> - Either - (ModuleError Annotation) - (Module ResolvedDep (Type ResolvedDep Annotation)) -testTypecheck input = - case parseModuleAndFormatError input of - Right moduleParts -> checkModule input moduleParts - Left e -> error (show e) - -spec :: Spec -spec = do - describe "Modules" $ do - describe "Tests" $ do - it "Accepts a unit test with type `Boolean`" $ do - testTypecheck - ( joinText - [ "test \"it's fine\" = yes", - "def yes = True" - ] - ) - `shouldSatisfy` isRight - - it "Does not accept a unit test with another type" $ do - let input = - joinText - [ "test \"it's fine\" = yes", - "def yes = 100" - ] - testTypecheck input - `shouldSatisfy` \case - Left - ( ErrorInTest - "it's fine" - ( TestDoesNotTypecheck - _ - (TCTypeMismatch _ _) - ) - ) -> True - _ -> False - - describe "Typecheck" $ do - let typecheckAModule (filepath, input) = - it ("Typechecks " <> filepath <> " successfully") $ - testTypecheck input `shouldSatisfy` isRight - traverse_ typecheckAModule testInputs diff --git a/smol-core/test/Test/ParserSpec.hs b/smol-core/test/Test/ParserSpec.hs deleted file mode 100644 index 3e395b84..00000000 --- a/smol-core/test/Test/ParserSpec.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Test.ParserSpec (spec) where - -import Data.Bifunctor (second) -import Data.Either (isRight) -import Data.FileEmbed -import Data.Foldable (traverse_) -import Data.Functor -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Sequence as Seq -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Smol.Core -import Test.Helpers -import Test.Hspec - --- these are saved in a file that is included in compilation -testInputs :: [(FilePath, Text)] -testInputs = - fmap (second T.decodeUtf8) $(makeRelativeToProject "test/static/" >>= embedDir) - -spec :: Spec -spec = do - describe "Parser" $ do - describe "Constraint" $ do - let inputs = - [ ( "Eq Int", - Constraint "Eq" [tyInt] - ), - ( "Eq (a,b)", - Constraint "Eq" [tyTuple (tyVar "a") [tyVar "b"]] - ) - ] - traverse_ - ( \(input, expected) -> - it (T.unpack $ "Parses constraint: " <> input) $ do - parseConstraintAndFormatError input `shouldBe` Right expected - ) - inputs - - describe "Module" $ do - let singleDefs = - [ "type Dog a = Woof String | Other a", - "def id : a -> a", - "def id a = a", - "def compose f g a = f (g a)", - "def compose : (c -> b) -> (a -> b) -> (a -> c)", - "def onePlusOneEqualsTwo = 1 + 1 == 2", - "test \"one plus one equals two\" = 1 + 1 == 2", - "def usesEquals : (Eq (a,b)) => (a,b) -> (a,b) -> Bool", - "class Eq a { equals: a -> a -> Bool }", - "instance Eq Int = eqInt", - "instance (Eq a) => Eq (Maybe a) = eqMaybeA" - ] - - it "All defs" $ do - let result = parseModuleAndFormatError (T.intercalate "\n" (T.pack <$> singleDefs)) - result `shouldSatisfy` isRight - - traverse_ - ( \input -> it ("Parses module item: " <> input) $ do - let result = parseModuleAndFormatError (T.pack input) - - result `shouldSatisfy` isRight - ) - singleDefs - - traverse_ - ( \(filename, contents) -> - it ("Parses " <> filename) $ do - let result = parseModuleAndFormatError contents - result `shouldSatisfy` isRight - ) - testInputs - - describe "Expr" $ do - let strings = - [ ("True", bool True), - ("False", bool False), - ("Unit", unit), - ("-1", int (-1)), - ("100", int 100), - ("if True then 1 else 2", EIf () (bool True) (int 1) (int 2)), - ("1 + 2", EInfix () OpAdd (int 1) (int 2)), - ("1 + 2 + 3", EInfix () OpAdd (EInfix () OpAdd (int 1) (int 2)) (int 3)), - ("\"\"", EPrim () (PString mempty)), - ("\"horses\"", EPrim () (PString "horses")), - ("(True)", bool True), - ("(True,True)", tuple (bool True) [bool True]), - ("(100, 200, 300)", tuple (int 100) [int 200, int 300]), - ("log", var "log"), - ("Prelude.log", EVar () (ParseDep "log" (Just "Prelude"))), - ("\\a -> True", ELambda () "a" (bool True)), - ( "(\\a -> True : Int -> Bool)", - EAnn () (TFunc () mempty tyInt tyBool) (ELambda () "a" (bool True)) - ), - ( "(\\a -> a : a -> a)", - EAnn () (TFunc () mempty (tyVar "a") (tyVar "a")) (ELambda () "a" (var "a")) - ), - ("{ a: 1, b: True }", ERecord () (M.fromList [("a", int 1), ("b", bool True)])), - ("Just", constructor "Just"), - ("Maybe.Just", EConstructor () (ParseDep "Just" (Just "Maybe"))), - ("Just True", EApp () (constructor "Just") (bool True)), - ("These 1 False", EApp () (EApp () (constructor "These") (int 1)) (bool False)), - ( "case a of (b, c) -> b + c", - patternMatch (var "a") [(PTuple () (PVar () "b") (NE.fromList [PVar () "c"]), EInfix () OpAdd (var "b") (var "c"))] - ), - ( "case (1,2) of (a,_) -> a", - patternMatch (tuple (int 1) [int 2]) [(PTuple () (PVar () "a") (NE.fromList [PWildcard ()]), var "a")] - ), - ( "case (True, 1) of (True, a) -> a | (False,_) -> 0", - patternMatch - (tuple (bool True) [int 1]) - [ (PTuple () (PLiteral () (PBool True)) (NE.fromList [PVar () "a"]), var "a"), - (PTuple () (PLiteral () (PBool False)) (NE.fromList [PWildcard ()]), int 0) - ] - ), - ( "case [1,2,3] of [_, ...b] -> b | other -> other", - patternMatch - (array [int 1, int 2, int 3]) - [ (PArray () [PWildcard ()] (SpreadValue () "b"), var "b"), - (PVar () "other", var "other") - ] - ), - ("let a = 1 in a", ELet () "a" (int 1) (var "a")), - ("f (a b)", EApp () (var "f") (EApp () (var "a") (var "b"))), - ("fmap inc (Just 1)", EApp () (EApp () (var "fmap") (var "inc")) (EApp () (constructor "Just") (int 1))), - ("Just (1 + 1)", EApp () (constructor "Just") (EInfix () OpAdd (int 1) (int 1))), - ("[]", EArray () mempty), - ("[1,2,3,4]", EArray () (Seq.fromList [int 1, int 2, int 3, int 4])) - ] - traverse_ - ( \(str, expr) -> it (T.unpack str) $ do - case parseExprAndFormatError str of - Right parsedExp -> parsedExp $> () `shouldBe` expr - Left e -> error (T.unpack e) - ) - strings - - describe "Type" $ do - let strings = - [ ("True", tyBoolLit True), - ("False", tyBoolLit False), - ("1 | 2 | 3", tyIntLit [1, 2, 3]), - ("\"horse\"", tyStrLit ["horse"]), - ("1 + 2", TInfix () OpAdd (tyIntLit [1]) (tyIntLit [2])), - ( "(a -> b) -> Maybe a -> Maybe b", - TFunc - () - mempty - ( TFunc () mempty (tyVar "a") (tyVar "b") - ) - (TFunc () mempty (tyCons "Maybe" [tyVar "a"]) (tyCons "Maybe" [tyVar "b"])) - ), - ( "m (a -> b)", - TApp - () - (tyVar "m") - ( TFunc () mempty (TVar () "a") (TVar () "b") - ) - ), - ( "m (a -> b) -> m a -> m b", - TFunc - () - mempty - (TApp () (tyVar "m") (TFunc () mempty (TVar () "a") (TVar () "b"))) - ( TFunc - () - mempty - (TApp () (TVar () "m") (TVar () "a")) - (TApp () (TVar () "m") (TVar () "b")) - ) - ), - ( "(a -> b) -> f a -> f b", - TFunc - () - mempty - (TFunc () mempty (TVar () "a") (TVar () "b")) - ( TFunc - () - mempty - (TApp () (TVar () "f") (TVar () "a")) - (TApp () (TVar () "f") (TVar () "b")) - ) - ), - ("Maybe.Maybe", TConstructor () (ParseDep "Maybe" (Just "Maybe"))), - ("[Bool]", TArray () 0 tyBool), - ("String", TPrim () TPString), - ("Either e a", tyCons "Either" [tyVar "e", tyVar "a"]), - ( "s -> (a, s)", - TFunc () mempty (tyVar "s") (tyTuple (tyVar "a") [tyVar "s"]) - ), - ( "(b -> c) -> (a -> b)", - TFunc () mempty (TFunc () mempty (tyVar "b") (tyVar "c")) (TFunc () mempty (tyVar "a") (tyVar "b")) - ), - ( "a -> State s a", - TFunc () mempty (tyVar "a") (tyCons "State" [tyVar "s", tyVar "a"]) - ) - ] - traverse_ - ( \(str, ty) -> it (T.unpack str) $ do - case parseTypeAndFormatError str of - Right parsedTy -> parsedTy $> () `shouldBe` ty - Left e -> error (T.unpack e) - ) - strings - - describe "DataType" $ do - let strings = - [ ( "type Expr ann = EInt ann Int", - DataType "Expr" ["ann"] (M.singleton "EInt" [TVar () "ann", TPrim () TPInt]) - ) - ] - traverse_ - ( \(str, dt) -> it (T.unpack str) $ do - case parseDataTypeAndFormatError str of - Right parsedDt -> parsedDt $> () `shouldBe` dt - Left e -> error (T.unpack e) - ) - strings diff --git a/smol-core/test/Test/TransformSpec.hs b/smol-core/test/Test/TransformSpec.hs deleted file mode 100644 index e5609865..00000000 --- a/smol-core/test/Test/TransformSpec.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.TransformSpec (spec) where - -import Control.Monad (void) -import Data.Foldable (traverse_) -import qualified Data.Text as T -import Smol.Core.Parser -import Smol.Core.Transform.BetaReduce -import Smol.Core.Transform.EtaReduce -import Smol.Core.Transform.FlattenLets -import Smol.Core.Transform.FloatDown -import Test.Helpers -import Test.Hspec - -spec :: Spec -spec = do - describe "BetaReduce" $ do - let singleDefs = - [ ("id", "id"), - ("(\\a -> a + 1) b", "let a = b in a + 1"), - ("(\\a -> \\b -> a + b) a1 b2", "let a = a1; let b = b2; a + b"), - ("(\\a -> a + 1 : Int -> Int) b", "let a = b in a + 1"), - ("if True then 1 else 2", "1"), - ("if False then 1 else 2", "2"), - ("{ a: 1, b: 2 }.a", "1") - ] - - traverse_ - ( \(input, expectText) -> it ("Beta reduces: " <> input) $ do - let expr = getRight $ parseExprAndFormatError (T.pack input) - expected = getRight $ parseExprAndFormatError (T.pack expectText) - - void (betaReduce expr) `shouldBe` void expected - ) - singleDefs - - describe "EtaReduce" $ do - let singleDefs = - [ ("id", "id"), - ("\\a -> id a", "id"), - ("\\a -> \\b -> id a b", "id"), - ("\\a -> \\b -> \\c -> id a b c", "id") - ] - - traverse_ - ( \(input, expectText) -> it ("Eta reduces: " <> input) $ do - let expr = getRight $ parseExprAndFormatError (T.pack input) - expected = getRight $ parseExprAndFormatError (T.pack expectText) - - void (etaReduce expr) `shouldBe` void expected - ) - singleDefs - - describe "FlattenLets" $ do - let singleDefs = - [ ("id", "id"), - ( "let a = (let b = 1 in b + 1) in a + 1", - "let b = 1; let a = b + 1; a + 1" - ), - ( "let a = (let b = (let c = 1 in c + 1) in b + 1) in a + 1", - "let c = 1; let b = c + 1; let a = b + 1; a + 1" - ) - ] - - traverse_ - ( \(input, expectText) -> it ("Flattens lets: " <> input) $ do - let expr = getRight $ parseExprAndFormatError (T.pack input) - expected = getRight $ parseExprAndFormatError (T.pack expectText) - - void (flattenLets expr) `shouldBe` void expected - ) - singleDefs - - describe "FloatDown" $ do - let singleDefs = - [ ("id", "id"), - ( "let a = 1; case a of True -> 1 | False -> 2", - "let a = 1; case a of True -> 1 | False -> 2" - ), - ( "let a = 1; case b of True -> 1 | False -> 2", - "case b of True -> let a = 1; 1 | False -> let a = 1; 2" - ), - ("let a = 1; if a then 1 else 2", "let a = 1; if a then 1 else 2"), - ( "let a = 1; if b then 1 else 2", - "if b then let a = 1; 1 else let a = 1; 2" - ), - ( "let a = 1; let b = 2; if c then 1 else 2", - "if c then let a = 1; let b = 2; 1 else let a = 1; let b = 2; 2" - ) - ] - - traverse_ - ( \(input, expectText) -> it ("Flattens lets: " <> input) $ do - let expr = getRight $ parseExprAndFormatError (T.pack input) - expected = getRight $ parseExprAndFormatError (T.pack expectText) - - void (floatDown expr) `shouldBe` void expected - ) - singleDefs diff --git a/smol-core/test/Test/Typecheck/ExhaustivenessSpec.hs b/smol-core/test/Test/Typecheck/ExhaustivenessSpec.hs deleted file mode 100644 index f06f0079..00000000 --- a/smol-core/test/Test/Typecheck/ExhaustivenessSpec.hs +++ /dev/null @@ -1,447 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typecheck.ExhaustivenessSpec - ( spec, - ) -where - -import Control.Monad.Except -import Control.Monad.Reader -import qualified Data.List.NonEmpty as NE -import Smol.Core -import Smol.Core.Typecheck.FromParsedExpr -import Test.BuiltInTypes -import Test.Helpers -import Test.Hspec - -env :: (Monoid ann, Ord ann) => TCEnv ann -env = TCEnv mempty (builtInTypes emptyResolvedDep) mempty mempty mempty - -type PatternM = ExceptT (TCError Annotation) (Reader (TCEnv Annotation)) - --- this is partial as fuck but let's get it typechecking and import it into the --- new project - -runPatternM :: - PatternM a -> - Either (TCError Annotation) a -runPatternM value = - runReader (runExceptT value) env - -exhaustiveCheck :: - [Pattern ResolvedDep (Type ResolvedDep Annotation)] -> - Either (TCError Annotation) [Pattern ResolvedDep (Type ResolvedDep Annotation)] -exhaustiveCheck pats = runPatternM $ isExhaustive pats - -_redundantCasesCheck :: - [Pattern ResolvedDep (Type ResolvedDep Annotation)] -> - Either (TCError Annotation) [Pattern ResolvedDep (Type ResolvedDep Annotation)] -_redundantCasesCheck pats = runPatternM $ redundantCases pats - -_noDuplicatesCheck :: - Pattern ResolvedDep (Type ResolvedDep Annotation) -> - Either (TCError Annotation) () -_noDuplicatesCheck = runPatternM . noDuplicateVariables - -spec :: Spec -spec = do - describe "Exhaustiveness" $ do - describe "Smaller list versions" $ do - it "Empty is empty" $ do - smallerListVersions [] `shouldBe` ([] :: [[Int]]) - it "1 list is the same" $ do - smallerListVersions [[1]] `shouldBe` ([[1]] :: [[Int]]) - it "2 list adds a 1 list" $ do - smallerListVersions [[1, 2]] `shouldBe` ([[2], [1, 2]] :: [[Int]]) - it "3 list adds a 2 and a 1 list" $ do - smallerListVersions [[1, 2, 3]] `shouldBe` ([[3], [2, 3], [1, 2, 3]] :: [[Int]]) - - describe "annihilate" $ do - it "Tuple of wildcards annihilates tuple of true lits" $ do - let left = - PTuple - mempty - (PWildcard mempty) - ( NE.fromList - [ PWildcard mempty, - PWildcard mempty - ] - ) - right = - PTuple - mempty - (PLiteral mempty (PBool True)) - ( NE.fromList - [ PLiteral mempty (PBool True), - PLiteral mempty (PBool True) - ] - ) - annihilate left right `shouldBe` True - - it "Tuple of wildcards annihilates tuple of true lits" $ do - let left = - PTuple - mempty - (PWildcard mempty) - ( NE.fromList [PWildcard mempty, PLiteral mempty (PBool True)] - ) - right = - PTuple - mempty - (PLiteral mempty (PBool True)) - ( NE.fromList [PLiteral mempty (PBool True), PLiteral mempty (PBool True)] - ) - annihilate left right `shouldBe` True - - describe "Exhaustiveness" $ - do - it "True literal is complete in itself" $ do - let ty = tyBoolLit True - exhaustiveCheck [PLiteral ty (PBool True)] - `shouldBe` Right [] - it "False literal is complete in itself" $ do - let ty = tyBoolLit False - exhaustiveCheck [PLiteral ty (PBool False)] - `shouldBe` Right [] - - it "Int literal is complete in itself" $ do - let ty = tyIntLit [100] - exhaustiveCheck [PLiteral ty (PInt 100)] - `shouldBe` Right mempty - - it "Int needs wildcard" $ do - exhaustiveCheck [PLiteral tyInt (PInt 100)] - `shouldBe` Right [PWildcard tyInt] - - it "Union of int literals" $ do - let ty = tyIntLit [1, 2] - exhaustiveCheck [PLiteral ty (PInt 1)] - `shouldBe` Right [PLiteral (tyIntLit [1, 2]) (PInt 2)] - - it "Wildcard is fine" $ do - exhaustiveCheck [PWildcard tyInt] `shouldBe` Right [] - - it "Var alone is fine" $ do - exhaustiveCheck [PVar tyInt "a"] `shouldBe` Right [] - - it "Both True and False is fine" $ do - exhaustiveCheck - [ PLiteral tyBool (PBool False), - PLiteral - tyBool - ( PBool True - ) - ] - `shouldBe` Right [] - - it "Just True return Lit False" $ do - exhaustiveCheck - [PLiteral tyBool (PBool False)] - `shouldBe` Right - [ PLiteral - tyBool - ( PBool True - ) - ] - - it "Just False return Lit True" $ do - exhaustiveCheck - [PLiteral tyBool (PBool True)] - `shouldBe` Right - [ PLiteral - tyBool - ( PBool False - ) - ] - - it "Int literal returns Wildcard" $ do - exhaustiveCheck [PLiteral tyInt (PInt 1)] - `shouldBe` Right [PWildcard tyInt] - - it "Int then var is exhaustive" $ do - exhaustiveCheck - [ PLiteral tyInt (PInt 1), - PVar tyInt "otherwise" - ] - `shouldBe` Right mempty - - it "Pair of vars is fine" $ do - exhaustiveCheck - [ PTuple - (tyTuple tyInt [tyInt]) - (PWildcard tyInt) - (NE.singleton $ PWildcard tyInt) - ] - `shouldBe` Right [] - - it "Pair of False is returned" $ - do - let true = PLiteral tyBool (PBool True) - false = PLiteral tyBool (PBool False) - tuple' = tyTuple tyBool [tyBool] - exhaustiveCheck - [ PTuple tuple' true (NE.singleton true), - PTuple tuple' false (NE.singleton true), - PTuple tuple' true (NE.singleton false) - ] - `shouldBe` Right [PTuple tuple' false (NE.singleton false)] - - it "3 tuple of wildcards is exhaustive" $ do - let wildcard = PWildcard tyInt - tuple' = tyTuple tyInt [tyInt, tyInt] - exhaustiveCheck - [PTuple tuple' wildcard (NE.fromList [wildcard, wildcard])] - `shouldBe` Right mempty - - it "3 tuple of ones are not exhaustive" $ do - let one = PLiteral tyInt (PInt 1) - wildcard = PWildcard tyInt - tuple' = tyTuple tyInt [tyInt, tyInt] - exhaustiveCheck - [PTuple tuple' one (NE.fromList [one, one])] - `shouldBe` Right [PTuple tuple' wildcard (NE.fromList [wildcard, wildcard])] - - it "First in 3-tuples is non-exhaustive" $ do - let one = PLiteral tyInt (PInt 1) - wildcard = PWildcard tyInt - tuple' = tyTuple tyInt [tyInt, tyInt] - exhaustiveCheck - [ PTuple - tuple' - one - ( NE.fromList [wildcard, wildcard] - ) - ] - `shouldBe` Right - [ PTuple - tuple' - wildcard - ( NE.fromList [wildcard, wildcard] - ) - ] - - it "Tuples of 2 bools creates 4 patterns in total" $ do - let true = PLiteral tyBool (PBool True) - false = PLiteral tyBool (PBool False) - tuple' = tyTuple tyBool [tyBool] - exhaustiveCheck - [ PTuple - tuple' - true - ( NE.fromList [true] - ) - ] - `shouldBe` Right - [ PTuple - tuple' - true - ( NE.fromList [false] - ), - PTuple - tuple' - false - ( NE.fromList [true] - ), - PTuple - tuple' - false - ( NE.fromList [false] - ) - ] - - it "When one item in a tuple is a wildcard, other patterns it needs are also" $ do - let true = PLiteral tyBool (PBool True) - false = PLiteral tyBool (PBool False) - wildcard = PWildcard tyBool - tuple' = tyTuple tyBool [tyBool] - exhaustiveCheck - [PTuple tuple' wildcard (NE.singleton true)] - `shouldBe` Right - [ PTuple - tuple' - wildcard - ( NE.fromList [false] - ) - ] - - it "Tuple of two wildcards covers everything" $ do - let wildcard = PWildcard tyBool - tuple' = tyTuple tyBool [tyBool] - exhaustiveCheck - [PTuple tuple' wildcard (NE.singleton wildcard)] - `shouldBe` Right [] - - -- its not but cba fixing now, making it over rather than under safe - xit "Pair with var is exhaustive" $ do - let true = PLiteral tyBool (PBool True) - false = PLiteral tyBool (PBool False) - tuple' = tyTuple tyBool [tyBool] - exhaustiveCheck - [ PTuple tuple' true (NE.singleton true), - PTuple tuple' false (NE.singleton true), - PTuple tuple' (PVar tyBool "dog") (NE.singleton false) - ] - `shouldBe` Right [] - - -- same as above - xit "A pair with complete coverage of Right and Left is exhaustive" $ do - let either' = tyCons "Either" [tyVar "e", tyVar "a"] - leftE = fromParsedType <$> PConstructor either' "Left" [PVar (tyVar "e") "e"] - rightF = fromParsedType <$> PConstructor either' "Right" [PVar (tyVar "a") "f"] - rightA = fromParsedType <$> PConstructor either' "Right" [PVar (tyVar "a") "a"] - wildcard = fromParsedType <$> PWildcard either' - tuple' = fromParsedType $ tyTuple either' [either'] - exhaustiveCheck - [ PTuple tuple' rightF (NE.singleton rightA), - PTuple tuple' leftE (NE.singleton wildcard), - PTuple tuple' wildcard (NE.singleton leftE) - ] - `shouldBe` Right mempty - --- [PTuple tuple' wildcard (NE.singleton wildcard)] - -{- - it "A pair annihilates empty" $ do - exhaustiveCheck - [ PConstructor mempty "Just" [PTuple mempty (PWildcard mempty) (NE.singleton $ PWildcard mempty)], - PConstructor mempty "Nothing" mempty - ] - `shouldBe` Right mempty - it "Constructor returns unused constructor" $ do - exhaustiveCheck - [PConstructor mempty "Just" [PWildcard mempty]] - `shouldBe` Right [PConstructor mempty "Nothing" []] - it "Constructor returns unused items inside it" $ do - exhaustiveCheck - [ PConstructor mempty "Just" [PLiteral mempty (PBool True)], - PConstructor mempty "Nothing" mempty - ] - `shouldBe` Right - [ PConstructor - mempty - "Just" - [ PLiteral - mempty - (PBool False) - ], - PConstructor - mempty - "Just" - [ PWildcard mempty - ] - ] - it "Constructor returns multiple unused constructors" $ do - exhaustiveCheck - [ PConstructor mempty "This" [PWildcard mempty] - ] - `shouldBe` Right - [ PConstructor mempty "That" [PWildcard mempty], - PConstructor mempty "These" [PWildcard mempty, PWildcard mempty] - ] - it "Nested constructors" $ do - exhaustiveCheck - [ PConstructor mempty "Just" [PConstructor mempty "Nothing" mempty], - PConstructor mempty "Just" [PWildcard mempty] - ] - `shouldBe` Right - [ PConstructor mempty "Nothing" [] - ] - it "A var is equivalent to a wildcard" $ do - exhaustiveCheck - [ PConstructor mempty "Just" [PVar mempty "a"], - PConstructor mempty "Nothing" mempty - ] - `shouldBe` Right [] - it "Multiple int literals" $ do - exhaustiveCheck [PLiteral mempty (PInt 1), PLiteral mempty (PInt 2)] - `shouldBe` Right [PWildcard mempty] - - describe "Redundant cases" $ do - it "Returns none" $ do - redundantCasesCheck [PWildcard mempty] `shouldBe` Right mempty - it "Returns anything after a wildcard (1)" $ do - redundantCasesCheck - [ PWildcard mempty, - PLiteral mempty (PBool True) - ] - `shouldBe` Right - [ PLiteral mempty (PBool True) - ] - it "Returns anything after a wildcard (2)" $ do - redundantCasesCheck - [ PWildcard mempty, - PLiteral mempty (PBool True), - PLiteral mempty (PBool False) - ] - `shouldBe` Right - [ PLiteral mempty (PBool True), - PLiteral mempty (PBool False) - ] - it "Works with constructors" $ do - redundantCasesCheck - [ PConstructor mempty "Just" [PWildcard mempty], - PConstructor mempty "Just" [PLiteral mempty (PInt 1)], - PConstructor mempty "Nothing" mempty - ] - `shouldBe` Right - [ PConstructor - mempty - "Just" - [PLiteral mempty (PInt 1)] - ] - it "Multiple ints make wildcard necessary" $ do - redundantCasesCheck - [PLiteral mempty (PInt 1), PLiteral mempty (PInt 2), PWildcard mempty] - `shouldBe` Right [] - describe "noDuplicateVariables" $ do - it "Is fine with wildcard" $ do - noDuplicatesCheck (PWildcard mempty) `shouldSatisfy` isRight - it "Is fine with lit" $ do - noDuplicatesCheck (PLiteral mempty (PBool True)) `shouldSatisfy` isRight - it "Is fine with single var" $ do - noDuplicatesCheck (PVar mempty "a") `shouldSatisfy` isRight - it "Is fine with a pair of different vars" $ do - noDuplicatesCheck - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "b") - ) - `shouldSatisfy` isRight - it "Hates a pair of the same var" $ do - noDuplicatesCheck - ( PTuple - mempty - (PVar mempty "a") - (NE.singleton $ PVar mempty "a") - ) - `shouldSatisfy` isLeft - - it "Is fine with a constructor with no dupes" $ do - noDuplicatesCheck - ( PConstructor - mempty - "Dog" - [ PVar mempty "a", - PVar mempty "b" - ] - ) - `shouldSatisfy` isRight - it "Is not fine with a constructor with dupes" $ do - noDuplicatesCheck - ( PConstructor - mempty - "Dog" - [ PVar mempty "a", - PVar mempty "b", - PConstructor - mempty - "Dog" - [ PVar mempty "c", - PVar mempty "a" - ] - ] - ) - `shouldSatisfy` isLeft - --} diff --git a/smol-core/test/Test/Typecheck/NestingMonadSpec.hs b/smol-core/test/Test/Typecheck/NestingMonadSpec.hs deleted file mode 100644 index 3824d943..00000000 --- a/smol-core/test/Test/Typecheck/NestingMonadSpec.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typecheck.NestingMonadSpec (spec) where - -import Control.Monad.Writer.CPS -import Test.Hspec - -spec :: Spec -spec = do - describe "Nesting" $ do - it "Writes some stuff" $ do - let action = tell [1 :: Int, 2, 3] - runWriter action - `shouldBe` ((), [1, 2, 3]) - - it "Writes some stuff in a sub-action" $ do - let subAction = tell [4 :: Int, 5, 6] - action = do - tell [1 :: Int, 2, 3] - subAction - - runWriter action - `shouldBe` ((), [1, 2, 3, 4, 5, 6]) - - it "Writes some stuff in a sub-action, throws it away" $ do - let subAction = tell [4 :: Int, 5, 6] - action = do - tell [1 :: Int, 2, 3] - let (_, as) = runWriter subAction - tell [7, 8, 9] - pure as - - runWriter action - `shouldBe` ([4, 5, 6], [1, 2, 3, 7, 8, 9]) diff --git a/smol-core/test/Test/Typecheck/PatternSpec.hs b/smol-core/test/Test/Typecheck/PatternSpec.hs deleted file mode 100644 index 54805298..00000000 --- a/smol-core/test/Test/Typecheck/PatternSpec.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typecheck.PatternSpec (spec) where - -import qualified Data.Map.Strict as M -import Smol.Core -import Test.BuiltInTypes -import Test.Helpers -import Test.Hspec - -spec :: Spec -spec = do - describe "checkPattern" $ do - let emptyEnv = TCEnv mempty (builtInTypes emptyResolvedDep) mempty mempty mempty - it "PVar" $ do - snd <$> runTypecheckM emptyEnv (checkPattern tyInt (PVar () "a")) - `shouldBe` Right - ( M.singleton "a" tyInt - ) - - it "PVar with unique" $ do - let mkUnique a = UniqueDefinition a 123 - snd <$> runTypecheckM emptyEnv (checkPattern tyInt (PVar () (mkUnique "a"))) - `shouldBe` Right - ( M.singleton (mkUnique "a") tyInt - ) - - it "PConstructor with unique" $ do - let mkUnique a = UniqueDefinition a 123 - snd - <$> runTypecheckM - emptyEnv - ( checkPattern - ( TApp - () - (TConstructor () (LocalDefinition "Expr")) - (TVar () (mkUnique "ann")) - ) - (PConstructor () "EInt" [PWildcard (), PVar () (mkUnique "i")]) - ) - `shouldBe` Right - ( M.fromList - [ (mkUnique "i", tyInt) - ] - ) - - it "PConstructor with unique from unknown type" $ do - let mkUnique a = UniqueDefinition a 123 - snd - <$> runTypecheckM - emptyEnv - ( checkPattern - ( TUnknown () 123 - ) - (PConstructor () "EInt" [PWildcard (), PVar () (mkUnique "i")]) - ) - `shouldBe` Right - ( M.fromList - [ (mkUnique "i", tyInt) - ] - ) diff --git a/smol-core/test/Test/Typecheck/SubtypeSpec.hs b/smol-core/test/Test/Typecheck/SubtypeSpec.hs deleted file mode 100644 index 55dea223..00000000 --- a/smol-core/test/Test/Typecheck/SubtypeSpec.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Typecheck.SubtypeSpec (spec) where - -import Control.Monad.Trans.Writer.CPS (runWriterT) -import Data.Either -import Data.Foldable (traverse_) -import Data.List.NonEmpty (NonEmpty (..)) -import Smol.Core -import Smol.Core.Typecheck.FromParsedExpr -import Smol.Core.Typecheck.Simplify -import Test.Helpers -import Test.Hspec - --- Repeat after me, Duck is a subtype of Bird --- so Duck <: Bird --- 1 is a subtype of 1 | 2 --- so 1 <: 1 | 2 --- 1 | 2 is a subtype of Int --- so 1 | 2 <: Int --- -spec :: Spec -spec = do - describe "Subtyping" $ do - describe "generaliseLiteral" $ do - it "Negative literal makes int" $ do - generaliseLiteral (tyIntLit [-1]) - `shouldBe` TPrim () TPInt - - describe "Subtype" $ do - describe "Everything defeats TUnknown" $ do - let things = [TPrim () TPBool, TVar () "horse", TFunc () mempty (TVar () "a") (TVar () "b")] - traverse_ - ( \ty -> it (show ty <> " combines with TUnknown") $ do - fst <$> runWriterT (isSubtypeOf ty (TUnknown () 0)) `shouldSatisfy` isRight - ) - things - - describe "Combine two datatypes" $ do - it "Maybe Nat <: Maybe i1" $ do - let one = fromParsedType $ tyCons "Maybe" [tyInt] - two = fromParsedType $ tyCons "Maybe" [tyUnknown 1] - expected = (one, [TCWSubstitution $ Substitution (SubUnknown 1) (TPrim () TPInt)]) - - runWriterT (one `isSubtypeOf` two) - `shouldBe` Right expected - - it "Maybe Nat <: i1" $ do - let one = fromParsedType $ tyCons "Maybe" [tyInt] - two = fromParsedType $ TUnknown () 1 - expected = (one, [TCWSubstitution $ Substitution (SubUnknown 1) one]) - - runWriterT (one `isSubtypeOf` two) - `shouldBe` Right expected - - it "Maybe Nat <: a b" $ do - let one = fromParsedType $ tyCons "Maybe" [tyInt] - two = fromParsedType $ TApp () (TVar () "a") (TVar () "b") - expected = - ( one, - [ TCWSubstitution $ Substitution (SubId "a") (TConstructor () "Maybe"), - TCWSubstitution $ Substitution (SubId "b") (TPrim () TPInt) - ] - ) - - runWriterT (one `isSubtypeOf` two) - `shouldBe` Right expected - - it "Maybe Nat <: i1 i2" $ do - let one = fromParsedType $ tyCons "Maybe" [tyInt] - two = fromParsedType $ TApp () (TUnknown () 1) (TUnknown () 2) - expected = - ( one, - [ TCWSubstitution $ Substitution (SubUnknown 1) (TConstructor () "Maybe"), - TCWSubstitution $ Substitution (SubUnknown 2) (TPrim () TPInt) - ] - ) - - runWriterT (one `isSubtypeOf` two) - `shouldBe` Right expected - - it "(a -> Maybe Nat) <: (a -> i1)" $ do - let maybeNat = tyCons "Maybe" [tyInt] - one = fromParsedType $ TFunc () mempty (tyVar "a") maybeNat - two = fromParsedType $ TFunc () mempty (tyVar "a") (TUnknown () 1) - expected = (one, [TCWSubstitution $ Substitution (SubUnknown 1) (fromParsedType maybeNat)]) - - runWriterT (one `isSubtypeOf` two) - `shouldBe` Right expected - - describe "Combine" $ do - let inputs = - [ ("1", "2", "1 | 2"), - ("1 | 2", "2", "1 | 2"), - ("1 | 2", "3", "1 | 2 | 3"), - ("\"eg\"", "\"g\"", "\"eg\" | \"g\"") - ] - traverse_ - ( \(one, two, result) -> it (show one <> " <> " <> show two) $ do - let a = - combineMany $ - fromParsedType (unsafeParseType one) - :| [fromParsedType (unsafeParseType two)] - fst <$> runWriterT a `shouldBe` Right (fromParsedType (unsafeParseType result)) - ) - inputs - - describe "Type addition" $ do - let inputs = - [ ("1", "1", "2"), - ("1", "2", "3"), - ("1 | 2", "2", "3 | 4"), - ("1 | 2", "3 | 4", "4 | 5 | 6"), - ("Int", "Int", "Int"), - ("String", "String", "String"), - ("\"a\"", "String", "String"), - ("String", "\"a\"", "String"), - ("\"po\"", "\"po\"", "\"popo\"") - ] - traverse_ - ( \(one, two, result) -> it (show one <> " + " <> show two <> " = " <> show result) $ do - let a = - simplifyType - ( TInfix - () - OpAdd - (fromParsedType (unsafeParseType one)) - (fromParsedType (unsafeParseType two)) - ) - a `shouldBe` fromParsedType (unsafeParseType result) - - let b = - simplifyType - ( TInfix - () - OpAdd - (fromParsedType (unsafeParseType two)) - (fromParsedType (unsafeParseType one)) - ) - b `shouldBe` fromParsedType (unsafeParseType result) - ) - inputs - - describe "Valid pairs" $ do - let validPairs = - [ ("True", "True"), - ("False", "False"), - ("True", "Bool"), - ("1", "a"), - ("(True, False)", "(True,Bool)"), - ("Maybe", "Maybe"), - ("Maybe 1", "Maybe a"), - ("{ item: 1 }", "{}"), - ("[1 | 2]", "[Int]"), - ("1", "1 | 2"), - ("(Int,Int)", "(a,b)") - ] - traverse_ - ( \(lhs, rhs) -> it (show lhs <> " <: " <> show rhs) $ do - fst - <$> runWriterT - ( isSubtypeOf - (fromParsedType $ unsafeParseType lhs) - (fromParsedType $ unsafeParseType rhs) - ) - `shouldSatisfy` isRight - ) - validPairs - - describe "Invalid pairs" $ do - let validPairs = - [ ("Bool", "True"), - ("1", "2 | 3") - ] - traverse_ - ( \(lhs, rhs) -> it (show lhs <> " <: " <> show rhs) $ do - fst - <$> runWriterT - ( isSubtypeOf - (fromParsedType $ unsafeParseType lhs) - (fromParsedType $ unsafeParseType rhs) - ) - `shouldSatisfy` isLeft - ) - validPairs - - describe "Plus" $ do - it "U1 + U2 <: Int" $ do - fst - <$> runWriterT - ( isSubtypeOf - (TInfix () OpAdd (TUnknown () 1) (TUnknown () 2)) - tyInt - ) - `shouldSatisfy` isRight - - it "U1 == U2 <: Bool" $ do - fst - <$> runWriterT - ( isSubtypeOf - (TInfix () OpEquals (TUnknown () 1) (TUnknown () 2)) - tyBool - ) - `shouldSatisfy` isRight diff --git a/smol-core/test/Test/Typecheck/ToDictionaryPassingSpec.hs b/smol-core/test/Test/Typecheck/ToDictionaryPassingSpec.hs deleted file mode 100644 index 95747ae1..00000000 --- a/smol-core/test/Test/Typecheck/ToDictionaryPassingSpec.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Typecheck.ToDictionaryPassingSpec (spec) where - -import Control.Monad.Reader -import Data.Bifunctor (bimap) -import Data.Foldable (traverse_) -import Data.Functor -import Data.List (nub) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.String (fromString) -import qualified Data.Text as T -import Smol.Core -import Smol.Core.Modules.ResolveDeps -import Smol.Core.Modules.Types.Module -import Smol.Core.Typecheck.FromParsedExpr (fromParsedExpr) -import Smol.Core.Typecheck.Typeclass -import Test.Helpers -import Test.Hspec - -simplify :: Expr ResolvedDep ann -> Expr ResolvedDep () -simplify = void . goExpr - where - changeIdent (TypeclassCall ident i) = - LocalDefinition $ "tc" <> ident <> fromString (show i) - changeIdent (UniqueDefinition ident i) = - LocalDefinition $ ident <> fromString (show i) - changeIdent ident = ident - - goExpr (EVar ann ident) = - EVar ann (changeIdent ident) - goExpr (EAnn ann ty rest) = - EAnn ann (typeForComparison ty) (goExpr rest) - goExpr (ELambda ann ident body) = - ELambda ann (changeIdent ident) (goExpr body) - goExpr (EPatternMatch ann matchExpr pats) = - EPatternMatch ann (goExpr matchExpr) (fmap (bimap goPattern goExpr) pats) - goExpr other = mapExpr goExpr other - - goPattern (PVar ann ident) = PVar ann (changeIdent ident) - goPattern other = mapPattern goPattern other - -constructorsForTypecheckEnv :: TCEnv ann -> S.Set Constructor -constructorsForTypecheckEnv env = - foldMap (M.keysSet . dtConstructors) (tceDataTypes env) - -evalExpr :: - [Constraint ResolvedDep Annotation] -> - T.Text -> - Either - (TCError Annotation) - ( ResolvedExpr (Type ResolvedDep Annotation), - M.Map (ResolvedDep Identifier) (Constraint ResolvedDep Annotation) - ) -evalExpr constraints input = - case parseExprAndFormatError input of - Left e -> error (show e) - Right expr -> - case resolveExprDeps expr (getTypeclassMethodNames @Annotation typecheckEnv) mempty (constructorsForTypecheckEnv @Annotation typecheckEnv) of - Left e -> error $ "error resolving Expr deps :" <> show e - Right resolvedExpr -> - let env = - typecheckEnv - { tceConstraints = constraints - } - in elaborate env resolvedExpr - --- | elaborate but don't do clever resolving so we can construct the --- expectations we want -evalExprUnsafe :: - T.Text -> - Either (TCError Annotation) (ResolvedExpr (Type ResolvedDep Annotation)) -evalExprUnsafe input = case parseExprAndFormatError input of - Left e -> error (show e) - Right expr -> - case elaborate typecheckEnv (fromParsedExpr expr) of - Right (typedExpr, _typeclassUses) -> pure typedExpr - Left e -> Left e - -runDictEnv :: ReaderT PassDictEnv m a -> m a -runDictEnv = flip runReaderT emptyPassDictEnv - -spec :: Spec -spec = do - describe "toDictionaryPassing" $ do - describe "Get dictionaries" $ do - it "Single item dictionary for single constraint" $ do - let constraints = addTypesToConstraint <$> NE.fromList [Constraint "Eq" [tyInt]] - expected = evalExprUnsafe "(\\a1 -> \\b2 -> a1 == b2 : Int -> Int -> Bool)" - - instances = moInstances testModule - dictEnv = - ToDictEnv - { tdeClasses = tceClasses typecheckEnv, - tdeInstances = instances, - tdeVars = mempty - } - - fmap simplify (runDictEnv $ createTypeclassDict dictEnv constraints) - `shouldBe` simplify <$> expected - - it "Tuple for two constraints" $ do - let constraints = addTypesToConstraint <$> NE.fromList [Constraint "Eq" [tyInt], Constraint "Eq" [tyInt]] - expected = evalExprUnsafe "((\\a1 -> \\b2 -> a1 == b2 : Int -> Int -> Bool), (\\a1 -> \\b2 -> a1 == b2 : Int -> Int -> Bool))" - - instances = moInstances testModule - dictEnv = - ToDictEnv - { tdeClasses = tceClasses typecheckEnv, - tdeInstances = instances, - tdeVars = mempty - } - - fmap simplify (runDictEnv $ createTypeclassDict dictEnv constraints) - `shouldBe` simplify <$> expected - - describe "Convert expr to use typeclass dictionaries" $ do - traverse_ - ( \(constraints, parts, expectedConstraints, expectedParts) -> - let input = joinText parts - expected = joinText expectedParts - in it ("Successfully converted " <> show input) $ do - let (expr, typeclassUses) = getRight $ evalExpr constraints input - instances = mempty - - let expectedExpr = getRight $ evalExprUnsafe expected - (dedupedConstraints, tidyExpr) = deduplicateConstraints typeclassUses expr - - dictEnv = - ToDictEnv - { tdeClasses = tceClasses typecheckEnv, - tdeInstances = instances, - tdeVars = mempty - } - - result = runDictEnv $ convertExprToUseTypeclassDictionary dictEnv (addTypesToConstraint <$> dedupedConstraints) tidyExpr - - dedupedConstraints `shouldBe` expectedConstraints - simplify <$> result `shouldBe` Right (simplify expectedExpr) - ) - [ (mempty, ["1 + 2"], mempty, ["1 + 2"]), - ( [ Constraint "Eq" [tcVar "a"], - Constraint "Eq" [tcVar "b"] - ], - [ "(\\a -> \\b -> case (a,b) of ((leftA, leftB), (rightA, rightB)) -> ", - "if equals leftA rightA then equals leftB rightB else False : (a,b) -> (a,b) -> Bool)" - ], - [ Constraint "Eq" [tcVar "a"], - Constraint "Eq" [tcVar "b"] - ], - [ "\\instances -> case (instances : (a -> a -> Bool, b -> b -> Bool)) of (tcvaluefromdictionary0, tcvaluefromdictionary1) -> ", - "(\\a1 -> \\b2 -> case (a1,b2) of ((leftA3, leftB4), (rightA5, rightB6)) ->", - "if tcvaluefromdictionary0 leftA3 rightA5 then tcvaluefromdictionary1 leftB4 rightB6 else False : (a,b) -> (a,b) -> Bool)" - ] - ) - ] - - -- the whole transformation basically - describe "toDictionaryPassing" $ do - traverse_ - ( \(constraints, parts, expectedParts) -> do - let input = joinText parts - expected = joinText expectedParts - in it ("Successfully inlined " <> show input) $ do - let (expr, typeclassUses) = getRight $ evalExpr constraints input - - instances = moInstances testModule - - let expectedExpr = getRight $ evalExprUnsafe expected - - (dedupedConstraints, tidyExpr) = deduplicateConstraints typeclassUses expr - - allConstraints = nub (dedupedConstraints <> constraints) -- we lose outer constraints sometimes - dictEnv = - ToDictEnv - { tdeClasses = tceClasses typecheckEnv, - tdeInstances = instances, - tdeVars = mempty - } - - result = toDictionaryPassing dictEnv mempty (addTypesToConstraint <$> allConstraints) tidyExpr - - simplify <$> result `shouldBe` Right (simplify expectedExpr) - ) - [ (mempty, ["1 + 2"], ["1 + 2"]), - ( mempty, - ["equals (1: Int) (2: Int)"], - [ "let eqint = (\\a1 -> \\b2 -> a1 == b2 : Int -> Int -> Bool); eqint (1 : Int) (2: Int)" - ] - ), - ( mempty, - ["equals ((1: Int), (2: Int)) ((2: Int), (3: Int))"], - [ "let eqintint = let eqint = (\\a1 -> \\b2 -> a1 == b2 : Int -> Int -> Bool);", - "(\\pairA7 -> \\pairB8 -> case (pairA7, pairB8) of ((a19, b110), (a211, b212)) ->", - "if eqint a19 a211 ", - "then eqint b110 b212", - "else False : (a, b) -> (a,b) -> Bool); ", - "eqintint ((1: Int), (2: Int)) ((2: Int), (3: Int))" - ] - ), - ( [Constraint "Eq" [tcVar "a"]], - ["(\\a -> \\b -> equals a b : a -> a -> Bool)"], - [ "\\instances -> case (instances : (a -> a -> Bool)) of tcvaluefromdictionary0 -> ", - "(\\a1 -> \\b2 -> tcvaluefromdictionary0 a1 b2 : a -> a -> Bool)" - ] - ), - ( mempty, - ["show Zero"], - [ "let shownatural = (\\nat15 -> ", - "case nat15 of Suc n16 -> \"S \" + shownatural n16 ", - "| _ -> \"\" : Natural -> String); ", - "shownatural Zero" - ] - ) - ] diff --git a/smol-core/test/Test/Typecheck/TypeclassSpec.hs b/smol-core/test/Test/Typecheck/TypeclassSpec.hs deleted file mode 100644 index 26a46a3b..00000000 --- a/smol-core/test/Test/Typecheck/TypeclassSpec.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Typecheck.TypeclassSpec (spec) where - -import Data.Either -import qualified Data.Map.Strict as M -import Smol.Core -import Smol.Core.Typecheck.Typeclass -import Smol.Core.Typecheck.Typeclass.KindChecker -import Test.Helpers -import Test.Hspec - -spec :: Spec -spec = do - describe "recoverTypeclassUses" $ do - it "No classes, nothing to find" $ do - recoverTypeclassUses @() [] `shouldBe` mempty - it "Uses Eq Int" $ do - recoverTypeclassUses @() - [ TCWTypeclassUse (UniqueDefinition "a" 123) "Eq" [("a", 10)], - TCWSubstitution (Substitution (SubUnknown 10) tyInt) - ] - `shouldBe` M.singleton (UniqueDefinition "a" 123) (Constraint "Eq" [tyInt]) - - describe "instanceMatchesType" $ do - it "Eq (a,Bool) does not match Eq (Int, Int)" $ do - instanceMatchesType @_ @() [tyTuple tyInt [tyInt]] [tyTuple (tcVar "a") [tyBool]] - `shouldBe` Left (tyInt, tyBool) - - it "Eq (a,b) matches Eq (Int, Int)" $ do - instanceMatchesType @_ @() [tyTuple tyInt [tyInt]] [tyTuple (tcVar "a") [tcVar "b"]] - `shouldBe` Right - [ Substitution (SubId (LocalDefinition "a")) tyInt, - Substitution (SubId (LocalDefinition "b")) tyInt - ] - - describe "lookupTypeclassInstance" $ do - it "Is not there" $ do - lookupTypeclassInstance @() typecheckEnv (Constraint "Eq" [tyBool]) - `shouldSatisfy` isLeft - - it "Is there" $ do - let result = lookupTypeclassInstance @() typecheckEnv (Constraint "Eq" [tyInt]) - inConstraints <$> result `shouldBe` Right [] - - it "Nested item is there" $ do - let result = lookupTypeclassInstance @() typecheckEnv (Constraint "Eq" [tyTuple tyInt [tyInt]]) - inConstraints <$> result `shouldBe` Right [Constraint "Eq" [tyInt], Constraint "Eq" [tyInt]] - - it "Doubly nested item is there" $ do - let result = lookupTypeclassInstance @() typecheckEnv (Constraint "Eq" [tyTuple tyInt [tyTuple tyInt [tyInt]]]) - result `shouldSatisfy` isRight - - it "Other nested item is there" $ do - lookupTypeclassInstance @() typecheckEnv (Constraint "Eq" [tyTuple tyBool [tyInt]]) - `shouldSatisfy` isLeft - - describe "Check instances" $ do - it "Good Show instance" $ do - checkInstance @() - typecheckEnv - showTypeclass - (addTypesToConstraint (Constraint "Show" [tyUnit])) - ( Instance - { inExpr = unsafeParseInstanceExpr "\\a -> \"Unit\"", - inConstraints = [] - } - ) - `shouldSatisfy` isRight - - it "Bad Show instance" $ do - checkInstance @() - typecheckEnv - showTypeclass - (addTypesToConstraint (Constraint "Show" [tyUnit])) - ( Instance - { inExpr = unsafeParseInstanceExpr "\\a -> 123", - inConstraints = [] - } - ) - `shouldSatisfy` isLeft - - it "Good Eq instance" $ do - checkInstance @() - typecheckEnv - eqTypeclass - (addTypesToConstraint (Constraint "Eq" [tyInt])) - ( Instance - { inExpr = unsafeParseInstanceExpr "\\a -> \\b -> a == b", - inConstraints = [] - } - ) - `shouldSatisfy` isRight - - it "Bad Eq instance" $ do - checkInstance @() - typecheckEnv - eqTypeclass - (addTypesToConstraint (Constraint "Show" [tyUnit])) - ( Instance - { inExpr = unsafeParseInstanceExpr "\\a -> \\b -> 123", - inConstraints = [] - } - ) - `shouldSatisfy` isLeft - - it "Tuple Eq instance" $ do - checkInstance @() - typecheckEnv - eqTypeclass - (addTypesToConstraint (Constraint "Eq" [tyTuple (tcVar "a") [tcVar "b"]])) - ( Instance - { inExpr = - unsafeParseInstanceExpr "\\a -> \\b -> case (a,b) of ((a1, a2), (b1, b2)) -> if equals a1 b1 then equals a2 b2 else False", - inConstraints = - [ Constraint "Eq" [tcVar "a"], - Constraint "Eq" [tcVar "b"] - ] - } - ) - `shouldSatisfy` isRight - - it "Natural Show instance" $ do - checkInstance @() - typecheckEnv - showTypeclass - (addTypesToConstraint (Constraint "Show" [tyCons "Natural" []])) - ( Instance - { inExpr = - unsafeParseInstanceExpr "\\nat -> case nat of Suc n -> \"S \" + show n | _ -> \"\"", - inConstraints = - [] - } - ) - `shouldSatisfy` isRight - - it "Functor Maybe instance" $ do - checkInstance @() - typecheckEnv - functorTypeclass - (addTypesToConstraint (Constraint "Functor" [tyCons "Maybe" []])) - ( Instance - { inExpr = - unsafeParseInstanceExpr "\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing", - inConstraints = mempty - } - ) - `shouldSatisfy` isRight - - it "Functor (Maybe a) instance" $ do - checkInstance @() - typecheckEnv - functorTypeclass - (addTypesToConstraint (Constraint "Functor" [tyCons "Maybe" [tcVar "a"]])) - ( Instance - { inExpr = - unsafeParseInstanceExpr "\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing", - inConstraints = mempty - } - ) - `shouldBe` Left (TCTypeclassError $ InstanceKindMismatch "f" (KindFn Star Star) Star) - - describe "KindChecker" $ do - let dts = tceDataTypes typecheckEnv - describe "type for kind" $ do - it "Int" $ do - fmap getTypeAnnotation (typeKind dts (tyInt :: Type ResolvedDep ())) - `shouldBe` Right Star - - it "Maybe Int" $ do - fmap getTypeAnnotation (typeKind dts (tyCons "Maybe" [tyInt] :: Type ResolvedDep ())) - `shouldBe` Right Star - - it "Either Int Int" $ do - fmap getTypeAnnotation (typeKind dts (tyCons "Either" [tyInt, tyInt] :: Type ResolvedDep ())) - `shouldBe` Right Star - - it "Either Int" $ do - fmap getTypeAnnotation (typeKind dts (tyCons "Either" [tyInt] :: Type ResolvedDep ())) - `shouldBe` Right - ( KindFn Star Star - ) - - it "Int -> Int" $ do - fmap getTypeAnnotation (typeKind dts (tyFunc tyInt tyInt :: Type ResolvedDep ())) - `shouldBe` Right Star - - it "f a" $ do - fmap getTypeAnnotation (typeKind dts (tyApp (tcVar "f") (tcVar "a") :: Type ResolvedDep ())) - `shouldBe` Right Star - - describe "type from type sig" $ do - it "a in 'a -> String'" $ do - let result = getRight (typeKind dts (tyFunc (tcVar "a") tyString)) - - lookupKindInType result "a" `shouldBe` Just Star - - it "f in 'f a'" $ do - let result = getRight $ typeKind dts (tyApp (tcVar "f") (tcVar "a")) - - lookupKindInType result "a" `shouldBe` Just Star - - lookupKindInType result "f" `shouldBe` Just (KindFn Star Star) - - it "f in 'f a b'" $ do - let result = getRight $ typeKind dts (tyApp (tyApp (tcVar "f") (tcVar "a")) (tcVar "b")) - - lookupKindInType result "a" `shouldBe` Just Star - - lookupKindInType result "b" `shouldBe` Just Star - - lookupKindInType result "f" - `shouldBe` Just (KindFn Star (KindFn Star Star)) - - describe "Unify kinds" $ do - it "Star and star" $ do - unifyKinds @ResolvedDep @() UStar UStar `shouldBe` Right mempty - it "Star and var" $ do - unifyKinds @ResolvedDep @Int UStar (UVar 1) `shouldBe` Right (M.singleton 1 UStar) - it "Recover argument of Kind function" $ do - unifyKinds @ResolvedDep @Int (UKindFn (UVar 1) UStar) (UKindFn UStar (UVar 2)) - `shouldBe` Right (M.fromList [(1, UStar), (2, UStar)]) - it "Recover argument of multi arg Kind function" $ do - unifyKinds @ResolvedDep @Int (UKindFn (UVar 1) (UKindFn (UVar 2) UStar)) (UKindFn UStar (UVar 3)) - `shouldBe` Right - ( M.fromList - [ (1, UStar), - (3, UKindFn (UVar 2) UStar) - ] - ) - - -- don't do anything with concrete ones pls - -- then we can look those up again later - describe "findDedupedConstraints" $ do - it "Empty is empty" $ do - findDedupedConstraints @() mempty `shouldBe` (mempty, mempty) - - it "One is one and gets a new name" $ do - findDedupedConstraints @() (M.singleton "oldname" (Constraint "Eq" [tcVar "a"])) - `shouldBe` ( [ Constraint "Eq" [tcVar "a"] - ], - M.singleton "oldname" (TypeclassCall "valuefromdictionary" 0) - ) - - it "We don't rename concrete instances" $ do - findDedupedConstraints @() (M.singleton "oldname" (Constraint "Eq" [tyInt])) - `shouldBe` ( mempty, - mempty - ) - - it "Two functions, each used twice become one of each" $ do - findDedupedConstraints @() - ( M.fromList - [ ("eqInt1", Constraint "Eq" [tcVar "a"]), - ("eqInt2", Constraint "Eq" [tcVar "a"]), - ("eqBool1", Constraint "Eq" [tcVar "b"]), - ("eqBool2", Constraint "Eq" [tcVar "b"]) - ] - ) - `shouldBe` ( [ Constraint "Eq" [tcVar "a"], - Constraint "Eq" [tcVar "b"] - ], - M.fromList - [ ("eqBool1", TypeclassCall "valuefromdictionary" 0), - ("eqBool2", TypeclassCall "valuefromdictionary" 0), - ("eqInt1", TypeclassCall "valuefromdictionary" 1), - ("eqInt2", TypeclassCall "valuefromdictionary" 1) - ] - ) - - describe "matchType" $ do - it "(Int, Bool) matches (a,b)" $ do - let tyMatch = unsafeParseType "(Int, Bool)" - tyTypeclass = unsafeParseType "(a,b)" - matchType tyMatch tyTypeclass `shouldSatisfy` isRight - - it "[Int] matches [a]" $ do - let tyMatch = unsafeParseType "[Int]" - tyTypeclass = unsafeParseType "[a]" - matchType tyMatch tyTypeclass `shouldSatisfy` isRight - - it "Horse matches Horse" $ do - let tyMatch = unsafeParseType "Horse" - tyTypeclass = unsafeParseType "Horse" - matchType tyMatch tyTypeclass `shouldSatisfy` isRight - - it "Maybe Int matches Maybe a" $ do - let tyMatch = unsafeParseType "Maybe Int" - tyTypeclass = unsafeParseType "Maybe a" - matchType tyMatch tyTypeclass `shouldSatisfy` isRight - - describe "isConcrete" $ do - it "yes, because it has no vars" $ do - isConcrete @_ @() (Constraint "Eq" [tyInt]) `shouldBe` True - - it "no, because it has a var" $ do - isConcrete @_ @() (Constraint "Eq" [tcVar "a"]) `shouldBe` False diff --git a/smol-core/test/Test/TypecheckSpec.hs b/smol-core/test/Test/TypecheckSpec.hs deleted file mode 100644 index ceff3105..00000000 --- a/smol-core/test/Test/TypecheckSpec.hs +++ /dev/null @@ -1,800 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.TypecheckSpec (spec) where - -import Control.Monad.State -import Data.Bifunctor -import Data.Either -import Data.Foldable (traverse_) -import Data.Functor -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Error.Diagnose (defaultStyle, printDiagnostic, stdout) -import Smol.Core -import Smol.Core.Typecheck.FromParsedExpr -import Test.Helpers -import Test.Hspec - -evalExpr :: - Text -> - Either (TCError Annotation) (ResolvedExpr (Type ResolvedDep Annotation)) -evalExpr input = case parseExprAndFormatError input of - Left e -> error (show e) - Right expr -> testElaborate expr - -getLeft :: (Show a) => Either e a -> e -getLeft (Left e) = e -getLeft (Right a) = error (show a) - -testElaborate :: - (Ord ann, Show ann, Monoid ann) => - Expr ParseDep ann -> - Either (TCError ann) (Expr ResolvedDep (Type ResolvedDep ann)) -testElaborate expr = - case elaborate typecheckEnv (fromParsedExpr expr) of - Right (typedExpr, _) -> pure typedExpr - Left e -> Left e - -spec :: Spec -spec = do - describe "TypecheckSpec" $ do - describe "Parse and typecheck" $ do - let inputs = - [ ("True", "True"), - ("False", "False"), - ("Unit", "Unit"), - ("(1,2)", "(1, 2)"), - ("(\\a -> if a then 1 else 2 : Bool -> Int) True", "Int"), - ("(\\a -> if a then 1 else 2) True", "1 | 2"), - ("(\\a -> if a then -1 else 2) True", "-1 | 2"), - ("(\\a -> \\b -> a) True 1", "True"), - ("(\\a -> 1 : {dog: Bool} -> 1) { dog: True, cat: 1 }", "1"), - ("(\\rec -> rec.bool) { bool: True }", "True"), - ("(\\a -> True : (1 | 2) -> True) 1", "True"), - ("(\\a -> True : (1 | 2 | 3 | 4 | 5 | 6) -> True) 5", "True"), - ("(1 : Int) + (2 : Int)", "Int"), - ("1 + 2", "3"), - ("-1 + 200", "199"), - ("200 + -100", "100"), - ("let f = \\a -> a + 41; let g = f 1 == 42; case g of True -> 1", "1"), - ("1 == 1", "True"), - ("6 == 7", "False"), - ("(1 + 2 + 3 : Int)", "Int"), - ("(1 + 2 + 3 : Int)", "Int"), - ("(\"horse\" : String)", "String"), - ("\"hor\" + \"se\"", "\"horse\""), - ("let a = if True then \"eg\" else \"og\"; a + \"g\"", "\"egg\" | \"ogg\""), - ( "(\\pair -> case pair of (a,_) -> a : (Bool, Int) -> Bool) (True, 1)", - "Bool" - ), - ( "(\\pair -> case pair of (True, a) -> a | (False,_) -> 0 : (Bool, Int) -> Int) (True,1)", - "Int" - ), - ( "(case (True, 1) of (True, a) -> a: Int)", - "Int" -- this should remain total as we know it's always True - ), - ( "Just True", - "Maybe True" - ), - ( "(Just True : Maybe True)", - "Maybe True" - ), - ( "(Just : a -> Maybe a)", - "a -> Maybe a" - ), - ( "(That 1 : These a 1)", - "These a 1" - ), - ( "These 1 True", - "These 1 True" - ), - ( "(Left 1 : Either 1 Bool)", - "Either 1 Bool" - ), - ( "(Right True : Either e True)", - "Either e True" - ), - ( "(case Just 1 of Just a -> a | _ -> 0 : Int)", - "Int" - ), - ( "(\\a -> case a of 1 -> 10 | 2 -> 20 : (1 | 2) -> Int) 1", - "Int" - ), - ( "(\\a -> case a of (1,_) -> 10 | (2,_) -> 20 : (1 | 2,Bool) -> Int) (1,False)", - "Int" - ), - ( "(\\a -> a : Maybe a -> Maybe a) (Nothing : Maybe Int)", - "Maybe Int" - ), - ( "(\\a -> a : Maybe a -> Maybe a) (Just 1)", - "Maybe 1" - ), - ( "(\\f -> \\ident -> case ident of Identity a -> Identity (f a) : (a -> b) -> Identity a -> Identity b)", - "(a -> b) -> Identity a -> Identity b" - ), - ( "(\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing : (a -> b) -> Maybe a -> Maybe b)", - "(a -> b) -> Maybe a -> Maybe b" - ), - ( "(\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing : (b -> a) -> Maybe b -> Maybe a)", - "(b -> a) -> Maybe b -> Maybe a" - ), - ( "(case (This 42 : These Int Int) of This a -> a : Int)", - "Int" - ), - ( "let fmap = (\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing : (a -> b) -> Maybe a -> Maybe b); let inc = (\\a -> True : Int -> Bool); fmap inc", - "Maybe Int -> Maybe Bool" - ), - ( "let fmap = (\\f -> \\either -> case either of Right a -> Right (f a) | Left e -> Left e : (a -> b) -> Either e a -> Either e b); let inc = (\\a -> True : Int -> Bool); fmap inc", - "Either e Int -> Either e Bool" - ), - ( "let fmap = (\\f -> \\either -> case either of Right a -> Right (f a) | Left e -> Left e : (a -> b) -> Either e a -> Either e b); fmap", - "(a -> b) -> Either e a -> Either e b" - ), - -- ( "let fmap = (\\f -> \\state -> case state of (State sas) -> State (\\s -> case sas s of (a, s) -> (f a, s)) : (a -> b) -> State s a -> State s b) in fmap", - -- "(a -> b) -> State s a -> State s b" - -- ), - ( "let const = (\\a -> \\b -> a : a -> b -> a); const True 100", - "True" - ), - ( "let id = (\\a -> a : a -> a); id True", - "True" - ), - ( "let id = (\\a -> a : a -> a); (id True, id 1)", - "(True, 1)" - ), - ( "(\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing : (a -> b) -> Maybe a -> Maybe b)", - "(a -> b) -> Maybe a -> Maybe b" - ), - ( "(\\maybeF -> \\maybeA -> case (maybeF, maybeA) of (Just f, Just a) -> Just (f a) | _ -> Nothing : Maybe (a -> b) -> Maybe a -> Maybe b)", - "Maybe (a -> b) -> Maybe a -> Maybe b" - ), - ( "(\\value -> \\default -> case value of Right a -> a | Left _ -> default : Either e a -> a -> a)", - "Either e a -> a -> a" - ), - -- ( "let liftA2 = (\\ap -> \\fmap -> \\f -> \\ma -> \\mb -> ap (fmap f ma) mb : (m (a -> b) -> m a -> m b) -> ((a -> b) -> m a -> m b) -> (a -> b -> c) -> m a -> m b -> m c); let add2 = (\\a -> \\b -> a + b : Int -> Int -> Int); liftA2 add2 (Just 1) (Just 2)", - -- "Maybe Int" - -- ), - ("(\\a -> a + 1) 1", "2"), - ("0 + 0", "0"), - ("0 + 1", "1"), - ("1 + 1", "2"), - ("\"dog\" + \"log\"", "\"doglog\""), - ("(\"dog\" : String) + (\"log\" : String)", "String"), - ("let f = \\a -> a + 1; let g = 100; f 1", "2"), - ("(\\pair -> case pair of (a,b) -> a + b : (Int,Int) -> Int)", "(Int,Int) -> Int"), - ("let id = (\\i -> i : i -> i); case (Just 1) of Just a -> Just (id a) | Nothing -> Nothing", "Maybe 1"), - ("[1,2]", "[ 1 | 2 ]"), - ("[1,2,3,4]", "[1 | 4 | 2 | 3]"), - ("[True]", "[True]"), - ("([1,2,3,4] : [Int])", "[Int]"), - ("case (\"dog\" : String) of \"log\" -> True | _ -> False", "Bool"), - ("case ([1,2,3] : [Int]) of [a] -> [a] | [_,...b] -> b", "[Int]"), - ("case ([1,2]: [Int]) of [a,...] -> a | _ -> 0", "Int"), - ("let a = if True then 1 else 2; let b = if True then 7 else 9; a + b", "8 | 9 | 10 | 11"), - ("\\a -> a == True", "Bool -> Bool"), - ("(\\x -> (x 1, x (False,True))) (\\a -> a)", "(1, (False, True))"), -- look! higher rank types - ("let f = (\\x -> (x 1, x False) : (a -> a) -> (1, False)); let id = \\a -> a; f id", "(1, False)"), -- they need annotation, but that's ok - ("\\a -> \\b -> if a then a else b", "Bool -> Bool -> Bool"), - ("\\a -> case a of (b,c) -> if b then b else c", "(Bool,Bool) -> Bool"), - ("equals (10 : Int) (11: Int)", "Bool"), -- using Eq Int typeclass instance - ("let maybeFmap = \\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing; let useFmap = (\\fmap -> fmap (\\a -> a + 1 : Int -> Int) : ((a -> b) -> f a -> f b) -> f Int -> f Int); useFmap maybeFmap", "Maybe Int -> Maybe Int") - ] - traverse_ - ( \(inputExpr, expectedType) -> it (T.unpack inputExpr <> " :: " <> T.unpack expectedType) $ do - case (,) <$> first (T.pack . show) (evalExpr inputExpr) <*> parseTypeAndFormatError expectedType of - Right (te, typ) -> - let result = typeForComparison (getExprAnnotation te) $> () - expected = fromParsedType (typeForComparison typ $> ()) - in result `shouldBe` expected - other -> error (show other) - ) - inputs - - describe "Expected failures" $ do - let inputs = - [ "equals (10 : Int) True" -- the two `a`s do not match - ] - traverse_ - ( \inputExpr -> it (T.unpack inputExpr <> " fails typechecking") $ do - first (T.pack . show) (evalExpr inputExpr) `shouldSatisfy` isLeft - ) - inputs - - describe "reduceType" $ do - it "Primitives are no-op" $ do - let ty = unsafeParseType "Int" - reduceType ty `shouldBe` ty - it "Happy datatypes are left happy" $ do - let ty = unsafeParseType "Maybe 1" - reduceType ty `shouldBe` ty - it "Types applied to happy datatypes are resolved" $ do - let ty = TApp () (TFunc () mempty (TVar () "a") (tyCons "Maybe" [tyVar "a"])) (TPrim () TPInt) - expected = unsafeParseType "Maybe Int" - reduceType ty `shouldBe` expected - it "Types applied to happy datatypes are resolved" $ do - let ty = TApp () (TFunc () mempty (TUnknown () 1) (tyCons "Maybe" [tyUnknown 1])) (TPrim () TPInt) - expected = unsafeParseType "Maybe Int" - reduceType ty `shouldBe` expected - - describe "freshen" $ do - let emptyState = TCState mempty 0 mempty - it "No unknowns" $ do - let input = fromParsedType $ unsafeParseType "Int -> Int" - expected = input - evalState (freshen input) emptyState `shouldBe` (expected, []) - - it "A -> A becomes 1 -> 1" $ do - let input = fromParsedType $ TFunc () mempty (tyVar "A") (tyVar "A") - expected = TFunc () mempty (tyUnknown 0) (tyUnknown 0) - evalState (freshen input) emptyState `shouldBe` (expected, [Substitution (SubUnknown 0) (TVar () "A")]) - - describe "getApplyReturnType" $ do - it "Simple function" $ do - let input = fromParsedType $ unsafeParseType "Int -> Int" - expected = fromParsedType $ unsafeParseType "Int" - getApplyReturnType input - `shouldBe` Right (Just expected) - - it "Nested function" $ do - let input = fromParsedType $ unsafeParseType "Int -> Int -> Bool" - expected = fromParsedType $ unsafeParseType "Int -> Bool" - getApplyReturnType input - `shouldBe` Right (Just expected) - - it "Nested function with constructors" $ do - let input = fromParsedType $ unsafeParseType "Int -> Maybe Int -> Maybe Bool" - expected = fromParsedType $ unsafeParseType "Maybe Int -> Maybe Bool" - getApplyReturnType input - `shouldBe` Right (Just expected) - - it "Nested higher-order function with constructors" $ do - let input = fromParsedType $ unsafeParseType "(a -> b) -> Maybe a -> Maybe b" - expected = fromParsedType $ unsafeParseType "Maybe a -> Maybe b" - getApplyReturnType input - `shouldBe` Right (Just expected) - - describe "getRequiredEnv" $ do - it "Empty" $ do - freeVars (unsafeParseTypedExpr "\\a -> 1") `shouldBe` mempty - - it "Empty" $ do - freeVars (unsafeParseTypedExpr "\\a -> c") - `shouldBe` S.singleton "c" - - it "New var, behind lambda" $ do - freeVars (unsafeParseTypedExpr "\\a -> \\b -> b + c") - `shouldBe` S.singleton "c" - - xit "New vars, inside pattern match" $ do - freeVars (unsafeParseTypedExpr "\\a -> case (1,2) of (c,d) -> c + d + e") - `shouldBe` S.singleton "e" - - describe "checkPattern" $ do - it "Match Right a with Either e a" $ do - let pat = PConstructor () (LocalDefinition "Right") [PVar () "a"] - ty = fromParsedType (tyCons "Either" [tyVar "e", tyVar "a"]) - - fst <$> runTypecheckM typecheckEnv (checkPattern ty pat) - `shouldBe` Right - ( PConstructor - ty - (LocalDefinition "Right") - [PVar (fromParsedType $ tyVar "a") "a"] - ) - - it "Match Right True with Either 1 True" $ do - let pat = PConstructor () (LocalDefinition "Right") [PLiteral () (PBool True)] - ty = fromParsedType (tyCons "Either" [tyIntLit [1], tyBoolLit True]) - - fst <$> runTypecheckM typecheckEnv (checkPattern ty pat) - `shouldBe` Right - ( PConstructor - ty - (LocalDefinition "Right") - [PLiteral (fromParsedType $ tyBoolLit True) (PBool True)] - ) - - it "Match Left e with Either e a" $ do - let pat = PConstructor () (LocalDefinition "Left") [PVar () "e"] - ty = fromParsedType (tyCons "Either" [tyVar "e", tyVar "a"]) - - fst <$> runTypecheckM typecheckEnv (checkPattern ty pat) - `shouldBe` Right - ( PConstructor - ty - (LocalDefinition "Left") - [PVar (fromParsedType $ tyVar "e") "e"] - ) - - it "Match State inner with State s a" $ do - let pat = PConstructor () (LocalDefinition "State") [PVar () "inner"] - ty = fromParsedType (tyCons "State" [tyVar "s", tyVar "a"]) - tyExpected = TFunc () mempty (tyVar "s") (tyTuple (tyVar "a") [tyVar "s"]) - - fst <$> runTypecheckM typecheckEnv (checkPattern ty pat) - `shouldBe` Right - ( PConstructor - ty - (LocalDefinition "State") - [PVar (fromParsedType tyExpected) "inner"] - ) - - describe "expected typechecking failures" $ do - let inputs = - [ "(\\a -> if a then 1 else True) True", - "(\\a -> True : (1 | 2) -> True) 3", - "(\\pair -> case pair of (a,b,c) -> a + b + c : (Int,Int) -> Int) (1,2)", - "1 + \"dog\"", - "(case (False, 1) of (True, a) -> a: Int)", - "(case Just 1 of These a -> a | _ -> 0 : Int)", -- need to lookup constructor - "(case Just 1 of Just _ a -> a | _ -> 0 : Int)", -- too many args in pattern - "(case Just 1 of Just -> 1 | _ -> 0 : Int)", -- not enough args in pattern - "(\\a -> case a of 1 -> 10 | 2 -> 20 | 3 -> 30 : (1 | 2) -> Int) 1" -- pattern contains something not found in union - -- "Nothing", -- don't know what 'a' is - -- "This 1" -- don't know what 'b' is - ] - traverse_ - ( \inputExpr -> it (T.unpack inputExpr) $ do - let result = evalExpr inputExpr - printDiagnostic stdout True True 2 defaultStyle (typeErrorDiagnostic inputExpr (getLeft result)) - result `shouldSatisfy` isLeft - ) - inputs - - describe "Typecheck" $ do - it "Infers nat" $ do - let input = EPrim () (PInt 1) - expected = tyIntLit [1] - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Int literal becomes Int under annotation" $ do - let input = EAnn () tyInt (EPrim () (PInt 1)) - expected = tyInt - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Int literal becomes Int under annotation" $ do - let input = EAnn () tyInt (EPrim () (PInt 1)) - expected = tyInt - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Infers int" $ do - let input = EPrim () (PInt (-1)) - expected = tyIntLit [-1] - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Int becomes int under annotation" $ do - let input = EAnn () tyInt (EPrim () (PInt 1)) - expected = tyInt - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Infers bool literal true" $ do - let input = EPrim () (PBool True) - expected = tyBoolLit True - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Infers bool literal false" $ do - let input = EPrim () (PBool False) - expected = tyBoolLit False - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Knows bool literal is bool when annotated" $ do - let input = EAnn () tyBool (EPrim () (PBool True)) - expected = tyBool - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Infers annotated function" $ do - let input = - EAnn - () - (TFunc () mempty tyBool tyBool) - (ELambda () (identifier "a") (var "a")) - expected = - TFunc () mempty tyBool tyBool - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Function does not match annotation" $ do - let input = EAnn () (TFunc () mempty tyBool tyInt) (ELambda () (identifier "a") (var "a")) - testElaborate input `shouldSatisfy` isLeft - - it "Literal is not function in annotation" $ do - let input = EAnn () tyInt (ELambda () (identifier "a") (var "a")) - testElaborate input `shouldSatisfy` isLeft - - it "If statement with annotation" $ do - let input = EAnn () tyInt (EIf () (bool True) (int 1) (int 2)) - expected = tyInt - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "If statement with annotation - incorrect pred type" $ do - let input = EAnn () tyInt (EIf () (int 1) (int 1) (int 2)) - testElaborate input `shouldSatisfy` isLeft - - it "If statement with annotation - mismatched reply types" $ do - let input = EAnn () tyBool (EIf () (bool True) (int 1) (int 2)) - testElaborate input `shouldSatisfy` isLeft - - it "Application with annotation on function" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty tyBool tyBool) - (unsafeParseExpr "\\a -> a") - ) - (bool True) - expected :: Type dep () - expected = tyBool - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Application with annotation" $ do - let input = EAnn () tyBool (unsafeParseExpr "(\\a -> a) True") - expected :: Type dep () - expected = tyBool - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Application with annotation breaks" $ do - let input = EAnn () tyInt (unsafeParseExpr "(\\a -> a) True") - testElaborate input `shouldSatisfy` isLeft - - it "Application with no annotation" $ do - let input = unsafeParseExpr "(\\a -> a) True" - expected :: Type dep () - expected = tyBoolLit True - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Two arg application with no annotation" $ do - let input = unsafeParseExpr "(\\a -> \\b -> a) True 1" - expected :: Type dep () - expected = tyBoolLit True - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Function use in if" $ do - let input = - EAnn - () - tyInt - (unsafeParseExpr "if ((\\a -> a) True) then 1 else 2") - expected :: Type dep () - expected = tyInt - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Function use in if no annotation" $ do - let input = unsafeParseExpr "if ((\\a -> a) True) then 1 else 2" - expected :: Type dep () - expected = tyIntLit [1, 2] - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "If statement combines return types but generalises to Int" $ do - let input = - EIf - () - (unsafeParseExpr "(\\a -> a) True") - (EAnn () tyInt (int 1)) - (int 2) - expected :: Type dep () - expected = tyInt - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Detects annotated tuple" $ do - let input = - EAnn - () - (tyTuple tyInt [tyBool, tyInt]) - (tuple (int 1) [bool True, int 2]) - expected :: Type dep () - expected = tyTuple tyInt [tyBool, tyInt] - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Infers unannotated tuple" $ do - let input = - tuple (int 1) [bool True, int 2] - expected :: Type dep () - expected = tyTuple (tyIntLit [1]) [tyBoolLit True, tyIntLit [2]] - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Detects annotated tuple with wrong values" $ do - let input = - EAnn - () - (tyTuple tyInt [tyBool, tyInt]) - (tuple (int 1) [int 3, int 2]) - testElaborate input `shouldSatisfy` isLeft - - it "Detects annotated tuple with different length" $ do - let input = - EAnn - () - (tyTuple tyInt [tyBool]) - (tuple (int 1) [bool True, int 2]) - testElaborate input - `shouldBe` Left - (TCTupleSizeMismatch 3 (tyTuple tyInt [tyBool])) - - it "Uses polymorphic function with annotation of final value" $ do - let lambda = - EAnn - () - (TFunc () mempty (tyVar "A") (tyVar "A")) - (ELambda () "a" (var "a")) - - input = - EAnn - () - tyInt - (EApp () lambda (int 1)) - - expected :: Type dep () - expected = tyInt - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Uses polymorphic function" $ do - let argInput = - EAnn - () - (TFunc () mempty (tyVar "A") (tyVar "A")) - (ELambda () "a" (var "a")) - input = EApp () argInput (int 1) - - expected :: Type dep () - expected = tyIntLit [1] - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Uses polymorphic function once" $ do - let argInput = - EAnn - () - (TFunc () mempty (tyVar "A") (tyVar "A")) - (ELambda () "a" (var "a")) - fnInput = - ELambda - () - "f" - (EApp () (var "f") (int 1)) - input = EApp () fnInput argInput - expected :: Type dep () - expected = tyIntLit [1] - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Uses polymorphic function twice" $ do - let argInput = - EAnn - () - (TFunc () mempty (tyVar "A") (tyVar "A")) - (ELambda () "a" (var "a")) - fnInput = unsafeParseExpr "\\f -> (f 1, f True)" - input = EApp () fnInput argInput - expected :: Type dep () - expected = tyTuple (tyIntLit [1]) [tyBoolLit True] - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Succeeds when a function wants a subtype of a value but gets the value" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty tyBool tyInt) - (ELambda () "a" (int 100)) - ) - (EAnn () (tyBoolLit True) (bool True)) - - testElaborate input `shouldSatisfy` isRight - - it "Fails when a function wants a value but gets a subtype of the value" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty (tyBoolLit True) tyInt) - (ELambda () "a" (int 100)) - ) - (EAnn () tyBool (bool True)) - - testElaborate input `shouldSatisfy` isLeft - - it "Fails when a function wants one the True type but gets the False type" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty (tyBoolLit True) tyInt) - (ELambda () "a" (int 100)) - ) - (bool False) - - testElaborate input `shouldSatisfy` isLeft - - it "Record with literals in" $ do - let input = ERecord () (M.fromList [("a", bool True), ("b", int 1)]) - - expected :: Type dep () - expected = - TRecord - () - ( M.fromList - [ ("a", tyBoolLit True), - ("b", tyIntLit [1]) - ] - ) - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Pass empty record to function that wants an empty one" $ do - let input = - EApp - () - (EAnn () (TFunc () mempty (TRecord () mempty) tyInt) (ELambda () "rec" (int 1))) - (ERecord () mempty) - - testElaborate input `shouldSatisfy` isRight - - it "Pass bigger record to function that wants an empty one" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty (TRecord () mempty) tyInt) - (ELambda () "rec" (int 1)) - ) - (ERecord () (M.singleton "item" (int 1))) - - testElaborate input `shouldSatisfy` isRight - - it "Pass incorrect record to function" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty (TRecord () (M.singleton "item" tyBool)) tyInt) - (ELambda () "rec" (int 1)) - ) - (ERecord () (M.singleton "item" (int 1))) - - testElaborate input `shouldSatisfy` isLeft - - it "Pass empty record to function that wants items" $ do - let input = - EApp - () - ( EAnn - () - (TFunc () mempty (TRecord () (M.singleton "item" tyBool)) tyInt) - (ELambda () "rec" (int 1)) - ) - (ERecord () mempty) - - testElaborate input `shouldSatisfy` isLeft - - it "Patterns have type of input type" $ do - let input = unsafeParseExpr "(\\maybe -> case maybe of Just b -> 1 | Nothing -> 0 : Maybe Bool -> Int)" - expected = TFunc () mempty (TApp () (TConstructor () "Maybe") tyBool) tyInt - - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Infers Just with fresh var" $ do - let input = unsafeParseExpr "Just" - expected = - EConstructor - ( TFunc () mempty (TUnknown () 0) (TApp () (TConstructor () "Maybe") (TUnknown () 0)) - ) - "Just" - testElaborate input `shouldBe` Right expected - - it "Infers Nothing with fresh var" $ do - let input = unsafeParseExpr "Nothing" - expected = - fromParsedType - <$> fromParsedExpr - ( EConstructor - ( tyCons "Maybe" [tyUnknown 0] - ) - "Nothing" - ) - testElaborate input `shouldBe` Right expected - - it "Basic let binding" $ do - let input = unsafeParseExpr "let a = 1; a" - expected = ELet (tyIntLit [1]) "a" (EPrim (tyIntLit [1]) (PInt 1)) (EVar (tyIntLit [1]) "a") - testElaborate input `shouldBe` Right expected - - it "Function knows about it's external deps" $ do - let input = unsafeParseExpr "(\\a -> a : Int -> Int)" - tyBA = TFunc () mempty tyInt tyInt - expected = - ELambda - tyBA - "a" - (EVar tyInt "a") - let result = case testElaborate input of - Right (EAnn _ _ body) -> body - other -> error (show other) - result `shouldBe` expected - - it "Function knows about it's external deps" $ do - let input = unsafeParseExpr "(\\a -> \\b -> a : Int -> Int -> Int)" - tyBA = TFunc () (M.singleton "a" tyInt) tyInt tyInt - tyABA = TFunc () mempty tyInt tyBA - expected = - ELambda - tyABA - "a" - (ELambda tyBA "b" (EVar tyInt "a")) - let result = case testElaborate input of - Right (EAnn _ _ body) -> body - other -> error (show other) - result `shouldBe` expected - - it "OK boys 1" $ do - let input = - unsafeParseExpr - "let id = (\\i -> i : i -> i); case (Just 1) of Just a -> Just (id a) | Nothing -> Nothing" - expected = fromParsedType $ unsafeParseType "Maybe 1" - getExprAnnotation <$> testElaborate input - `shouldBe` Right - expected - - it "id function" $ do - let input = unsafeParseExpr "let id = (\\a -> a : a -> a); id True" - expected = fromParsedType $ unsafeParseType "True" - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "const function" $ do - let input = unsafeParseExpr "let const = (\\a -> \\b -> a : a -> b -> a); const True 100" - expected = fromParsedType $ unsafeParseType "True" - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected - - it "Weird boys 0" $ do - let input = unsafeParseExpr "let fmap = (\\f -> case (Just (1 : Int)) of Just a -> Just (f a) : (Int -> b) -> Maybe b); let id = (\\i -> i : Int -> Int); fmap id" - expected = fromParsedType $ unsafeParseType "Maybe Int" - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Weird boys 4" $ do - let input = - unsafeParseExpr - "let fmap = (\\f -> \\val -> case val of Just aa -> Just (f aa) | Nothing -> Nothing : (a -> b) -> Maybe a -> Maybe b); let id = (\\i -> i : Int -> Int); fmap id (Just 1000)" - expected = fromParsedType $ unsafeParseType "Maybe Int" - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Weird boys 5" $ do - let input = - unsafeParseExpr - "let fmap = (\\f -> \\maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing : (a -> b) -> Maybe a -> Maybe b); let id = (\\i -> i : c -> c); (fmap id (Just 1) : Maybe 1)" - expected = fromParsedType $ unsafeParseType "Maybe 1" - getExprAnnotation <$> testElaborate input `shouldBe` Right expected - - it "Applying with a polymorphic function as arg" $ do - let input = - unsafeParseExpr "let apply = (\\f -> \\a -> f a : (a -> b) -> a -> b); let id = (\\c -> c : zz -> zz); apply id 1" - expected = fromParsedType $ unsafeParseType "1" - getExprAnnotation <$> testElaborate input - `shouldBe` Right expected diff --git a/smol-core/test/static/Either.smol b/smol-core/test/static/Either.smol deleted file mode 100644 index 3388a17a..00000000 --- a/smol-core/test/static/Either.smol +++ /dev/null @@ -1,13 +0,0 @@ -type Either e a = Left e | Right a - -def orDefault : a -> Either e a -> a -def orDefault default value = - case value of - Right a -> a - | Left _ -> default - -def fmap : (a -> b) -> Either e a -> Either e b -def fmap f value = - case value of - Right a -> Right (f a) - | Left e -> Left e diff --git a/smol-core/test/static/Eq.smol b/smol-core/test/static/Eq.smol deleted file mode 100644 index 6e9b9c27..00000000 --- a/smol-core/test/static/Eq.smol +++ /dev/null @@ -1,45 +0,0 @@ -class Eq a { equals : a -> a -> Bool } - -instance Eq Int = \a -> \b -> a == b - -instance Eq Bool = \a -> \b -> a == b - -instance Eq String = \a -> \b -> a == b - -instance (Eq a, Eq b) => Eq (a,b) = \pairA -> \pairB -> - case (pairA, pairB) of - ((a1, b1), (a2, b2)) -> if equals a1 a2 then equals b1 b2 else False - -type Maybe a = Just a | Nothing - -instance (Eq a) => Eq (Maybe a) = \a -> \b -> case (a,b) of - (Just a, Just b) -> equals a b - | (Nothing, Nothing) -> True - | _ -> False - -def useEqualsInt : Bool -def useEqualsInt = equals (1: Int) (2: Int) - -def useEqualsA : (Eq a) => a -> a -> Bool -def useEqualsA a b = equals a b - -def notEquals : (Eq a) => a -> a -> Bool -def notEquals a b = if useEqualsA a b then False else True - -def pair : (Int,Int) -def pair = (1,2) - -def flipPair : (a,b) -> (b, a) -def flipPair pair = case pair of (a,b) -> (b,a) - -def main : Bool -def main = notEquals pair (flipPair pair) - -def useMaybe : Bool -def useMaybe = equals Nothing (Just (1: Int)) - -def useNewInstances : Bool -def useNewInstances = if equals (True : Bool) (False : Bool) - then equals ("dog" : String) ("log" : String) - else False - diff --git a/smol-core/test/static/Expr.smol b/smol-core/test/static/Expr.smol deleted file mode 100644 index 1de78bb6..00000000 --- a/smol-core/test/static/Expr.smol +++ /dev/null @@ -1,17 +0,0 @@ -type Expr ann - = ENumber ann Int - | EAdd ann (Expr ann) (Expr ann) - -def run expr = - case expr of - (ENumber _ i) -> i - | (EAdd _ _ _) -> 100 - -def run2 expr = - let go = \inner -> - case inner of - (ENumber _ i) -> i - | (EAdd _ a b) -> go a + go b - in go expr - -def main = run (EAdd Unit (ENumber Unit 1) (ENumber Unit 41)) diff --git a/smol-core/test/static/Functor.smol b/smol-core/test/static/Functor.smol deleted file mode 100644 index 2d065971..00000000 --- a/smol-core/test/static/Functor.smol +++ /dev/null @@ -1,45 +0,0 @@ -class Functor f { fmap : (a -> b) -> f a -> f b } - -/* Maybe */ - -type Maybe a = Just a | Nothing - -instance Functor Maybe = - \f -> \maybe -> case maybe of Just a -> Just (f a) | Nothing -> Nothing - -test "fmap works with Just" = - let unwrapMaybe = \maybe -> case maybe of - Just a -> a | Nothing -> 0; - let inc = (\a -> a + 1 : Int -> Int); - unwrapMaybe (fmap inc (Just 1)) == unwrapMaybe (Just (2 : Int)) - -/* List */ - -type List a = Cons a (List a) | Nil - -instance Functor List = - \f -> \list -> case list of - Cons a rest -> Cons (f a) (fmap f rest) - | Nil -> Nil - -test "fmap works with List" = - let listHead = \list -> case list of - Cons a _ -> a | Nil -> 0; - let inc = (\a -> a + 1 : Int -> Int); - listHead (fmap inc (Cons 1 Nil)) == listHead (Cons (2 : Int) Nil) - -/* Either */ - -type Either e a = Right a | Left e - -instance Functor (Either e) = - \f -> \either -> case either of - Right a -> Right (f a) - | Left e -> Left e - -test "fmap works with Either" = - let unwrapEither = \either -> case either of - Right a -> a | _ -> 0; - let inc = (\a -> a + 1 : Int -> Int); - unwrapEither (fmap inc (Right 1)) == unwrapEither (Right (2 : Int)) - diff --git a/smol-core/test/static/Maybe.smol b/smol-core/test/static/Maybe.smol deleted file mode 100644 index 1b6483f5..00000000 --- a/smol-core/test/static/Maybe.smol +++ /dev/null @@ -1,19 +0,0 @@ -type Maybe a = - Just a - | Nothing - -def fromMaybe : Maybe a -> a -> a -def fromMaybe val fallback = - case val of - Just a -> a - | _ -> fallback - -def fmap : (a -> b) -> Maybe a -> Maybe b -def fmap f maybeA = - case maybeA of - Just a -> Just (f a) - | _ -> Nothing - -test "fmap id does nothing" = - let id = \a -> a; - fromMaybe (fmap id (Just True)) False == True diff --git a/smol-core/test/static/Monoid.smol b/smol-core/test/static/Monoid.smol deleted file mode 100644 index 3427fb60..00000000 --- a/smol-core/test/static/Monoid.smol +++ /dev/null @@ -1,19 +0,0 @@ -class Semigroup a { mappend: a -> a -> a } - -instance Semigroup Int = \a -> \b -> a + a - -class Monoid a { mempty: a } - -instance Monoid Int = 0 - -type All = All Bool - -def runAll : All -> Bool -def runAll all = case all of All a -> a - -instance Semigroup All = \a -> \b -> case (a,b) of - (All True, All True) -> All True - | _ -> All False - -instance Monoid All = All True - diff --git a/smol-core/test/static/Prelude.smol b/smol-core/test/static/Prelude.smol deleted file mode 100644 index ff6a7ecf..00000000 --- a/smol-core/test/static/Prelude.smol +++ /dev/null @@ -1,32 +0,0 @@ -def id : a -> a -def id a = a - -def compose : - (b -> c) -> - (a -> b) -> - (a -> c) -def compose f g a = f (g a) - -def not : Bool -> Bool -def not a = if a then False else True - -def and : Bool -> Bool -> Bool -def and a b = if a then b else False - -def or : Bool -> Bool -> Bool -def or a b = if a then True else b - -def fst : (a, b) -> a -def fst pair = case pair of (a, _) -> a - -def snd : (a, b) -> b -def snd pair = case pair of (_, b) -> b - -def const : a -> b -> a -def const a b = a - -type Identity a = Identity a - -def runIdentity : Identity a -> a -def runIdentity identity = case identity of Identity a -> a - diff --git a/smol-core/test/static/Reader.smol b/smol-core/test/static/Reader.smol deleted file mode 100644 index 1ef18814..00000000 --- a/smol-core/test/static/Reader.smol +++ /dev/null @@ -1,16 +0,0 @@ -type Reader r a = Reader (r -> a) - -def run : Reader (r -> a) -> r -> a -def run reader r = - case reader of (Reader ra) -> ra r - -def pure : a -> Reader r a -def pure a = - Reader (\r -> a) - -def ask : Reader (r -> r) -def ask = let id = \a -> a in Reader id - -def local : (r -> r) -> Reader (r -> a) -> Reader (r -> a) -def local envF reader = - Reader (\r -> run reader (envF r)) diff --git a/smol-core/test/static/Semigroup.smol b/smol-core/test/static/Semigroup.smol deleted file mode 100644 index c46a65b2..00000000 --- a/smol-core/test/static/Semigroup.smol +++ /dev/null @@ -1,21 +0,0 @@ -class Eq a { equals : a -> a -> Bool } - -instance Eq Int = \a -> \b -> a == b - -class Semigroup a { mappend: a -> a -> a } - -instance Semigroup Int = \a -> \b -> a + a - -type First a = First a - -def runFirst : First a -> a -def runFirst firstA = case firstA of (First a) -> a - -instance Semigroup (First a) = \a -> \b -> a - -def true : Bool -def true = runFirst (mappend (First (True : Bool)) (First (False : Bool))) - -def main : Bool -def main = equals (mappend (20 : Int) (22 : Int)) (42 : Int) - diff --git a/smol-core/test/static/Show.smol b/smol-core/test/static/Show.smol deleted file mode 100644 index b1ad602a..00000000 --- a/smol-core/test/static/Show.smol +++ /dev/null @@ -1,43 +0,0 @@ - -class Show a { show: a -> String } - -instance Show Bool = \bool -> - if bool then "True" else "False" - -test "Show True" = - show (True: Bool) == "True" - -test "Show False" = - show (False: Bool) == "False" - -/* Natural */ - -type Natural = Suc Natural | Zero - -instance Show Natural = \nat -> case nat of - Suc n -> "S (" + show n + ")" - | Zero -> "Z" -test "Show Zero" = - show Zero == "Z" - -test "Show Three" = - show (Suc (Suc (Suc Zero))) == "S (S (S (Z)))" - -/* List */ - -type List a = Cons a (List a) | Nil - -instance (Show a) => Show (List a) = - \list -> case list of - Cons a rest -> show a + ":" + show rest - | Nil -> "Nil" - -def showBoolList = - show (Cons (True: Bool) (Cons (False: Bool) Nil)) == "True:False:Nil" - -test "Show Bool List" = showBoolList - -def showNaturalList = - show (Cons (Suc Zero) (Cons Zero Nil)) == "S (Z):Z:Nil" - -test "Show Natural List" = showNaturalList diff --git a/smol-core/test/static/State.smol b/smol-core/test/static/State.smol deleted file mode 100644 index d9235b48..00000000 --- a/smol-core/test/static/State.smol +++ /dev/null @@ -1,41 +0,0 @@ -type State s a = - State (s -> (a, s)) - -def pure : a -> State s a -def pure a = - State (\s -> (a, s)) - - -def get : State s s -def get = - State (\s -> (s, s)) - -def put : s -> State s Unit -def put s = - State (\oldS -> (Unit, s)) - -def fmap : (a -> b) -> State s a -> State s b -def fmap f state = - case state of (State sas) -> - State (\s -> - case sas s of (a, s) -> (f a, s) - ) - -def ap : State s (a -> b) -> State s a -> State s b -def ap stateF stateA = - State (\s -> case stateF of (State sfs) -> - let fs = sfs s; - case fs of (f, ss) -> - case stateA of (State sas) -> - let as = sas ss; - case as of (a, sss) -> (f a, sss)) - -def bind : (a -> State s b) -> State s a -> State s b -def bind f state = State (\s -> - case state of (State sas) -> - case (sas s) of (a, ss) -> - case f a of (State sbs) -> sbs ss) - -def run : State s a -> s -> (a, s) -def run state s = case state of (State sas) -> sas s - diff --git a/smol-core/test/static/These.smol b/smol-core/test/static/These.smol deleted file mode 100644 index 07c91d1c..00000000 --- a/smol-core/test/static/These.smol +++ /dev/null @@ -1,2 +0,0 @@ -type These a b = This a | That b | These a b - diff --git a/smol-core/test/static/Tree.smol b/smol-core/test/static/Tree.smol deleted file mode 100644 index 8fbe91a8..00000000 --- a/smol-core/test/static/Tree.smol +++ /dev/null @@ -1,19 +0,0 @@ -type Tree a = - Branch (Tree a) a (Tree a) | Leaf a - -def fmap : (a -> b) -> Tree a -> Tree b -def fmap f = - let map = \innerTree -> - case innerTree of - (Branch left a right) -> Branch (map left) (f a) (map right) - | (Leaf a) -> Leaf (f a) - in map - -def invert : Tree a -> Tree b -def invert = - let invertTree = \innerTree -> - case innerTree of - (Branch left a right) -> Branch (invertTree right) a (invertTree left) - | (Leaf a) -> Leaf a - in invertTree - diff --git a/smol-repl/.gitignore b/smol-repl/.gitignore deleted file mode 100644 index 39dffb9e..00000000 --- a/smol-repl/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -dist-newstyle -.direnv diff --git a/smol-repl/CHANGELOG.md b/smol-repl/CHANGELOG.md deleted file mode 100644 index fcf2589c..00000000 --- a/smol-repl/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for nix-basic - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/smol-repl/app/Main.hs b/smol-repl/app/Main.hs deleted file mode 100644 index 1725c88d..00000000 --- a/smol-repl/app/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified Repl - -main :: IO () -main = Repl.main diff --git a/smol-repl/smol-repl.cabal b/smol-repl/smol-repl.cabal deleted file mode 100644 index 599d1784..00000000 --- a/smol-repl/smol-repl.cabal +++ /dev/null @@ -1,69 +0,0 @@ -cabal-version: 2.4 -name: smol-repl -version: 0.1.0.0 - --- The license under which the package is released. --- license: -author: Daniel Harvey -maintainer: danieljamesharvey@gmail.com - --- A copyright notice. --- copyright: --- category: -extra-source-files: - CHANGELOG.md - static/runtime.c - -common shared - ghc-options: - -threaded -rtsopts -with-rtsopts=-N -Wall - -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - - build-depends: - , base - , diagnose - , haskeline - , megaparsec - , optparse-applicative - , smol-backend - , smol-core - , text - - other-modules: - Repl - Smol.Check - Smol.Repl - Smol.Repl.Helpers.Diagnostics - Smol.Repl.Helpers.ShowTestResults - -library - import: shared - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - hs-source-dirs: src - default-language: Haskell2010 - -executable smol-repl - import: shared - main-is: Main.hs - hs-source-dirs: app - hs-source-dirs: src - ghc-options: -threaded -rtsopts -with-rtsopts=-N - other-modules: Repl - build-depends: - , base - , diagnose - , haskeline - , megaparsec - , smol-backend - , smol-core - , smol-repl - , text - - default-language: Haskell2010 diff --git a/smol-repl/src/Repl.hs b/smol-repl/src/Repl.hs deleted file mode 100644 index 709d6be7..00000000 --- a/smol-repl/src/Repl.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Repl where - -import Control.Applicative -import Data.Text (Text) -import qualified Options.Applicative as Opt -import qualified Smol.Check as Check -import qualified Smol.Repl as Repl -import System.IO - -data AppAction - = Repl - | Check Text -- check if a file is `ok` - -parseAppAction :: Opt.Parser AppAction -parseAppAction = - Opt.hsubparser - ( Opt.command - "repl" - ( Opt.info - (pure Repl) - (Opt.progDesc "Start new module-based Smol repl") - ) - <> Opt.command - "check" - ( Opt.info - (Check <$> filePathParse) - (Opt.progDesc "Check whether a file is valid and OK etc") - ) - ) - -filePathParse :: Opt.Parser Text -filePathParse = - Opt.argument - Opt.str - (Opt.metavar "") - -optionsParse :: Opt.Parser AppAction -optionsParse = parseAppAction - -helpfulPreferences :: Opt.ParserPrefs -helpfulPreferences = - Opt.defaultPrefs - { Opt.prefShowHelpOnError = True, - Opt.prefShowHelpOnEmpty = True - } - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - action <- - Opt.customExecParser - helpfulPreferences - (Opt.info (optionsParse <**> Opt.helper) Opt.fullDesc) - case action of - Repl -> Repl.repl - Check filePath -> Check.check filePath diff --git a/smol-repl/src/Smol/Check.hs b/smol-repl/src/Smol/Check.hs deleted file mode 100644 index ee17f3e5..00000000 --- a/smol-repl/src/Smol/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Smol.Check - ( check, - ) -where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Smol.Core.Modules.Check -import Smol.Core.Modules.RunTests -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Parser (parseModule) -import Smol.Repl.Helpers.Diagnostics -import Smol.Repl.Helpers.ShowTestResults -import System.Exit -import Prelude hiding (init) - --- read a file, check if it is OK etc -checkFile :: (MonadIO m) => Text -> m ExitCode -checkFile filePath = liftIO $ do - input <- T.readFile (T.unpack filePath) - case parseModule input of - Left bundle -> do - printDiagnostic (fromErrorBundle bundle input) - >> pure (ExitFailure 1) - Right moduleParts -> do - case checkModule input moduleParts of - Left e -> - printDiagnostic (moduleErrorDiagnostic e) - >> pure (ExitFailure 1) - Right tcModule -> do - let testResults = runTests tcModule - liftIO $ printTestResults testResults - if testsAllPass testResults - then putStrLn "Great job!" >> pure ExitSuccess - else pure (ExitFailure 1) - -check :: Text -> IO () -check filePath = do - liftIO $ checkFile filePath >>= exitWith diff --git a/smol-repl/src/Smol/Repl.hs b/smol-repl/src/Smol/Repl.hs deleted file mode 100644 index d95adb84..00000000 --- a/smol-repl/src/Smol/Repl.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Smol.Repl - ( repl, - ) -where - -import Control.Monad.IO.Class -import qualified Data.Text as T -import qualified Smol.Backend.Compile.RunLLVM as Run -import Smol.Backend.IR.FromExpr.Expr -import Smol.Backend.IR.ToLLVM.ToLLVM -import Smol.Core.Modules.Check -import Smol.Core.Modules.RunTests -import Smol.Core.Modules.Types.ModuleError -import Smol.Core.Parser (parseModule) -import Smol.Repl.Helpers.Diagnostics -import Smol.Repl.Helpers.ShowTestResults -import System.Console.Haskeline - -repl :: IO () -repl = do - putStrLn "Welcome to smol" - putStrLn "Exit with :quit" - runInputT defaultSettings loop - where - loop :: InputT IO () - loop = do - minput <- getInputLine ":> " - case minput of - Nothing -> return () - Just ":quit" -> return () - Just input -> do - case parseModule (T.pack input) of - Left bundle -> do - printDiagnostic (fromErrorBundle bundle (T.pack input)) >> loop - Right moduleParts -> - case checkModule (T.pack input) moduleParts of - Left e -> printDiagnostic (moduleErrorDiagnostic e) >> loop - Right tcModule -> do - liftIO $ printTestResults (runTests tcModule) - let llvmIR = irToLLVM (irFromModule tcModule) - resp <- liftIO $ fmap Run.rrResult (Run.run [] llvmIR) - liftIO $ putStrLn (T.unpack resp) - loop diff --git a/smol-repl/src/Smol/Repl/Helpers/Diagnostics.hs b/smol-repl/src/Smol/Repl/Helpers/Diagnostics.hs deleted file mode 100644 index 6397aa5c..00000000 --- a/smol-repl/src/Smol/Repl/Helpers/Diagnostics.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS -Wno-orphans #-} - -module Smol.Repl.Helpers.Diagnostics - ( fromErrorBundle, - printDiagnostic, - ) -where - -import Control.Monad.IO.Class -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void -import qualified Error.Diagnose as Diag -import Error.Diagnose.Compat.Megaparsec -import Text.Megaparsec - -type ParseErrorType = ParseErrorBundle Text Void - -replFilename :: FilePath -replFilename = "repl" - -instance HasHints Void msg where - hints _ = mempty - -printDiagnostic :: (MonadIO m) => Diag.Diagnostic Text -> m () -printDiagnostic = - Diag.printDiagnostic - Diag.stderr - True - True - 4 - Diag.defaultStyle - --- | turn Megaparsec error + input into a Diagnostic -fromErrorBundle :: ParseErrorType -> Text -> Diag.Diagnostic Text -fromErrorBundle bundle input = - let diag = - errorDiagnosticFromBundle - Nothing - "Parse error on input" - Nothing - bundle - in Diag.addFile diag replFilename (T.unpack input) diff --git a/smol-repl/src/Smol/Repl/Helpers/ShowTestResults.hs b/smol-repl/src/Smol/Repl/Helpers/ShowTestResults.hs deleted file mode 100644 index 51ba31e9..00000000 --- a/smol-repl/src/Smol/Repl/Helpers/ShowTestResults.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Smol.Repl.Helpers.ShowTestResults (testsAllPass, printTestResults) where - -import Data.Foldable (traverse_) -import Data.Monoid -import Smol.Core.Modules.Types - -testsAllPass :: [(a, Bool)] -> Bool -testsAllPass = getAll . foldMap (All . snd) - -printTestResults :: [(TestName, Bool)] -> IO () -printTestResults = - traverse_ printResult - where - printResult (name, True) = - putStrLn $ "โœ… " <> show name - printResult (name, False) = - putStrLn $ "โŒ " <> show name diff --git a/swagger.config.json b/swagger.config.json deleted file mode 100644 index 5c2305aa..00000000 --- a/swagger.config.json +++ /dev/null @@ -1 +0,0 @@ -{ "apiPackage": "mimsa-api", "modelPackage": "mimsa-types", "supportsES6": true, "withSeparateModelsAndApi": true, "npmName": "mimsa-types" } From fc69ff682e2709f1c833a7a3b360224961f3da7d Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Tue, 24 Oct 2023 20:41:26 +0100 Subject: [PATCH 2/4] Destroy --- README.md | 62 +------------------------- benchmarks/.dockerignore | 2 - benchmarks/.gitignore | 42 ------------------ benchmarks/LICENSE | 30 ------------- benchmarks/benchmark/Spec.hs | 85 ------------------------------------ benchmarks/benchmarks.cabal | 61 -------------------------- 6 files changed, 2 insertions(+), 280 deletions(-) delete mode 100644 benchmarks/.dockerignore delete mode 100644 benchmarks/.gitignore delete mode 100644 benchmarks/LICENSE delete mode 100644 benchmarks/benchmark/Spec.hs delete mode 100644 benchmarks/benchmarks.cabal diff --git a/README.md b/README.md index 6f230623..a8a7453c 100644 --- a/README.md +++ b/README.md @@ -1,61 +1,3 @@ -# mimsa +# llvm-calc -Mimsa is a small programming language. - -It is inspired syntactically by `Elm` and `Haskell`. - -It works by saving expressions into a database and referencing them by hashes like `Unison`. - -It can be used through a `repl` or it's own web-based editor. - -It compiles to readable Javascript. - -It aims to become a specialised DSL for small backend services, much like `Elm` is for frontends, however currently it's just a fun way to play with functional programming without installing anything. - -Try it at [mimsa.isverymuchmybusiness.com](https://mimsa.isverymuchmybusiness.com/) - - - -### Getting started - -#### Scratch - -When you open Mimsa, you'll see the `Scratch` screen. This is like a repl where you can try out expressions. - -Screenshot 2021-07-10 at 18 44 24 - -Let's try making a simple expression: - -Screenshot 2021-07-10 at 18 44 41 - -Note that now we have some input, the `Evaluate` button has appeared. Let's click it: - -Screenshot 2021-07-10 at 18 44 47 - -It's evaluated the expression, `20`, in pink, and the type of the expression, `Int`, in blue. Note we have not had to mention any types - in Mimsa they are all inferred. - -#### Exploring expressions - -At the bottom of the screen we have a set of names. These are all the expressions bound to names in our project. - -Screenshot 2021-07-10 at 18 48 22 - -If we click on any of them we can view the code for the expression. - -Screenshot 2021-07-10 at 18 49 06 - -We can change the code here, and even press `Update` to save a new expression and bind it to the name. This means any new users of the function will use your new version, but any old versions will still use the old version of the function. - -Note the `Compile export` button - this allows us to turn this expression into Javascript and download it. `Export` is the default runtime which just exports the function. There are a few other runtimes which allow Mimsa to do various side effects (more on this stuff soon). - -There is more info on the [syntax](https://github.com/danieljharvey/mimsa/blob/trunk/compiler/README.md). - -#### Other menu items to try - -โž• Add a new binding, ie, make a new expression and then give it a name, so that it can be used in other expressions. - -๐Ÿงท Add a new datatype that can be used in other expressions. The compiler will also try and create you helper functions for manipulating your datatype and save those in another expression. - -๐Ÿงช Add a unit test. As all values and expressions in Mimsa are immutable, this test will only be run once, and the output stored and linked to all the expressions it uses. - -๐Ÿ”Ž Type search - find useful functions by searching the type you are looking for, ala [Hoogle](https://hoogle.haskell.org/). +Example code for llvm tutorials found at: [https://danieljharvey.github.io/tags/llvm.html](https://danieljharvey.github.io/tags/llvm.html) diff --git a/benchmarks/.dockerignore b/benchmarks/.dockerignore deleted file mode 100644 index d7e4614b..00000000 --- a/benchmarks/.dockerignore +++ /dev/null @@ -1,2 +0,0 @@ -.stack-work -dist-newstyle diff --git a/benchmarks/.gitignore b/benchmarks/.gitignore deleted file mode 100644 index e6a31718..00000000 --- a/benchmarks/.gitignore +++ /dev/null @@ -1,42 +0,0 @@ -.direnv/ - -.stack-work/ -*~ -store/*.json -result -result/ - -output/ - -*.hie -swagger.json - -compiler/ - -# files generated during tests - -# typescript tests -test/golden/Typescript/*.ts -test/golden/Typescript-result/*.json -test/golden/CompileTSProject/ -test/golden/CompileTSProject-result/ -test/golden/CompileTSModuleProject/ -test/golden/CompileTSModuleProject-result/ -test/golden/CompileTSProjectWhole/ -test/golden/CompileTSProjectWhole-result/ - -# esmodules compilation tests -test/golden/ESModulesJS-result/*.json -test/golden/ESModulesJS/ -test/golden/CompileJSProject/ -test/golden/CompileJSProject-result/ -test/golden/CompileJSModuleProject/ -test/golden/CompileJSModuleProject-result/ -test/golden/CompileJSProjectWhole/ -test/golden/CompileJSProjectWhole-result/ - -# .prof files generated for profiling -*.prof - -# cabal shit -dist-newstyle diff --git a/benchmarks/LICENSE b/benchmarks/LICENSE deleted file mode 100644 index e637cdee..00000000 --- a/benchmarks/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2020 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/benchmarks/benchmark/Spec.hs b/benchmarks/benchmark/Spec.hs deleted file mode 100644 index 6400d112..00000000 --- a/benchmarks/benchmark/Spec.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main - ( main, - ) -where - -import Criterion.Main -import Criterion.Types (Config (..)) -import Data.Functor -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.Mimsa.Actions.Modules.Evaluate as Actions -import qualified Language.Mimsa.Actions.Monad as Actions -import Language.Mimsa.Core -import Language.Mimsa.Project.Stdlib -import Language.Mimsa.Types.Project - -unsafeParseExpr :: Text -> Expr Name () -unsafeParseExpr t = case parseExpr t of - Right a -> a $> () - Left _ -> - error $ - "Error parsing expr for benchmark:" - <> T.unpack t - --- build the stdlib, exploding if it fails (so that doesn't look like an --- incredible speedup) -buildThing :: - Actions.ActionM () -> - Project Annotation -> - Project Annotation -buildThing action prj = - case Actions.run prj action of - Right (proj, _, _) -> proj - Left e -> error (show e) - --- evaluate something -evaluateThing :: Text -> Expr Name Annotation -evaluateThing input = - let action = do - let expr = unsafeParseExpr input $> mempty - (_, result, _) <- Actions.evaluateModule expr mempty - pure result - in case Actions.run stdlib action of - Right (_, _, res) -> res - Left e -> error (show e) - -benchConfig :: Config -benchConfig = - defaultConfig - { jsonFile = Just "performance.json" - } - --- Our benchmark harness. -main :: IO () -main = - defaultMainWith - benchConfig - [ bgroup - "build stdlib" - [ bench "allFns" $ whnf (buildThing stdModules) mempty - ], - bgroup - "evaluate" - [ bench "evaluate big looping thing" $ - whnf evaluateThing "let countdown a = if a == 0 then True else countdown (a - 1); countdown 100000", - bench "evaluate parsing" $ - whnf evaluateThing "let pA = Parser.char \"a\"; let pB = Parser.char \"b\"; let p = Parser.many (Parser.alt pA pB); Parser.run p \"aababaa\"", - bench "evaluate parsing 2" $ - let input = T.replicate 1000 ",d" - in whnf - evaluateThing - ( mconcat - [ "let lexeme p = Parser.left p Parser.space0; ", - "let bracketL = lexeme (Parser.char \"[\"); ", - "let bracketR = lexeme (Parser.char \"]\"); ", - "let comma = lexeme (Parser.char \",\"); ", - "let inner = lexeme (Parser.char \"d\"); ", - "let bigP = Parser.right bracketL (Parser.left (Parser.sepBy comma inner) bracketR); ", - "Parser.run bigP \"[d" <> input <> "]\"" - ] - ) - ] - ] diff --git a/benchmarks/benchmarks.cabal b/benchmarks/benchmarks.cabal deleted file mode 100644 index e094adde..00000000 --- a/benchmarks/benchmarks.cabal +++ /dev/null @@ -1,61 +0,0 @@ -cabal-version: 2.2 -name: benchmark -version: 0.1.0.0 -description: - Please see the README on GitHub at - -homepage: https://github.com/danieljharvey/mimsa#readme -bug-reports: https://github.com/danieljharvey/mimsa/issues -author: Daniel J Harvey -maintainer: danieljamesharvey@gmail.com -copyright: 2021 Daniel J Harvey -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple - -source-repository head - type: git - location: https://github.com/danieljharvey/mimsa - -common common-all - ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints -Wmissing-deriving-strategies - -benchmark benchmark - import: common-all - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: benchmark - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - , aeson - , base >=4.7 && <5 - , bifunctors - , binary - , bytestring - , containers - , core - , criterion - , cryptonite - , diagnose - , directory - , exceptions - , file-embed - , hashable - , megaparsec - , memory - , mimsa - , monad-logger - , mtl - , openapi3 - , parallel - , parser-combinators - , prettyprinter - , QuickCheck - , text - , transformers - , wasm - - default-language: Haskell2010 From 8bc99e8a3de20dff2d6685f57f7a3730576fa7a7 Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Tue, 24 Oct 2023 20:42:35 +0100 Subject: [PATCH 3/4] Fix workflows --- .github/workflows/compiler-haskell.yml | 192 ------------------------- .github/workflows/lint-haskell.yml | 11 +- .github/workflows/performance.yml | 71 --------- .github/workflows/smol-haskell.yml | 69 --------- 4 files changed, 1 insertion(+), 342 deletions(-) delete mode 100644 .github/workflows/compiler-haskell.yml delete mode 100644 .github/workflows/performance.yml delete mode 100644 .github/workflows/smol-haskell.yml diff --git a/.github/workflows/compiler-haskell.yml b/.github/workflows/compiler-haskell.yml deleted file mode 100644 index 98897326..00000000 --- a/.github/workflows/compiler-haskell.yml +++ /dev/null @@ -1,192 +0,0 @@ -name: Compiler - build - -on: - push: - branches: - - trunk - paths: - - "benchmarks/**" - - "builder/**" - - "compiler/**" - - "repl/**" - - "core/**" - - "backends/**" - - "cabal.project" - - "cabal.project.freeze" - - pull_request: - branches: - - trunk - paths: - - "benchmarks/**" - - "builder/**" - - "compiler/**" - - "repl/**" - - "core/**" - - "backends/**" - - "cabal.project" - - "cabal.project.freeze" - -jobs: - build: - runs-on: ubuntu-latest - - steps: - - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4 - - - name: Cache cabal global package db - id: cabal-global - uses: actions/cache@v3 - with: - path: ~/.cabal - key: ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }} - - - name: Cache cabal-installed programs in ~/.local/bin - id: cabal-programs - uses: actions/cache@v3 - with: - path: ~/.cabal/bin - key: ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }} - - - name: Cache .cabal-work - uses: actions/cache@v3 - with: - path: dist-newstyle - key: ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }} - - - uses: haskell/actions/setup@v2 - with: - ghc-version: '9.6.2' - cabal-version: '3.10.1.0' - - - name: Build all things - run: make build - - test: - runs-on: ubuntu-latest - needs: build - steps: - - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4 - - - uses: actions/setup-node@v3 - with: - node-version: 19 - - - uses: haskell/actions/setup@v2 - with: - ghc-version: '9.6.2' - cabal-version: '3.10.1.0' - - - name: Cache cabal global package db - id: cabal-global - uses: actions/cache@v3 - with: - path: ~/.cabal - key: ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }} - - - name: Cache .cabal-work - uses: actions/cache@v3 - with: - path: dist-newstyle - key: ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }} - - - name: Cache cabal-installed programs in ~/.local/bin - id: cabal-programs - uses: actions/cache@v3 - with: - path: ~/.cabal/bin - key: ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }} - - - name: Cabal update - run: cabal update - - - name: Test core - run: make test-core - - - name: Test backends - run: make test-backends - - - name: Test compiler - run: yarn global add typescript@4.4 ts-node@10.9.1 & make test - - bench: - runs-on: ubuntu-latest - needs: build - steps: - - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4 - - - uses: haskell/actions/setup@v2 - with: - ghc-version: '9.6.2' - cabal-version: '3.10.1.0' - - - name: Cache cabal global package db - id: cabal-global - uses: actions/cache@v3 - with: - path: ~/.cabal - key: ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }} - - - name: Cache cabal-installed programs in ~/.local/bin - id: cabal-programs - uses: actions/cache@v3 - with: - path: ~/.cabal/bin - key: ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }} - - - name: Cache .cabal-work - uses: actions/cache@v3 - with: - path: dist-newstyle - key: ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }} - - - name: Run benchmarks - run: make bench - - - name: Create benchmark file - run: | - jq '.[2] | map({name: .reportName, unit: "Time (ms)", value: .reportAnalysis.anRegress[0].regCoeffs.iters.estPoint })' benchmarks/performance.json | tee sorted-results.json - - # Download previous benchmark result from cache (if exists) - - name: Download previous benchmark data - uses: actions/cache@v3 - with: - path: ./cache - key: ${{ runner.os }}-benchmark - - # Run `github-action-benchmark` action - - name: Store benchmark result - uses: benchmark-action/github-action-benchmark@v1 - with: - # What benchmark tool the output.txt came from - tool: 'customSmallerIsBetter' - # Where the output from the benchmark tool is stored - output-file-path: sorted-results.json - # Where the previous data file is stored - external-data-json-path: ./cache/benchmark-data.json - # Workflow will fail when an alert happens - fail-on-alert: true - # GitHub API token to make a commit comment - github-token: ${{ secrets.GITHUB_TOKEN }} - # Enable alert commit comment - comment-on-alert: true - # Mention @danieljharvey in the commit comment - alert-comment-cc-users: '@danieljharvey' diff --git a/.github/workflows/lint-haskell.yml b/.github/workflows/lint-haskell.yml index 67f44e9c..f0909eb8 100644 --- a/.github/workflows/lint-haskell.yml +++ b/.github/workflows/lint-haskell.yml @@ -17,15 +17,6 @@ jobs: - uses: mrkkrp/ormolu-action@v11 with: pattern: | - backends/**/*.hs - benchmarks/**/*.hs - builder/**/*.hs - compiler/**/*.hs - core/**/*.hs - repl/**/*.hs - smol-backend/**/*.hs - smol-core/**/*.hs - smol-repl/**/*.hs llvm-calc/**/*.hs llvm-calc2/**/*.hs llvm-calc3/**/*.hs @@ -44,6 +35,6 @@ jobs: - name: "Run HLint" uses: rwe/actions-hlint-run@v2 with: - path: '["backends/", "benchmarks/", "builder/", "compiler/", "core/", "repl/", "smol-backend/", "smol-core/", "smol-repl/", "llvm-calc/", "llvm-calc2", "llvm-calc3", "llvm-calc4"]' + path: '["llvm-calc/", "llvm-calc2", "llvm-calc3", "llvm-calc4"]' fail-on: warning diff --git a/.github/workflows/performance.yml b/.github/workflows/performance.yml deleted file mode 100644 index de0577fe..00000000 --- a/.github/workflows/performance.yml +++ /dev/null @@ -1,71 +0,0 @@ -# Do not run this workflow on pull request since this workflow has permission to modify contents. -on: - push: - branches: - - trunk - -permissions: - # deployments permission to deploy GitHub pages website - deployments: write - # contents permission to update benchmark contents in gh-pages branch - contents: write - -jobs: - benchmark: - name: Compiler performance regression check - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4 - - - uses: haskell/actions/setup@v2 - with: - ghc-version: '9.6.2' - cabal-version: '3.10.1.0' - - - name: Cache cabal global package db - id: cabal-global - uses: actions/cache@v3 - with: - path: ~/.cabal - key: ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-global-${{ matrix.plan.ghc }} - - - name: Cache cabal-installed programs in ~/.local/bin - id: cabal-programs - uses: actions/cache@v3 - with: - path: ~/.cabal/bin - key: ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-programs-${{ matrix.plan.ghc }} - - - name: Cache .cabal-work - uses: actions/cache@v3 - with: - path: dist-newstyle - key: ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-cabal-work-${{ matrix.plan.ghc }} - - - name: Cabal update - run: cabal update - - - name: Run benchmarks - run: make bench - - - name: Create benchmark file - run: | - jq '.[2] | map({name: .reportName, unit: "Time (ms)", value: .reportAnalysis.anRegress[0].regCoeffs.iters.estPoint })' benchmarks/performance.json | tee sorted-results.json - - # gh-pages branch is updated and pushed automatically with extracted benchmark data - - name: Store benchmark result - uses: benchmark-action/github-action-benchmark@v1 - with: - name: Store benchmarks in Github Pages - tool: 'customSmallerIsBetter' - output-file-path: sorted-results.json - # Access token to deploy GitHub Pages branch - github-token: ${{ secrets.GITHUB_TOKEN }} - # Push and deploy GitHub pages branch automatically - auto-push: true diff --git a/.github/workflows/smol-haskell.yml b/.github/workflows/smol-haskell.yml deleted file mode 100644 index 56764560..00000000 --- a/.github/workflows/smol-haskell.yml +++ /dev/null @@ -1,69 +0,0 @@ -name: Smol - build - -on: - push: - branches: - - trunk - paths: - - "benchmarks/**" - - "smol-backend/**" - - "smol-core/**" - - "smol-repl/**" - - "vendored/**" - - "cabal.project" - - "cabal.project.freeze" - - pull_request: - branches: - - trunk - paths: - - "benchmarks/**" - - "smol-backend/**" - - "smol-core/**" - - "smol-repl/**" - - "vendored/**" - - "cabal.project" - - "cabal.project.freeze" - -jobs: - build: - runs-on: ubuntu-latest - - steps: - - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4 - - - name: Install LLVM and Clang - uses: KyleMayes/install-llvm-action@v1 - with: - version: "14.0" - - - name: Cache cabal global package db - id: cabal-global - uses: actions/cache@v3 - with: - path: ~/.cabal - key: ${{ runner.os }}-2-smol-cabal-global-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-smol-cabal-global-${{ matrix.plan.ghc }} - - - name: Cache .cabal-work - uses: actions/cache@v3 - with: - path: dist-newstyle - key: ${{ runner.os }}-2-smol-cabal-work-${{ matrix.plan.ghc }}-${{ hashFiles('**.freeze') }} - restore-keys: | - ${{ runner.os }}-2-smol-cabal-work-${{ matrix.plan.ghc }} - - - uses: haskell/actions/setup@v2 - with: - ghc-version: '9.6.2' - cabal-version: '3.10.1.0' - - - name: Test smol - run: make test-smol - - - name: Test smol backend - run: make test-smol-backend - - - name: Build smol repl - run: make build-smol-repl From 0bf3b58ed2cfa8268f8a9cc6203dd598776e710f Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Tue, 24 Oct 2023 20:48:27 +0100 Subject: [PATCH 4/4] New install action --- .github/workflows/llvm-calc-haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/llvm-calc-haskell.yml b/.github/workflows/llvm-calc-haskell.yml index 194c4d8c..f6ce9153 100644 --- a/.github/workflows/llvm-calc-haskell.yml +++ b/.github/workflows/llvm-calc-haskell.yml @@ -54,7 +54,7 @@ jobs: restore-keys: | ${{ runner.os }}-2-llvm-calc-cabal-work-${{ matrix.plan.ghc }} - - uses: haskell/actions/setup@v2 + - uses: haskell-actions/setup@v2 with: ghc-version: '9.6.2' cabal-version: '3.10.1.0'