├── .envrc ├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── README.md ├── app ├── Main.hs └── Solver.hs ├── concept-art ├── README.md └── has-field.sol ├── doc └── core.md ├── flake.lock ├── flake.nix ├── hie.yaml ├── lib ├── StdAssertions.sol ├── Vm.sol ├── console.sol └── stdlib.sol ├── runsol.sh ├── scripts.nix ├── sol-core.cabal ├── spec ├── ast.md ├── examples │ └── filter.md ├── generic.md ├── makefile ├── new-solidity-spec.tex └── references.bib ├── src ├── Common │ ├── LightYear.hs │ ├── Monad.hs │ ├── NameSupply.hs │ ├── Pretty.hs │ └── RIO.hs ├── Language │ ├── Core.hs │ ├── Core │ │ ├── Parser.hs │ │ └── Types.hs │ ├── Yul.hs │ └── Yul │ │ └── Parser.hs └── Solcore │ ├── Desugarer │ ├── EmitCore.hs │ ├── IndirectCall.hs │ ├── LambdaLifting.hs │ ├── MatchCompiler.hs │ ├── ReplaceWildcard.hs │ ├── Specialise.hs │ └── UniqueTypeGen.hs │ ├── Frontend │ ├── Lexer │ │ ├── SolcoreLexer.x │ │ └── SolverInputLexer.x │ ├── Parser │ │ ├── SolcoreParser.y │ │ └── SolverInputParser.y │ ├── Pretty │ │ ├── Name.hs │ │ ├── ShortName.hs │ │ └── SolcorePretty.hs │ ├── Syntax.hs │ ├── Syntax │ │ ├── Contract.hs │ │ ├── ElabTree.hs │ │ ├── Name.hs │ │ ├── Stmt.hs │ │ ├── SyntaxTree.hs │ │ └── Ty.hs │ └── TypeInference │ │ ├── Erase.hs │ │ ├── Id.hs │ │ ├── InvokeGen.hs │ │ ├── NameSupply.hs │ │ ├── SccAnalysis.hs │ │ ├── TcContract.hs │ │ ├── TcEnv.hs │ │ ├── TcMonad.hs │ │ ├── TcReduce.hs │ │ ├── TcSat.hs │ │ ├── TcStmt.hs │ │ ├── TcSubst.hs │ │ └── TcUnify.hs │ ├── Pipeline │ ├── Options.hs │ ├── SolcorePipeline.hs │ └── SolverPipeline.hs │ └── Primitives │ ├── Primitives.hs │ └── Primitives.solc ├── std └── std.sol ├── test ├── Cases.hs ├── Main.hs ├── Solver.hs ├── examples │ ├── Convertible.solc │ ├── cases │ │ ├── Ackermann.solc │ │ ├── Add1.solc │ │ ├── BadInstance.solc │ │ ├── BoolNot.solc │ │ ├── Compose.solc │ │ ├── Compose2.solc │ │ ├── Compose3.solc │ │ ├── DupFun.solc │ │ ├── DuplicateFun.solc │ │ ├── EitherModule.solc │ │ ├── Enum.solc │ │ ├── Eq.solc │ │ ├── EqQual.solc │ │ ├── EvenOdd.solc │ │ ├── Filter.solc │ │ ├── Foo.solc │ │ ├── GetSet.solc │ │ ├── GoodInstance.solc │ │ ├── Id.solc │ │ ├── IncompleteInstDef.solc │ │ ├── Invokable.solc │ │ ├── KindTest.solc │ │ ├── ListModule.solc │ │ ├── Logic.solc │ │ ├── MatchCall.solc │ │ ├── Memory1.solc │ │ ├── Memory2.solc │ │ ├── Mutuals.solc │ │ ├── NegPair.solc │ │ ├── Option.solc │ │ ├── Pair.solc │ │ ├── PairMatch1.solc │ │ ├── PairMatch2.solc │ │ ├── Peano.solc │ │ ├── PeanoMatch.solc │ │ ├── Ref.solc │ │ ├── RefDeref.solc │ │ ├── SillyReturn.solc │ │ ├── SimpleField.solc │ │ ├── SimpleInvoke.solc │ │ ├── SimpleLambda.solc │ │ ├── SingleFun.solc │ │ ├── StructMembers.sol │ │ ├── Uncurry.solc │ │ ├── another-subst.solc │ │ ├── app.solc │ │ ├── assembly.solc │ │ ├── closure.solc │ │ ├── comp.solc │ │ ├── complexproxy.solc │ │ ├── compose0.solc │ │ ├── const.solc │ │ ├── constrained-instance-context.solc │ │ ├── constrained-instance.solc │ │ ├── constructor-weak-args.solc │ │ ├── default-inst.solc │ │ ├── default-instance-missing.solc │ │ ├── default-instance-weak.solc │ │ ├── join.solc │ │ ├── joinErr.solc │ │ ├── listid.solc │ │ ├── mainproxy.solc │ │ ├── memory.solc │ │ ├── morefun.solc │ │ ├── nid.solc │ │ ├── noclosure.solc │ │ ├── noconstr.solc │ │ ├── proxy.solc │ │ ├── proxy1.solc │ │ ├── reference-encoding-bad.solc │ │ ├── reference-encoding-good.solc │ │ ├── reference-encoding.solc │ │ ├── reference-test.solc │ │ ├── reference.solc │ │ ├── signature.solc │ │ ├── super-class.solc │ │ ├── tyexp.solc │ │ ├── typedef.solc │ │ ├── unconstrained-instance.solc │ │ ├── undefined.solc │ │ ├── unit.solc │ │ ├── vartyped.solc │ │ └── weirdfoo.solc │ ├── invokable │ │ ├── 021nid.solc │ │ ├── 022nid-invoke.solc │ │ ├── 024lamid.solc │ │ ├── 025lamid-invoke.solc │ │ ├── 026capture.solc │ │ ├── 027retfun.solc │ │ ├── 028modifier.solc │ │ └── 031enum.solc │ ├── pragmas │ │ ├── bound.solc │ │ ├── coverage.solc │ │ └── patterson.solc │ └── spec │ │ ├── 00answer.solc │ │ ├── 010answer.solc │ │ ├── 011id.solc │ │ ├── 012nid.solc │ │ ├── 013comp.solc │ │ ├── 01id.solc │ │ ├── 021not.solc │ │ ├── 022add.solc │ │ ├── 024arith.solc │ │ ├── 027sstore.solc │ │ ├── 02nid.solc │ │ ├── 031maybe.solc │ │ ├── 032simplejoin.solc │ │ ├── 033join.solc │ │ ├── 034cojoin.solc │ │ ├── 035padding.solc │ │ ├── 036wildcard.solc │ │ ├── 037dwarves.solc │ │ ├── 038food0.solc │ │ ├── 039food.solc │ │ ├── 041pair.solc │ │ ├── 042triple.solc │ │ ├── 043fstsnd.solc │ │ ├── 047rgb.solc │ │ ├── 048rgb2.solc │ │ ├── 051expreturn.solc │ │ ├── 051negBool.solc │ │ ├── 052negPair.solc │ │ ├── 052return.solc │ │ ├── 053return.solc │ │ ├── 06comp.solc │ │ ├── 09not.solc │ │ ├── 10negBool.solc │ │ ├── 11negPair.solc │ │ ├── 903badassign.solc │ │ ├── 939badfood.solc │ │ └── attic │ │ ├── 051expreturn.solc │ │ ├── 052return.solc │ │ └── 053return.solc ├── imports │ ├── booldef.solc │ └── boolmain.solc └── solver │ ├── red00.inp │ ├── red01.inp │ ├── red02.inp │ ├── red03.inp │ ├── red04.inp │ ├── red05.inp │ ├── red06.inp │ ├── sat00.inp │ ├── sat01.inp │ ├── sat02.inp │ ├── sat03.inp │ ├── sat04.inp │ └── sat05.inp └── yule ├── Builtins.hs ├── Compress.hs ├── Locus.hs ├── Main.hs ├── Options.hs ├── README.md ├── TM.hs └── Translate.hs /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v4 19 | 20 | - name: Set up GHC 21 | uses: haskell-actions/setup@v2 22 | id: setup 23 | with: 24 | ghc-version: '9.8.2' 25 | cabal-version: '3.10' 26 | 27 | - name: Configure the build 28 | run: | 29 | cabal configure --enable-tests --enable-benchmarks --disable-documentation 30 | cabal build all --dry-run 31 | # The last step generates dist-newstyle/cache/plan.json for the cache key. 32 | 33 | - name: Restore cached dependencies 34 | uses: actions/cache/restore@v4 35 | id: cache 36 | env: 37 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 38 | with: 39 | path: ${{ steps.setup.outputs.cabal-store }} 40 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 41 | restore-keys: ${{ env.key }}- 42 | 43 | - name: Install dependencies 44 | # If we had an exact cache hit, the dependencies will be up to date. 45 | if: steps.cache.outputs.cache-hit != 'true' 46 | run: cabal build all --only-dependencies 47 | 48 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 49 | - name: Save cached dependencies 50 | uses: actions/cache/save@v4 51 | # If we had an exact cache hit, trying to save the cache would error because of key clash. 52 | if: steps.cache.outputs.cache-hit != 'true' 53 | with: 54 | path: ${{ steps.setup.outputs.cabal-store }} 55 | key: ${{ steps.cache.outputs.cache-primary-key }} 56 | 57 | - name: Build 58 | run: cabal build --enable-tests --enable-benchmarks all 59 | - name: Run tests 60 | run: cabal test all 61 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | .direnv/ 25 | *.info 26 | Tasks.md 27 | *~ 28 | output.core 29 | /src/Solcore/Frontend/Parser/SolcoreParser.hs -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Experimental compiler for the new Solidity language 2 | 3 | 4 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Solcore.Pipeline.SolcorePipeline 4 | 5 | main :: IO () 6 | main = pipeline 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /app/Solver.hs: -------------------------------------------------------------------------------- 1 | import Solcore.Pipeline.SolverPipeline 2 | import System.Environment 3 | import System.Exit 4 | 5 | main :: IO () 6 | main 7 | = do 8 | args <- getArgs 9 | case args of 10 | [path] -> do 11 | b <- runForFile path 12 | if b then pure () else exitFailure 13 | _ -> do 14 | putStrLn "Usage: solver " 15 | exitFailure 16 | 17 | -------------------------------------------------------------------------------- /concept-art/README.md: -------------------------------------------------------------------------------- 1 | # Concepts 2 | 3 | Files that we don't expect to compile yet that demonstrate the usage / semantics of potential future language features 4 | -------------------------------------------------------------------------------- /concept-art/has-field.sol: -------------------------------------------------------------------------------- 1 | data Unit = Unit 2 | data Pair(a, b) = Pair(a,b) 3 | 4 | type uint = word 5 | type string = word 6 | type bool = word 7 | 8 | data Memory(t) = Memory(Word) 9 | 10 | // this lets us link a given field in a struct to its position in it's 11 | // underlying generic representation as a tuple. 12 | class self:Field(prevTypes, ty) {} 13 | 14 | // this struct should desugar into the following 15 | //struct S { 16 | // f1 : uint; 17 | // f2 : string; 18 | // f3 : bool; 19 | //} 20 | 21 | // a type abstraction over tuples 22 | type s = Pair(uint, Pair(string, bool)) 23 | 24 | // unique types identifying each field 25 | type sf1 = Unit 26 | type sf2 = Unit 27 | type sf3 = Unit 28 | 29 | // Field instances linking each field to it's position in the underlying tuple 30 | instance Pair(s, sf1):Field(Unit, uint) {} 31 | instance Pair(s, sf2):Field(uint, string) {} 32 | instance Pair(s, sf3):Field(Pair(uint, string), bool) {} 33 | 34 | 35 | // struct field member access desugars into calls to this class 36 | class self:HasField(fieldType) { 37 | function getField(x:self) -> fieldType; 38 | } 39 | 40 | // we instantiate generic instances for references to types that implement Field 41 | instance (Pair(t, fieldName):Field(prevTypes, fieldType), fieldType:ValueType) => Pair(Memory(t), fieldName):HasField(Memory(fieldType)) { 42 | function getField(x : Pair(Memory(T), fieldName)) -> fieldType { 43 | // TODO: define this function... 44 | let x : Proxy(prevTypes) = Proxy; 45 | let sz : Word = getMemorySize(x); 46 | let ret : fieldType = ValueType.abs(0); 47 | assembly { 48 | ret := mload(add(rep(fst(x)), sz)) 49 | }; 50 | return ret; 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1644229661, 6 | "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "foundry": { 19 | "inputs": { 20 | "flake-utils": "flake-utils", 21 | "nixpkgs": "nixpkgs" 22 | }, 23 | "locked": { 24 | "lastModified": 1748337024, 25 | "narHash": "sha256-CI16Q5nNADLbuiESN8MtqS2ae+C2B/cfCJm1IWZ++qU=", 26 | "owner": "shazow", 27 | "repo": "foundry.nix", 28 | "rev": "521c1ae4e795d7b84d03628fcd9d8aa5553925a7", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "shazow", 33 | "ref": "stable", 34 | "repo": "foundry.nix", 35 | "type": "github" 36 | } 37 | }, 38 | "nixpkgs": { 39 | "locked": { 40 | "lastModified": 1666753130, 41 | "narHash": "sha256-Wff1dGPFSneXJLI2c0kkdWTgxnQ416KE6X4KnFkgPYQ=", 42 | "owner": "NixOS", 43 | "repo": "nixpkgs", 44 | "rev": "f540aeda6f677354f1e7144ab04352f61aaa0118", 45 | "type": "github" 46 | }, 47 | "original": { 48 | "id": "nixpkgs", 49 | "type": "indirect" 50 | } 51 | }, 52 | "nixpkgs_2": { 53 | "locked": { 54 | "lastModified": 1715774670, 55 | "narHash": "sha256-iJYnKMtLi5u6hZhJm94cRNSDG5Rz6ZzIkGbhPFtDRm0=", 56 | "owner": "nixos", 57 | "repo": "nixpkgs", 58 | "rev": "b3fcfcfabd01b947a1e4f36622bbffa3985bdac6", 59 | "type": "github" 60 | }, 61 | "original": { 62 | "owner": "nixos", 63 | "ref": "nixpkgs-unstable", 64 | "repo": "nixpkgs", 65 | "type": "github" 66 | } 67 | }, 68 | "root": { 69 | "inputs": { 70 | "foundry": "foundry", 71 | "nixpkgs": "nixpkgs_2" 72 | } 73 | } 74 | }, 75 | "root": "root", 76 | "version": 7 77 | } 78 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "sol-core"; 3 | 4 | inputs = { 5 | # Nix Inputs 6 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 7 | foundry.url = "github:shazow/foundry.nix/stable"; 8 | }; 9 | 10 | outputs = { 11 | self, 12 | nixpkgs, 13 | foundry, 14 | }: 15 | let 16 | forAllSystems = function: 17 | nixpkgs.lib.genAttrs [ 18 | "x86_64-linux" 19 | "aarch64-linux" 20 | "x86_64-darwin" 21 | "aarch64-darwin" 22 | ] (system: function rec { 23 | inherit system; 24 | compilerVersion = "ghc982"; 25 | pkgs = import nixpkgs { 26 | inherit system; 27 | overlays = [ foundry.overlay ]; 28 | }; 29 | hsPkgs = pkgs.haskell.packages.${compilerVersion}.override { 30 | overrides = hfinal: hprev: { 31 | sol-core = hfinal.callCabal2nix "sol-core" ./. {}; 32 | }; 33 | }; 34 | }); 35 | in 36 | { 37 | # nix fmt 38 | formatter = forAllSystems ({pkgs, ...}: pkgs.alejandra); 39 | 40 | # nix develop 41 | devShell = forAllSystems ({hsPkgs, pkgs, ...}: 42 | hsPkgs.shellFor { 43 | # withHoogle = true; 44 | packages = p: [ 45 | p.sol-core 46 | ]; 47 | buildInputs = with pkgs; 48 | [ 49 | hsPkgs.haskell-language-server 50 | haskellPackages.cabal-install 51 | haskellPackages.alex 52 | haskellPackages.happy 53 | cabal2nix 54 | haskellPackages.ghcid 55 | haskellPackages.fourmolu 56 | haskellPackages.cabal-fmt 57 | foundry-bin 58 | ] 59 | ++ (builtins.attrValues (import ./scripts.nix {s = pkgs.writeShellScriptBin;})); 60 | }); 61 | 62 | # nix build 63 | packages = forAllSystems ({hsPkgs, ...}: { 64 | sol-core = hsPkgs.sol-core; 65 | default = hsPkgs.sol-core; 66 | }); 67 | 68 | # You can't build the sol-core package as a check because of IFD in cabal2nix 69 | checks = {}; 70 | 71 | # nix run 72 | apps = forAllSystems ({system, ...}: { 73 | sol-core = { 74 | type = "app"; 75 | program = "${self.packages.${system}.sol-core}/bin/sol-core"; 76 | }; 77 | default = self.apps.${system}.sol-core; 78 | }); 79 | }; 80 | } 81 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./src" 4 | component: "lib:sol-core" 5 | - path: "./test" 6 | component: "test:sol-core-tests" 7 | - path: "./app" 8 | component: "exe:sol-core" 9 | -------------------------------------------------------------------------------- /lib/stdlib.sol: -------------------------------------------------------------------------------- 1 | // SPDX-License-Identifier: MIT 2 | pragma solidity >=0.6.2 <0.9.0; 3 | import {console} from "lib/console.sol"; 4 | 5 | abstract contract Script { 6 | bool public IS_SCRIPT = true; 7 | } 8 | -------------------------------------------------------------------------------- /runsol.sh: -------------------------------------------------------------------------------- 1 | file=$1 2 | shift 3 | echo $file 4 | cabal run sol-core -- -f $file $* && 5 | cabal run yule -- output.core && 6 | forge script Output.sol 7 | -------------------------------------------------------------------------------- /scripts.nix: -------------------------------------------------------------------------------- 1 | {s}: 2 | { 3 | ghcidScript = s "dev" "ghcid --command 'cabal new-repl lib:sol-core' --allow-eval --warnings"; 4 | testScript = s "test" "cabal run test:sol-core-tests"; 5 | hoogleScript = s "hgl" "hoogle serve"; 6 | } 7 | -------------------------------------------------------------------------------- /sol-core.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.4 2 | 3 | name: sol-core 4 | version: 0.0.0.0 5 | -- synopsis: $synopsis 6 | -- description: $description 7 | -- category: $category 8 | -- homepage: $gitrepo#readme 9 | -- bug-reports: $gitrepo/issues 10 | -- maintainer: $maintainer 11 | build-type: Simple 12 | 13 | -- source-repository head 14 | -- type: git 15 | -- location: $gitrepo 16 | 17 | common common-opts 18 | 19 | build-depends: 20 | base >= 4.19.0.0 21 | , mtl 22 | , containers 23 | , algebraic-graphs 24 | , filepath 25 | , array 26 | , pretty 27 | , optparse-applicative 28 | , syb 29 | , megaparsec >= 9.6 30 | , parser-combinators >= 1.3 31 | , time 32 | , timeit 33 | 34 | build-tool-depends: happy:happy, alex:alex 35 | 36 | default-language: Haskell2010 37 | default-extensions: OverloadedStrings 38 | FlexibleInstances 39 | FlexibleContexts 40 | PatternSynonyms 41 | TupleSections 42 | TypeFamilies 43 | BlockArguments 44 | DeriveDataTypeable 45 | ImportQualifiedPost 46 | ScopedTypeVariables 47 | TypeApplications 48 | 49 | library 50 | import: common-opts 51 | 52 | -- cabal-fmt: expand src 53 | exposed-modules: 54 | Solcore.Desugarer.IndirectCall 55 | Solcore.Desugarer.LambdaLifting 56 | Solcore.Desugarer.MatchCompiler 57 | Solcore.Desugarer.ReplaceWildcard 58 | Solcore.Desugarer.Specialise 59 | Solcore.Desugarer.EmitCore 60 | Solcore.Desugarer.UniqueTypeGen 61 | Solcore.Frontend.Lexer.SolcoreLexer 62 | Solcore.Frontend.Lexer.SolverInputLexer 63 | Solcore.Frontend.Parser.SolcoreParser 64 | Solcore.Frontend.Parser.SolverInputParser 65 | Solcore.Frontend.Pretty.SolcorePretty 66 | Solcore.Frontend.Pretty.Name 67 | Solcore.Frontend.Pretty.ShortName 68 | Solcore.Frontend.Syntax 69 | Solcore.Frontend.Syntax.ElabTree 70 | Solcore.Frontend.Syntax.Ty 71 | Solcore.Frontend.Syntax.Contract 72 | Solcore.Frontend.Syntax.Name 73 | Solcore.Frontend.Syntax.Stmt 74 | Solcore.Frontend.Syntax.SyntaxTree 75 | Solcore.Frontend.TypeInference.Erase 76 | Solcore.Frontend.TypeInference.Id 77 | Solcore.Frontend.TypeInference.InvokeGen 78 | Solcore.Frontend.TypeInference.NameSupply 79 | Solcore.Frontend.TypeInference.SccAnalysis 80 | Solcore.Frontend.TypeInference.TcContract 81 | Solcore.Frontend.TypeInference.TcEnv 82 | Solcore.Frontend.TypeInference.TcMonad 83 | Solcore.Frontend.TypeInference.TcReduce 84 | Solcore.Frontend.TypeInference.TcSat 85 | Solcore.Frontend.TypeInference.TcStmt 86 | Solcore.Frontend.TypeInference.TcSubst 87 | Solcore.Frontend.TypeInference.TcUnify 88 | Solcore.Pipeline.Options 89 | Solcore.Pipeline.SolcorePipeline 90 | Solcore.Pipeline.SolverPipeline 91 | Solcore.Primitives.Primitives 92 | Language.Core 93 | Language.Core.Parser 94 | Language.Core.Types 95 | Language.Yul 96 | Language.Yul.Parser 97 | Common.LightYear 98 | Common.Monad 99 | Common.Pretty 100 | Common.RIO 101 | hs-source-dirs: 102 | src 103 | ghc-options: 104 | -O1 105 | 106 | executable sol-core 107 | import: common-opts 108 | main-is: Main.hs 109 | hs-source-dirs: 110 | app 111 | build-depends: sol-core 112 | build-tool-depends: alex:alex, happy:happy 113 | ghc-options: 114 | -O1 115 | -- program-default-options 116 | -- happy-options: --debug -gcai 117 | 118 | executable solver 119 | import: common-opts 120 | main-is: Solver.hs 121 | hs-source-dirs: 122 | app 123 | build-depends: sol-core 124 | build-tool-depends: alex:alex, happy:happy 125 | 126 | executable yule 127 | import: common-opts 128 | main-is: Main.hs 129 | hs-source-dirs: yule 130 | default-extensions: 131 | LambdaCase 132 | PatternSynonyms 133 | BlockArguments 134 | ImportQualifiedPost 135 | other-modules: Locus, Options, TM, Translate, Builtins, Compress 136 | build-depends: base ^>=4.19.1.0, 137 | pretty >= 1.1, 138 | containers >= 0.6, 139 | mtl >= 2.3, 140 | megaparsec >= 9.6, 141 | parser-combinators >= 1.3, 142 | optparse-applicative >= 0.18, 143 | sol-core 144 | 145 | test-suite sol-core-tests 146 | import: common-opts 147 | type: exitcode-stdio-1.0 148 | hs-source-dirs: test 149 | 150 | ghc-options: 151 | -Wall -threaded -rtsopts -with-rtsopts=-N -fdefer-typed-holes -O0 152 | 153 | main-is: Main.hs 154 | 155 | -- cabal-fmt: expand test -Main 156 | other-modules: 157 | Cases 158 | Solver 159 | 160 | build-depends: 161 | , sol-core 162 | , tasty 163 | , tasty-program 164 | , tasty-expected-failure 165 | , tasty-hunit 166 | , HUnit 167 | 168 | build-tool-depends: sol-core:sol-core, sol-core:yule 169 | -------------------------------------------------------------------------------- /spec/generic.md: -------------------------------------------------------------------------------- 1 | Generic representation of data types 2 | ------------------------------------ 3 | 4 | Following the paper 5 | 6 | 7 | -------------------------------------------------------------------------------- /spec/makefile: -------------------------------------------------------------------------------- 1 | default: pdf 2 | 3 | pdf: 4 | pdflatex new-solidity-spec.tex 5 | pdflatex new-solidity-spec.tex 6 | bibtex new-solidity-spec 7 | pdflatex new-solidity-spec.tex 8 | -------------------------------------------------------------------------------- /src/Common/LightYear.hs: -------------------------------------------------------------------------------- 1 | module Common.LightYear 2 | ( module Text.Megaparsec 3 | , module Text.Megaparsec.Char 4 | , Parser 5 | , runMyParser 6 | , runParserE 7 | , runParserM 8 | ) where 9 | import Control.Monad.Error.Class 10 | import Text.Megaparsec 11 | import Text.Megaparsec.Char 12 | -- import Text.Megaparsec.Char.Lexer qualified as Lexer 13 | import Data.Void 14 | 15 | type Parser = Parsec Void String 16 | 17 | runMyParser :: String -> Parser a -> String -> a 18 | runMyParser name p = runMyParser' p name 19 | 20 | runMyParser' :: Parser a -> String -> String -> a 21 | runMyParser' p filename input = 22 | case parse p filename input of 23 | Left e -> error (errorBundlePretty e) 24 | Right x -> x 25 | 26 | runParserE :: Parser a -> String -> String -> Either String a 27 | runParserE = runParserM 28 | 29 | runParserM :: MonadError String m => Parser a -> String -> String -> m a 30 | runParserM p filename input = 31 | case parse p filename input of 32 | Left e -> throwError (errorBundlePretty e) 33 | Right x -> return x 34 | 35 | -------------------------------------------------------------------------------- /src/Common/Monad.hs: -------------------------------------------------------------------------------- 1 | module Common.Monad where 2 | import Control.Monad 3 | import Control.Monad.IO.Class ( MonadIO(..) ) 4 | import GHC.Stack ( HasCallStack ) 5 | import System.Exit ( exitFailure ) 6 | 7 | 8 | writeln :: MonadIO m => String -> m () 9 | writeln = liftIO . putStrLn 10 | 11 | writes :: MonadIO m => [String] -> m () 12 | writes = writeln . concat 13 | 14 | errors :: HasCallStack => [String] -> a 15 | errors = error . concat 16 | 17 | panics :: MonadIO m => [String] -> m a 18 | panics msgs = do 19 | liftIO $ putStrLn $ concat ("PANIC: ":msgs) 20 | liftIO exitFailure 21 | 22 | nopanics :: MonadIO m => [String] -> m a 23 | nopanics msgs = do 24 | liftIO $ putStrLn $ concat msgs 25 | liftIO exitFailure 26 | 27 | warns :: MonadIO m => [String] -> m () 28 | warns = writes 29 | -------------------------------------------------------------------------------- /src/Common/NameSupply.hs: -------------------------------------------------------------------------------- 1 | module Common.NameSupply(NS, namePool, split, deplete) where 2 | 3 | addNumbers :: [String] -> [Integer] -> [String] 4 | addNumbers names numbers = do 5 | number <- numbers 6 | name <- names 7 | return $ name ++ show number 8 | 9 | namePool :: [String] 10 | namePool = names ++ addNumbers names [1..] where 11 | names = ["a","b","c","d","t","u"] 12 | 13 | type NS = [String] 14 | 15 | deplete :: NS -> (String,NS) 16 | deplete (x:xs) = (x,xs) 17 | 18 | split :: NS -> (NS,NS) 19 | split (x:y:zs) = (x:xs,y:ys) where (xs,ys) = split zs 20 | 21 | test1 = take 10 namePool 22 | test2 = take 10 $ fst (split namePool) 23 | test3 = fst (deplete ns) where ns = snd (deplete namePool) 24 | 25 | -------------------------------------------------------------------------------- /src/Common/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Common.Pretty 2 | ( Pretty(..) 3 | , module Text.PrettyPrint 4 | , (><) -- to avoid hiding Prelude (<>) 5 | , dotSep 6 | , commaSep, commaSepList 7 | , angles 8 | ) where 9 | import Text.PrettyPrint hiding((<>)) 10 | import Text.PrettyPrint qualified as PP 11 | 12 | -- in Prelude (<>) is defined as infixr 6 13 | -- in pretty, it is defined as infixl 6 14 | -- Prelude infixr 6 <> cannot mix with infixl 6 <+> 15 | -- Hence to avoid hiding Prelude (<>) define (><) 16 | infixl 6 >< 17 | (><) :: Doc -> Doc -> Doc 18 | (><) = (PP.<>) 19 | 20 | class Pretty a where 21 | ppr :: a -> Doc 22 | 23 | dotSep :: [Doc] -> Doc 24 | dotSep = hcat . punctuate dot 25 | where 26 | dot = text "." 27 | 28 | commaSep :: [Doc] -> Doc 29 | commaSep = hsep . punctuate comma 30 | 31 | commaSepList :: Pretty a => [a] -> Doc 32 | commaSepList = hsep . punctuate comma . map ppr 33 | 34 | angles :: Doc -> Doc 35 | angles d = char '<' >< d >< char '>' 36 | -------------------------------------------------------------------------------- /src/Common/RIO.hs: -------------------------------------------------------------------------------- 1 | module Common.RIO( 2 | RIO, 3 | runRIO, 4 | writeln, 5 | load, 6 | store, 7 | update, 8 | module Control.Monad.Reader, 9 | module Data.IORef 10 | ) where 11 | import Common.Monad 12 | import Control.Monad.Reader 13 | import Data.IORef 14 | 15 | type RIO env a = ReaderT env IO a 16 | -- instance MonadIO RIO 17 | 18 | -- load :: MonadIO m => IORef a -> m a 19 | load :: IORef a -> RIO env a 20 | load = liftIO . readIORef 21 | 22 | -- store :: MonadIO m =>IORef a -> a -> m () 23 | store :: IORef a -> a -> RIO env () 24 | store r v = liftIO $ writeIORef r v 25 | 26 | -- update :: MonadIO m => IORef a -> (a->a) -> m () 27 | update :: IORef a -> (a->a) -> RIO env () 28 | update f = liftIO . modifyIORef f 29 | 30 | runRIO :: RIO env a -> env -> IO a 31 | runRIO m env = runReaderT m env 32 | -------------------------------------------------------------------------------- /src/Language/Core.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# OPTIONS_GHC -Wincomplete-patterns #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | module Language.Core 5 | ( Expr(..), Stmt(..), Arg(..), Alt(..), pattern ConAlt, Pat(..), Con(..), Contract(..), Core(..) 6 | , module Language.Core.Types 7 | , pattern SAV 8 | , Name 9 | ) where 10 | 11 | import Common.Pretty 12 | import Language.Core.Types 13 | import Language.Yul 14 | 15 | 16 | type Name = String 17 | 18 | data Expr 19 | = EWord Integer 20 | | EBool Bool 21 | | EVar Name 22 | | EPair Expr Expr 23 | | EFst Expr 24 | | ESnd Expr 25 | | EInl Type Expr 26 | | EInr Type Expr 27 | | EInK Int Type Expr 28 | | ECall Name [Expr] 29 | | EUnit 30 | instance Show Expr where 31 | show = render . ppr 32 | 33 | pattern SAV :: Name -> Expr -> Stmt 34 | pattern SAV x e = SAssign (EVar x) e 35 | data Stmt 36 | = SAssign Expr Expr 37 | | SAlloc Name Type 38 | | SExpr Expr 39 | | SAssembly [YulStmt] 40 | | SReturn Expr 41 | | SComment String 42 | | SBlock [Stmt] 43 | -- | SMatch Expr [Alt] 44 | | SMatch Type Expr [Alt] 45 | | SFunction Name [Arg] Type [Stmt] 46 | | SRevert String 47 | -- deriving Show 48 | 49 | data Arg = TArg Name Type 50 | instance Show Arg where show = render . ppr 51 | instance Show Stmt where show :: Stmt -> String 52 | show = render . ppr 53 | 54 | data Alt = Alt Pat Name Stmt deriving Show 55 | pattern ConAlt :: Con -> Name -> Stmt -> Alt 56 | pattern ConAlt c n s = Alt (PCon c) n s 57 | 58 | data Pat = PVar Name | PCon Con | PWildcard | PIntLit Integer 59 | deriving Show 60 | data Con = CInl | CInr | CInK Int deriving Show 61 | 62 | data Contract = Contract { ccName :: Name, ccStmts :: [Stmt] } 63 | 64 | newtype Core = Core [Stmt] 65 | instance Show Core where show = render . ppr 66 | instance Show Contract where show = render . ppr 67 | 68 | instance Pretty Contract where 69 | ppr (Contract n stmts) = text "contract" <+> text n <+> lbrace $$ nest 4 (vcat (map ppr stmts)) $$ rbrace 70 | 71 | instance Pretty Type where 72 | ppr TWord = text "word" 73 | ppr TBool = text "bool" 74 | ppr TUnit = text "unit" 75 | ppr (TPair t1 t2) = parens (ppr t1 <+> text "*" <+> ppr t2) 76 | ppr (TSum t1 t2) = parens (ppr t1 <+> text "+" <+> ppr t2) 77 | ppr (TSumN ts) = text "sum" >< parens(commaSepList ts) 78 | ppr (TFun ts t) = parens (hsep (map ppr ts) <+> text "->" <+> ppr t) 79 | ppr (TNamed n t) = text n >< braces(ppr t) 80 | 81 | instance Pretty Expr where 82 | ppr (EWord i) = text (show i) 83 | ppr (EBool b) = text (show b) 84 | ppr EUnit = text "()" 85 | ppr (EVar x) = text x 86 | ppr (EPair e1 e2) = parens (ppr e1 >< comma <+> ppr e2) 87 | ppr (EFst e) = text "fst" >< parens (ppr e) 88 | ppr (ESnd e) = text "snd" >< parens (ppr e) 89 | ppr (EInl t e) = text "inl" >< angles (ppr t) >< parens (ppr e) 90 | ppr (EInr t e) = text "inr" >< angles (ppr t) >< parens (ppr e) 91 | ppr (EInK k t e) = text "in" >< parens(int k) >< angles (ppr t) >< parens (ppr e) 92 | ppr (ECall f es) = text f >< parens(commaSepList es) 93 | 94 | instance Pretty Stmt where 95 | ppr (SAssign lhs rhs) = ppr lhs <+> text ":=" <+> ppr rhs 96 | ppr (SAlloc x t) = text "let" <+> text x <+> text ":" <+> ppr t 97 | ppr (SExpr e) = ppr e 98 | ppr (SAssembly yul) = text "assembly" <+> lbrace 99 | $$ nest 2 (vcat (map ppr yul)) 100 | $$ rbrace 101 | ppr (SReturn e) = text "return" <+> ppr e 102 | ppr (SComment c) = text "//" <+> text c 103 | ppr (SBlock stmts) = lbrace $$ nest 2 (vcat (map ppr stmts)) $$ rbrace 104 | {- 105 | ppr (SMatch e alts) = 106 | text "match" <+> ppr e <+> text "with" 107 | <+> lbrace $$ nest 2 (vcat $ map ppr alts) $$ rbrace 108 | -} 109 | ppr (SMatch t e alts) = 110 | text "match" >< angles (ppr t) <+> ppr e <+> text "with" 111 | <+> lbrace $$ nest 2 (vcat $ map ppr alts) $$ rbrace 112 | ppr (SFunction f args ret stmts) = 113 | text "function" <+> text f 114 | <+> parens (hsep (punctuate comma (map ppr args))) 115 | <+> text "->" <+> ppr ret 116 | <+> lbrace $$ nest 2 (vcat (map ppr stmts)) $$ rbrace 117 | ppr (SRevert s) = text "revert" <+> text (show s) 118 | 119 | instance Pretty Pat where 120 | ppr (PVar x) = text x 121 | ppr (PCon c) = ppr c 122 | ppr PWildcard = text "_" 123 | ppr (PIntLit i) = integer i 124 | 125 | instance Pretty Alt where 126 | ppr (Alt c n s) = ppr c <+> text n <+> text "=>" <+> ppr s 127 | 128 | instance Pretty Con where 129 | ppr CInl = text "inl" 130 | ppr CInr = text "inr" 131 | ppr (CInK k) = text "in" <+> parens (int k) 132 | 133 | instance Pretty Arg where 134 | ppr (TArg n t) = text n <+> text ":" <+> ppr t 135 | 136 | instance Pretty Core where 137 | ppr (Core stmts) = vcat (map ppr stmts) 138 | 139 | 140 | instance Pretty [Stmt] where 141 | ppr stmts = vcat (map ppr stmts) 142 | -------------------------------------------------------------------------------- /src/Language/Core/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Core.Parser where 2 | import Language.Core 3 | ( Core(..), Contract(..), 4 | Alt(..), 5 | Pat(..), 6 | pattern ConAlt, 7 | Arg(..), 8 | Con(..), 9 | Stmt(SExpr, SAlloc, SReturn, SBlock, SMatch, 10 | SFunction, SAssign, SAssembly, SRevert), 11 | Expr(..), 12 | Type(..) ) 13 | import Common.LightYear 14 | import Text.Megaparsec.Char.Lexer qualified as L 15 | import Control.Monad.Combinators.Expr 16 | import Language.Yul.Parser(parseYul, yulBlock) 17 | 18 | parseCore :: String -> Core 19 | parseCore = runMyParser "core" coreProgram 20 | 21 | parseContract :: String -> String -> Contract 22 | parseContract filename = runMyParser filename coreContract 23 | 24 | -- Note: this module repeats some definitions from YulParser.Name 25 | -- This is intentional as we may want to make different syntax choices 26 | 27 | sc :: Parser () 28 | sc = L.space space1 29 | (L.skipLineComment "//") 30 | (L.skipBlockComment "/*" "*/") 31 | 32 | lexeme :: Parser a -> Parser a 33 | lexeme = L.lexeme sc 34 | 35 | symbol :: String -> Parser String 36 | symbol = L.symbol sc 37 | 38 | startIdentChar :: Parser Char 39 | startIdentChar = letterChar <|> char '_' <|> char '$' 40 | 41 | identChar :: Parser Char 42 | identChar = alphaNumChar <|> char '_' <|> char '$' 43 | 44 | identifier :: Parser String 45 | identifier = lexeme ((:) <$> startIdentChar <*> many identChar) 46 | 47 | integer :: Parser Integer 48 | integer = lexeme L.decimal 49 | 50 | int :: Parser Int 51 | int = fromInteger <$> integer 52 | 53 | stringLiteral :: Parser String 54 | stringLiteral = lexeme (char '"' *> manyTill L.charLiteral (char '"')) 55 | 56 | parens :: Parser a -> Parser a 57 | parens = between (symbol "(") (symbol ")") 58 | 59 | braces :: Parser a -> Parser a 60 | braces = between (symbol "{") (symbol "}") 61 | 62 | angles :: Parser a -> Parser a 63 | angles = between (symbol "<") (symbol ">") 64 | 65 | commaSep :: Parser a -> Parser [a] 66 | commaSep p = p `sepBy` symbol "," 67 | 68 | pKeyword :: String -> Parser String 69 | pKeyword w = try $ lexeme (string w <* notFollowedBy identChar) 70 | 71 | pPrimaryType :: Parser Type 72 | pPrimaryType = choice 73 | [ TWord <$ pKeyword "word" 74 | , TBool <$ pKeyword "bool" 75 | , TUnit <$ pKeyword "unit" 76 | , TSumN <$> ( pKeyword "sum" *> parens (commaSep coreType)) 77 | , parens coreType 78 | , TNamed <$> identifier <*> braces coreType 79 | ] 80 | 81 | coreType :: Parser Type 82 | coreType = makeExprParser pPrimaryType coreTypeTable 83 | 84 | coreTypeTable :: [[Operator Parser Type]] 85 | coreTypeTable = [[InfixR (TPair <$ symbol "*")] 86 | ,[InfixR (TSum <$ symbol "+")]] 87 | 88 | pPrimaryExpr :: Parser Expr 89 | pPrimaryExpr = choice 90 | [ EWord <$> integer 91 | , EBool True <$ pKeyword "true" 92 | , EBool False <$ pKeyword "false" 93 | , pTuple 94 | , try (ECall <$> identifier <*> parens (commaSep coreExpr)) 95 | , EVar <$> (identifier <* notFollowedBy (symbol "(")) 96 | ] 97 | 98 | pTuple :: Parser Expr 99 | pTuple = go <$> parens (commaSep coreExpr) where 100 | go [] = EUnit 101 | go [e] = e 102 | go [e1, e2] = EPair e1 e2 103 | go (e:es) = EPair e (go es) 104 | 105 | 106 | coreExpr :: Parser Expr 107 | coreExpr = choice 108 | [ pKeyword "inl" *> (EInl <$> angles coreType <*> pPrimaryExpr) 109 | , pKeyword "inr" *> (EInr <$> angles coreType <*> pPrimaryExpr) 110 | , pKeyword "in" *> (EInK <$> parens int <*> coreType <*> pPrimaryExpr) 111 | , pKeyword "fst" *> (EFst <$> pPrimaryExpr) 112 | , pKeyword "snd" *> (ESnd <$> pPrimaryExpr) 113 | , pPrimaryExpr 114 | ] 115 | 116 | coreStmt :: Parser Stmt 117 | coreStmt = choice 118 | [ SAlloc <$> (pKeyword "let" *> identifier) <*> (symbol ":" *> coreType) 119 | , SReturn <$> (pKeyword "return" *> coreExpr) 120 | , SBlock <$> braces(many coreStmt) 121 | , SMatch <$> (pKeyword "match" *> angles coreType) <*> (coreExpr <* pKeyword "with") <*> braces(many coreAlt) 122 | -- , SMatch <$> (pKeyword "match" *> coreExpr <* pKeyword "with") <*> (symbol "{" *> many coreAlt <* symbol "}") 123 | , SFunction <$> (pKeyword "function" *> identifier) <*> (parens (commaSep coreArg)) <*> (symbol "->" *> coreType) 124 | <*> (symbol "{" *> many coreStmt <* symbol "}") 125 | , SAssembly <$> (pKeyword "assembly" *> yulBlock) 126 | , SRevert <$> (pKeyword "revert" *> stringLiteral) 127 | , try (SAssign <$> (coreExpr <* symbol ":=") <*> coreExpr) 128 | , SExpr <$> coreExpr 129 | ] 130 | 131 | coreArg :: Parser Arg 132 | coreArg = TArg <$> identifier <*> (symbol ":" *> coreType) 133 | 134 | coreAlt :: Parser Alt 135 | coreAlt = Alt <$> corePat <*> identifier <* symbol "=>" <*> coreStmt 136 | 137 | corePat :: Parser Pat 138 | corePat = choice 139 | [ PIntLit <$> integer 140 | , PCon CInl <$ pKeyword "inl" 141 | , PCon CInr <$ pKeyword "inr" 142 | , pKeyword "in" >> PCon . CInK <$> parens int 143 | , PVar <$> identifier 144 | , PWildcard <$ pKeyword "_" 145 | ] 146 | 147 | coreProgram :: Parser Core 148 | coreProgram = sc *> (Core <$> many coreStmt) <* eof 149 | 150 | coreContract :: Parser Contract 151 | coreContract = sc *> (Contract <$> (pKeyword "contract" *> identifier ) 152 | <*> braces (many coreStmt)) <* eof 153 | -------------------------------------------------------------------------------- /src/Language/Core/Types.hs: -------------------------------------------------------------------------------- 1 | module Language.Core.Types where 2 | 3 | data Type 4 | = TWord 5 | | TBool 6 | | TPair Type Type -- binary product, e.g. (word * word) 7 | | TSum Type Type -- binary sum, e.g. (unit + word) 8 | | TSumN [Type] -- n-ary sum 9 | | TFun [Type] Type 10 | | TUnit 11 | | TNamed String Type -- named type, e.g. Option{unit + word} 12 | deriving (Show) 13 | 14 | stripTypeName :: Type -> Type 15 | stripTypeName (TNamed _ t) = stripTypeName t 16 | stripTypeName t = t 17 | 18 | zeroSizedType :: Type -> Bool 19 | zeroSizedType TUnit = True 20 | zeroSizedType (TNamed _ t) = zeroSizedType t 21 | zeroSizedType (TPair t1 t2) = zeroSizedType t1 && zeroSizedType t2 22 | zeroSizedType _ = False 23 | -------------------------------------------------------------------------------- /src/Language/Yul.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | module Language.Yul where 3 | import Data.Generics (Data, Typeable) 4 | 5 | import Common.Pretty 6 | import Solcore.Frontend.Syntax.Name 7 | 8 | import Solcore.Frontend.Pretty.Name 9 | 10 | 11 | newtype Yul = Yul { yulStmts :: [YulStmt] } 12 | instance Show Yul where show = render . ppr 13 | instance Show YulStmt where show = render . ppr 14 | instance Show YulExp where show = render . ppr 15 | instance Show YLiteral where show = render . ppr 16 | 17 | instance Semigroup Yul where 18 | Yul a <> Yul b = Yul (a <> b) 19 | 20 | instance Monoid Yul where 21 | mempty = Yul [] 22 | 23 | type YArg = Name 24 | type YReturns = Maybe [Name] 25 | pattern YNoReturn :: Maybe a 26 | pattern YNoReturn = Nothing 27 | pattern YReturns :: a -> Maybe a 28 | pattern YReturns a = Just a 29 | pattern YulAlloc :: Name -> YulStmt 30 | pattern YulAlloc name = YLet [name] Nothing 31 | pattern YAssign1 :: Name -> YulExp -> YulStmt 32 | pattern YAssign1 name expr = YAssign [name] expr 33 | 34 | type YulCases = [YulCase] 35 | type YulCase = (YLiteral, YulBlock) 36 | type YulDefault = Maybe YulBlock 37 | type YulBlock = [YulStmt] 38 | 39 | 40 | data YulStmt 41 | = YBlock YulBlock 42 | | YFun Name [YArg] YReturns [YulStmt] 43 | | YLet [Name] (Maybe YulExp) 44 | | YAssign [Name] YulExp 45 | | YIf YulExp YulBlock 46 | | YSwitch YulExp YulCases YulDefault 47 | | YFor YulBlock YulExp YulBlock YulBlock 48 | | YBreak 49 | | YContinue 50 | | YLeave 51 | | YComment String 52 | | YExp YulExp 53 | deriving (Eq, Ord, Data, Typeable) 54 | 55 | data YulExp 56 | = YCall Name [YulExp] 57 | | YIdent Name 58 | | YLit YLiteral 59 | deriving (Eq, Ord, Data, Typeable) 60 | 61 | data YLiteral 62 | = YulNumber Integer 63 | | YulString String 64 | | YulTrue 65 | | YulFalse 66 | deriving (Eq, Ord, Data, Typeable) 67 | 68 | yulInt :: Integral i => i -> YulExp 69 | yulInt = YLit . YulNumber . fromIntegral 70 | 71 | yulBool :: Bool -> YulExp 72 | yulBool True = YLit YulTrue 73 | yulBool False = YLit YulFalse 74 | 75 | instance Pretty Yul where 76 | ppr (Yul stmts) = vcat (map ppr stmts) 77 | 78 | instance Pretty YulStmt where 79 | ppr (YBlock stmts) = 80 | lbrace 81 | $$ nest 4 (vcat (map ppr stmts)) 82 | $$ rbrace 83 | ppr (YFun name args rets stmts) = 84 | text "function" 85 | <+> ppr name 86 | <+> prettyargs 87 | <+> prettyrets rets 88 | <+> lbrace 89 | $$ nest 4 (vcat (map ppr stmts)) 90 | $$ rbrace 91 | where 92 | prettyargs = parens (commaSepList args) 93 | prettyrets Nothing = empty 94 | prettyrets (Just rs) = text "->" <+> commaSepList rs 95 | ppr (YLet vars expr) = 96 | text "let" <+> commaSepList vars 97 | <+> maybe empty (\e -> text ":=" <+> ppr e) expr 98 | ppr (YAssign vars expr) = commaSepList vars <+> text ":=" <+> ppr expr 99 | ppr (YIf cond stmts) = text "if" <+> parens (ppr cond) <+> ppr (YBlock stmts) 100 | ppr (YSwitch expr cases def) = 101 | text "switch" 102 | <+> ppr expr 103 | $$ nest 4 (vcat (map (\(lit, stmts) -> text "case" <+> ppr lit <+> ppr (YBlock stmts)) cases)) 104 | $$ maybe empty (\stmts -> text "default" <+> ppr (YBlock stmts)) def 105 | ppr (YFor pre cond post stmts) = 106 | text "for" <+> braces (hsep (map ppr pre)) 107 | <+> ppr cond 108 | <+> hsep (map ppr post) <+> ppr (YBlock stmts) 109 | ppr YBreak = text "break" 110 | ppr YContinue = text "continue" 111 | ppr YLeave = text "leave" 112 | ppr (YComment c) = text "/*" <+> text c <+> text "*/" 113 | ppr (YExp e) = ppr e 114 | 115 | instance Pretty YulExp where 116 | ppr :: YulExp -> Doc 117 | ppr (YCall name args) = ppr name >< parens (hsep (punctuate comma (map ppr args))) 118 | ppr (YIdent name) = ppr name 119 | ppr (YLit lit) = ppr lit 120 | 121 | instance Pretty YLiteral where 122 | ppr (YulNumber n) = integer n 123 | ppr (YulString s) = doubleQuotes (text s) 124 | ppr YulTrue = text "true" 125 | ppr YulFalse = text "false" 126 | 127 | -- commaSepList :: Pretty a => [a] -> Doc 128 | -- commaSepList = hsep . punctuate comma . map ppr 129 | 130 | {- | wrap a Yul chunk in a Solidity function with the given name 131 | assumes result is in a variable named "_result" 132 | -} 133 | wrapInSolFunction :: Pretty a => Name -> a -> Doc 134 | wrapInSolFunction name yul = text "function" <+> ppr name <+> prettyargs <+> text " public returns (uint256 _wrapresult)" <+> lbrace 135 | $$ nest 2 assembly 136 | $$ rbrace 137 | where 138 | assembly = text "assembly" <+> lbrace 139 | $$ nest 2 (ppr yul) 140 | $$ rbrace 141 | prettyargs = parens empty 142 | 143 | wrapInContract :: Name -> Name -> Doc -> Doc 144 | wrapInContract name entry body = empty 145 | $$ text "// SPDX-License-Identifier: UNLICENSED" 146 | $$ text "pragma solidity ^0.8.23;" 147 | $$ text "import {console,Script} from \"lib/stdlib.sol\";" 148 | $$ text "contract" <+> ppr name <+> text "is Script"<+> lbrace 149 | $$ nest 2 run 150 | $$ nest 2 body 151 | $$ rbrace 152 | 153 | where 154 | run = text "function run() public " <+> lbrace 155 | $$ nest 2 (text "console.log(\"RESULT --> \","<+> ppr entry >< text ");") 156 | $$ rbrace $$ text "" 157 | -------------------------------------------------------------------------------- /src/Language/Yul/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Yul.Parser(parseYul, yulBlock) where 2 | {- 3 | import Text.Megaparsec 4 | import Text.Megaparsec.Char 5 | import Data.Void 6 | -} 7 | import Common.LightYear 8 | import Text.Megaparsec.Char.Lexer qualified as L 9 | import Language.Yul 10 | import Solcore.Frontend.Syntax.Name(Name(..)) 11 | 12 | parseYul :: String -> Yul 13 | parseYul = runMyParser "yul" yulProgram 14 | 15 | sc :: Parser () 16 | sc = L.space space1 17 | (L.skipLineComment "//") 18 | (L.skipBlockComment "/*" "*/") 19 | 20 | lexeme :: Parser a -> Parser a 21 | lexeme = L.lexeme sc 22 | 23 | symbol :: String -> Parser String 24 | symbol = L.symbol sc 25 | 26 | startIdentChar :: Parser Char 27 | startIdentChar = letterChar <|> char '_' <|> char '$' 28 | 29 | identChar :: Parser Char 30 | identChar = alphaNumChar <|> char '_' <|> char '$' 31 | 32 | identifier :: Parser String 33 | identifier = lexeme ((:) <$> startIdentChar <*> many identChar) 34 | 35 | pName :: Parser Name 36 | pName = Name <$> identifier 37 | 38 | integer :: Parser Integer 39 | integer = lexeme L.decimal 40 | 41 | stringLiteral :: Parser String 42 | stringLiteral = char '"' *> manyTill L.charLiteral (char '"') 43 | 44 | parens :: Parser a -> Parser a 45 | parens = between (symbol "(") (symbol ")") 46 | 47 | commaSep :: Parser a -> Parser [a] 48 | commaSep p = p `sepBy` symbol "," 49 | 50 | pKeyword :: String -> Parser String 51 | pKeyword w = lexeme (string w <* notFollowedBy identChar) 52 | 53 | yulExpression :: Parser YulExp 54 | yulExpression = choice 55 | [ YLit <$> yulLiteral 56 | , try (YCall <$> pName<*> parens (commaSep yulExpression)) 57 | , YIdent <$> pName 58 | ] 59 | 60 | yulLiteral :: Parser YLiteral 61 | yulLiteral = choice 62 | [ YulNumber <$> integer 63 | , YulString <$> stringLiteral 64 | , YulTrue <$ pKeyword "true" 65 | , YulFalse <$ pKeyword "false" 66 | ] 67 | 68 | yulStmt :: Parser YulStmt 69 | yulStmt = choice 70 | [ YBlock <$> yulBlock 71 | , yulFun 72 | , YLet <$> (pKeyword "let" *> commaSep pName) <*> optional (symbol ":=" *> yulExpression) 73 | , YIf <$> (pKeyword "if" *> yulExpression) <*> yulBlock 74 | , YSwitch <$> 75 | (pKeyword "switch" *> yulExpression) <*> 76 | many yulCase <*> 77 | optional (pKeyword "default" *> yulBlock) 78 | , try (YAssign <$> commaSep pName <*> (symbol ":=" *> yulExpression)) 79 | , YExp <$> yulExpression 80 | ] 81 | 82 | yulBlock :: Parser [YulStmt] 83 | yulBlock = between (symbol "{") (symbol "}") (many yulStmt) 84 | 85 | yulCase :: Parser (YLiteral, [YulStmt]) 86 | yulCase = do 87 | _ <- pKeyword "case" 88 | lit <- yulLiteral 89 | stmts <- yulBlock 90 | return (lit, stmts) 91 | 92 | yulFun :: Parser YulStmt 93 | yulFun = do 94 | _ <- symbol "function" 95 | name <- pName 96 | args <- parens (commaSep pName) 97 | rets <- optional (symbol "->" *> commaSep pName) 98 | YFun name args rets <$> yulBlock 99 | 100 | yulProgram :: Parser Yul 101 | yulProgram = sc *> (Yul <$> many yulStmt) <* eof 102 | -------------------------------------------------------------------------------- /src/Solcore/Desugarer/IndirectCall.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Desugarer.IndirectCall where 2 | 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.State 6 | import qualified Data.Map as Map 7 | import Solcore.Desugarer.UniqueTypeGen (UniqueTyMap) 8 | import Solcore.Frontend.Pretty.SolcorePretty 9 | import Solcore.Frontend.Syntax 10 | import Solcore.Frontend.TypeInference.TcEnv (primCtx) 11 | import Solcore.Primitives.Primitives 12 | 13 | -- top level desugarer 14 | 15 | indirectCall :: CompUnit Name -> IO (CompUnit Name, [Name]) 16 | indirectCall cunit 17 | = (, fnames) <$> runIndirectM (desugar cunit) 18 | (Env (Map.keys primCtx ++ fnames)) 19 | where 20 | fnames = collect cunit 21 | 22 | -- type class for desugar indirect calls 23 | 24 | class Desugar a where 25 | desugar :: a -> IndirectM a 26 | 27 | instance Desugar a => Desugar [a] where 28 | desugar = mapM desugar 29 | 30 | instance Desugar a => Desugar (Maybe a) where 31 | desugar = mapM desugar 32 | 33 | instance Desugar (CompUnit Name) where 34 | desugar (CompUnit imps ds) = CompUnit imps <$> desugar ds 35 | 36 | instance Desugar (TopDecl Name) where 37 | desugar (TContr c) = TContr <$> desugar c 38 | desugar (TFunDef f) = TFunDef <$> desugar f 39 | desugar (TClassDef c) = pure $ TClassDef c 40 | desugar (TInstDef i) = TInstDef <$> desugar i 41 | desugar (TDataDef d) = pure $ TDataDef d 42 | desugar (TSym s) = pure $ TSym s 43 | desugar (TPragmaDecl d) = pure $ TPragmaDecl d 44 | desugar (TMutualDef ms) = TMutualDef <$> desugar ms 45 | 46 | instance Desugar (Contract Name) where 47 | desugar (Contract n vs ds) 48 | = Contract n vs <$> desugar ds 49 | 50 | instance Desugar (FunDef Name) where 51 | desugar (FunDef sig bdy) 52 | = FunDef sig <$> desugar bdy 53 | 54 | instance Desugar (ContractDecl Name) where 55 | desugar (CFieldDecl fd) 56 | = CFieldDecl <$> desugar fd 57 | desugar (CFunDecl fd) 58 | = CFunDecl <$> desugar fd 59 | desugar (CMutualDecl ds) 60 | = CMutualDecl <$> desugar ds 61 | desugar (CConstrDecl cd) 62 | = CConstrDecl <$> desugar cd 63 | desugar d = pure d 64 | 65 | instance Desugar (Field Name) where 66 | desugar (Field n t me) 67 | = Field n t <$> desugar me 68 | 69 | instance Desugar (Constructor Name) where 70 | desugar (Constructor ps bd) 71 | = Constructor ps <$> desugar bd 72 | 73 | instance Desugar (Stmt Name) where 74 | desugar (lhs := rhs) 75 | = (:=) <$> desugar lhs <*> desugar rhs 76 | desugar (Let n mt me) 77 | = Let n mt <$> desugar me 78 | desugar (StmtExp e) 79 | = StmtExp <$> desugar e 80 | desugar (Return e) 81 | = Return <$> desugar e 82 | desugar (Match es eqn) 83 | = Match <$> desugar es <*> desugar eqn 84 | desugar e@(Asm _) = pure e 85 | 86 | instance Desugar (Exp Name) where 87 | desugar (Con a es) 88 | = Con a <$> desugar es 89 | desugar (FieldAccess e f) 90 | = (flip FieldAccess f) <$> desugar e 91 | desugar (Lam ps bd t) 92 | = Lam ps <$> desugar bd <*> pure t 93 | desugar (TyExp e t) 94 | = flip TyExp t <$> desugar e 95 | desugar (Call m n es) 96 | = do 97 | m' <- desugar m 98 | es' <- desugar es 99 | b <- isDirectCall n 100 | let qn = QualName invokableName "invoke" 101 | args' = [Var n, indirectArgs es'] 102 | if b then 103 | pure $ Call m' n es' 104 | else 105 | pure $ Call Nothing qn args' 106 | desugar x = pure x 107 | 108 | instance Desugar (Equation Name) where 109 | desugar (ps, ss) = (ps,) <$> desugar ss 110 | 111 | instance Desugar (Instance Name) where 112 | desugar (Instance d ps n ts t fs) 113 | = Instance d ps n ts t <$> desugar fs 114 | 115 | -- building indirect function call arguments 116 | 117 | indirectArgs :: [Exp Name] -> Exp Name 118 | indirectArgs [] = Con (Name "()") [] 119 | indirectArgs [e] = e 120 | indirectArgs (e : es) = epair e (indirectArgs es) 121 | where 122 | epair e1 e2 = Con (Name "pair") [e1, e2] 123 | 124 | -- building the initial environment 125 | 126 | class Collect a where 127 | collect :: a -> [Name] 128 | 129 | instance Collect a => Collect [a] where 130 | collect = concatMap collect 131 | 132 | instance Collect a => Collect (Maybe a) where 133 | collect = concatMap collect 134 | 135 | instance Collect (CompUnit Name) where 136 | collect (CompUnit _ ds) = collect ds 137 | 138 | instance Collect (TopDecl Name) where 139 | collect (TContr c) = collect c 140 | collect (TFunDef fd) 141 | = [sigName (funSignature fd)] 142 | collect (TClassDef c) = collect c 143 | collect (TInstDef _) = [] 144 | collect (TDataDef _) = [] 145 | collect (TSym _) = [] 146 | collect (TPragmaDecl _) = [] 147 | collect (TMutualDef ms) = collect ms 148 | 149 | instance Collect (Contract Name) where 150 | collect (Contract _ _ ds) = collect ds 151 | 152 | instance Collect (ContractDecl Name) where 153 | collect (CFieldDecl f) = [] 154 | collect (CFunDecl fd) 155 | = [sigName (funSignature fd)] 156 | collect (CMutualDecl ds) = concatMap collect ds 157 | collect (CConstrDecl _) = [] 158 | collect _ = [] 159 | 160 | instance Collect (Class Name) where 161 | collect c 162 | = map (qual . sigName) $ signatures c 163 | where 164 | qual n = QualName (className c) (pretty n) 165 | 166 | -- definition of a monad for indirect calls 167 | 168 | type IndirectM a = StateT Env IO a 169 | 170 | data Env = Env { 171 | funNames :: [Name] 172 | } deriving Show 173 | 174 | runIndirectM :: IndirectM a -> Env -> IO a 175 | runIndirectM m env = evalStateT m env 176 | 177 | isDirectCall :: Name -> IndirectM Bool 178 | isDirectCall n = (elem n) <$> gets funNames 179 | 180 | addFunctionName :: Name -> IndirectM () 181 | addFunctionName n 182 | = modify (\ env -> env {funNames = n : funNames env}) 183 | 184 | -------------------------------------------------------------------------------- /src/Solcore/Desugarer/ReplaceWildcard.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Desugarer.ReplaceWildcard where 2 | 3 | import Control.Monad.Except 4 | import Control.Monad.IO.Class 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Control.Monad.Writer 8 | 9 | import Data.List 10 | 11 | import Solcore.Frontend.Syntax 12 | import Solcore.Frontend.TypeInference.Id 13 | 14 | -- replacing wildcards by fresh pattern variables 15 | 16 | class ReplaceWildcard a where 17 | replace :: a -> CompilerM a 18 | 19 | instance ReplaceWildcard a => ReplaceWildcard [a] where 20 | replace = mapM replace 21 | 22 | instance ( ReplaceWildcard a 23 | , ReplaceWildcard b) => ReplaceWildcard (a,b) where 24 | replace (a,b) = (,) <$> replace a <*> replace b 25 | 26 | instance ReplaceWildcard a => ReplaceWildcard (Maybe a) where 27 | replace Nothing = pure Nothing 28 | replace (Just e) = Just <$> replace e 29 | 30 | instance ReplaceWildcard (Pat Id) where 31 | replace v@(PVar _) = return v 32 | replace (PCon n ps) 33 | = PCon n <$> replace ps 34 | replace PWildcard 35 | = freshPVar 36 | replace p@(PLit _) 37 | = return p 38 | 39 | instance ReplaceWildcard (Exp Id) where 40 | replace v@(Var _) = return v 41 | replace (Con n es) 42 | = Con n <$> replace es 43 | replace (FieldAccess e n) 44 | = (flip FieldAccess n) <$> replace e 45 | replace e@(Lit _) = return e 46 | replace (Call me n es) 47 | = Call <$> (replace me) <*> 48 | pure n <*> 49 | replace es 50 | replace (Lam args bd mt) 51 | = Lam args <$> replace bd <*> pure mt 52 | replace (TyExp e ty) 53 | = flip TyExp ty <$> replace e 54 | 55 | instance ReplaceWildcard (Stmt Id) where 56 | replace (e1 := e2) 57 | = (e1 :=) <$> replace e2 58 | replace (Let n t me) 59 | = Let n t <$> replace me 60 | replace (StmtExp e) 61 | = StmtExp <$> replace e 62 | replace (Return e) 63 | = Return <$> replace e 64 | replace (Match es eqns) 65 | = Match <$> replace es <*> replace eqns 66 | replace s = pure s 67 | 68 | instance ReplaceWildcard (FunDef Id) where 69 | replace (FunDef sig bd) 70 | = FunDef sig <$> replace bd 71 | 72 | instance ReplaceWildcard (Constructor Id) where 73 | replace (Constructor ps bd) 74 | = Constructor ps <$> replace bd 75 | 76 | instance ReplaceWildcard (Instance Id) where 77 | replace (Instance d ps n ts m funs) 78 | = Instance d ps n ts m <$> replace funs 79 | 80 | instance ReplaceWildcard (TopDecl Id) where 81 | replace (TFunDef fd) 82 | = TFunDef <$> replace fd 83 | replace (TInstDef inst) 84 | = TInstDef <$> replace inst 85 | replace d = return d 86 | 87 | instance ReplaceWildcard (ContractDecl Id) where 88 | replace (CFunDecl fd) 89 | = CFunDecl <$> replace fd 90 | replace (CConstrDecl c) 91 | = CConstrDecl <$> replace c 92 | replace d = pure d 93 | 94 | instance ReplaceWildcard (Contract Id) where 95 | replace (Contract n ts decls) 96 | = Contract n ts <$> replace decls 97 | 98 | -- Compiler monad infra 99 | 100 | type CompilerM a 101 | = ReaderT String (ExceptT String 102 | (WriterT [FunDef Id] 103 | (StateT Int IO))) a 104 | 105 | mkPrefix :: [Name] -> String 106 | mkPrefix = intercalate "_" . map show 107 | 108 | inc :: CompilerM Int 109 | inc = do 110 | i <- get 111 | put (i + 1) 112 | return i 113 | 114 | freshName :: CompilerM Name 115 | freshName 116 | = do 117 | n <- inc 118 | -- pre <- ask 119 | return (Name ("var_" ++ show n)) 120 | 121 | freshId :: CompilerM Id 122 | freshId = Id <$> freshName <*> var 123 | where 124 | var = (TyVar . TVar) <$> freshName 125 | 126 | freshExpVar :: CompilerM (Exp Id) 127 | freshExpVar 128 | = Var <$> freshId 129 | 130 | freshPVar :: CompilerM (Pat Id) 131 | freshPVar 132 | = PVar <$> freshId 133 | 134 | runCompilerM :: [Name] -> CompilerM a -> IO (Either String a, [FunDef Id]) 135 | runCompilerM ns m 136 | = evalStateT (runWriterT (runExceptT (runReaderT m (mkPrefix ns)))) 0 137 | -------------------------------------------------------------------------------- /src/Solcore/Desugarer/UniqueTypeGen.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Desugarer.UniqueTypeGen where 2 | 3 | import Control.Monad.State 4 | import qualified Data.Map as Map 5 | import Solcore.Frontend.Syntax 6 | import Solcore.Frontend.Pretty.SolcorePretty 7 | 8 | uniqueTypeGen :: CompUnit Name -> IO (CompUnit Name, UniqueTyMap) 9 | uniqueTypeGen c@(CompUnit imps ds) 10 | = do 11 | env <- runUniqueM (uniqueTyGen c) 12 | let ds' = (TDataDef <$> Map.elems (uniqueMap env)) ++ ds 13 | pure (CompUnit imps ds', uniqueMap env) 14 | 15 | class UniqueTypeGen a where 16 | uniqueTyGen :: a -> UniqueM () 17 | 18 | instance UniqueTypeGen a => UniqueTypeGen [a] where 19 | uniqueTyGen = mapM_ uniqueTyGen 20 | 21 | instance UniqueTypeGen a => UniqueTypeGen (Maybe a) where 22 | uniqueTyGen Nothing = pure () 23 | uniqueTyGen (Just x) = uniqueTyGen x 24 | 25 | instance UniqueTypeGen (CompUnit Name) where 26 | uniqueTyGen (CompUnit _ ds) 27 | = uniqueTyGen ds 28 | 29 | instance UniqueTypeGen (TopDecl Name) where 30 | uniqueTyGen (TContr c) = uniqueTyGen c 31 | uniqueTyGen (TFunDef f) = uniqueTyGen f 32 | uniqueTyGen (TClassDef c) = uniqueTyGen c 33 | uniqueTyGen _ = pure () 34 | 35 | instance UniqueTypeGen (FunDef Name) where 36 | uniqueTyGen (FunDef sig _) = uniqueTyGen sig 37 | 38 | instance UniqueTypeGen (Signature Name) where 39 | uniqueTyGen sig 40 | = createUniqueType (sigName sig) 41 | 42 | instance UniqueTypeGen (Class Name) where 43 | uniqueTyGen = uniqueTyGen . signatures 44 | 45 | instance UniqueTypeGen (Contract Name) where 46 | uniqueTyGen (Contract _ _ ds) 47 | = uniqueTyGen ds 48 | 49 | instance UniqueTypeGen (ContractDecl Name) where 50 | uniqueTyGen (CFunDecl fd) = uniqueTyGen fd 51 | uniqueTyGen _ = pure () 52 | 53 | -- creating a new unique type 54 | 55 | createUniqueType :: Name -> UniqueM () 56 | createUniqueType n 57 | = do 58 | dn <- freshName ("t_" ++ pretty n) 59 | addUniqueType n (mkUniqueType dn) 60 | 61 | mkUniqueType :: Name -> DataTy 62 | mkUniqueType dn 63 | = let 64 | argVar = TVar (Name "args") 65 | retVar = TVar (Name "ret") 66 | c = Constr dn [] 67 | in DataTy dn [] [c] 68 | 69 | -- monad definition 70 | 71 | type UniqueM a = StateT Env IO a 72 | 73 | type UniqueTyMap = Map.Map Name DataTy 74 | 75 | data Env = Env { 76 | uniqueMap :: UniqueTyMap 77 | , count :: Int 78 | } 79 | 80 | runUniqueM :: UniqueM a -> IO Env 81 | runUniqueM m 82 | = execStateT m (Env Map.empty 0) 83 | 84 | addUniqueType :: Name -> DataTy -> UniqueM () 85 | addUniqueType n t 86 | = modify $ \ env -> env { uniqueMap = Map.insert n t (uniqueMap env) } 87 | 88 | inc :: UniqueM Int 89 | inc = do 90 | s <- get 91 | let c = count s 92 | put $ s { count = c + 1 } 93 | return c 94 | 95 | freshName :: String -> UniqueM Name 96 | freshName s 97 | = do 98 | n <- inc 99 | pure (Name $ s ++ show n) 100 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Parser/SolverInputParser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Solcore.Frontend.Parser.SolverInputParser where 3 | 4 | import Data.Either 5 | import Data.List.NonEmpty (NonEmpty, cons, singleton) 6 | 7 | import Solcore.Frontend.Lexer.SolverInputLexer hiding (lexer) 8 | import Solcore.Frontend.Syntax.Name 9 | import Solcore.Frontend.Syntax 10 | import Solcore.Primitives.Primitives hiding (pairTy) 11 | import Language.Yul 12 | } 13 | 14 | 15 | %name parser Input 16 | %monad {Alex}{(>>=)}{return} 17 | %tokentype { Token } 18 | %error { parseError } 19 | %lexer {lexer}{Token _ TEOF} 20 | 21 | %token 22 | identifier {Token _ (TIdent $$)} 23 | '.' {Token _ TDot} 24 | 'sat' {Token _ TSat} 25 | 'reduce' {Token _ TReduce} 26 | 'class' {Token _ TClass} 27 | 'instance' {Token _ TInstance} 28 | 'forall' {Token _ TForall} 29 | ';' {Token _ TSemi} 30 | ':' {Token _ TColon} 31 | '~' {Token _ TEquiv} 32 | ',' {Token _ TComma} 33 | '=>' {Token _ TDArrow} 34 | '(' {Token _ TLParen} 35 | ')' {Token _ TRParen} 36 | '{' {Token _ TLBrace} 37 | '}' {Token _ TRBrace} 38 | 39 | %expect 0 40 | 41 | %% 42 | -- input definition 43 | 44 | Input :: { SolverState } 45 | Input : TopDeclList ToSolve { SolverState (uncurry Theta (partitionEithers $1)) $2 } 46 | 47 | TopDeclList :: { [Either (Qual Pred) (Qual Pred)] } 48 | TopDeclList : TopDecl TopDeclList { $1 : $2 } 49 | | {- empty -} { [] } 50 | 51 | ToSolve :: { SolverProblem } 52 | ToSolve : 'sat' ':' '{' ConstraintList '}' ';' {Sat $4} 53 | | 'reduce' ':' '{' ConstraintList '}' '~' '{' ConstraintList '}' ';' {Reduce $4 $8} 54 | 55 | -- top level declarations 56 | 57 | TopDecl :: { Either (Qual Pred) (Qual Pred) } 58 | TopDecl : ClassDef {Left $1} 59 | | InstDef {Right $1} 60 | 61 | -- class definitions 62 | 63 | ClassDef :: { Qual Pred } 64 | ClassDef 65 | : SigPrefix 'class' Var ':' Name OptParam ';' { (snd $1) :=> (InCls $5 $3 $6) } 66 | 67 | 68 | OptParam :: { [Ty] } 69 | OptParam : '(' VarCommaList ')' {$2} 70 | | {- empty -} {[]} 71 | 72 | VarCommaList :: { [Ty] } 73 | VarCommaList : Var ',' VarCommaList {$1 : $3} 74 | | Var {[$1]} 75 | 76 | ContextOpt :: {[Pred]} 77 | ContextOpt : {- empty -} %shift {[]} 78 | | Context {$1} 79 | 80 | Context :: {[Pred]} 81 | Context : '(' ConstraintList ')' '=>' { $2 } 82 | 83 | ConstraintList :: { [Pred] } 84 | ConstraintList : Constraint ',' ConstraintList {$1 : $3} 85 | | Constraint {[$1]} 86 | | {[]} 87 | SigPrefix :: {([Ty], [Pred])} 88 | SigPrefix : 'forall' Tyvars '.' ConstraintList '=>' {($2, $4)} 89 | | 'forall' Tyvars '.' {($2, [])} 90 | | {- empty -} {([], [])} 91 | 92 | 93 | Constraint :: { Pred } 94 | Constraint : Type ':' Name OptTypeParam {InCls $3 $1 $4} 95 | 96 | -- instance declarations 97 | 98 | InstDef :: { Qual Pred } 99 | InstDef : SigPrefix 'instance' Type ':' Name OptTypeParam ';' { (snd $1) :=> (InCls $5 $3 $6) } 100 | 101 | OptTypeParam :: { [Ty] } 102 | OptTypeParam : '(' TypeCommaList ')' {$2} 103 | | {- empty -} {[]} 104 | 105 | TypeCommaList :: { [Ty] } 106 | TypeCommaList : Type ',' TypeCommaList {$1 : $3} 107 | | Type {[$1]} 108 | | {- empty -} { [] } 109 | 110 | Tyvars :: {[Ty]} 111 | Tyvars : Name Tyvars { (TyCon $1 []) : $2} 112 | | {-empty-} {[]} 113 | 114 | 115 | -- basic type definitions 116 | 117 | Type :: { Ty } 118 | Type : Name OptTypeParam {TyCon $1 $2} 119 | | TupleTy {$1} 120 | 121 | TupleTy :: { Ty } 122 | TupleTy : '(' TypeCommaList ')' {mkTupleTy $2} 123 | 124 | Var :: { Ty } 125 | Var : Name {TyCon $1 []} 126 | 127 | Name :: { Name } 128 | Name : identifier { Name $1 } 129 | | QualName %shift { QualName (fst $1) (snd $1) } 130 | 131 | QualName :: { (Name, String) } 132 | QualName : QualName '.' identifier { (QualName (fst $1) (snd $1), $3)} 133 | 134 | { 135 | data Theta 136 | = Theta { 137 | classes :: [Qual Pred] 138 | , insts :: [Qual Pred] 139 | } deriving Show 140 | 141 | data SolverState 142 | = SolverState { 143 | theta :: Theta 144 | , problem :: SolverProblem 145 | } deriving Show 146 | 147 | data SolverProblem 148 | = Sat [Pred] 149 | | Reduce [Pred] [Pred] 150 | | Improvement Scheme 151 | deriving Show 152 | 153 | pairTy :: Ty -> Ty -> Ty 154 | pairTy t1 t2 = TyCon "pair" [t1,t2] 155 | 156 | mkTupleTy :: [Ty] -> Ty 157 | mkTupleTy [] = TyCon (Name "()") [] 158 | mkTupleTy ts = foldr1 pairTy ts 159 | 160 | parseError (Token (line, col) lexeme) 161 | = alexError $ "Parse error while processing lexeme: " ++ show lexeme 162 | ++ "\n at line " ++ show line ++ ", column " ++ show col 163 | 164 | lexer :: (Token -> Alex a) -> Alex a 165 | lexer = (=<< alexMonadScan) 166 | 167 | runParser :: String -> Either String SolverState 168 | runParser content = do 169 | runAlex content parser 170 | } 171 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Pretty/Name.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Pretty.Name where 2 | import Common.Pretty 3 | import Solcore.Frontend.Syntax.Name 4 | 5 | 6 | instance Pretty Name where 7 | ppr (QualName n s) = ppr n <> text "." <> text s 8 | ppr (Name s) = text s 9 | 10 | 11 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Pretty/ShortName.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Pretty.ShortName where 2 | import Solcore.Frontend.Syntax.Contract 3 | import Solcore.Frontend.Syntax.Name 4 | import Solcore.Frontend.Pretty.Name 5 | import Solcore.Frontend.Syntax.Stmt 6 | import Solcore.Frontend.Syntax.Ty 7 | import Solcore.Frontend.TypeInference.Id 8 | import Solcore.Frontend.Pretty.SolcorePretty(pretty) 9 | 10 | import Common.Pretty 11 | prettys :: Pretty a => [a] -> String 12 | prettys = render . brackets . commaSep . map ppr 13 | 14 | class Pretty a => HasShortName a where 15 | shortName :: a -> String 16 | shortName = pretty 17 | 18 | instance HasShortName Name 19 | instance HasShortName Id 20 | 21 | instance HasShortName a => HasShortName (Contract a) where 22 | shortName (Contract n _ _) = shortName n 23 | 24 | instance HasShortName a => HasShortName (Signature a) where 25 | shortName sig = shortName (sigName sig) 26 | 27 | instance HasShortName a => HasShortName (FunDef a) where 28 | shortName fd = "function " ++shortName (funSignature fd) 29 | 30 | instance HasShortName a => HasShortName (Instance a) where 31 | shortName is = unwords 32 | [ "instance" 33 | , pretty (mainTy is) 34 | , ":" 35 | , pretty (instName is) 36 | , prettys (paramsTy is) 37 | ] 38 | instance HasShortName a => HasShortName (TopDecl a) where 39 | shortName (TContr c) = shortName c 40 | shortName (TFunDef fd) = shortName fd 41 | shortName (TClassDef c) = shortName (className c) 42 | shortName (TInstDef is) = shortName is 43 | shortName (TMutualDef ts) = concatMap shortName ts 44 | shortName (TDataDef d) = pretty (dataName d) 45 | shortName (TPragmaDecl p) = pretty p 46 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Syntax ( module Solcore.Frontend.Syntax.Contract 2 | , module Solcore.Frontend.Syntax.Name 3 | , module Solcore.Frontend.Syntax.Stmt 4 | , module Solcore.Frontend.Syntax.Ty 5 | ) where 6 | 7 | import Solcore.Frontend.Syntax.Contract 8 | import Solcore.Frontend.Syntax.Name 9 | import Solcore.Frontend.Syntax.Stmt 10 | import Solcore.Frontend.Syntax.Ty 11 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax/Contract.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Syntax.Contract where 2 | 3 | import Data.Generics (Data, Typeable) 4 | import Data.List.NonEmpty 5 | 6 | import Solcore.Frontend.Syntax.Name 7 | import Solcore.Frontend.Syntax.Stmt 8 | import Solcore.Frontend.Syntax.Ty 9 | 10 | -- compilation unit 11 | 12 | data CompUnit a 13 | = CompUnit { 14 | imports :: [Import] 15 | , contracts :: [TopDecl a] 16 | } deriving (Eq, Ord, Show, Data, Typeable) 17 | 18 | data TopDecl a 19 | = TContr (Contract a) 20 | | TFunDef (FunDef a) 21 | | TClassDef (Class a) 22 | | TInstDef (Instance a) 23 | | TMutualDef [TopDecl a] 24 | | TDataDef DataTy 25 | | TSym TySym 26 | | TPragmaDecl Pragma 27 | deriving (Eq, Ord, Show, Data, Typeable) 28 | 29 | -- empty list in pragma: restriction on all class / instances 30 | 31 | data PragmaType 32 | = NoCoverageCondition 33 | | NoPattersonCondition 34 | | NoBoundVariableCondition 35 | deriving (Eq, Ord, Show, Data, Typeable) 36 | 37 | data PragmaStatus 38 | = Enabled 39 | | DisableAll 40 | | DisableFor (NonEmpty Name) 41 | deriving (Eq, Ord, Show, Data, Typeable) 42 | 43 | data Pragma 44 | = Pragma { 45 | pragmaType :: PragmaType 46 | , pragmaStatus :: PragmaStatus 47 | } deriving (Eq, Ord, Show, Data, Typeable) 48 | 49 | newtype Import 50 | = Import { unImport :: Name } 51 | deriving (Eq, Ord, Show, Data, Typeable) 52 | 53 | -- definition of the contract structure 54 | 55 | data Contract a 56 | = Contract { 57 | name :: Name 58 | , tyParams :: [Tyvar] 59 | , decls :: [ContractDecl a] 60 | } deriving (Eq, Ord, Show, Data, Typeable) 61 | 62 | -- definition of a algebraic data type 63 | 64 | data DataTy 65 | = DataTy { 66 | dataName :: Name 67 | , dataParams :: [Tyvar] 68 | , dataConstrs :: [Constr] 69 | } deriving (Eq, Ord, Show, Data, Typeable) 70 | 71 | data Constr 72 | = Constr { 73 | constrName :: Name 74 | , constrTy :: [Ty] 75 | } deriving (Eq, Ord, Show, Data, Typeable) 76 | 77 | -- definition of type synonym 78 | 79 | data TySym 80 | = TySym { 81 | symName :: Name 82 | , symVars :: [Tyvar] 83 | , symType :: Ty 84 | } deriving (Eq, Ord, Show, Data, Typeable) 85 | 86 | -- definition of contract constructor 87 | 88 | data Constructor a 89 | = Constructor { 90 | constrParams :: [Param a] 91 | , constrBody :: (Body a) 92 | } deriving (Eq, Ord, Show, Data, Typeable) 93 | 94 | -- definition of classes and instances 95 | 96 | data Class a 97 | = Class { 98 | classContext :: [Pred] 99 | , className :: Name 100 | , paramsVar :: [Tyvar] 101 | , mainVar :: Tyvar 102 | , signatures :: [Signature a] 103 | } deriving (Eq, Ord, Show, Data, Typeable) 104 | 105 | data Signature a 106 | = Signature { 107 | sigVars :: [Tyvar] 108 | , sigContext :: [Pred] 109 | , sigName :: Name 110 | , sigParams :: [Param a] 111 | , sigReturn :: Maybe Ty 112 | } deriving (Eq, Ord, Show, Data, Typeable) 113 | 114 | 115 | data Instance a 116 | = Instance { 117 | instDefault :: Bool 118 | , instContext :: [Pred] 119 | , instName :: Name 120 | , paramsTy :: [Ty] 121 | , mainTy :: Ty 122 | , instFunctions :: [FunDef a] 123 | } deriving (Eq, Ord, Show, Data, Typeable) 124 | 125 | -- definition of contract field variables 126 | 127 | data Field a 128 | = Field { 129 | fieldName :: Name 130 | , fieldTy :: Ty 131 | , fieldInit :: Maybe (Exp a) 132 | } deriving (Eq, Ord, Show, Data, Typeable) 133 | 134 | -- definition of functions 135 | 136 | data FunDef a 137 | = FunDef { 138 | funSignature :: Signature a 139 | , funDefBody :: Body a 140 | } deriving (Eq, Ord, Show, Data, Typeable) 141 | 142 | data ContractDecl a 143 | = CDataDecl DataTy 144 | | CFieldDecl (Field a) 145 | | CFunDecl (FunDef a) 146 | | CMutualDecl [ContractDecl a] -- used only after SCC analysis 147 | | CConstrDecl (Constructor a) 148 | deriving (Eq, Ord,Show, Data, Typeable) 149 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Solcore.Frontend.Syntax.Name where 3 | 4 | import Data.Generics (Data, Typeable) 5 | import Data.String 6 | 7 | data Name 8 | = Name String 9 | | QualName Name String 10 | deriving (Eq, Ord, Data, Typeable) 11 | 12 | instance Show Name where 13 | show (Name s) = s 14 | show (QualName n s) 15 | = show n ++ "." ++ s 16 | 17 | instance IsString Name where 18 | fromString = Name 19 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax/Stmt.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Syntax.Stmt where 2 | 3 | import Data.Generics (Data, Typeable) 4 | 5 | import Solcore.Frontend.Syntax.Name 6 | import Solcore.Frontend.Syntax.Ty 7 | import Language.Yul 8 | 9 | -- definition of statements 10 | 11 | type Equation a = ([Pat a], [Stmt a]) 12 | type Equations a = [Equation a] 13 | 14 | data Stmt a 15 | = (Exp a) := (Exp a) -- assignment 16 | | Let a (Maybe Ty) (Maybe (Exp a)) -- local variable 17 | | StmtExp (Exp a) -- expression level statements 18 | | Return (Exp a) -- return statements 19 | | Match [Exp a] (Equations a) -- pattern matching 20 | | Asm YulBlock -- Yul block 21 | deriving (Eq, Ord, Show, Data, Typeable) 22 | 23 | type Body a = [Stmt a] 24 | 25 | data Param a 26 | = Typed a Ty 27 | | Untyped a 28 | deriving (Eq, Ord, Show, Data, Typeable) 29 | 30 | paramName :: Param a -> a 31 | paramName (Typed n _) = n 32 | paramName (Untyped n) = n 33 | 34 | -- definition of the expression syntax 35 | 36 | data Exp a 37 | = Var a -- variable 38 | | Con a [Exp a] -- data type constructor 39 | | FieldAccess (Maybe (Exp a)) a -- field access 40 | | Lit Literal -- literal 41 | | Call (Maybe (Exp a)) a [Exp a] -- function call 42 | | Lam [Param a] (Body a) (Maybe Ty) -- lambda-abstraction 43 | | TyExp (Exp a) Ty -- type annotated expression 44 | deriving (Eq, Ord, Show, Data, Typeable) 45 | 46 | -- pattern matching equations 47 | 48 | data Pat a 49 | = PVar a 50 | | PCon a [Pat a] 51 | | PWildcard 52 | | PLit Literal 53 | deriving (Eq, Ord, Show, Data, Typeable) 54 | 55 | -- definition of literals 56 | 57 | data Literal 58 | = IntLit Integer 59 | | StrLit String 60 | deriving (Eq, Ord, Show, Data, Typeable) 61 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax/SyntaxTree.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Syntax.SyntaxTree where 2 | 3 | import Data.Generics (Data,Typeable) 4 | import Data.List (union) 5 | import Data.List.NonEmpty 6 | import Language.Yul 7 | import Solcore.Frontend.Syntax.Name 8 | 9 | -- compilation unit 10 | 11 | data CompUnit 12 | = CompUnit { 13 | imports :: [Import] 14 | , contracts :: [TopDecl] 15 | } deriving (Eq, Ord, Show, Data, Typeable) 16 | 17 | data TopDecl 18 | = TContr Contract 19 | | TFunDef FunDef 20 | | TClassDef Class 21 | | TInstDef Instance 22 | | TDataDef DataTy 23 | | TSym TySym 24 | | TPragmaDecl Pragma 25 | deriving (Eq, Ord, Show, Data, Typeable) 26 | 27 | -- empty list in pragma: restriction on all class / instances 28 | 29 | data PragmaType 30 | = NoCoverageCondition 31 | | NoPattersonCondition 32 | | NoBoundVariableCondition 33 | deriving (Eq, Ord, Show, Data, Typeable) 34 | 35 | data PragmaStatus 36 | = Enabled 37 | | DisableAll 38 | | DisableFor (NonEmpty Name) 39 | deriving (Eq, Ord, Show, Data, Typeable) 40 | 41 | data Pragma 42 | = Pragma { 43 | pragmaType :: PragmaType 44 | , pragmaStatus :: PragmaStatus 45 | } deriving (Eq, Ord, Show, Data, Typeable) 46 | 47 | newtype Import 48 | = Import { unImport :: Name } 49 | deriving (Eq, Ord, Show, Data, Typeable) 50 | 51 | -- definition of the contract structure 52 | 53 | data Contract 54 | = Contract { 55 | name :: Name 56 | , tyParams :: [Ty] 57 | , decls :: [ContractDecl] 58 | } deriving (Eq, Ord, Show, Data, Typeable) 59 | 60 | -- definition of a algebraic data type 61 | 62 | data DataTy 63 | = DataTy { 64 | dataName :: Name 65 | , dataParams :: [Ty] 66 | , dataConstrs :: [Constr] 67 | } deriving (Eq, Ord, Show, Data, Typeable) 68 | 69 | data Constr 70 | = Constr { 71 | constrName :: Name 72 | , constrTy :: [Ty] 73 | } deriving (Eq, Ord, Show, Data, Typeable) 74 | 75 | -- type definition 76 | 77 | data Ty 78 | = TyCon Name [Ty] -- type constructor 79 | deriving (Eq, Ord, Show, Data, Typeable) 80 | 81 | pattern (:->) t1 t2 = TyCon (Name "->") [t1, t2] 82 | 83 | tyName :: Ty -> Name 84 | tyName (TyCon n _) = n 85 | 86 | data Pred = InCls { 87 | predName :: Name 88 | , predMain :: Ty 89 | , predParams :: [Ty] 90 | } deriving (Eq, Ord, Show, Data, Typeable) 91 | 92 | tysFrom :: [Pred] -> [Ty] 93 | tysFrom = foldr go [] 94 | where 95 | go p ac = (predMain p) : predParams p `union` ac 96 | 97 | 98 | -- definition of type synonym 99 | 100 | data TySym 101 | = TySym { 102 | symName :: Name 103 | , symVars :: [Ty] 104 | , symType :: Ty 105 | } deriving (Eq, Ord, Show, Data, Typeable) 106 | 107 | -- definition of contract constructor 108 | 109 | data Constructor 110 | = Constructor { 111 | constrParams :: [Param] 112 | , constrBody :: Body 113 | } deriving (Eq, Ord, Show, Data, Typeable) 114 | 115 | -- definition of classes and instances 116 | 117 | data Class 118 | = Class { 119 | classContext :: [Pred] 120 | , className :: Name 121 | , paramsVar :: [Ty] 122 | , mainVar :: Ty 123 | , signatures :: [Signature] 124 | } deriving (Eq, Ord, Show, Data, Typeable) 125 | 126 | data Signature 127 | = Signature { 128 | sigVars :: [Ty] 129 | , sigContext :: [Pred] 130 | , sigName :: Name 131 | , sigParams :: [Param] 132 | , sigReturn :: Maybe Ty 133 | } deriving (Eq, Ord, Show, Data, Typeable) 134 | 135 | 136 | data Instance 137 | = Instance { 138 | instDefault :: Bool 139 | , instContext :: [Pred] 140 | , instName :: Name 141 | , paramsTy :: [Ty] 142 | , mainTy :: Ty 143 | , instFunctions :: [FunDef] 144 | } deriving (Eq, Ord, Show, Data, Typeable) 145 | 146 | -- definition of contract field variables 147 | 148 | data Field 149 | = Field { 150 | fieldName :: Name 151 | , fieldTy :: Ty 152 | , fieldInit :: Maybe Exp 153 | } deriving (Eq, Ord, Show, Data, Typeable) 154 | 155 | -- definition of functions 156 | 157 | data FunDef 158 | = FunDef { 159 | funSignature :: Signature 160 | , funDefBody :: Body 161 | } deriving (Eq, Ord, Show, Data, Typeable) 162 | 163 | data ContractDecl 164 | = CDataDecl DataTy 165 | | CFieldDecl Field 166 | | CFunDecl FunDef 167 | | CConstrDecl Constructor 168 | deriving (Eq, Ord,Show, Data, Typeable) 169 | -- definition of statements 170 | 171 | type Equation = ([Pat], [Stmt]) 172 | type Equations = [Equation] 173 | 174 | data Stmt 175 | = Assign Exp Exp -- assignment 176 | | Let Name (Maybe Ty) (Maybe Exp) -- local variable 177 | | StmtExp Exp -- expression level statements 178 | | Return Exp -- return statements 179 | | Match [Exp] Equations -- pattern matching 180 | | Asm YulBlock -- Yul block 181 | deriving (Eq, Ord, Show, Data, Typeable) 182 | 183 | type Body = [Stmt] 184 | 185 | data Param 186 | = Typed Name Ty 187 | | Untyped Name 188 | deriving (Eq, Ord, Show, Data, Typeable) 189 | 190 | -- expression syntax 191 | 192 | data Exp 193 | = Lit Literal -- literal 194 | | ExpName (Maybe Exp) Name [Exp] -- function call or constructor 195 | | ExpVar (Maybe Exp) Name -- variables or field access 196 | | Lam [Param] Body (Maybe Ty) -- lambda-abstraction 197 | | TyExp Exp Ty -- type annotation expression 198 | deriving (Eq, Ord, Show, Data, Typeable) 199 | 200 | -- pattern matching equations 201 | 202 | data Pat 203 | = Pat Name [Pat] 204 | | PWildcard 205 | | PLit Literal 206 | deriving (Eq, Ord, Show, Data, Typeable) 207 | 208 | -- definition of literals 209 | 210 | data Literal 211 | = IntLit Integer 212 | | StrLit String 213 | deriving (Eq, Ord, Show, Data, Typeable) 214 | 215 | pairTy :: Ty -> Ty -> Ty 216 | pairTy t1 t2 = TyCon "pair" [t1,t2] 217 | 218 | funtype :: [Ty] -> Ty -> Ty 219 | funtype ts t = foldr (:->) t ts 220 | 221 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/Syntax/Ty.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.Syntax.Ty where 2 | 3 | 4 | import Data.Generics (Data, Typeable) 5 | import Solcore.Frontend.Syntax.Name 6 | 7 | -- basic typing infrastructure 8 | 9 | data Tyvar 10 | = TVar { var :: Name } 11 | deriving (Eq, Ord, Show, Data, Typeable) 12 | 13 | data Ty 14 | = TyVar Tyvar -- type variable 15 | | TyCon Name [Ty] -- type constructor 16 | deriving (Eq, Ord, Show, Data, Typeable) 17 | 18 | infixr 4 :-> 19 | 20 | pattern (:->) a b 21 | = TyCon (Name "->") [a, b] 22 | 23 | argTy :: Ty -> [Ty] 24 | argTy (t1 :-> t2) = t1 : argTy t2 25 | argTy _ = [] 26 | 27 | retTy :: Ty -> Maybe Ty 28 | retTy (TyVar _) = Nothing 29 | retTy (t1 :-> t2) = ret t2 30 | where 31 | ret (ta :-> tb) = ret tb 32 | ret t = Just t 33 | retTy t@(TyCon _ _) = Just t 34 | 35 | splitTy :: Ty -> ([Ty], Ty) 36 | splitTy (a :-> b) 37 | = let (as, r) = splitTy b 38 | in (a : as, r) 39 | splitTy t = ([], t) 40 | 41 | funtype :: [Ty] -> Ty -> Ty 42 | funtype ts t = foldr (:->) t ts 43 | 44 | class AlphaEq a where 45 | alphaEq :: a -> a -> Bool 46 | 47 | instance AlphaEq a => AlphaEq [a] where 48 | alphaEq ts ts' = and $ zipWith alphaEq ts ts' 49 | 50 | instance AlphaEq Ty where 51 | alphaEq (TyVar _) (TyVar _) 52 | = True 53 | alphaEq (TyCon n ts) (TyCon n' ts') 54 | = n == n' && (and (zipWith alphaEq ts ts')) 55 | alphaEq _ _ 56 | = False 57 | 58 | instance AlphaEq Pred where 59 | alphaEq (InCls n t ts) (InCls n' t' ts') 60 | = n == n' && alphaEq t t' && alphaEq ts ts' 61 | alphaEq (t1 :~: t2) (t1' :~: t2') 62 | = alphaEq t1 t1' && alphaEq t2 t2' 63 | alphaEq _ _ = False 64 | 65 | -- definition of constraints 66 | 67 | data Pred = InCls { 68 | predName :: Name 69 | , predMain :: Ty 70 | , predParams :: [Ty] 71 | } 72 | | Ty :~: Ty 73 | deriving (Eq, Ord, Show, Data, Typeable) 74 | 75 | 76 | -- qualified types 77 | 78 | data Qual t 79 | = [Pred] :=> t 80 | deriving (Eq, Ord, Show, Data, Typeable) 81 | 82 | infix 2 :=> 83 | 84 | -- type schemes 85 | 86 | data Scheme 87 | = Forall [Tyvar] (Qual Ty) 88 | deriving (Eq, Ord, Show, Data, Typeable) 89 | 90 | monotype :: Ty -> Scheme 91 | monotype t = Forall [] ([] :=> t) 92 | 93 | {- 94 | A measure for types, predicates and constraints for the Patterson Condition 2: 95 | "The constraint has fewer constructors and variables 96 | (taken together and counting repetitions) than the head" 97 | -} 98 | class HasMeasure a where 99 | measure :: a -> Int 100 | 101 | instance HasMeasure Ty where 102 | measure (TyVar _) = 1 103 | measure (TyCon _ ts) = 1 + sum (map measure ts) 104 | 105 | instance HasMeasure Pred where 106 | measure (InCls _ t as) = sum (map measure as) + measure t 107 | measure (t :~: u) = measure t + measure u 108 | 109 | instance HasMeasure [Pred] where 110 | measure = sum . map measure 111 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/Erase.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.Erase where 2 | 3 | import Solcore.Frontend.Syntax 4 | import Solcore.Frontend.TypeInference.Id 5 | 6 | -- erasing Id's 7 | 8 | class Erase a where 9 | type EraseRes a 10 | erase :: a -> EraseRes a 11 | 12 | instance Erase a => Erase [a] where 13 | type EraseRes [a] = [EraseRes a] 14 | erase = map erase 15 | 16 | instance Erase a => Erase (Maybe a) where 17 | type EraseRes (Maybe a) = Maybe (EraseRes a) 18 | erase = fmap erase 19 | 20 | instance (Erase a, Erase b) => Erase (a,b) where 21 | type EraseRes (a,b) = (EraseRes a, EraseRes b) 22 | 23 | erase (x, y) = (erase x, erase y) 24 | 25 | instance Erase (Instance Id) where 26 | type EraseRes (Instance Id) = Instance Name 27 | 28 | erase (Instance d ctx n ts t funs) 29 | = Instance d ctx n ts t (erase funs) 30 | 31 | instance Erase (FunDef Id) where 32 | type EraseRes (FunDef Id) = FunDef Name 33 | 34 | erase (FunDef sig bd) 35 | = FunDef (erase sig) (erase bd) 36 | 37 | instance Erase (Signature Id) where 38 | type EraseRes (Signature Id) = Signature Name 39 | 40 | erase (Signature n ps t args rt) 41 | = Signature n ps t (erase args) rt 42 | 43 | instance Erase (Stmt Id) where 44 | type EraseRes (Stmt Id) = Stmt Name 45 | 46 | erase (e1 := e2) 47 | = (erase e1) := (erase e2) 48 | erase (Let n mt me) 49 | = Let (idName n) mt (erase me) 50 | erase (StmtExp e) 51 | = StmtExp (erase e) 52 | erase (Return e) 53 | = Return (erase e) 54 | erase (Match es eqns) 55 | = Match (erase es) (erase eqns) 56 | erase (Asm blk) 57 | = Asm blk 58 | 59 | instance Erase (Exp Id) where 60 | type EraseRes (Exp Id) = Exp Name 61 | 62 | erase (Var v) 63 | = Var (idName v) 64 | erase (Con n es) 65 | = Con (idName n) (map erase es) 66 | erase (FieldAccess me n) 67 | = FieldAccess (erase me) (idName n) 68 | erase (Call me n es) 69 | = Call (erase me) (idName n) (erase es) 70 | erase (Lam ps bd mt) 71 | = Lam (erase ps) (erase bd) mt 72 | erase (TyExp e t) 73 | = TyExp (erase e) t 74 | erase (Lit l) = Lit l 75 | 76 | instance Erase (Param Id) where 77 | type EraseRes (Param Id) = Param Name 78 | 79 | erase (Typed n t) 80 | = Typed (idName n) t 81 | erase (Untyped n) 82 | = Untyped (idName n) 83 | 84 | instance Erase (Pat Id) where 85 | type EraseRes (Pat Id) = Pat Name 86 | 87 | erase (PVar n) 88 | = PVar (idName n) 89 | erase (PCon n ps) 90 | = PCon (idName n) (erase ps) 91 | erase PWildcard 92 | = PWildcard 93 | erase (PLit l) 94 | = PLit l 95 | 96 | 97 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/Id.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.Id where 2 | 3 | import Data.Generics (Data, Typeable) 4 | 5 | import Solcore.Frontend.Syntax 6 | import Solcore.Frontend.TypeInference.TcSubst 7 | 8 | -- identifiers with a type 9 | 10 | data Id 11 | = Id { 12 | idName :: Name 13 | , idType :: Ty 14 | } deriving (Eq, Ord, Show, Data, Typeable) 15 | 16 | instance HasType Id where 17 | apply s (Id n t) = Id n (apply s t) 18 | fv (Id _ t) = fv t 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/NameSupply.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.NameSupply where 2 | 3 | import Solcore.Frontend.Syntax.Name 4 | 5 | type NameSupply = [Name] 6 | 7 | namePool :: NameSupply 8 | namePool = Name <$> (names ++ addNumbers names [1..]) 9 | where 10 | names = map wrap ['a' .. 'z'] 11 | wrap x = [x] 12 | 13 | 14 | addNumbers :: [String] -> [Int] -> [String] 15 | addNumbers xs ys 16 | = do 17 | y <- ys 18 | x <- xs 19 | return (x ++ show y) 20 | 21 | newName :: NameSupply -> (Name, NameSupply) 22 | newName (x : xs) = (x, xs) 23 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/TcEnv.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.TcEnv where 2 | 3 | import Data.List 4 | import Data.Map (Map) 5 | import qualified Data.Map as Map 6 | 7 | import Solcore.Desugarer.UniqueTypeGen (UniqueTyMap) 8 | import Solcore.Frontend.Pretty.SolcorePretty 9 | import Solcore.Frontend.Syntax 10 | import Solcore.Frontend.TypeInference.Id 11 | import Solcore.Frontend.TypeInference.NameSupply 12 | import Solcore.Frontend.TypeInference.TcSubst 13 | import Solcore.Frontend.TypeInference.TcUnify 14 | import Solcore.Pipeline.Options 15 | import Solcore.Primitives.Primitives 16 | 17 | 18 | -- definition of type environment 19 | type Arity = Int 20 | 21 | -- type constructor arity and names of constructors 22 | data TypeInfo 23 | = TypeInfo { 24 | arity :: Arity -- number of type parameters 25 | , constrNames :: [Name] -- list of data constructor names 26 | , fieldNames :: [Name] -- list of field names 27 | } deriving (Eq, Ord, Show) 28 | 29 | wordTypeInfo :: TypeInfo 30 | wordTypeInfo = TypeInfo 0 [] [] 31 | 32 | unitTypeInfo :: TypeInfo 33 | unitTypeInfo = TypeInfo 0 [Name "()"] [] 34 | 35 | pairTypeInfo :: TypeInfo 36 | pairTypeInfo = TypeInfo 2 [Name "pair"] [] 37 | 38 | arrowTypeInfo :: TypeInfo 39 | arrowTypeInfo = TypeInfo 2 [] [] 40 | 41 | -- name of constructor and its scheme 42 | type ConInfo = (Name, Scheme) 43 | 44 | -- number of weak parameters and method names 45 | type Method = Name 46 | data ClassInfo 47 | = ClassInfo { 48 | classArity :: Arity 49 | , methods :: [Method] 50 | , classpred :: Pred 51 | , supers :: [Pred] 52 | } deriving Show 53 | 54 | type Table a = Map Name a 55 | 56 | -- typing environment 57 | type Env = Table Scheme 58 | type ClassTable = Table ClassInfo 59 | type TypeTable = Table TypeInfo 60 | type Inst = Qual Pred 61 | type InstTable = Table [Inst] 62 | type DefTable = Table Inst 63 | 64 | data TcEnv 65 | = TcEnv { 66 | ctx :: Env -- Variable environment 67 | , instEnv :: InstTable -- Instance Environment 68 | , defaultEnv :: DefTable -- Default instance environment 69 | , typeTable :: TypeTable -- Type information environment 70 | , classTable :: ClassTable -- Class information table 71 | , contract :: Maybe Name -- current contract name 72 | -- used to type check calls. 73 | , subst :: Subst -- Current substitution 74 | , nameSupply :: NameSupply -- Fresh name supply 75 | , uniqueTypes :: UniqueTyMap -- unique type map 76 | , directCalls :: [Name] -- defined function names 77 | , generateDefs :: Bool -- should generate new defs? 78 | , generated :: [TopDecl Id] 79 | , counter :: Int -- used to generate new names 80 | , logs :: [String] -- Logging 81 | , warnings :: [String] -- warnings collected to user 82 | , enableLog :: Bool -- Enable logging? 83 | , coverage :: PragmaStatus -- Disable coverage checking for names. 84 | , patterson :: PragmaStatus -- Disable Patterson condition for names. 85 | , boundVariable :: PragmaStatus -- Disable bound variable condition for names. 86 | , maxRecursionDepth :: Int -- max recursion depth in 87 | -- context reduction 88 | , tcOptions :: Option 89 | } 90 | 91 | initTcEnv :: Option -> TcEnv 92 | initTcEnv options 93 | = TcEnv { ctx = primCtx 94 | , instEnv = primInstEnv 95 | , defaultEnv = Map.empty 96 | , typeTable = primTypeEnv 97 | , classTable = primClassEnv 98 | , contract = Nothing 99 | , subst = mempty 100 | , nameSupply = namePool 101 | , uniqueTypes = primDataType 102 | , directCalls = [ Name "primAddWord" 103 | , Name "primEqWord" 104 | ] 105 | , generateDefs = True 106 | , generated = [] 107 | , counter = 0 108 | , logs = [] 109 | , warnings = [] 110 | , enableLog = True 111 | , coverage = Enabled 112 | , patterson = Enabled 113 | , boundVariable = Enabled 114 | , maxRecursionDepth = 100 115 | , tcOptions = options 116 | } 117 | 118 | primCtx :: Env 119 | primCtx 120 | = Map.fromList [ primAddWord 121 | , primEqWord 122 | , primInvoke 123 | , primPair 124 | , primUnit 125 | ] 126 | 127 | primTypeEnv :: TypeTable 128 | primTypeEnv = Map.fromList [ (Name "word", wordTypeInfo) 129 | , (Name "pair", pairTypeInfo) 130 | , (Name "->", arrowTypeInfo) 131 | , (Name "()", unitTypeInfo) 132 | ] 133 | 134 | primInstEnv :: InstTable 135 | primInstEnv = Map.empty 136 | 137 | primClassEnv :: ClassTable 138 | primClassEnv = Map.empty 139 | {- = Map.fromList [(Name "invokable", invokableInfo)] 140 | where 141 | invokableInfo 142 | = ClassInfo 2 [QualName (Name "invokable") "invoke"] 143 | (InCls (Name "invokable") self args) 144 | self = TyVar (TVar (Name "self") False) 145 | args = map TyVar [TVar (Name "args") False, TVar (Name "ret") False] 146 | -} 147 | 148 | primDataType :: Map Name DataTy 149 | primDataType = Map.fromList [ (Name "primAddWord", dt1 ) 150 | , (Name "primEqWord", dt2) 151 | , (QualName (Name "invokable") "invoke", dt3) 152 | ] 153 | where 154 | dt1 = DataTy (Name "t_primAddWord") 155 | [] 156 | [Constr (Name "t_primAddWord") []] 157 | dt2 = DataTy (Name "t_primEqWord") 158 | [] 159 | [Constr (Name "t_primEqWord") []] 160 | dt3 = DataTy (Name "t_invokable.invoke") 161 | [] 162 | [Constr (Name "t_invokable.invoke") []] 163 | 164 | 165 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/TcSat.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.TcSat where 2 | 3 | import Control.Monad 4 | import Control.Monad.Except 5 | import Control.Monad.Trans 6 | import Data.List 7 | import Data.Maybe 8 | 9 | import Solcore.Frontend.Syntax 10 | import Solcore.Frontend.Parser.SolverInputParser 11 | import Solcore.Frontend.Pretty.SolcorePretty 12 | import Solcore.Frontend.TypeInference.TcEnv 13 | import Solcore.Frontend.TypeInference.TcMonad 14 | import Solcore.Frontend.TypeInference.TcSubst 15 | import Solcore.Frontend.TypeInference.TcUnify 16 | 17 | import Solcore.Pipeline.Options 18 | 19 | sat :: [Pred] -> TcM [Subst] 20 | sat ps 21 | = do 22 | n <- askMaxRecursionDepth 23 | satI n ps 24 | 25 | satI :: Int -> [Pred] -> TcM [Subst] 26 | satI 0 p = throwError $ unwords [ "Could not deduce:" 27 | , pretty p 28 | , "because the solver exceeded the max number of iterations!" 29 | ] 30 | satI n [] = pure [mempty] -- rule SEmpty 31 | satI n [p] = satOne n p -- rule SInst 32 | satI n (p : ps) 33 | = do --rule SConj 34 | ss0 <- satOne n p 35 | ss1 <- mapM (satI (n - 1)) [apply s ps | s <- ss0] 36 | pure $ [s' <> s | s <- ss0, s1 <- ss1, s' <- s1] 37 | 38 | -- rule SInst 39 | 40 | satOne :: Int -> Pred -> TcM [Subst] 41 | satOne n p = do -- rule Inst 42 | delta <- sats p 43 | when (null delta) $ 44 | throwError $ unwords ["There is no instance to satisfy:", pretty p] 45 | ss <- mapM (\ (s,q) -> satI (n - 1) q) delta 46 | foldM (step n p) [mempty] delta 47 | 48 | step :: Int -> Pred -> [Subst] -> (Subst, [Pred]) -> TcM [Subst] 49 | step 0 p _ _ = throwError $ unwords [ "Could not deduce:" 50 | , pretty p 51 | , "because the solver exceeded the max number of iterations!" 52 | ] 53 | step n p sacc (s,ps) 54 | = do 55 | ss <- liftM (map (s <>)) (satI (n - 1) ps) 56 | return [s' <> s1 | s' <- ss, s1 <- sacc] 57 | 58 | -- function sats 59 | 60 | sats :: Pred -> TcM [(Subst, [Pred])] 61 | sats p@(InCls c t ts) 62 | = do 63 | insts <- askInstEnv c 64 | catMaybes <$> mapM (gen t) insts 65 | sats p = tcmError $ "Invalid constraint:" ++ pretty p 66 | 67 | gen :: Ty -> Inst -> TcM (Maybe (Subst, [Pred])) 68 | gen t k@(ps :=> h@(InCls _ t' _)) 69 | = do 70 | r <- defaultM (mgu t t') 71 | case r of 72 | Just s -> pure $ Just (s, apply s ps) 73 | Nothing -> pure Nothing 74 | gen _ _ = pure Nothing 75 | 76 | -- closure 77 | 78 | reach :: [Pred] -> [Tyvar] -> [Pred] 79 | reach ps vs = [p | p@(InCls _ t _) <- ps, fv t `subset` vs] 80 | 81 | closure :: [Pred] -> [Tyvar] -> [Pred] 82 | closure ps vs 83 | | fv (reach ps vs) `subset` vs = reach ps vs 84 | | otherwise = closure ps (fv (reach ps vs)) 85 | 86 | -- utilities 87 | 88 | subset :: Eq a => [a] -> [a] -> Bool 89 | subset ps qs = all (\ x -> x `elem` qs) ps 90 | 91 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/TcSubst.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | module Solcore.Frontend.TypeInference.TcSubst where 3 | 4 | import Data.List 5 | 6 | import Solcore.Frontend.Syntax 7 | 8 | -- basic substitution infrastructure 9 | 10 | newtype Subst 11 | = Subst { unSubst :: [(Tyvar, Ty)] } deriving (Eq, Show) 12 | 13 | restrict :: Subst -> [Tyvar] -> Subst 14 | restrict (Subst s) vs 15 | = Subst [(v,t) | (v,t) <- s, v `notElem` vs] 16 | 17 | emptySubst :: Subst 18 | emptySubst = Subst [] 19 | 20 | -- composition operators 21 | 22 | instance Semigroup Subst where 23 | s1 <> s2 = Subst (outer ++ inner) 24 | where 25 | outer = [(u, apply s1 t) | (u, t) <- unSubst s2] 26 | inner = [(v,t) | (v,t) <- unSubst s1, v `notElem` dom2] 27 | dom2 = map fst (unSubst s2) 28 | 29 | instance Monoid Subst where 30 | mempty = emptySubst 31 | 32 | (+->) :: Tyvar -> Ty -> Subst 33 | u +-> t = Subst [(u, t)] 34 | 35 | class HasType a where 36 | apply :: Subst -> a -> a 37 | fv :: a -> [Tyvar] 38 | 39 | instance (HasType a, HasType b, HasType c) => HasType (a,b,c) where 40 | apply s (z,x,y) = (apply s z, apply s x, apply s y) 41 | fv (z,x,y) = fv z `union` fv x `union` fv y 42 | 43 | instance (HasType a, HasType b) => HasType (a,b) where 44 | apply s (x,y) = (apply s x, apply s y) 45 | fv (x,y) = fv x `union` fv y 46 | 47 | instance HasType a => HasType [a] where 48 | apply s = map (apply s) 49 | fv = foldr (union . fv) [] 50 | 51 | 52 | instance HasType a => HasType (Maybe a) where 53 | apply :: HasType a => Subst -> Maybe a -> Maybe a 54 | apply s = fmap (apply s) 55 | fv = maybe [] fv 56 | 57 | instance HasType Name where 58 | apply _ n = n 59 | fv _ = [] 60 | 61 | instance HasType Ty where 62 | apply (Subst s) t@(TyVar v) 63 | = maybe t id (lookup v s) 64 | apply s (TyCon n ts) 65 | = TyCon n (map (apply s) ts) 66 | 67 | fv (TyVar v) = [v] 68 | fv (TyCon _ ts) = fv ts 69 | 70 | instance HasType Constr where 71 | apply s (Constr dn ts) 72 | = Constr dn (apply s ts) 73 | fv (Constr _ ts) = fv ts 74 | 75 | instance HasType Pred where 76 | apply s (InCls n t ts) = InCls n (apply s t) (apply s ts) 77 | apply s (t1 :~: t2) = (apply s t1) :~: (apply s t2) 78 | 79 | fv (InCls _ t ts) = fv (t : ts) 80 | fv (t1 :~: t2) = fv [t1,t2] 81 | 82 | instance HasType a => HasType (Qual a) where 83 | apply s (ps :=> t) = (apply s ps) :=> (apply s t) 84 | fv (ps :=> t) = fv ps `union` fv t 85 | 86 | instance HasType Scheme where 87 | apply s (Forall vs t) 88 | = Forall vs (apply s' t) 89 | where 90 | s' = restrict s vs 91 | fv (Forall vs t) 92 | = fv t \\ vs 93 | 94 | instance HasType a => HasType (Signature a) where 95 | apply s (Signature vs ctx n p r) 96 | = let 97 | ctx' = apply s ctx 98 | p' = apply s p 99 | r' = apply s r 100 | vs' = fv ctx' `union` fv p' `union` fv r' 101 | in Signature vs' ctx' n p' r' 102 | fv (Signature vs c _ p r) = fv (c,p,r) \\ vs 103 | 104 | instance HasType a => HasType (Param a) where 105 | apply s (Typed i t) = Typed (apply s i) (apply s t) 106 | apply s (Untyped i) = Untyped (apply s i) 107 | fv (Typed i t) = fv (i,t) 108 | fv (Untyped i) = fv i 109 | 110 | instance HasType a => HasType (FunDef a) where 111 | apply s (FunDef sig bd) 112 | = FunDef (apply s sig) (apply s bd) 113 | fv (FunDef sig bd) 114 | = fv sig `union` fv bd 115 | 116 | instance HasType a => HasType (Instance a) where 117 | apply s (Instance d ctx n ts t funs) 118 | = Instance d 119 | (apply s ctx) 120 | n 121 | (apply s ts) 122 | (apply s t) 123 | (apply s funs) 124 | fv (Instance _ ctx n ts t funs) 125 | = fv ctx `union` fv (t : ts) 126 | 127 | instance HasType a => HasType (Exp a) where 128 | apply s (Var v) = Var (apply s v) 129 | apply s (Con n es) 130 | = Con (apply s n) (apply s es) 131 | apply s (FieldAccess e v) 132 | = FieldAccess (apply s e) (apply s v) 133 | apply s (Call m v es) 134 | = Call (apply s <$> m) (apply s v) (apply s es) 135 | apply s (Lam ps bd mt) 136 | = Lam (apply s ps) (apply s bd) (apply s <$> mt) 137 | apply s (TyExp e ty) 138 | = TyExp (apply s e) (apply s ty) 139 | apply s (Lit l) = Lit l 140 | 141 | fv (Var v) = fv v 142 | fv (Con n es) 143 | = fv n `union` fv es 144 | fv (FieldAccess e v) 145 | = fv e `union` fv v 146 | fv (Call m v es) 147 | = maybe [] fv m `union` fv v `union` fv es 148 | fv (Lam ps bd mt) 149 | = fv ps `union` fv bd `union` maybe [] fv mt 150 | fv (TyExp e ty) 151 | = fv e `union` fv ty 152 | 153 | instance HasType a => HasType (Stmt a) where 154 | apply s (e1 := e2) 155 | = (apply s e1) := (apply s e2) 156 | apply s (Let v mt me) 157 | = Let (apply s v) 158 | (apply s <$> mt) 159 | (apply s <$> me) 160 | apply s (StmtExp e) 161 | = StmtExp (apply s e) 162 | apply s (Return e) 163 | = Return (apply s e) 164 | apply s (Match es eqns) 165 | = Match (apply s es) (apply s eqns) 166 | apply _ s 167 | = s 168 | 169 | fv (e1 := e2) 170 | = fv e1 `union` fv e2 171 | fv (Let v mt me) 172 | = fv v `union` (maybe [] fv mt) 173 | `union` (maybe [] fv me) 174 | fv (StmtExp e) = fv e 175 | fv (Return e) = fv e 176 | fv (Match es eqns) 177 | = fv es `union` fv eqns 178 | fv (Asm blk) = [] 179 | 180 | instance HasType a => HasType (Pat a) where 181 | apply s (PVar v) = PVar (apply s v) 182 | apply s (PCon v ps) 183 | = PCon (apply s v) (apply s ps) 184 | apply _ p = p 185 | 186 | fv (PVar v) = fv v 187 | fv (PCon v ps) = fv v `union` fv ps 188 | 189 | 190 | -------------------------------------------------------------------------------- /src/Solcore/Frontend/TypeInference/TcUnify.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Frontend.TypeInference.TcUnify where 2 | 3 | import Control.Monad 4 | import Control.Monad.Except 5 | import Control.Monad.Reader 6 | 7 | import Data.List 8 | 9 | import Common.Pretty 10 | import Solcore.Frontend.Pretty.SolcorePretty hiding ((<>)) 11 | import Solcore.Frontend.Syntax 12 | import Solcore.Frontend.TypeInference.TcSubst 13 | 14 | -- standard unification machinery 15 | 16 | varBind :: (MonadError String m) => Tyvar -> Ty -> m Subst 17 | varBind v t 18 | | t == TyVar v = return mempty 19 | | v `elem` fv t = infiniteTyErr v t 20 | | otherwise = do 21 | return (v +-> t) 22 | 23 | isTyCon :: Ty -> Bool 24 | isTyCon (TyCon _ _) = True 25 | isTyCon _ = False 26 | 27 | -- type matching 28 | 29 | class Match a where 30 | match :: (MonadError String m) => a -> a -> m Subst 31 | 32 | instance Match Ty where 33 | match (TyCon n ts) (TyCon n' ts') 34 | | n == n' = match ts ts' 35 | match t1@(TyVar v) t 36 | | t1 == t = pure mempty 37 | | otherwise = do 38 | pure (v +-> t) 39 | match t1 t2 = typesNotMatch t1 t2 40 | 41 | instance (Pretty a, Match a) => Match [a] where 42 | match [] [] = pure mempty 43 | match (t : ts) (t' : ts') = 44 | do 45 | s1 <- match t t' 46 | s2 <- match ts ts' 47 | merge s1 s2 48 | match ts ts' = typesMatchListErr (map pretty ts) (map pretty ts') 49 | 50 | instance Match Pred where 51 | match (InCls n t ts) (InCls n' t' ts') 52 | | n == n' = match (t : ts) (t' : ts') 53 | | otherwise = throwError "Classes differ!" 54 | 55 | instance (HasType a, Match a) => Match (Qual a) where 56 | match (ps :=> t) (ps' :=> t') = 57 | do 58 | s1 <- match t t' 59 | s2 <- match (apply s1 t) (apply s1 t') 60 | merge s1 s2 61 | 62 | -- most general unifier 63 | 64 | mgu :: (MonadError String m) => Ty -> Ty -> m Subst 65 | mgu (TyCon n ts) (TyCon n' ts') 66 | | n == n' && length ts == length ts' = 67 | solve (zip ts ts') mempty 68 | mgu (TyVar v) t = varBind v t 69 | mgu t (TyVar v) = varBind v t 70 | mgu t1 t2 = typesDoNotUnify t1 t2 71 | 72 | mguPred :: (MonadError String m) => Pred -> Pred -> m Subst 73 | mguPred p@(InCls n t ts) p'@(InCls n' t' ts') 74 | | n == n' = unifyTypes (t : ts) (t' : ts') 75 | | otherwise = 76 | throwError $ 77 | unlines 78 | [ "Cannot unify predicates:" 79 | , pretty p 80 | , "with" 81 | , pretty p' 82 | ] 83 | mguPred (t1 :~: t2) (t1' :~: t2') = 84 | unifyTypes [t1, t2] [t1', t2'] 85 | 86 | solve :: (MonadError String m) => [(Ty, Ty)] -> Subst -> m Subst 87 | solve [] s = pure s 88 | solve ((t1, t2) : ts) s = 89 | do 90 | s1 <- mgu (apply s t1) (apply s t2) 91 | s2 <- solve ts s1 92 | pure (s2 <> s1) 93 | 94 | unifyTypes :: (MonadError String m) => [Ty] -> [Ty] -> m Subst 95 | unifyTypes ts ts' = solve (zip ts ts') mempty 96 | 97 | unifyAllTypes :: (MonadError String m) => [Ty] -> m Subst 98 | unifyAllTypes [] = pure mempty 99 | unifyAllTypes (t : ts) = 100 | do 101 | s1 <- unifyAllTypes ts 102 | s2 <- mgu (apply s1 t) (apply s1 t) 103 | pure (s2 <> s1) 104 | 105 | -- composition operator for matching 106 | 107 | merge :: (MonadError String m) => Subst -> Subst -> m Subst 108 | merge s1@(Subst p1) s2@(Subst p2) = 109 | if agree 110 | then pure (Subst (p1 ++ p2)) 111 | else mergeError disagree 112 | where 113 | disagree = foldr step [] (dom p1 `intersect` dom p2) 114 | step v ac 115 | | alphaEq (apply s1 (TyVar v)) (apply s2 (TyVar v)) = ac 116 | | otherwise = (apply s1 (TyVar v), apply s2 (TyVar v)) : ac 117 | agree = 118 | all 119 | (\v -> alphaEq (apply s1 (TyVar v)) (apply s2 (TyVar v))) 120 | (dom p1 `intersect` dom p2) 121 | dom s = map fst s 122 | 123 | mergeError :: (MonadError String m) => [(Ty, Ty)] -> m a 124 | mergeError ts = throwError $ unlines $ "Cannot match types:" : ss 125 | where 126 | ss = map go ts 127 | go (x, y) = pretty x ++ " with " ++ pretty y 128 | 129 | -- basic error messages 130 | 131 | infiniteTyErr :: (MonadError String m) => Tyvar -> Ty -> m a 132 | infiniteTyErr v t = 133 | throwError $ 134 | unwords 135 | [ "Cannot construct the infinite type:" 136 | , pretty v 137 | , "~" 138 | , pretty t 139 | ] 140 | 141 | typesNotMatch :: (MonadError String m) => Ty -> Ty -> m a 142 | typesNotMatch t1 t2 = 143 | throwError $ 144 | unwords 145 | [ "Types do not match:" 146 | , pretty t1 147 | , "and" 148 | , pretty t2 149 | ] 150 | 151 | typesMatchListErr :: (MonadError String m) => [String] -> [String] -> m a 152 | typesMatchListErr ts ts' = 153 | throwError (errMsg (zip ts ts')) 154 | where 155 | errMsg ps = 156 | unwords ["Types do not match:"] 157 | ++ concatMap tyList ps 158 | tyList (t1, t2) = t1 <> " and " <> t2 159 | 160 | typesDoNotUnify :: (MonadError String m) => Ty -> Ty -> m a 161 | typesDoNotUnify t1 t2 = 162 | throwError $ 163 | unwords 164 | [ "Types:" 165 | , pretty t1 166 | , "and" 167 | , pretty t2 168 | , "do not unify" 169 | ] 170 | 171 | -------------------------------------------------------------------------------- /src/Solcore/Pipeline/Options.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Pipeline.Options where 2 | import Options.Applicative 3 | 4 | 5 | data Option 6 | = Option 7 | { fileName :: FilePath 8 | , optNoSpec :: !Bool 9 | , optNoDesugarCalls :: !Bool 10 | , optNoMatchCompiler :: !Bool 11 | -- Options controlling printing 12 | , optVerbose :: !Bool 13 | , optDumpDS :: !Bool 14 | , optDumpDF :: !Bool 15 | , optDumpSpec :: !Bool 16 | , optDumpCore :: !Bool 17 | -- Options controlling diagnostic output 18 | , optDebugSpec :: !Bool 19 | , optDebugCore :: !Bool 20 | , optTiming :: !Bool 21 | } deriving (Eq, Show) 22 | 23 | emptyOption :: FilePath -> Option 24 | emptyOption path = Option 25 | { fileName = path 26 | , optNoSpec = False 27 | , optNoDesugarCalls = False 28 | , optNoMatchCompiler = False 29 | -- Options controlling printing 30 | , optVerbose = False 31 | , optDumpDS = False 32 | , optDumpDF = False 33 | , optDumpSpec = False 34 | , optDumpCore = False 35 | -- Options controlling diagnostic output 36 | , optDebugSpec = False 37 | , optDebugCore = False 38 | , optTiming = False 39 | } 40 | 41 | options :: Parser Option 42 | options 43 | = Option <$> strOption ( 44 | long "file" 45 | <> short 'f' 46 | <> metavar "FILE" 47 | <> help "Input file name") 48 | <*> switch ( long "no-specialise" 49 | <> short 'n' 50 | <> help "Skip specialisation and core emission phases") 51 | <*> switch ( long "no-desugar-calls" 52 | <> short 's' 53 | <> help "Skip indirect call desugaring") 54 | <*> switch (long "no-match-compiler" 55 | <> short 'm' 56 | <> help "Skip match compilation") 57 | -- Options controlling printing 58 | <*> switch ( long "verbose" 59 | <> short 'v' 60 | <> help "Verbose output") 61 | <*> switch ( long "dump-ds" 62 | <> help "Dump desugared contract") 63 | <*> switch ( long "dump-df" 64 | <> help "Dump defunctionalised contract") 65 | <*> switch ( long "dump-spec" 66 | <> help "Dump specialised contract") 67 | <*> switch ( long "dump-core" 68 | <> help "Dump low-level core") 69 | -- Options controlling diagnostic output 70 | <*> switch ( long "debug-spec" 71 | <> help "Debug specialisation") 72 | <*> switch ( long "debug-core" 73 | <> help "Debug core emission") 74 | <*> switch ( long "timing" 75 | <> help "Measure time of some phases") 76 | 77 | 78 | -- parsing command line arguments 79 | argumentsParser :: IO Option 80 | argumentsParser = do 81 | let opts = info (options <**> helper) 82 | (fullDesc <> 83 | header "Solcore - solidity core language") 84 | execParser opts 85 | -------------------------------------------------------------------------------- /src/Solcore/Pipeline/SolcorePipeline.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Pipeline.SolcorePipeline where 2 | 3 | import Control.Monad 4 | 5 | import qualified Data.Map as Map 6 | import qualified Data.Time as Time 7 | import Solcore.Desugarer.IndirectCall (indirectCall) 8 | import Solcore.Desugarer.LambdaLifting (lambdaLifting) 9 | import Solcore.Desugarer.MatchCompiler 10 | import Solcore.Desugarer.UniqueTypeGen (uniqueTypeGen) 11 | import Solcore.Frontend.Lexer.SolcoreLexer 12 | import Solcore.Frontend.Parser.SolcoreParser 13 | import Solcore.Frontend.Pretty.SolcorePretty 14 | import Solcore.Frontend.Syntax.ElabTree 15 | import Solcore.Frontend.Syntax.Contract 16 | import Solcore.Frontend.Syntax 17 | import Solcore.Frontend.TypeInference.SccAnalysis 18 | import Solcore.Frontend.TypeInference.TcContract 19 | import Solcore.Frontend.TypeInference.TcEnv 20 | import Solcore.Desugarer.Specialise(specialiseCompUnit) 21 | import Solcore.Desugarer.EmitCore(emitCore) 22 | import Solcore.Pipeline.Options(Option(..), argumentsParser) 23 | import System.Exit 24 | import System.FilePath 25 | import qualified System.TimeIt as TimeIt 26 | 27 | -- main compiler driver function 28 | pipeline :: IO () 29 | pipeline = do 30 | startTime <- Time.getCurrentTime 31 | opts <- argumentsParser 32 | let verbose = optVerbose opts 33 | noDesugarCalls = optNoDesugarCalls opts 34 | noMatchCompiler = optNoMatchCompiler opts 35 | timeItNamed :: String -> IO a -> IO a 36 | timeItNamed = optTimeItNamed opts 37 | file = fileName opts 38 | dir = takeDirectory file 39 | t' <- runParser dir file 40 | withErr t' $ \ ast@(CompUnit imps ds) -> do 41 | when verbose $ do 42 | putStrLn "> AST after name resolution" 43 | putStrLn $ pretty ast 44 | r5 <- if noDesugarCalls 45 | then do 46 | r2 <- timeItNamed "SCC " $ sccAnalysis ast 47 | withErr r2 $ \ ast' -> do 48 | when verbose $ do 49 | putStrLn "> SCC Analysis:" 50 | putStrLn $ pretty ast' 51 | timeItNamed "Indirect Calls" $ typeInfer opts ast' 52 | else do 53 | r2 <- timeItNamed "SCC " $ sccAnalysis ast 54 | withErr r2 $ \ ast' -> do 55 | when verbose $ do 56 | putStrLn "> SCC Analysis:" 57 | putStrLn $ pretty ast' 58 | (ast3, fnames) <- timeItNamed "Indirect Calls" $ indirectCall ast' 59 | when verbose $ do 60 | putStrLn "> Indirect call desugaring:" 61 | putStrLn $ pretty ast3 62 | timeItNamed "Typecheck " $ typeInfer opts ast3 63 | withErr r5 $ \ (c', env) -> do 64 | let warns = warnings env 65 | logsInfo = logs env 66 | tyctx = ctx env 67 | ts = generated env 68 | when verbose $ do 69 | putStrLn "> Type inference logs:" 70 | mapM_ putStrLn (reverse $ logsInfo) 71 | putStrLn "> Elaborated tree:" 72 | putStrLn $ pretty c' 73 | if noMatchCompiler then do 74 | unless (optNoSpec opts) do 75 | r9 <- timeItNamed "Specialise " $ specialiseCompUnit c' (optDebugSpec opts) env 76 | when (optDumpSpec opts) do 77 | putStrLn "> Specialised contract:" 78 | putStrLn (pretty r9) 79 | r10 <- timeItNamed "Emit Core " $ emitCore (optDebugCore opts) env r9 80 | when (optDumpCore opts) do 81 | putStrLn "> Core contract(s):" 82 | forM_ r10 (putStrLn . pretty) 83 | else do 84 | r8 <- timeItNamed "Match compiler" $ matchCompiler c' 85 | withErr r8 $ \ res -> do 86 | when (verbose || optDumpDS opts) do 87 | putStrLn "> Match compilation result:" 88 | putStrLn (pretty res) 89 | unless (optNoSpec opts) do 90 | r9 <- timeItNamed "Specialise " $ specialiseCompUnit res (optDebugSpec opts) env 91 | when (optDumpSpec opts) do 92 | putStrLn "> Specialised contract:" 93 | putStrLn (pretty r9) 94 | r10 <- timeItNamed "Emit Core " $ emitCore (optDebugCore opts) env r9 95 | when (optDumpCore opts) do 96 | putStrLn "> Core contract(s):" 97 | forM_ r10 (putStrLn . pretty) 98 | 99 | runParser :: String -> String -> IO (Either String (CompUnit Name)) 100 | runParser dir file = do 101 | content <- readFile file 102 | r1 <- moduleParser dir content 103 | case r1 of 104 | Left err -> pure $ Left err 105 | Right t -> buildAST t 106 | 107 | withErr :: Either String a -> (a -> IO b) -> IO b 108 | withErr r f 109 | = either err f r 110 | where 111 | err s = do 112 | putStrLn s 113 | exitWith (ExitFailure 1) 114 | 115 | -- add declarations generated in the previous step 116 | -- and moving data types inside contracts to the 117 | -- global scope. 118 | 119 | moveData :: CompUnit Name -> CompUnit Name 120 | moveData (CompUnit imps decls) 121 | = CompUnit imps (foldr step [] decls) 122 | where 123 | step (TContr c) ac 124 | = let (dts, c') = extractData c 125 | dts' = map TDataDef dts 126 | in (TContr c') : dts' ++ ac 127 | step d ac = d : ac 128 | 129 | extractData :: Contract Name -> ([DataTy], Contract Name) 130 | extractData (Contract n ts ds) 131 | = (ds1, Contract n ts ds0) 132 | where 133 | (ds1, ds0) = foldr step ([], []) ds 134 | step (CDataDecl dt) (dts, cs) = (dt : dts, cs) 135 | step c (dts, cs) = (dts, c : cs) 136 | 137 | addGenerated :: CompUnit Name -> 138 | [TopDecl Name] -> 139 | CompUnit Name 140 | addGenerated (CompUnit imps ds) ts 141 | = CompUnit imps (ds ++ ts) 142 | 143 | optTimeItNamed :: Option -> String -> IO a -> IO a 144 | optTimeItNamed opts s a = if (optTiming opts) then TimeIt.timeItNamed s a else a 145 | -------------------------------------------------------------------------------- /src/Solcore/Pipeline/SolverPipeline.hs: -------------------------------------------------------------------------------- 1 | module Solcore.Pipeline.SolverPipeline where 2 | 3 | import Control.Monad 4 | import Data.List 5 | import qualified Data.Map as Map 6 | 7 | import Solcore.Frontend.Parser.SolverInputParser 8 | import Solcore.Frontend.Pretty.SolcorePretty 9 | import Solcore.Frontend.Syntax.Name 10 | import Solcore.Frontend.Syntax.Ty 11 | import Solcore.Frontend.TypeInference.TcEnv 12 | import Solcore.Frontend.TypeInference.TcMonad 13 | import Solcore.Frontend.TypeInference.TcReduce 14 | import Solcore.Frontend.TypeInference.TcSat 15 | import Solcore.Pipeline.Options 16 | 17 | -- running the satisfiability (for tests) 18 | 19 | runForFile :: FilePath -> IO Bool 20 | runForFile file 21 | = do 22 | content <- readFile file 23 | let res = runParser content 24 | case res of 25 | Left err -> do 26 | putStrLn err 27 | pure False 28 | Right state -> do 29 | runSolver state 30 | 31 | runSolver :: SolverState -> IO Bool 32 | runSolver (SolverState (Theta cls insts) p) 33 | = solveProblem cls insts p 34 | 35 | solveProblem :: [Qual Pred] -> [Qual Pred] -> SolverProblem -> IO Bool 36 | solveProblem cls insts (Sat ps) 37 | = runSat (correct cls) (correct insts) (correct ps) 38 | solveProblem cls insts (Reduce ps qs) 39 | = runReduce (correct cls) (correct insts) (correct ps) (correct qs) 40 | 41 | -- simple hack: type variables on tests 42 | -- should be strings of length 1 43 | 44 | class Correct a where 45 | correct :: a -> a 46 | 47 | instance Correct a => Correct [a] where 48 | correct = map correct 49 | 50 | instance Correct Ty where 51 | correct t@(TyCon n ts) 52 | | isVar n = TyVar (TVar n) 53 | | otherwise = TyCon n (correct ts) 54 | 55 | instance Correct Pred where 56 | correct (InCls n t ts) 57 | = InCls n (correct t) (correct ts) 58 | correct (t1 :~: t2) 59 | = (correct t1) :~: (correct t2) 60 | 61 | instance Correct (Qual Pred) where 62 | correct (ps :=> p) 63 | = (correct ps) :=> (correct p) 64 | 65 | isVar :: Name -> Bool 66 | isVar n = length (pretty n) == 1 67 | 68 | runSat :: [Qual Pred] -> [Qual Pred] -> [Pred] -> IO Bool 69 | runSat cls insts ps 70 | = do 71 | let 72 | senv = buildEnv cls insts 73 | res <- runTcM (sat ps) senv 74 | case res of 75 | Left err -> do 76 | putStrLn err 77 | pure False 78 | Right ([s], _) -> do 79 | putStrLn "Constraint is satisfiable!" 80 | pure True 81 | Right (ss, _) -> do 82 | when (null ss) (putStrLn $ "Could not satisfy " ++ unwords (map pretty ps)) 83 | unless (null ss) (putStrLn $ "Not unique solution for " ++ unwords (map pretty ps)) 84 | pure False 85 | 86 | runReduce :: [Qual Pred] -> [Qual Pred] -> [Pred] -> [Pred] -> IO Bool 87 | runReduce cls insts ps qs 88 | = do 89 | let 90 | senv = buildEnv cls insts 91 | res <- runTcM (reduce ps) senv 92 | case res of 93 | Left err -> do 94 | putStrLn err 95 | pure False 96 | Right (ps', _) -> do 97 | putStrLn $ "Reduced constraints:" ++ pretty ps' 98 | putStrLn $ "Desired:" ++ pretty qs 99 | putStrLn $ "Final result:" ++ show (ps' == qs) 100 | pure (ps' == qs) 101 | 102 | buildEnv :: [Qual Pred] -> [Qual Pred] -> TcEnv 103 | buildEnv cls insts = insertClasses cls (insertInsts insts) 104 | 105 | insertClasses :: [Qual Pred] -> TcEnv -> TcEnv 106 | insertClasses cls env = foldr step env cls 107 | where 108 | step c@(ps :=> h@(InCls n t ts)) senv 109 | = let 110 | info = ClassInfo (length (t : ts)) [] h ps 111 | in senv {classTable = Map.insert n info (classTable senv) } 112 | 113 | insertInsts :: [Qual Pred] -> TcEnv 114 | insertInsts 115 | = foldr step (initTcEnv (emptyOption "")) 116 | where 117 | step i@(ps :=> h@(InCls c _ _)) senv 118 | = senv{ instEnv = Map.insertWith (++) c [i] (instEnv senv) } 119 | -------------------------------------------------------------------------------- /src/Solcore/Primitives/Primitives.solc: -------------------------------------------------------------------------------- 1 | data Unit = Unit 2 | type Memory[a] = Word 3 | 4 | class ref : Ref[deref] { 5 | function load (r : ref) -> deref ; 6 | function store (r : ref, v : deref) ; 7 | } 8 | 9 | type Stack [a] = a 10 | 11 | instance Stack[a] : Ref [Memory[a]] { 12 | function load (r : Stack[a]) -> Memory[a] {} 13 | 14 | function store(r : Stack[a], v : Memory[a]) {} 15 | } 16 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Cases 4 | import Solver 5 | import Test.Tasty 6 | 7 | main :: IO () 8 | main = defaultMain tests 9 | 10 | tests :: TestTree 11 | tests 12 | = testGroup "Tests" 13 | [ 14 | cases 15 | , pragmas 16 | , spec 17 | , std 18 | , imports 19 | , reduceTests 20 | ] 21 | -------------------------------------------------------------------------------- /test/Solver.hs: -------------------------------------------------------------------------------- 1 | module Solver where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.Program 5 | import Test.Tasty.ExpectedFailure 6 | 7 | 8 | -- constructing the test suit 9 | 10 | satTests :: TestTree 11 | satTests = testGroup "Tests for SAT" 12 | [ 13 | testFile solverDir "sat00.inp" 14 | , testFile solverDir "sat01.inp" 15 | , testFile solverDir "sat02.inp" 16 | , testFile solverDir "sat03.inp" 17 | , expectFail $ testFile solverDir "sat04.inp" 18 | , expectFail $ testFile solverDir "sat05.inp" 19 | ] 20 | where 21 | solverDir = "./test/solver" 22 | 23 | testFile :: String -> String -> TestTree 24 | testFile folder file 25 | = testProgram file "cabal" (basicOptions ++ [folder ++ "/" ++ file]) Nothing 26 | where 27 | basicOptions = ["run", "solver", "--"] 28 | 29 | 30 | reduceTests :: TestTree 31 | reduceTests = testGroup "Tests for reduce" 32 | [ 33 | testFile solverDir "red00.inp" 34 | , testFile solverDir "red01.inp" 35 | , testFile solverDir "red02.inp" 36 | , testFile solverDir "red03.inp" 37 | , testFile solverDir "red04.inp" 38 | , testFile solverDir "red05.inp" 39 | , testFile solverDir "red06.inp" 40 | ] 41 | where 42 | solverDir = "./test/solver" 43 | 44 | 45 | -------------------------------------------------------------------------------- /test/examples/Convertible.solc: -------------------------------------------------------------------------------- 1 | data Pair(a,b) = Pair(a,b); 2 | data Proxy(a) = Proxy; 3 | data Unit = Unit; 4 | 5 | class a:Typedef(r) { 6 | function abs(x:r) -> a; 7 | function rep(x:a) -> r; 8 | } 9 | 10 | 11 | data uint16 = uint16(word); 12 | 13 | instance uint16:Typedef(word) { 14 | function abs(r:word) { return uint16(r);} 15 | function rep(x: uint16) -> word { 16 | match x { 17 | | uint16(val) => return val; 18 | }; 19 | } 20 | } 21 | 22 | data uint8 = uint8(word); 23 | 24 | instance uint8:Typedef(word) { 25 | function abs(r:word) { return uint8(r);} 26 | function rep(x: uint8) -> word { 27 | match x { 28 | | uint8(val) => return val; 29 | }; 30 | } 31 | } 32 | 33 | data uint256 = uint256(word); 34 | 35 | instance uint256:Typedef(word) { 36 | function abs(r:word) { return uint256(r);} 37 | function rep(x: uint256) -> word { 38 | match x { 39 | | uint256(val) => return val; 40 | }; 41 | } 42 | } 43 | 44 | 45 | function foo(x:word) -> uint16 { 46 | let result : uint16 = Typedef.abs(x); 47 | return result; 48 | } 49 | 50 | 51 | class self:Convertible(r) 52 | { 53 | function convert(x:self) -> r; 54 | } 55 | 56 | instance Pair(uint8,Proxy(uint16)):Convertible(uint16) { 57 | function convert(p:Pair(uint8,Proxy(uint16))) -> uint16 { 58 | match p { 59 | | Pair(x, _) => return Typedef.abs(Typedef.rep(x)); 60 | }; 61 | } 62 | } 63 | 64 | 65 | 66 | function uint8to16(x : uint8) -> uint16 { 67 | let proxy : Proxy(uint16) = Proxy; 68 | let result : uint16 = Convertible.convert(Pair(x,proxy)); 69 | return result; 70 | } 71 | 72 | /* 73 | forall Pair(a,Proxy(b)):Convertible(b). function convert(x:a) -> b { 74 | let proxy : Proxy(b) = Proxy; 75 | let result : b = Convertible.convert(Pair(x,proxy)); 76 | return result; 77 | } 78 | */ 79 | 80 | forall a, b. function convert(x:a) -> b { 81 | let proxy : Proxy(b) = Proxy; 82 | let result : b = Convertible.convert(Pair(x,proxy)); 83 | return result; 84 | } 85 | 86 | function bar(x:Unit) -> word { 87 | let result: word = convert(x); 88 | return result; 89 | } 90 | 91 | 92 | instance Pair(uint8,Proxy(uint256)):Convertible(uint256) { 93 | function convert(p:Pair(uint8,Proxy(uint256))) -> uint256 { 94 | match p { 95 | | Pair(x, _) => return Typedef.abs(Typedef.rep(x)); 96 | }; 97 | } 98 | } 99 | 100 | instance Pair(uint16,Proxy(uint256)):Convertible(uint256) { 101 | function convert(p:Pair(uint16,Proxy(uint256))) -> uint256 { 102 | match p { 103 | | Pair(x, _) => return Typedef.abs(Typedef.rep(x)); 104 | }; 105 | } 106 | } 107 | 108 | 109 | 110 | contract Bar { 111 | 112 | function main() -> word { 113 | let x = Unit; 114 | let y : word = convert(x); 115 | return y; 116 | } 117 | 118 | } -------------------------------------------------------------------------------- /test/examples/cases/Ackermann.solc: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Succ(Nat) ; 2 | 3 | function foo (x, y) { 4 | match y, x { 5 | | y1, Zero => return 1 ; 6 | | Zero, Succ(x2) => return 2; 7 | | Succ(y3), Succ(x3) => return 3; 8 | } 9 | } 10 | 11 | -------------------------------------------------------------------------------- /test/examples/cases/Add1.solc: -------------------------------------------------------------------------------- 1 | contract Add1 { 2 | function main() { 3 | let res: word; 4 | assembly { 5 | res := add(40, 2) 6 | } 7 | return res; 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/BadInstance.solc: -------------------------------------------------------------------------------- 1 | class a:Enum { 2 | function fromEnum(x:a) -> word; 3 | } 4 | 5 | data Color = R | G | B; 6 | 7 | data Bool = False | True; 8 | 9 | instance Bool : Enum { 10 | function fromEnum(b) { 11 | match b { 12 | | R => return 0; 13 | | G => return 1; 14 | }; 15 | } 16 | } 17 | 18 | 19 | -------------------------------------------------------------------------------- /test/examples/cases/BoolNot.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | 3 | function not (b) { 4 | match b { 5 | | False => return True ; 6 | | True => return False ; 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /test/examples/cases/Compose.solc: -------------------------------------------------------------------------------- 1 | function compose(f,g) { 2 | return lam (x) { 3 | return f(g(x)); 4 | } ; 5 | } 6 | 7 | function id(x) { return x; } 8 | 9 | function main() { 10 | let f = compose(id,id); 11 | return f(42); 12 | } 13 | 14 | -------------------------------------------------------------------------------- /test/examples/cases/Compose2.solc: -------------------------------------------------------------------------------- 1 | contract Compose { 2 | function compose(f,g) { 3 | return lam (x) { 4 | return f(g(x)); 5 | } ; 6 | } 7 | 8 | function id(x) { return x; } 9 | 10 | function idid() { return compose(id,id); } 11 | 12 | // function main() { return idid(42); } 13 | 14 | function main() { 15 | let f = compose(id,id); 16 | return f(42); 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /test/examples/cases/Compose3.solc: -------------------------------------------------------------------------------- 1 | contract Compose { 2 | function compose(f,g) { 3 | return lam (x) { 4 | return f(g(x)); 5 | } ; 6 | } 7 | 8 | function id(x) { return x; } 9 | 10 | function idid() { return compose(id,id); } 11 | 12 | function apply1(f, a) { return f(a); } 13 | 14 | function main() { 15 | return apply1(compose(id, id), 42); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/examples/cases/DupFun.solc: -------------------------------------------------------------------------------- 1 | function f(x : word) -> word { 2 | return x; 3 | } 4 | 5 | function f(x : word) -> word { 6 | return 10; 7 | } 8 | 9 | function g(x : word) -> word { 10 | return f(x); 11 | } 12 | -------------------------------------------------------------------------------- /test/examples/cases/DuplicateFun.solc: -------------------------------------------------------------------------------- 1 | 2 | class self:A { 3 | function foo(p : self) -> word; 4 | } 5 | 6 | class self:B { 7 | function foo(p : self) -> word; 8 | } 9 | 10 | instance word:B { 11 | function foo(x : word) -> word { 12 | return x; 13 | } 14 | } 15 | 16 | // error: Constraint for A not found in type of foo 17 | instance word:A { 18 | function foo(x : word) -> word { 19 | return x; 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/cases/EitherModule.solc: -------------------------------------------------------------------------------- 1 | contract EitherModule { 2 | data Either(a,b) = Left(a) | Right(b); 3 | data List(a) = Nil | Cons(a,List(a)); 4 | 5 | function lefts(xs) { 6 | match xs { 7 | | Nil => return Nil ; 8 | | Cons(y,ys) => 9 | match y { 10 | | Left(z) => return Cons(z,lefts(ys)) ; 11 | | Right(z) => return lefts(ys) ; 12 | } 13 | } 14 | } 15 | 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/cases/Enum.solc: -------------------------------------------------------------------------------- 1 | class a: Enum { 2 | function fromEnum(a) -> word; 3 | } 4 | 5 | data Food = Curry | Beans | Other; 6 | 7 | instance Food : Enum { 8 | function fromEnum(x : Food) { 9 | match x { 10 | | Curry => return 1; 11 | | Beans => return 2; 12 | | Other => return 3; 13 | } 14 | } 15 | } 16 | 17 | contract Food { 18 | function main() { 19 | return Enum.fromEnum(Beans); 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/cases/Eq.solc: -------------------------------------------------------------------------------- 1 | data Bool = True | False; 2 | 3 | class a : Eq { 4 | function eq (x : a, y : a) -> Bool; 5 | } 6 | 7 | forall a . a : Eq => class a : Ord { 8 | function lt (x : a, y : a) -> Bool ; 9 | } 10 | 11 | instance word : Eq { 12 | function eq (x,y) { 13 | match primEqWord(x,y) { 14 | | 0 => 15 | return False; 16 | | _ => 17 | return True ; 18 | }; 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /test/examples/cases/EqQual.solc: -------------------------------------------------------------------------------- 1 | data Bool = True | False; 2 | 3 | class a : Eq { 4 | function eq (x : a, y : a) -> Bool; 5 | } 6 | 7 | forall a . a : Eq => class a : Ord { 8 | function lt (x : a, y : a) -> Bool ; 9 | } 10 | 11 | instance word : Eq { 12 | function eq (x,y) { 13 | match primEqWord(x,y) { 14 | | 0 => 15 | return False; 16 | | _ => 17 | return True ; 18 | } 19 | } 20 | } 21 | 22 | function foo (x) { 23 | return Eq.eq (x, 0); 24 | } 25 | -------------------------------------------------------------------------------- /test/examples/cases/EvenOdd.solc: -------------------------------------------------------------------------------- 1 | contract EvenOdd { 2 | data Nat = Zero | Succ(Nat) 3 | data Bool = False | True 4 | 5 | function even (n) { 6 | match n { 7 | | Zero => return True; 8 | | Succ(m) => return odd(m); 9 | }; 10 | } 11 | 12 | function odd(n) { 13 | match n { 14 | | Zero => return False; 15 | | Succ(m) => return even(m); 16 | }; 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /test/examples/cases/Filter.solc: -------------------------------------------------------------------------------- 1 | data List(a) = Nil | Cons(a,List(a)) 2 | data Bool = False | True 3 | 4 | function and(x,y) { 5 | match x, y { 6 | | False, _ => return False; 7 | | True, z => return z; 8 | }; 9 | } 10 | 11 | class a : Eq { 12 | function eq (x : a, y : a) -> Bool ; 13 | } 14 | 15 | instance Word : Eq { 16 | function eq (x, y) { 17 | match primEqWord(x,y) { 18 | | 0 => return False ; 19 | | _ => return True ; 20 | }; 21 | } 22 | } 23 | 24 | 25 | function filter (f, xs) { 26 | match xs { 27 | | Nil => return Nil ; 28 | | Cons(y,ys) => 29 | match f(y) { 30 | | False => return filter(f,ys); 31 | | True => return Cons(y,filter(f,ys)); 32 | }; 33 | }; 34 | } 35 | 36 | function list1 () { 37 | return Cons(1, Cons(2, Cons(3, Nil))); 38 | } 39 | 40 | function foo0(y) { 41 | return filter((lam (x){ return eq(x,y); }), list1()); 42 | } 43 | 44 | function foo1() { 45 | return filter((lam (x){ return eq(x,1); }), list1()); 46 | } 47 | 48 | function foo2(p,q) { 49 | return filter(lam (x) { return and(p(x), q(x)) ; } 50 | , list1()); 51 | } 52 | 53 | -------------------------------------------------------------------------------- /test/examples/cases/Foo.solc: -------------------------------------------------------------------------------- 1 | function one() { 2 | return primAddWord(1, zero()) ; 3 | } 4 | 5 | function zero () { 6 | return 0; 7 | } 8 | 9 | 10 | -------------------------------------------------------------------------------- /test/examples/cases/GetSet.solc: -------------------------------------------------------------------------------- 1 | contract GetSet { 2 | value : Word ; 3 | 4 | function setValue (x) { 5 | value = x ; 6 | } 7 | 8 | function getValue () { 9 | return value ; 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /test/examples/cases/GoodInstance.solc: -------------------------------------------------------------------------------- 1 | class a:Enum { 2 | function fromEnum(x:a) -> Word; 3 | } 4 | 5 | data Color = R | G | B 6 | 7 | instance Color : Enum { 8 | function fromEnum(c) { 9 | match c { 10 | | R => return 1; 11 | | G => return 2; 12 | | B => return 3; 13 | }; 14 | } 15 | } 16 | 17 | 18 | data Bool = False | True 19 | 20 | instance Bool : Enum { 21 | function fromEnum(b) { 22 | match b { 23 | | False => return 0; 24 | | True => return 1; 25 | }; 26 | } 27 | } 28 | 29 | contract GoodInstance { 30 | function main() { return fromEnum(True);} 31 | } 32 | -------------------------------------------------------------------------------- /test/examples/cases/Id.solc: -------------------------------------------------------------------------------- 1 | function id() { 2 | return lam (x) { return x; } ; 3 | } 4 | 5 | contract Id { 6 | function main () { 7 | let f = id(); 8 | return f(0); 9 | } 10 | } 11 | 12 | 13 | -------------------------------------------------------------------------------- /test/examples/cases/IncompleteInstDef.solc: -------------------------------------------------------------------------------- 1 | class a : Foo(b) { 2 | function foo (x : a, y : b) -> b ; 3 | function faa (y : a) -> a ; 4 | } 5 | 6 | data Bool = False | True; 7 | 8 | data Maybe(a) = Nothing | Just(a); 9 | 10 | instance Bool : Foo(Bool) { 11 | function faa(y) { 12 | return y ; 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/cases/Invokable.solc: -------------------------------------------------------------------------------- 1 | 2 | class self : invokable(args, ret) { 3 | function invoke (s:self, a:args) -> ret; 4 | } 5 | 6 | function id(x) { 7 | return x ; 8 | } 9 | 10 | data IdToken(a) = IdToken; 11 | 12 | instance IdToken(a) : invokable(a,a) { 13 | function invoke(token: IdToken(a), a) -> a { 14 | return id(a); 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/cases/KindTest.solc: -------------------------------------------------------------------------------- 1 | data M = M 2 | function foo(x: M(Word)) {} 3 | 4 | data P(a) = P 5 | function foo2(x: P) {} 6 | -------------------------------------------------------------------------------- /test/examples/cases/ListModule.solc: -------------------------------------------------------------------------------- 1 | contract ListModule { 2 | data List(a) = Nil | Cons(a,List(a)); 3 | data Bool = True | False; 4 | 5 | 6 | function zipWith (f,xs,ys) { 7 | match xs, ys { 8 | | Nil, Nil => return Nil ; 9 | | Cons(x1,xs1), Cons(y1,ys1) => 10 | return Cons(f(x1,y1), zipWith(f,xs1,ys1)) ; 11 | } 12 | } 13 | 14 | function foldr(f, v, xs) { 15 | match xs { 16 | | Nil => return v; 17 | | Cons(y,ys) => 18 | return f(y, foldr(f,v,ys)) ; 19 | } 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/cases/Logic.solc: -------------------------------------------------------------------------------- 1 | contract Logic { 2 | data Bool = True | False; 3 | 4 | function not (x) { 5 | match x { 6 | | True => return False ; 7 | | False => return True ; 8 | } 9 | } 10 | 11 | function and(x, y) { 12 | match x, y { 13 | | False, _ => return False ; 14 | | True , _ => return y ; 15 | } 16 | } 17 | 18 | function and1 (x, y) { 19 | match x, y { 20 | | False, False => return False ; 21 | | True , False => return False; 22 | | False ,True => return False; 23 | | True, True => return True; 24 | } 25 | } 26 | 27 | function elim (f, g, x) { 28 | match x { 29 | | True => return f; 30 | | False => return g; 31 | } 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /test/examples/cases/MatchCall.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | 3 | contract MatchCall { 4 | function f() { 5 | return True; 6 | } 7 | 8 | function main() { 9 | match f() { 10 | | True => return 42; 11 | } 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /test/examples/cases/Memory1.solc: -------------------------------------------------------------------------------- 1 | data memory(a) = memory(word); 2 | 3 | function g() { 4 | let x : memory(memory(word)); 5 | let y : memory(word) = memory(1); 6 | x = memory(0); 7 | } 8 | -------------------------------------------------------------------------------- /test/examples/cases/Memory2.solc: -------------------------------------------------------------------------------- 1 | data Memory(a) = Memory(word); 2 | 3 | function g() { 4 | let x : Memory(Memory(word)) = Memory(0); 5 | } 6 | -------------------------------------------------------------------------------- /test/examples/cases/Mutuals.solc: -------------------------------------------------------------------------------- 1 | contract Mutual { 2 | function main () { 3 | return f(); 4 | } 5 | function f () { 6 | return 42; 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /test/examples/cases/NegPair.solc: -------------------------------------------------------------------------------- 1 | 2 | class a : Neg { 3 | function neg(x:a) -> a; 4 | } 5 | 6 | data B = F | T; 7 | 8 | instance B : Neg { 9 | function neg (x : B) { 10 | match x { 11 | | F => return T; 12 | | T => return F; 13 | } 14 | } 15 | } 16 | 17 | function fst (p) { 18 | match p { 19 | | (x,y) => return x; 20 | } 21 | } 22 | 23 | function snd(p) { 24 | match p { 25 | | (x,y) => return y; 26 | } 27 | } 28 | 29 | 30 | forall a b . a : Neg, b : Neg => instance (a,b):Neg { 31 | function neg(p) { 32 | return (Neg.neg (fst(p)), Neg.neg(snd (p))); 33 | } 34 | } 35 | 36 | contract NegPair { 37 | 38 | function bnot(x) { 39 | match x { 40 | | T => return F; 41 | | F => return T; 42 | } 43 | } 44 | 45 | function fromB(b) { 46 | match b { 47 | | F => return 0; 48 | | T => return 1; 49 | } 50 | } 51 | 52 | function main() { return fromB(fst(Neg.neg((F,T)))); } 53 | } 54 | -------------------------------------------------------------------------------- /test/examples/cases/Option.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function join(mmx) { 5 | match mmx { 6 | | None => return None; 7 | | Some(Some(x)) => return Some(x); 8 | | Some(None) => return None; 9 | } 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /test/examples/cases/Pair.solc: -------------------------------------------------------------------------------- 1 | function fst (x) { 2 | match x { 3 | | (a,_) => return a; 4 | } 5 | } 6 | 7 | function snd(x : (a,b)) -> b { 8 | match x { 9 | | (_,b) => return b; 10 | } 11 | } 12 | 13 | function uncurry(f,x) { 14 | match x { 15 | | (a,b) => return f(a,b); 16 | } 17 | } 18 | 19 | function curry(f,x,y) { 20 | return f((x,y)) ; 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/cases/PairMatch1.solc: -------------------------------------------------------------------------------- 1 | data Pair(a, b) = Pair(a, b); 2 | 3 | function foo(p: a) -> word { 4 | let x: word = p; 5 | return x; 6 | } 7 | -------------------------------------------------------------------------------- /test/examples/cases/PairMatch2.solc: -------------------------------------------------------------------------------- 1 | 2 | function snd(p: (a, word)) -> a { 3 | match p { 4 | | (_, w) => return w; 5 | } 6 | } 7 | 8 | 9 | -------------------------------------------------------------------------------- /test/examples/cases/Peano.solc: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Succ(Nat); 2 | 3 | function natInd (step,v,n) { 4 | match n { 5 | | Zero => return v ; 6 | | Succ(m) => return step(m, natInd(step,v,m)); 7 | } 8 | } 9 | 10 | function add(n,m) { 11 | return natInd (lam (x, acc) {return Succ(acc) ; }, m, n); 12 | } 13 | -------------------------------------------------------------------------------- /test/examples/cases/PeanoMatch.solc: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Succ(Nat); 2 | 3 | function foo(n) { 4 | match n { 5 | | Zero => return Succ(Zero) ; 6 | | Succ(Succ(x)) => return x; 7 | | x => return Zero; 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/Ref.solc: -------------------------------------------------------------------------------- 1 | class ref : Ref(deref) { 2 | function load (r : ref) -> deref; 3 | function store (r : ref, d : deref) -> unit; 4 | } 5 | 6 | data Memory(a) = new(a); 7 | 8 | instance Memory(a) : Ref(a) { 9 | function load (r) { 10 | match r { 11 | | new(x) => return x; 12 | } 13 | } 14 | } 15 | 16 | 17 | -------------------------------------------------------------------------------- /test/examples/cases/RefDeref.solc: -------------------------------------------------------------------------------- 1 | class ref:Loadable (deref) { 2 | function load (r : ref) -> deref; 3 | } 4 | 5 | class ref:Storable (deref) { 6 | function store (r : ref, d : deref) -> Unit; 7 | } 8 | 9 | // haskell style class constraints 10 | forall ref deref . 11 | ref : Loadable(deref) 12 | , ref : Storable(ref) => class ref:Ref (deref) {} 13 | -------------------------------------------------------------------------------- /test/examples/cases/SillyReturn.solc: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Succ(Nat); 2 | data Bool = True | False; 3 | 4 | function even (n) -> Bool { 5 | match n { 6 | | Zero => return 1; return True; 7 | | Succ(m) => return 0; return False; 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/SimpleField.solc: -------------------------------------------------------------------------------- 1 | contract Simple { 2 | val : word ; 3 | 4 | function getVal () { 5 | return val ; 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /test/examples/cases/SimpleInvoke.solc: -------------------------------------------------------------------------------- 1 | function lambdaimpl1 (x) { 2 | return x; 3 | } 4 | data LambdaTy0(a) = LambdaTy0; 5 | class self : invokable (args, ret) { 6 | function invoke (self : self, args : args) -> ret; 7 | } 8 | instance LambdaTy0(a) : invokable (a, a) { 9 | forall a . function invoke (self : LambdaTy0(a), args : a) -> a { 10 | return lambdaimpl1(args); 11 | } 12 | } 13 | contract SimpleLambda { 14 | function f () { 15 | let n = LambdaTy0 ; 16 | return invokable.invoke(n, 0); 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /test/examples/cases/SimpleLambda.solc: -------------------------------------------------------------------------------- 1 | contract SimpleLambda{ 2 | function f (z) { 3 | let n = lam (x,y) { 4 | return primAddWord(x,primAddWord(y,1)); 5 | } ; 6 | let m = lam (x) { 7 | return primAddWord (z,x) ; 8 | } ; 9 | return m(n(1,0)); 10 | } 11 | function main() { 12 | return f(50); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/cases/SingleFun.solc: -------------------------------------------------------------------------------- 1 | function id (x) { 2 | return x ; 3 | } 4 | -------------------------------------------------------------------------------- /test/examples/cases/StructMembers.sol: -------------------------------------------------------------------------------- 1 | /// Other used stdlib classes and types: 2 | class self:Ref(deref) { 3 | function load(x:self) -> deref; 4 | } 5 | 6 | data Uint256 = Uint256(Word) 7 | data Bool = True | False 8 | data Bytes32 = Bytes32(Word) 9 | data Unit = Unit 10 | 11 | data Proxy(t) = Proxy 12 | data Memory(x) = Memory(Word) 13 | 14 | /// Specific new stdlib classes and types: 15 | 16 | class self:StructMember(preceding, memberTy) {} 17 | data StructMember(structType, fieldType) = StructMember 18 | 19 | // "dead" is only here to compensate for non-relaxed coverage condition and 20 | // incorrectly implemented Paterson condition 21 | data MemberAccess(ty, field, dead) = MemberAccess(ty) 22 | 23 | 24 | /// Usage Example / Proof of Concept: 25 | 26 | /* 27 | struct S { 28 | x:Uint256; 29 | y:Bool; 30 | z:Bytes32; 31 | } 32 | */ 33 | 34 | data S = S(Pair(Uint256, Pair(Bool, Bytes32))) 35 | 36 | data Field_x = FieldX // Selector type for "x" 37 | data Field_y = FieldY // Selector type for "y" 38 | data Field_z = FieldZ // Selector type for "z" 39 | 40 | // StructMember instances for field selectors: 41 | instance StructMember(S, Field_x):StructMember(Unit, Uint256) {} 42 | instance StructMember(S, Field_y):StructMember(Uint256, Bool) {} 43 | instance StructMember(S, Field_z):StructMember(Pair(Uint256, Bool), Bytes32) {} 44 | 45 | /* Further compiler-internal builtin instances for use on stack (at least the stackref versions cannot be expressed in-language, 46 | * but none of these rely on any layout other than the compiler-builtin stack layout, so we can handle these purely internally 47 | * as "compiler magic"): 48 | */ 49 | /* 50 | instance MemberAccess(S, Field_x):Ref(Uint256); 51 | instance MemberAccess(stackref(S), Field_x):Ref(stackref(Uint256)); 52 | instance MemberAccess(S, Field_y):Ref(Bool); 53 | instance MemberAccess(stackref(S), Field_y):Ref(stackref(Bool)); 54 | instance MemberAccess(S, Field_z):Ref(Bytes32); 55 | instance MemberAccess(stackref(S), Field_z):Ref(stackref(Bytes32)); 56 | */ 57 | 58 | 59 | /// Size of a type in memory 60 | class self:MemorySize { 61 | function memorySize(x:Proxy(self)) -> Word; 62 | } 63 | 64 | /// Size of the struct member types in memory: 65 | instance Unit:MemorySize { function memorySize(x) -> Word { return 0; } } 66 | instance Uint256:MemorySize { function memorySize(x) -> Word { return 32; } } 67 | instance Bool:MemorySize { function memorySize(x) -> Word { return 32; } } 68 | instance Bytes32:MemorySize { function memorySize(x) -> Word { return 32; } } 69 | 70 | /// Memory size of pairs 71 | instance Pair(a,b):MemorySize { 72 | function memorySize(x) -> Word 73 | { 74 | let pa:Proxy(a); 75 | let pb:Proxy(b); 76 | let sz = memorySize(pa); 77 | let szb = memorySize(pb); 78 | assembly { sz := add(sz, szb) }; // TODO: bounds check? 79 | return sz; 80 | } 81 | 82 | } 83 | 84 | /// Fragments of a generic memory implementation: 85 | class self:MemoryType { 86 | function loadFromMemory(p:Proxy(self), off:Word) -> self; 87 | } 88 | 89 | instance Uint256:MemoryType { 90 | function loadFromMemory(p:Proxy(Uint256), off:Word) -> Uint256 { 91 | let v; 92 | assembly { v := mload(off) }; 93 | return Uint256(v); 94 | } 95 | } 96 | 97 | instance (a:MemoryType) => Memory(a):Ref(a) { 98 | function load(x) { 99 | let p:Proxy(a); 100 | match x { | Memory(off) => return loadFromMemory(p, off); }; 101 | } 102 | } 103 | 104 | /// Crucial instance: member access to struct fields in memory: 105 | 106 | instance ( 107 | StructMember(structType, fieldType):StructMember(precedingTuple, ty), 108 | precedingTuple:MemorySize, 109 | Memory(ty):Ref(ty) 110 | ) => MemberAccess(Memory(structType), fieldType, 111 | // Needs ridiculous amounts of constructor applications due to incorrect implementation of the Paterson Condition 112 | // Needs to mention "ty" due to non-relaxed Coverage Condition 113 | Memory(ty) 114 | ):Ref(ty) 115 | { 116 | function load(x) { 117 | let ptr:Word; 118 | match x { | MemberAccess(Memory(y)) => ptr = y; }; 119 | 120 | let p:Proxy(precedingTuple); 121 | let offset = memorySize(p); 122 | 123 | assembly { ptr := add(ptr, offset) }; 124 | 125 | let tyPtr:Memory(ty) = Memory(ptr); 126 | return load(tyPtr); 127 | } 128 | } 129 | 130 | function test() 131 | { 132 | let x:Memory(S); 133 | let memberAccess:MemberAccess(Memory(S), Field_x, 134 | Memory(Uint256) // will become unnecessary 135 | ); 136 | memberAccess = MemberAccess(x); 137 | let result = load(memberAccess); 138 | /* 139 | Eventually, I imagine ``let result = x.x;`` to merely desugar to 140 | 141 | let result = load(MemberAccess(x):MemberAccess(_, Field_x)); 142 | 143 | which is equivalent to the above. 144 | */ 145 | } 146 | 147 | -------------------------------------------------------------------------------- /test/examples/cases/Uncurry.solc: -------------------------------------------------------------------------------- 1 | function uncurry (f,p) { 2 | match p { 3 | | (x,y) => return f(x,y); 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /test/examples/cases/another-subst.solc: -------------------------------------------------------------------------------- 1 | class a: Foo {function foo(x:a) -> (); } 2 | 3 | forall a b . a : Foo, b : Foo => instance (a,b) : Foo { 4 | function foo( p : (a,b) ) { 5 | match p { 6 | | (pa, pb) => Foo.foo(pa); Foo.foo(pb); 7 | } 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/app.solc: -------------------------------------------------------------------------------- 1 | function app () { 2 | return lam (f, x) {return f(x);}; 3 | } 4 | 5 | function id (x) { 6 | return x; 7 | } 8 | 9 | function foo() { 10 | let f = app(); 11 | return f(id,0); 12 | } 13 | -------------------------------------------------------------------------------- /test/examples/cases/assembly.solc: -------------------------------------------------------------------------------- 1 | class a : Mem { 2 | function size(x : a) -> word; 3 | } 4 | 5 | instance word : Mem { 6 | function size(x : word) -> word { 7 | return 32; 8 | } 9 | } 10 | 11 | function foo () { 12 | let ptr : word; 13 | let size = Mem.size(0); 14 | assembly { 15 | ptr := add(32, size); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/examples/cases/closure.solc: -------------------------------------------------------------------------------- 1 | function foo (z, k : (), a : word) { 2 | let f = lam (x : word, y) { 3 | k; 4 | return primAddWord(a,primAddWord(y,z)); 5 | }; 6 | return f(0,1); 7 | } 8 | -------------------------------------------------------------------------------- /test/examples/cases/comp.solc: -------------------------------------------------------------------------------- 1 | function compose (f,g,x) { 2 | return f(g(x)); 3 | } 4 | -------------------------------------------------------------------------------- /test/examples/cases/complexproxy.solc: -------------------------------------------------------------------------------- 1 | data Proxy(a) = Proxy; 2 | 3 | function add(x:word, y: word) {return x;} 4 | 5 | class self:BaseMemoryType { 6 | function memorySize(x:Proxy(self)) -> word; 7 | } 8 | 9 | 10 | instance word:BaseMemoryType { 11 | function memorySize(x:Proxy(word)) -> word { 12 | return 32; 13 | } 14 | } 15 | 16 | forall a b . a:BaseMemoryType, b:BaseMemoryType => 17 | instance (a,b):BaseMemoryType { 18 | 19 | function memorySize(x) -> word { // not correct semantically, just for debugging 20 | return add(BaseMemoryType.memorySize(Proxy:Proxy(a)), 21 | // BaseMemoryType.memorySize(Proxy:Proxy(b)) 22 | morefun(Proxy:Proxy(b)) 23 | ); 24 | } 25 | } 26 | // this should trigger a type error. 27 | forall t. function morefun(p:Proxy(t)) -> word { return BaseMemoryType.memorySize(Proxy:Proxy(t));} 28 | 29 | contract TestMemoryType { 30 | function main() -> word { 31 | return BaseMemoryType.memorySize(Proxy:Proxy( (word,word) )); 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /test/examples/cases/compose0.solc: -------------------------------------------------------------------------------- 1 | function compose (f,g) { 2 | return lam (x) { 3 | return f(g(x)); 4 | }; 5 | } 6 | -------------------------------------------------------------------------------- /test/examples/cases/const.solc: -------------------------------------------------------------------------------- 1 | function const() { 2 | return lam (x, y) { return y ;} ; 3 | } 4 | 5 | contract Foo { 6 | function main () { 7 | let f = const(); 8 | return f(0,1); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /test/examples/cases/constrained-instance-context.solc: -------------------------------------------------------------------------------- 1 | 2 | 3 | data memory(t) = memory(word); 4 | 5 | class t:ValueTy { 6 | function rep(x:t) -> word; 7 | } 8 | 9 | instance memory(t) : ValueTy { 10 | function rep(x: memory(t)) -> word { 11 | match x { 12 | | memory(w) => return w; 13 | } 14 | } 15 | } 16 | 17 | class ref:Ref(deref) { 18 | function store(loc: ref, value: deref) -> (); 19 | } 20 | 21 | forall t . t : ValueTy => instance memory(t) : Ref(t) { 22 | function store(loc: memory(t), value: t) -> () { 23 | // We don't have a `ValueTy` bound on `t` anywhere, so this should raise a type error... 24 | let vw = ValueTy.rep(value); 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /test/examples/cases/constrained-instance.solc: -------------------------------------------------------------------------------- 1 | 2 | data memory(t) = memory(word); 3 | 4 | class t:ValueTy { 5 | function rep(x:t) -> word; 6 | } 7 | 8 | instance memory(t) : ValueTy { 9 | function rep(x: memory(t)) -> word { 10 | match x { 11 | | memory(w) => return w; 12 | } 13 | } 14 | } 15 | 16 | class ref:Ref(deref) { 17 | function store(loc: ref, value: deref) -> (); 18 | } 19 | 20 | instance memory(t) : Ref(t) { 21 | forall t . t : ValueTy => function store(loc: memory(t), value: t) -> () { 22 | // We don't have a `ValueTy` bound on `t` anywhere, so this should raise a type error... 23 | let vw = ValueTy.rep(value); 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /test/examples/cases/constructor-weak-args.solc: -------------------------------------------------------------------------------- 1 | class ref:Loadable (deref) { 2 | function load (r : ref) -> deref; 3 | } 4 | 5 | forall t . t : Loadable(word) => function foo(v : t) -> word { 6 | return Loadable.load(v); 7 | } 8 | -------------------------------------------------------------------------------- /test/examples/cases/default-inst.solc: -------------------------------------------------------------------------------- 1 | class self:Test { function f(x:self); } 2 | 3 | default instance a:Test { function f(x:self) {}} 4 | 5 | data memory(a) = memory(word); 6 | data Proxy(a) = Proxy; 7 | 8 | instance memory(memory(word)):Test { function f(x:self) {}} 9 | 10 | forall a. 11 | function f(p:Proxy(a)) { 12 | let x:memory(a); 13 | Test.f(x); 14 | } 15 | 16 | function g() { 17 | f(Proxy:Proxy(memory(memory(word)))); // needs to choose default instance in Test.f 18 | f(Proxy:Proxy(memory(word))); // needs to choose concrete instance 19 | } 20 | -------------------------------------------------------------------------------- /test/examples/cases/default-instance-missing.solc: -------------------------------------------------------------------------------- 1 | class self:Test { function f(x:self); } 2 | 3 | data memory(a) = memory(word); 4 | data Proxy(a) = Proxy; 5 | 6 | instance memory(memory(word)):Test { function f(x:self) {}} 7 | 8 | forall a. 9 | function f(p:Proxy(a)) { 10 | let x:memory(a); 11 | Test.f(x); 12 | } 13 | 14 | function g() { 15 | f(Proxy:Proxy(memory(memory(word)))); // needs to choose default instance in Test.f 16 | f(Proxy:Proxy(memory(word))); // needs to choose concrete instance 17 | } 18 | -------------------------------------------------------------------------------- /test/examples/cases/default-instance-weak.solc: -------------------------------------------------------------------------------- 1 | class self:Test(weak) { function f(x:self) -> weak; } 2 | 3 | data memory(a) = memory(word); 4 | data Proxy(a) = Proxy; 5 | 6 | default instance a:Test(word) { function f(x:self) -> word { return 42; }} 7 | 8 | instance memory(memory(word)):Test(bool) { function f(x:self) { return true; }} 9 | 10 | // If we choose the default instance to typecheck f, 11 | // this will pass type-checking, since ``r`` is word. 12 | // But: for a = memory(word), ``r`` will be ``bool`` and this is invalid! 13 | forall a. 14 | function f(p:Proxy(a)) { 15 | let x:memory(a); 16 | let r = Test.f(x); 17 | assembly { 18 | sstore(0, r) 19 | } 20 | } 21 | 22 | function g() { 23 | f(Proxy:Proxy(memory(memory(word)))); // valid, since default instance is used 24 | f(Proxy:Proxy(memory(word))); // PROBLEM: now we have a bool cross the assembly barrier 25 | } 26 | -------------------------------------------------------------------------------- /test/examples/cases/join.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | data Bool = False | True; 4 | 5 | function maybe(n, o) { 6 | match o { 7 | | None => return n; 8 | | Some(x) => return x; 9 | } 10 | } 11 | 12 | function join(mmx) { 13 | let result = None; 14 | match mmx { 15 | | Some(Some(x)) => result = Some(x); 16 | | None => result = None; 17 | } 18 | return result; 19 | } 20 | 21 | function main() { 22 | return maybe(0, join(Some(Some(0)))); 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /test/examples/cases/joinErr.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | data Bool = False | True; 4 | 5 | function maybe(n, o) { 6 | match o { 7 | | None => return n; 8 | | Some(x) => return x; 9 | } 10 | } 11 | 12 | function join(mmx) { 13 | let result = None; 14 | match mmx { 15 | | Some(Some(x)) => result = Some(x); 16 | | None => result = None; 17 | } 18 | return result; 19 | } 20 | 21 | 22 | function main() { 23 | return maybe(0, join(Some(Some(False)))); 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /test/examples/cases/listid.solc: -------------------------------------------------------------------------------- 1 | data List(a) = Nil | Cons(a, List(a)); 2 | 3 | forall a . function id(x : a) -> a { 4 | return x; 5 | } 6 | 7 | function listid(xs) { 8 | match xs { 9 | | Nil => return Nil ; 10 | | Cons(x,xs) => return Cons(id(x), listid(xs)); 11 | }; 12 | } 13 | -------------------------------------------------------------------------------- /test/examples/cases/mainproxy.solc: -------------------------------------------------------------------------------- 1 | data Proxy(a) = Proxy; 2 | 3 | class self:BaseMemoryType { 4 | function memorySize(x:Proxy(self)) -> word; 5 | } 6 | 7 | 8 | instance word:BaseMemoryType { 9 | function memorySize(x:Proxy(self)) -> word { 10 | return 32; 11 | } 12 | } 13 | 14 | 15 | function morefun(p:Proxy(t)) -> word { return BaseMemoryType.memorySize(Proxy:Proxy(t)); 16 | } 17 | 18 | contract TestMemoryType { 19 | function main() -> word { 20 | return morefun(Proxy:Proxy(word)); 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /test/examples/cases/memory.solc: -------------------------------------------------------------------------------- 1 | data Memory(t) = Memory(word); 2 | data Bytes = Bytes; 3 | 4 | function get_bytes() -> Memory(Bytes) { 5 | let ptr : word; 6 | assembly { 7 | ptr := mload(0x40) 8 | } 9 | return Memory(ptr); 10 | } 11 | -------------------------------------------------------------------------------- /test/examples/cases/morefun.solc: -------------------------------------------------------------------------------- 1 | data Proxy(a) = Proxy; 2 | 3 | class a:C { 4 | function fun(p:Proxy(a)) -> word; 5 | } 6 | 7 | forall t . t : C => function morefun(p:Proxy(t)) -> word { 8 | return C.fun(Proxy:Proxy(t)); 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/nid.solc: -------------------------------------------------------------------------------- 1 | function nid() { 2 | return id; 3 | } 4 | function id (x) { 5 | return x; 6 | } 7 | 8 | 9 | -------------------------------------------------------------------------------- /test/examples/cases/noclosure.solc: -------------------------------------------------------------------------------- 1 | function foo (z) { 2 | let f = lam (x : word, y) { 3 | return primAddWord(x,primAddWord(y,1)); 4 | }; 5 | return primAddWord(f(0,1),z); 6 | } 7 | -------------------------------------------------------------------------------- /test/examples/cases/noconstr.solc: -------------------------------------------------------------------------------- 1 | class a : Foo { 2 | function foo (x : a) -> word; 3 | } 4 | 5 | // here the constraint a : Foo is 6 | // defered to outer scope where the 7 | // error should be detected. 8 | 9 | function bla (x : a) -> word { 10 | return Foo.foo(x); 11 | } 12 | 13 | contract Test { 14 | function main() { 15 | return bla(1); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/examples/cases/proxy.solc: -------------------------------------------------------------------------------- 1 | data Proxy(a) = Proxy; 2 | 3 | class self:BaseMemoryType { 4 | function memorySize(x:Proxy(self)) -> word; 5 | } 6 | 7 | 8 | forall t . t : BaseMemoryType => 9 | function morefun(p:Proxy(t)) -> word { 10 | return BaseMemoryType.memorySize(Proxy:Proxy(t)); 11 | } 12 | -------------------------------------------------------------------------------- /test/examples/cases/proxy1.solc: -------------------------------------------------------------------------------- 1 | data Proxy(a) = Proxy; 2 | 3 | class a:C { 4 | function fun(p:Proxy(a)) -> word; 5 | } 6 | 7 | forall t. function morefun(p:Proxy(t)) -> word { 8 | return C.fun(Proxy:Proxy(t)); 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/reference-test.solc: -------------------------------------------------------------------------------- 1 | data memory(a) = memory(word); 2 | 3 | class abs:Typedef(rep) { 4 | function abs(v:rep) -> abs; 5 | function rep(v:abs) -> rep; 6 | } 7 | 8 | instance memory(a):Typedef(word) { 9 | function abs(ptr:word) -> memory(a) { 10 | return memory(ptr); 11 | } 12 | function rep(v:memory(a)) -> word { 13 | match v { 14 | | memory(ptr) => return ptr; 15 | } 16 | } 17 | } 18 | 19 | pragma no-patterson-condition Test; 20 | pragma no-bounded-variable-condition Test; 21 | class self:Test { 22 | function test(x:self) -> word; 23 | } 24 | 25 | instance word:Test { 26 | function test(x:word) -> word { 27 | return x; 28 | } 29 | } 30 | 31 | data test(a) = test(memory(a)); 32 | 33 | instance test(a):Typedef(memory(a)) { 34 | function rep(x:test(a)) -> memory(a) { 35 | match x { 36 | | test(m) => return m; 37 | } 38 | } 39 | function abs(m:memory(a)) -> test(a) { 40 | return test(m); 41 | } 42 | } 43 | 44 | forall abs rep . test(abs):Typedef(rep), rep:Test => 45 | instance test(abs):Test { 46 | function test(x:test(abs)) -> word { 47 | return Test.test(Typedef.rep(x)); 48 | } 49 | } 50 | 51 | contract C { 52 | function main() { 53 | let x:test(word) = test(memory(42)); 54 | let ptr:word = Test.test(x); 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /test/examples/cases/reference.solc: -------------------------------------------------------------------------------- 1 | class ref : Ref(deref) { 2 | function load (r:ref) -> deref; 3 | function store(r:ref, v:deref) -> unit; 4 | } 5 | 6 | data stack(a) = stack(a); 7 | 8 | instance stack(a) : Ref(a) { 9 | } 10 | 11 | data MemberAccess(ty, field) = MemberAccess(ty); 12 | 13 | data PairFst = PairFst; 14 | data PairSnd = PairSnd; 15 | 16 | pragma no-bounded-variable-condition Ref; 17 | data XRef(st, field, fieldType) = XRef(st, field); 18 | forall r : Ref (a,b) . instance XRef(r, PairFst, a) : Ref(a) {} 19 | forall r : Ref (a,b) . instance XRef(r, PairSnd, b) : Ref(b) {} 20 | 21 | contract AssignNested { 22 | function main() { 23 | let x : stack( (word, (word, word)) ); 24 | let z : stack( (word, (word, word)) ); 25 | 26 | // either of the next lines is fine on their own, but not together 27 | Ref.store( XRef(z,PairFst), 21); 28 | Ref.store( XRef(XRef(x, PairSnd), PairFst), 20 ); 29 | 30 | return 77; 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /test/examples/cases/signature.solc: -------------------------------------------------------------------------------- 1 | class self:Typedef(underlyingType) { 2 | function rep(x:self) -> underlyingType; 3 | } 4 | 5 | 6 | forall t:Typedef(word) . function tripleFun(x:t) { 7 | return Typedef.rep(x); 8 | } 9 | -------------------------------------------------------------------------------- /test/examples/cases/super-class.solc: -------------------------------------------------------------------------------- 1 | data List(a) = Nil | Cons(a,List(a)); 2 | data Bool = False | True; 3 | 4 | function and (x,y) { 5 | match x,y { 6 | | False, _ => return False; 7 | | True, y => return y; 8 | } 9 | } 10 | 11 | class a : Eq { 12 | function eq(x : a, y : a) -> Bool; 13 | } 14 | 15 | instance Bool : Eq { 16 | function eq (x : Bool, y : Bool) -> Bool { 17 | match x, y { 18 | | False, False => return True; 19 | | True, True => return True; 20 | | _, _ => return False; 21 | } 22 | } 23 | } 24 | 25 | forall a . a : Eq => instance (List(a)) : Eq { 26 | function eq (xs : List(a), ys : List(a)) -> Bool { 27 | match xs, ys { 28 | | Nil, Nil => return True; 29 | | Cons(x,xs), Cons(y,ys) => 30 | return and(Eq.eq(x,y),Eq.eq(xs,ys)); 31 | } 32 | } 33 | } 34 | 35 | function foo() { 36 | let x = Eq.eq(Nil, Nil); 37 | } 38 | -------------------------------------------------------------------------------- /test/examples/cases/tyexp.solc: -------------------------------------------------------------------------------- 1 | function main () { 2 | let y = 0 : word ; 3 | return y; 4 | } 5 | -------------------------------------------------------------------------------- /test/examples/cases/typedef.solc: -------------------------------------------------------------------------------- 1 | class self:Typedef(underlyingType) { 2 | function rep(x:self) -> underlyingType; 3 | function abs(x:underlyingType) -> self; 4 | } 5 | 6 | forall t . t : Typedef((word,(word,word))) => 7 | function tripleFun(x:t) { 8 | return Typedef.rep(x); 9 | } 10 | -------------------------------------------------------------------------------- /test/examples/cases/unconstrained-instance.solc: -------------------------------------------------------------------------------- 1 | data memory(t) = memory(word); 2 | 3 | class t:ValueTy { 4 | function rep(x:t) -> word; 5 | } 6 | 7 | instance memory(t) : ValueTy { 8 | function rep(x: memory(t)) -> word { 9 | match x { 10 | | memory(w) => return w; 11 | }; 12 | } 13 | } 14 | 15 | class ref:Ref(deref) { 16 | function store(loc: ref, value: deref) -> (); 17 | } 18 | 19 | instance memory(t) : Ref(t) { 20 | function store(loc: memory(t), value: t) -> () { 21 | // We don't have a `ValueTy` bound on `t` anywhere, so this should raise a type error... 22 | let vw = ValueTy.rep(value); 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /test/examples/cases/undefined.solc: -------------------------------------------------------------------------------- 1 | forall any.function undefined() -> any { 2 | assembly { 3 | revert(0,0) 4 | }; 5 | } 6 | 7 | function useWord(w:word) {} 8 | 9 | contract Magic { 10 | function main() { 11 | useWord(undefined()); 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /test/examples/cases/unit.solc: -------------------------------------------------------------------------------- 1 | contract Unit { 2 | function one (x : ()) { 3 | return 1; 4 | } 5 | 6 | function unitVal() { 7 | return (); 8 | } 9 | 10 | function unitMatch (x) { 11 | match x { 12 | | () => return 1; 13 | } 14 | } 15 | 16 | function foo (x : word) { 17 | return (); 18 | } 19 | 20 | function main() { 21 | return unitMatch(foo(one(unitVal()))); 22 | } 23 | } 24 | 25 | class a : Def { 26 | function def () -> a ; 27 | } 28 | 29 | instance () : Def { 30 | function def() { 31 | return (); 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /test/examples/cases/vartyped.solc: -------------------------------------------------------------------------------- 1 | function foo () { 2 | let f : (word) -> word = lam (x) { return x ; } ; 3 | return f(1); 4 | } 5 | -------------------------------------------------------------------------------- /test/examples/cases/weirdfoo.solc: -------------------------------------------------------------------------------- 1 | data W(a) = W(a); 2 | class a: Foo {function foo(); } 3 | instance ((word, a) : Foo) => (word, W(a)) : Foo { 4 | function foo() {} 5 | } 6 | -------------------------------------------------------------------------------- /test/examples/invokable/021nid.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | function id(x) { 3 | return x ; 4 | } 5 | 6 | function nid() { 7 | return id; 8 | } 9 | 10 | function const(x, y) { return x; } 11 | 12 | function main() { 13 | return nid(42); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /test/examples/invokable/022nid-invoke.solc: -------------------------------------------------------------------------------- 1 | 2 | class self : Invokable(args, ret) { 3 | function invoke (s:self, a:args) -> ret; 4 | } 5 | 6 | function id(x) { 7 | return x ; 8 | } 9 | 10 | data IdToken(a) = IdToken 11 | 12 | instance IdToken(a) : Invokable(a,a) { 13 | function invoke(token: IdToken(a), arg:a) -> a { 14 | return id(arg); 15 | } 16 | } 17 | 18 | contract InvokeId { 19 | function id(x) { 20 | return x ; 21 | } 22 | 23 | /* 24 | function nid() { 25 | return id; 26 | } 27 | */ 28 | 29 | function nidimpl() { 30 | return IdToken; 31 | } 32 | 33 | function main() { 34 | // Instead of: `return nid(42)` 35 | return invoke(nidimpl(), 42); 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /test/examples/invokable/024lamid.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | function id(x) { 3 | return x ; 4 | } 5 | 6 | 7 | function main() { 8 | let nid = lam(x) {return x;}; 9 | return nid(42); 10 | } 11 | } -------------------------------------------------------------------------------- /test/examples/invokable/025lamid-invoke.solc: -------------------------------------------------------------------------------- 1 | /* Manual translation of: 2 | contract Id1 { 3 | function main() { 4 | let nid = lam(x) {return x;}; 5 | return nid(42); 6 | } 7 | } 8 | */ 9 | 10 | class self : Invokable(args, ret) { 11 | function invoke (s:self, a:args) -> ret; 12 | } 13 | 14 | function lam0impl(x: c) -> c { return x; } 15 | 16 | data Lam0Token(a) = Lam0Token 17 | 18 | instance Lam0Token(a) : Invokable(a,a) { 19 | function invoke(token: Lam0Token(a), arg:a) -> a { 20 | return lam0impl(arg); 21 | } 22 | } 23 | 24 | 25 | contract InvokeLam { 26 | function main() { 27 | let nid = Lam0Token; 28 | return invoke(nid, 42); 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /test/examples/invokable/026capture.solc: -------------------------------------------------------------------------------- 1 | /* Manual translation of: 2 | contract Id1 { 3 | function main() { 4 | let y = 42; 5 | let nid = lam(x) {return addW(x,y);}; 6 | return nid(17); 7 | } 8 | } 9 | */ 10 | 11 | function addW(x: Word, y:Word) -> Word { 12 | let res : Word; 13 | assembly { 14 | res := add(x, y) 15 | }; 16 | return res; 17 | } 18 | 19 | class self : Invokable(args, ret) { 20 | function invoke (s:self, a:args) -> ret; 21 | } 22 | 23 | // env might be a tuple, here it is a single Word 24 | function lam1impl(env: Word, x: c) -> c { 25 | let y = env; 26 | return addW(x,y); 27 | } 28 | 29 | data Lam1Closure(a) = Lam1Closure(Word) 30 | 31 | instance Lam1Closure(a) : Invokable(a,Word) { 32 | function invoke(clos: Lam1Closure(a), arg:a) -> Word { 33 | match clos { 34 | | Lam1Closure(env) => return lam1impl(env, arg); 35 | }; 36 | } 37 | } 38 | 39 | 40 | contract InvokeCapLam { 41 | function main() { 42 | let y = 42; 43 | let clos = Lam1Closure(y); 44 | 45 | return invoke(clos, 17); 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /test/examples/invokable/027retfun.solc: -------------------------------------------------------------------------------- 1 | /* Manual translation of: 2 | contract Id1 { 3 | 4 | function foo() { 5 | let y = 42; 6 | let nid = lam(x) {return y;}; 7 | return nid; 8 | } 9 | function main() { 10 | return nid(17); 11 | } 12 | } 13 | */ 14 | 15 | class self : Invokable(args, ret) { 16 | function invoke (s:self, a:args) -> ret; 17 | } 18 | 19 | // env might be a tuple, here it is a single Word 20 | function lam1impl(env: Word, x: c) -> c { return env; } 21 | 22 | data Lam1Closure(a) = Lam1Closure(Word) 23 | 24 | instance Lam1Closure(a) : Invokable(a,Word) { 25 | function invoke(clos: Lam1Closure(a), arg:a) -> Word { 26 | match clos { 27 | | Lam1Closure(env) => return lam1impl(env, arg); 28 | }; 29 | } 30 | } 31 | 32 | 33 | contract InvokeCapLam { 34 | function foo() { 35 | let y = 42; 36 | let clos = Lam1Closure(y); 37 | return clos; 38 | } 39 | 40 | function main() { 41 | 42 | return invoke(foo(), 17); 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /test/examples/invokable/028modifier.solc: -------------------------------------------------------------------------------- 1 | function add1(x) { 2 | return addW(x,1); 3 | } 4 | 5 | function addW(x: Word, y:Word) -> Word { 6 | let res : Word; 7 | assembly { 8 | res := add(x, y) 9 | }; 10 | return res; 11 | } 12 | 13 | class self : Invokable(args, ret) { 14 | function invoke (s:self, a:args) -> ret; 15 | } 16 | 17 | 18 | /* Manual translation of: 19 | contract Id1 { 20 | // modifier calls its argument and adds one to result 21 | function add1mod(f) { 22 | return lam(a) { return add1(f(a)); } 23 | } 24 | 25 | function foo(x) { 26 | return addW(x,2); 27 | } 28 | 29 | function main() { 30 | let bar = add1mod(foo); 31 | return bar(39); 32 | } 33 | } 34 | */ 35 | 36 | function foo(x:Word) -> Word { 37 | return addW(x, 2); 38 | } 39 | 40 | data FooToken = FooToken 41 | 42 | instance FooToken:Invokable(Word, Word) { 43 | function invoke(self:FooToken, arg: Word) -> Word { 44 | return foo(arg); 45 | } 46 | } 47 | 48 | // lambda in add1mod captures a function 49 | // so env contains the closure 50 | 51 | forall f.(f: Invokable(Word,Word)) => function lam1impl (env : f, a:Word) { 52 | let f = env; 53 | return add1(invoke(f, a)); 54 | } 55 | 56 | // we want: 57 | // data Lam1Closure = f:Invokable(Word,Word) => Lam1Closure(f) 58 | 59 | data Lam1Closure(f) = Lam1Closure(f) 60 | 61 | /* 62 | function extractEnv(clos: Lam1Closure(f)) -> f { 63 | match clos { 64 | | Lam1Closure(env) => return env; 65 | }; 66 | } 67 | */ 68 | instance (f:Invokable(Word,Word)) => Lam1Closure(f) : Invokable(Word,Word) { 69 | function invoke(clos, arg:Word) -> Word { 70 | match clos { 71 | | Lam1Closure(env) => return lam1impl(env, arg); 72 | }; 73 | } 74 | } 75 | 76 | function add1mod(f) { 77 | return Lam1Closure(f); 78 | } 79 | 80 | contract Modifier { 81 | 82 | 83 | function main() { 84 | let barClos = add1mod(FooToken); 85 | return invoke(barClos, 39); 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /test/examples/invokable/031enum.solc: -------------------------------------------------------------------------------- 1 | function addW(x: Word, y:Word) -> Word { 2 | let res : Word; 3 | assembly { 4 | res := add(x, y) 5 | }; 6 | return res; 7 | } 8 | 9 | class a:Enum { 10 | function fromEnum(x:a) -> Word; 11 | } 12 | 13 | data Color = R | G | B 14 | 15 | instance Color : Enum { 16 | function fromEnum(c) { 17 | match c { 18 | | R => return 1; 19 | | G => return 2; 20 | | B => return 3; 21 | }; 22 | } 23 | } 24 | 25 | data Bool = False | True 26 | 27 | instance Bool : Enum { 28 | function fromEnum(b) { 29 | match b { 30 | | False => return 0; 31 | | True => return 1; 32 | }; 33 | } 34 | } 35 | data FromEnumToken(a) = FromEnumToken 36 | 37 | class self : Invokable(args, ret) { 38 | function invoke (s:self, a:args) -> ret; 39 | } 40 | 41 | instance (a:Enum) => FromEnumToken(a) : Invokable(a,Word) { 42 | function invoke(fet : FromEnumToken(a), arg) -> Word { 43 | return fromEnum(arg); 44 | } 45 | } 46 | contract RGB { 47 | function main() { 48 | /* 49 | let x = fromEnum(B); 50 | let y = fromEnum(True); 51 | */ 52 | 53 | let fetC = FromEnumToken; 54 | let fetB = FromEnumToken; 55 | let x = invoke(fetC, B); 56 | let y = invoke(fetB,True); 57 | return addW(x,y); 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /test/examples/pragmas/bound.solc: -------------------------------------------------------------------------------- 1 | pragma no-bounded-variable-condition F; 2 | 3 | class a:D { function f(x:a); } 4 | class a:F(b) {} 5 | 6 | data Memory(a) = Memory(word); 7 | 8 | instance Memory(a):F(Memory(Memory(Memory(a)))) {} 9 | instance (c:D,a:F(c)) => Memory(Memory(Memory(a))):D { 10 | function f(x:Memory(Memory(Memory(a)))) {} 11 | } 12 | 13 | function g(y:b) { 14 | let x : Memory(Memory(Memory(Memory(b)))); 15 | f(x); 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/pragmas/coverage.solc: -------------------------------------------------------------------------------- 1 | pragma no-coverage-condition ; 2 | 3 | data List(a) = Nil | Cons(a,List(a)); 4 | data Bool = True | False ; 5 | 6 | class a : C(b,c) {} 7 | 8 | instance List(b) : C (a, List(a)) {} 9 | -------------------------------------------------------------------------------- /test/examples/pragmas/patterson.solc: -------------------------------------------------------------------------------- 1 | pragma no-patterson-condition ; 2 | 3 | class self:A {} 4 | class self:B {} 5 | class self:C {} 6 | class self:D {} 7 | 8 | 9 | data Uint256 = U; 10 | data T(x) = T; 11 | data S(x) = T; 12 | 13 | // This works. 14 | forall U . U : A => instance T(U):D {} 15 | 16 | // This should also work, but reports a violation of the Paterson condition. 17 | forall U . U : A, U : B, U : C => instance S(U):D {} 18 | -------------------------------------------------------------------------------- /test/examples/spec/00answer.solc: -------------------------------------------------------------------------------- 1 | contract Answer { 2 | function main() { 3 | return 42; 4 | } 5 | } -------------------------------------------------------------------------------- /test/examples/spec/010answer.solc: -------------------------------------------------------------------------------- 1 | contract Answer { 2 | function main() { 3 | return 42; 4 | } 5 | } -------------------------------------------------------------------------------- /test/examples/spec/011id.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | 3 | data Bool = False | True; 4 | 5 | function id(x) { 6 | return x ; 7 | } 8 | 9 | function const(x, y) { return x; } 10 | 11 | function main() { 12 | return const(id(42), False); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/spec/012nid.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | function id(x) { 3 | return x ; 4 | } 5 | 6 | function nid() { 7 | return id; 8 | } 9 | 10 | function const(x, y) { return x; } 11 | 12 | function main() { 13 | return const(nid(42), id(1)); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /test/examples/spec/013comp.solc: -------------------------------------------------------------------------------- 1 | contract Compose { 2 | function compose(f,g) { 3 | return lam (x) { 4 | return f(g(x)); 5 | } ; 6 | } 7 | 8 | function id(x) { return x; } 9 | 10 | function idid() { return compose(id,id); } 11 | 12 | function main() { 13 | let f = compose(id,id); 14 | return f(42); 15 | } 16 | } -------------------------------------------------------------------------------- /test/examples/spec/01id.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | 3 | data Bool = False | True; 4 | 5 | function id(x) { 6 | return x ; 7 | } 8 | 9 | function const(x, y) { return x; } 10 | 11 | function main() { 12 | return const(id(42), False); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/spec/021not.solc: -------------------------------------------------------------------------------- 1 | contract Not { 2 | data Bool = False | True; 3 | 4 | function main() { 5 | return fromBool(bnot(False)); 6 | } 7 | 8 | function fromBool(b) { 9 | match(b) { 10 | | False => return 0; 11 | | True => return 1; 12 | } 13 | } 14 | 15 | function bnot(b) { 16 | match b { 17 | | False => return True; 18 | | True => return False; 19 | } 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/spec/022add.solc: -------------------------------------------------------------------------------- 1 | function add(x : word, y : word) { 2 | let res: word; 3 | assembly { 4 | res := add(x, y) 5 | } 6 | return res; 7 | } 8 | 9 | contract Add1 { 10 | function main() { 11 | return add(40, 2); 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /test/examples/spec/024arith.solc: -------------------------------------------------------------------------------- 1 | 2 | 3 | function add(x : word, y : word) { 4 | let res: word; 5 | assembly { 6 | res := add(x, y) 7 | } 8 | return res; 9 | } 10 | 11 | function sub(x : word, y : word) { 12 | let res: word; 13 | assembly { 14 | res := sub(x, y) 15 | } 16 | return res; 17 | } 18 | 19 | function div(x : word, y: word) { 20 | let res: word; 21 | assembly { 22 | res := div(x, y) 23 | } 24 | return res; 25 | } 26 | 27 | function sdiv(x : word, y: word) { 28 | let res: word; 29 | assembly { 30 | res := sdiv(x, y) 31 | } 32 | return res; 33 | } 34 | 35 | function mod(x : word, y: word) { 36 | let res: word; 37 | assembly { 38 | res := mod(x, y) 39 | } 40 | return res; 41 | } 42 | 43 | function smod(x : word, y: word) { 44 | let res: word; 45 | assembly { 46 | res := smod(x, y) 47 | } 48 | return res; 49 | } 50 | 51 | function exp(x : word, y: word) { 52 | let res: word; 53 | assembly { 54 | res := exp(x, y) 55 | } 56 | return res; 57 | } 58 | 59 | 60 | contract Arith { 61 | function main() { 62 | return add(mod(sub(div(exp(2,18),4), 1), 16), 27); 63 | } 64 | } 65 | -------------------------------------------------------------------------------- /test/examples/spec/027sstore.solc: -------------------------------------------------------------------------------- 1 | contract Sstore { 2 | function main() { 3 | let res : word; 4 | assembly { 5 | sstore(0, 42) 6 | res := sload(0) 7 | } 8 | return res; 9 | } 10 | } -------------------------------------------------------------------------------- /test/examples/spec/02nid.solc: -------------------------------------------------------------------------------- 1 | contract Id1 { 2 | function id(x) { 3 | return x ; 4 | } 5 | 6 | function nid() { 7 | return id; 8 | } 9 | 10 | function const(x, y) { return x; } 11 | 12 | function main() { 13 | let f = nid(); 14 | return const(f(42), id(1)); 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/spec/031maybe.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function just(x) { return Some(x); } 5 | 6 | function maybe(n, o) { 7 | match o { 8 | | None => return n; 9 | | Some(x) => return x; 10 | } 11 | } 12 | 13 | function main() { 14 | return maybe(0, Some(42)); 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/spec/032simplejoin.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function just(x) { return Some(x); } 5 | 6 | function maybe(n, o) { 7 | match o { 8 | | None => return n; 9 | | Some(x) => return x; 10 | } 11 | } 12 | 13 | 14 | function join(mmx) { 15 | match mmx { 16 | | None => return None; 17 | | Some(None) => return None; 18 | | Some(Some(x)) => return Some(x); 19 | } 20 | } 21 | 22 | function join2(mmx) { 23 | match mmx { 24 | | Some(m) => match m { 25 | | None => return None; 26 | | Some(x) => return Some(x); 27 | } 28 | | _ => return None; 29 | } 30 | } 31 | 32 | function main() { 33 | return maybe(0, join(Some(Some(42)))); 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /test/examples/spec/033join.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function just(x) { return Some(x); } 5 | 6 | function maybe(n, o) { 7 | match o { 8 | | None => return n; 9 | | Some(x) => return x; 10 | } 11 | } 12 | 13 | function join(mmx) { 14 | match mmx { 15 | | Some(Some(x)) => return Some(x); 16 | | _ => return None; 17 | } 18 | } 19 | 20 | function main() { 21 | return maybe(0, join(Some(Some(42)))); 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /test/examples/spec/034cojoin.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function just(x) { return Some(x); } 5 | 6 | function maybe(n, o) { 7 | match o { 8 | | None => return n; 9 | | Some(x) => return x; 10 | } 11 | } 12 | 13 | function join(mmx) { 14 | let result = None; 15 | match mmx { 16 | | Some(Some(x)) => result = Some(x); 17 | | None => result = None; 18 | } 19 | return result; 20 | } 21 | 22 | function extract(mx) { 23 | match mx { 24 | | Some(x) => return x; 25 | } 26 | } 27 | 28 | function cojoin(x) { // Test that sum types can grow 29 | let result = None; 30 | result = Some(x); 31 | return result; 32 | } 33 | 34 | 35 | function main() { 36 | return maybe(0, join(cojoin(Some(42)))); 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /test/examples/spec/035padding.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function maybe(n, o) { 5 | match o { 6 | | Some(x) => return x; 7 | | None => return n; 8 | } 9 | } 10 | 11 | function main() { 12 | return maybe(7, None); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/spec/036wildcard.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function maybe(n, o) { 5 | match o { 6 | | Some(x) => return x; 7 | | _ => return n; 8 | } 9 | } 10 | 11 | function main() { 12 | return maybe(7, None); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/examples/spec/037dwarves.solc: -------------------------------------------------------------------------------- 1 | contract Dwarves { 2 | data Dwarf = Doc | Grumpy | Sleepy | Bashful | Happy | Sneezy | Dopey; 3 | 4 | 5 | function fromEnum(c) { 6 | match c { 7 | | Doc => return 1; 8 | | Grumpy => return 2; 9 | | Sleepy => return 3; 10 | | Bashful => return 4; 11 | | Happy => return 5; 12 | } 13 | } 14 | 15 | function main() { return fromEnum(Happy); } 16 | } 17 | -------------------------------------------------------------------------------- /test/examples/spec/038food0.solc: -------------------------------------------------------------------------------- 1 | data Food = Curry | Beans | Other; 2 | data CFood = Red(Food) | Green(Food) | Nocolor; 3 | 4 | 5 | 6 | function fromEnum(x : CFood) { 7 | match x { 8 | | Red(Curry) => return 1; 9 | | Green(Beans) => return 42; 10 | | _ => return 3; 11 | } 12 | } 13 | 14 | 15 | contract Food { 16 | function id(x) { 17 | return(x); 18 | } 19 | 20 | function main() { 21 | return fromEnum(id(Green(Beans))); 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /test/examples/spec/039food.solc: -------------------------------------------------------------------------------- 1 | 2 | data Food = Curry | Beans | Other; 3 | data CFood = Red(Food) | Green(Food) | Nocolor; 4 | 5 | 6 | 7 | 8 | function fromEnum(x : Food) { 9 | match x { 10 | | Curry => return 1; 11 | | Beans => return 42; 12 | | Other => return 3; 13 | } 14 | } 15 | 16 | 17 | contract Food { 18 | function eat(x) { 19 | match x { 20 | | Red(f) => return f; 21 | | Green(f) => return f; 22 | | _ => return Other; 23 | } 24 | } 25 | 26 | function main() { 27 | return fromEnum(eat(Green(Beans))); 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /test/examples/spec/041pair.solc: -------------------------------------------------------------------------------- 1 | contract Pair { 2 | 3 | function fst(p) { 4 | match p { 5 | | (a,b) => return a; 6 | } 7 | } 8 | 9 | function main() { 10 | return fst((1,0)); 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /test/examples/spec/042triple.solc: -------------------------------------------------------------------------------- 1 | contract Triple { 2 | 3 | function asel(t) { 4 | match t { 5 | | (a,b,c) => return c; 6 | } 7 | } 8 | 9 | function main() { 10 | return asel((1,21,42)); 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /test/examples/spec/043fstsnd.solc: -------------------------------------------------------------------------------- 1 | 2 | 3 | data B = F | T; 4 | data Pair(a,b) = Pair(a,b); 5 | 6 | function fst (p) { 7 | match p { 8 | | Pair(x,y) => return x; 9 | } 10 | } 11 | 12 | function snd(p) { 13 | match p { 14 | | Pair(x,y) => return y; 15 | } 16 | } 17 | 18 | function add(x : word, y : word) { 19 | let res: word; 20 | assembly { 21 | res := add(x, y) 22 | } 23 | return res; 24 | } 25 | 26 | 27 | function addPair(p) { 28 | return add(fst(p), snd(p)); 29 | } 30 | 31 | contract FstSnd { 32 | function main() { return addPair(Pair(41,1)); } 33 | } 34 | -------------------------------------------------------------------------------- /test/examples/spec/047rgb.solc: -------------------------------------------------------------------------------- 1 | contract RGB { 2 | data Color = R | G | B; 3 | function main() { 4 | match B { 5 | | R => return 4; 6 | | G => return 2; 7 | | B => return 42; 8 | } 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /test/examples/spec/048rgb2.solc: -------------------------------------------------------------------------------- 1 | contract RGB { 2 | data Color = R | G | B; 3 | 4 | function fromEnum(c) { 5 | match c { 6 | | R => return 4; 7 | | G => return 2; 8 | | B => return 42; 9 | } 10 | } 11 | 12 | function main() { return fromEnum(B); } 13 | } 14 | -------------------------------------------------------------------------------- /test/examples/spec/051expreturn.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(Word); 3 | data U = U; 4 | 5 | // empty class needed since forall expects a nonempty context 6 | class a :Top {} 7 | instance a:Top {} 8 | 9 | /* For experiments, special handling when emitting code */ 10 | // this does not work, typechecker forces a ~ b 11 | // forall a, b.(a:Top, b:Top) => function ereturn(x:a) -> b { let res: b; return res; } 12 | // we might have 13 | // forall a.(a:Top) => function ereturn(x:a) -> a 14 | // or 15 | 16 | forall a . function ereturn(x:a) -> Unit { let res: Unit; return res; } 17 | // and then cast it to any type using unsafeCast 18 | 19 | /* simulate match expression 20 | x = match { | False => return 77; | True => W(22) } 21 | */ 22 | function elimBool1(b:Bool) -> Word { 23 | let x : W; 24 | x = W(1); 25 | match b { 26 | // this works 27 | // | False => x = unsafeCast(ereturn(77)); 28 | // but this does not - unknown intermediate type 29 | // | False => x = unsafeCast(unsafeCast(ereturn(77))); 30 | // what about "return(return 77)"? 31 | // this works 32 | | False => x = unsafeCast(ereturn(ereturn(77))); 33 | // but this does not 34 | // | False => x = unsafeCast(ereturn(unsafeCast(ereturn(77)))); 35 | | True => x = W(22); 36 | } 37 | 38 | match x { 39 | | W(y) => return y; 40 | } 41 | 42 | } 43 | 44 | // "semicolon" 45 | forall a. function semi(x:a) -> U { return U;} 46 | 47 | forall a b. function unsafeCast(x:a) -> b { 48 | let res: b; return res; 49 | } 50 | 51 | 52 | contract ExpReturn { 53 | function main() -> Word { 54 | return elimBool1(False); 55 | // return elimBool1(False); 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /test/examples/spec/051negBool.solc: -------------------------------------------------------------------------------- 1 | 2 | class a : Neg { 3 | function neg(x:a) -> a; 4 | } 5 | 6 | data B = F | T; 7 | 8 | 9 | instance B : Neg { 10 | function neg (x : B) { 11 | match x { 12 | | F => return T; 13 | | T => return F; 14 | } 15 | } 16 | } 17 | 18 | 19 | contract NegBool { 20 | 21 | function fromB(b) { 22 | match b { 23 | | F => return 0; 24 | | T => return 1; 25 | } 26 | } 27 | 28 | function main() { return fromB(Neg.neg(F)); } 29 | } 30 | -------------------------------------------------------------------------------- /test/examples/spec/052negPair.solc: -------------------------------------------------------------------------------- 1 | 2 | class a : Neg { 3 | function neg(x:a) -> a; 4 | } 5 | 6 | data B = F | T; 7 | data Pair(a,b) = Pair(a,b); 8 | 9 | instance B : Neg { 10 | function neg (x : B) { 11 | match x { 12 | | F => return T; 13 | | T => return F; 14 | } 15 | } 16 | } 17 | 18 | function fst (p) { 19 | match p { 20 | | Pair(x,y) => return x; 21 | } 22 | } 23 | 24 | function snd(p) { 25 | match p { 26 | | Pair(x,y) => return y; 27 | } 28 | } 29 | 30 | 31 | instance (a:Neg,b:Neg) => Pair(a,b):Neg { 32 | function neg(p) { 33 | return Pair(Neg.neg (fst(p)), Neg.neg(snd (p))); 34 | } 35 | } 36 | 37 | /* 38 | instance (a:Neg,b:Neg) => Pair(a,b):Neg { 39 | function neg(p) { 40 | match p { 41 | | Pair(a,b) => return Pair(neg(a), neg(b)); 42 | } 43 | } 44 | } 45 | */ 46 | contract NegPair { 47 | 48 | function bnot(x) { 49 | match x { 50 | | T => return F; 51 | | F => return T; 52 | } 53 | } 54 | 55 | function fromB(b) { 56 | match b { 57 | | F => return 0; 58 | | T => return 1; 59 | } 60 | } 61 | 62 | function main() { return fromB(fst(Neg.neg(Pair(F,T)))); } 63 | } 64 | -------------------------------------------------------------------------------- /test/examples/spec/052return.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(word); 3 | data U = U; 4 | 5 | 6 | /* For experiments, special handling when emitting code */ 7 | // this does not work, typechecker forces a ~ b 8 | // function ereturn(x:a) -> b { let res: b; return res; } 9 | // we might have 10 | // function ereturn(x:a) -> a 11 | // or 12 | 13 | function ereturn(x:a) -> unit { let res: unit; return res; } 14 | // and then cast it to any type using unsafeCast 15 | 16 | /* simulate match expression 17 | x = match { | False => return 77; | True => W(22) } 18 | */ 19 | function elimBool1(b:Bool) -> word { 20 | let x : W; 21 | x = W(1); 22 | match b { 23 | // this works 24 | | False => x = unsafeCast(ereturn(77)); 25 | // but this does not - unknown intermediate type 26 | // | False => x = unsafeCast(unsafeCast(ereturn(77))); 27 | // what about "return(return 77)"? 28 | // this does not work 29 | // | False => x = ereturn(ereturn(77)); 30 | // this works 31 | // | False => x = unsafeCast(ereturn(ereturn(77))); 32 | // this does not work (monomorphisation fails): 33 | // | False => x = unsafeCast(ereturn(unsafeCast(ereturn(77)))); 34 | 35 | | True => x = W(22); 36 | } 37 | 38 | match x { 39 | | W(y) => return y; 40 | } 41 | 42 | } 43 | 44 | // "semicolon" 45 | function semi(x:a) -> U { return U;} 46 | 47 | function unsafeCast(x:a) -> b { 48 | let res: b; return res; 49 | } 50 | 51 | 52 | contract ExpReturn { 53 | function main() -> word { 54 | return elimBool1(False); 55 | // return elimBool1(True); 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /test/examples/spec/053return.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(word); 3 | 4 | 5 | /* For experiments, special handling when emitting code */ 6 | function ereturn(x:a) -> b { let res: b; return res; } 7 | 8 | /* simulate match expression 9 | x = match { | False => return 77; | True => W(22) } 10 | */ 11 | function elimBool1(b:Bool) -> word { 12 | let x : W; 13 | x = W(1); 14 | match b { 15 | // this works 16 | | False => x = ereturn(77); 17 | // what about "return(return 77)"? 18 | // this does not work (monomorphisation fails) 19 | // | False => x = ereturn(ereturn(77)); 20 | 21 | | True => x = W(22); 22 | } 23 | 24 | match x { 25 | | W(y) => return y; 26 | } 27 | 28 | } 29 | 30 | 31 | contract ExpReturn { 32 | function main() -> word { 33 | return elimBool1(False); 34 | // return elimBool1(True); 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /test/examples/spec/06comp.solc: -------------------------------------------------------------------------------- 1 | contract Compose { 2 | function compose(f,g) { 3 | return lam (x) { 4 | return f(g(x)); 5 | } ; 6 | } 7 | 8 | function id(x) { return x; } 9 | 10 | function idid() { return compose(id,id); } 11 | 12 | function foo() { 13 | let f = idid(); 14 | return f(42); 15 | } 16 | 17 | function main() { 18 | let f = compose(id,id); 19 | return f(42); 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/spec/09not.solc: -------------------------------------------------------------------------------- 1 | contract Not { 2 | data Bool = False | True; 3 | 4 | function main() { 5 | return fromBool(bnot(False)); 6 | } 7 | 8 | function fromBool(b) { 9 | match(b) { 10 | | False => return 0; 11 | | True => return 1; 12 | } 13 | } 14 | 15 | function bnot(b) { 16 | match b { 17 | | False => return True; 18 | | True => return False; 19 | } 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/spec/10negBool.solc: -------------------------------------------------------------------------------- 1 | 2 | class a : Neg { 3 | function neg(x:a) -> a; 4 | } 5 | 6 | data B = F | T; 7 | 8 | 9 | instance B : Neg { 10 | function neg (x : B) { 11 | match x { 12 | | F => return T; 13 | | T => return F; 14 | } 15 | } 16 | } 17 | 18 | 19 | contract NegBool { 20 | 21 | function fromB(b) { 22 | match b { 23 | | F => return 0; 24 | | T => return 1; 25 | } 26 | } 27 | 28 | function main() { return fromB(Neg.neg(F)); } 29 | } 30 | -------------------------------------------------------------------------------- /test/examples/spec/11negPair.solc: -------------------------------------------------------------------------------- 1 | 2 | class a : Neg { 3 | function neg(x:a) -> a; 4 | } 5 | 6 | data B = F | T; 7 | 8 | instance B : Neg { 9 | function neg (x : B) { 10 | match x { 11 | | F => return T; 12 | | T => return F; 13 | } 14 | } 15 | } 16 | 17 | function fst (p) { 18 | match p { 19 | | (x,y) => return x; 20 | } 21 | } 22 | 23 | function snd(p) { 24 | match p { 25 | | (x,y) => return y; 26 | } 27 | } 28 | 29 | 30 | forall a b . a : Neg, b : Neg => instance (a,b):Neg { 31 | function neg(p) { 32 | return (Neg.neg (fst(p)), Neg.neg(snd (p))); 33 | } 34 | } 35 | 36 | contract NegPair { 37 | 38 | function bnot(x) { 39 | match x { 40 | | T => return F; 41 | | F => return T; 42 | } 43 | } 44 | 45 | function fromB(b) { 46 | match b { 47 | | F => return 0; 48 | | T => return 1; 49 | } 50 | } 51 | 52 | function main() { return fromB(fst(Neg.neg((F,T)))); } 53 | } 54 | -------------------------------------------------------------------------------- /test/examples/spec/903badassign.solc: -------------------------------------------------------------------------------- 1 | contract Option { 2 | data Option(a) = None | Some(a); 3 | 4 | function just(x) { return Some(x); } 5 | 6 | function maybe(n, o) { 7 | match o { 8 | | None => return n; 9 | | Some(x) => return x; 10 | } 11 | } 12 | 13 | function join(mmx) { 14 | let result = None; 15 | match mmx { 16 | | Some(Some(x)) => result = Some(x); 17 | | None => result = None; 18 | } 19 | return result; 20 | } 21 | 22 | function main() { 23 | return maybe(0, join(Some(Some(42)))); 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /test/examples/spec/939badfood.solc: -------------------------------------------------------------------------------- 1 | class a: Enum { 2 | function fromEnum(x : a) -> word; 3 | } 4 | 5 | data Food = Curry | Beans | Other; 6 | 7 | instance Food : Enum { 8 | function fromEnum(x : Food) { 9 | match x { 10 | | Curry => return 1; 11 | | Beans => return 2; 12 | | Other => return 3; 13 | } 14 | } 15 | } 16 | 17 | contract Food { 18 | function main() { 19 | return Enum.fromEnum(Beans); 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test/examples/spec/attic/051expreturn.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(Word); 3 | data U = U; 4 | 5 | // empty class needed since forall expects a nonempty context 6 | class a :Top {} 7 | instance a:Top {} 8 | 9 | /* For experiments, special handling when emitting code */ 10 | // this does not work, typechecker forces a ~ b 11 | // forall a, b.(a:Top, b:Top) => function ereturn(x:a) -> b { let res: b; return res; } 12 | // we might have 13 | // forall a.(a:Top) => function ereturn(x:a) -> a 14 | // or 15 | 16 | forall a:Top . function ereturn(x:a) -> Unit { let res: Unit; return res; } 17 | // and then cast it to any type using unsafeCast 18 | 19 | /* simulate match expression 20 | x = match { | False => return 77; | True => W(22) } 21 | */ 22 | function elimBool1(b:Bool) -> Word { 23 | let x : W; 24 | x = W(1); 25 | match b { 26 | // this works 27 | // | False => x = unsafeCast(ereturn(77)); 28 | // but this does not - unknown intermediate type 29 | // | False => x = unsafeCast(unsafeCast(ereturn(77))); 30 | // what about "return(return 77)"? 31 | // this works 32 | | False => x = unsafeCast(ereturn(ereturn(77))); 33 | // but this does not 34 | // | False => x = unsafeCast(ereturn(unsafeCast(ereturn(77)))); 35 | | True => x = W(22); 36 | }; 37 | 38 | match x { 39 | | W(y) => return y; 40 | }; 41 | 42 | } 43 | 44 | // "semicolon" 45 | forall a:Top . function semi(x:a) -> U { return U;} 46 | 47 | forall a:Top, b:Top . function unsafeCast(x:a) -> b { 48 | let res: b; return res; 49 | } 50 | 51 | 52 | contract ExpReturn { 53 | 54 | 55 | 56 | function main() -> Word { 57 | return elimBool1(False); 58 | // return elimBool1(False); 59 | } 60 | } 61 | -------------------------------------------------------------------------------- /test/examples/spec/attic/052return.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(word); 3 | data U = U; 4 | 5 | 6 | /* For experiments, special handling when emitting code */ 7 | // this does not work, typechecker forces a ~ b 8 | // function ereturn(x:a) -> b { let res: b; return res; } 9 | // we might have 10 | // function ereturn(x:a) -> a 11 | // or 12 | 13 | function ereturn(x:a) -> unit { let res: unit; return res; } 14 | // and then cast it to any type using unsafeCast 15 | 16 | /* simulate match expression 17 | x = match { | False => return 77; | True => W(22) } 18 | */ 19 | function elimBool1(b:Bool) -> word { 20 | let x : W; 21 | x = W(1); 22 | match b { 23 | // this works 24 | | False => x = unsafeCast(ereturn(77)); 25 | // but this does not - unknown intermediate type 26 | // | False => x = unsafeCast(unsafeCast(ereturn(77))); 27 | // what about "return(return 77)"? 28 | // this does not work 29 | // | False => x = ereturn(ereturn(77)); 30 | // this works 31 | // | False => x = unsafeCast(ereturn(ereturn(77))); 32 | // this does not work (monomorphisation fails): 33 | // | False => x = unsafeCast(ereturn(unsafeCast(ereturn(77)))); 34 | 35 | | True => x = W(22); 36 | }; 37 | 38 | match x { 39 | | W(y) => return y; 40 | }; 41 | 42 | } 43 | 44 | // "semicolon" 45 | function semi(x:a) -> U { return U;} 46 | 47 | function unsafeCast(x:a) -> b { 48 | let res: b; return res; 49 | } 50 | 51 | 52 | contract ExpReturn { 53 | function main() -> word { 54 | return elimBool1(False); 55 | // return elimBool1(True); 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /test/examples/spec/attic/053return.solc: -------------------------------------------------------------------------------- 1 | data Bool = False | True; 2 | data W = W(word); 3 | 4 | 5 | /* For experiments, special handling when emitting code */ 6 | function ereturn(x:a) -> b { let res: b; return res; } 7 | 8 | /* simulate match expression 9 | x = match { | False => return 77; | True => W(22) } 10 | */ 11 | function elimBool1(b:Bool) -> word { 12 | let x : W; 13 | x = W(1); 14 | match b { 15 | // this works 16 | | False => x = ereturn(77); 17 | // what about "return(return 77)"? 18 | // this does not work (monomorphisation fails) 19 | // | False => x = ereturn(ereturn(77)); 20 | 21 | | True => x = W(22); 22 | }; 23 | 24 | match x { 25 | | W(y) => return y; 26 | }; 27 | 28 | } 29 | 30 | 31 | contract ExpReturn { 32 | function main() -> word { 33 | return elimBool1(False); 34 | // return elimBool1(True); 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /test/imports/booldef.solc: -------------------------------------------------------------------------------- 1 | data Bool = True | False; 2 | 3 | function not (b : Bool) -> Bool { 4 | match b { 5 | | True => return False; 6 | | False => return True; 7 | } 8 | } 9 | 10 | class a : C { 11 | function c (x : a, y : a) -> word ; 12 | } 13 | 14 | class a : D { 15 | function d() -> a ; 16 | } 17 | 18 | forall a . a : C, a : D => function id (x : a) -> word { 19 | return C.c(x, D.d()); 20 | } 21 | -------------------------------------------------------------------------------- /test/imports/boolmain.solc: -------------------------------------------------------------------------------- 1 | import booldef ; 2 | 3 | function and (b1 : Bool, b2 : Bool) -> Bool { 4 | return False ; 5 | } 6 | -------------------------------------------------------------------------------- /test/solver/red00.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a . a : Eq => instance Foo(a) : Eq ; 3 | 4 | reduce : {Foo(Foo(a)) : Eq} ~ {a : Eq}; 5 | -------------------------------------------------------------------------------- /test/solver/red01.inp: -------------------------------------------------------------------------------- 1 | reduce : {a : Eq } ~ {a : Eq}; 2 | -------------------------------------------------------------------------------- /test/solver/red02.inp: -------------------------------------------------------------------------------- 1 | forall a . a : Eq => class a : Ord; 2 | forall a . a : Ord => instance Foo(a) : Ord ; 3 | 4 | reduce : {Foo(Foo(a)) : Ord, a : Eq} ~ {a : Ord}; 5 | -------------------------------------------------------------------------------- /test/solver/red03.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a . a : Eq => instance Foo(a) : Eq ; 3 | 4 | reduce : {Foo(Foo(word)) : Eq} ~ {}; 5 | -------------------------------------------------------------------------------- /test/solver/red04.inp: -------------------------------------------------------------------------------- 1 | class t : TypeRep(a); 2 | instance t:TypeRep(word); 3 | 4 | reduce : {a : TypeRep(b), a : TypeRep(word)} ~ {}; 5 | -------------------------------------------------------------------------------- /test/solver/red05.inp: -------------------------------------------------------------------------------- 1 | class a : A(b); 2 | instance word : A (word); 3 | 4 | reduce : {word : A (x)} ~ {}; 5 | -------------------------------------------------------------------------------- /test/solver/red06.inp: -------------------------------------------------------------------------------- 1 | class abs:Typedef(rep); 2 | instance uint:Typedef(word); 3 | instance memory(a):Typedef(word); 4 | instance memoryRef(a):Typedef(word); 5 | 6 | class lhs:Assign(rhs); 7 | instance ref(a) : Assign(a); 8 | 9 | class self : MemoryType ; 10 | class self : MemorySize ; 11 | instance word : MemoryType; 12 | instance word : MemorySize; 13 | instance uint : MemoryType; 14 | forall a . a : MemoryType => instance memoryRef(a) : Assign(a); 15 | class self:LValueMemberAccess(memberRefType); 16 | class self:RValueMemberAccess(memberValueType); 17 | class self:StructField(fieldType, offsetType); 18 | instance ():MemorySize; 19 | instance word:MemorySize; 20 | instance uint:MemorySize; 21 | forall a b . a : MemorySize, b:MemorySize => instance (a,b):MemorySize; 22 | forall structType fieldSelector fieldType offsetType . StructField(structType, fieldSelector):StructField(fieldType, offsetType), fieldType:MemoryType, offsetType:MemorySize => instance MemberAccessProxy(memory(structType), fieldSelector):RValueMemberAccess(fieldType); 23 | instance StructField(S, x_sel):StructField(word, ()); 24 | instance StructField(S, y_sel):StructField(uint, word); 25 | instance StructField(S, z_sel):StructField(word, word); 26 | 27 | reduce : {memory(S) : Typedef (word)} ~ {}; 28 | -------------------------------------------------------------------------------- /test/solver/sat00.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a : Eq . instance Foo(a) : Eq ; 3 | 4 | sat : {}; 5 | -------------------------------------------------------------------------------- /test/solver/sat01.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a : Eq . instance Foo(a) : Eq ; 3 | 4 | sat : {Foo(word) : Eq}; 5 | -------------------------------------------------------------------------------- /test/solver/sat02.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a : Eq . instance Foo(a) : Eq; 3 | 4 | sat : {Foo(Foo(word)) : Eq}; 5 | -------------------------------------------------------------------------------- /test/solver/sat03.inp: -------------------------------------------------------------------------------- 1 | instance Foo(word) : A(word); 2 | instance Foo(bool) : A(word); 3 | instance word : C; 4 | forall a : C . instance Foo(a) : D; 5 | 6 | sat : {b : A(a), b : D}; 7 | -------------------------------------------------------------------------------- /test/solver/sat04.inp: -------------------------------------------------------------------------------- 1 | forall a : C(b) . instance T(T(a)) : C(b); 2 | sat : {T(x) : C(x)}; 3 | -------------------------------------------------------------------------------- /test/solver/sat05.inp: -------------------------------------------------------------------------------- 1 | instance word : Eq ; 2 | forall a : Eq . instance Foo(a) : Eq ; 3 | 4 | sat : {bool : Eq}; 5 | -------------------------------------------------------------------------------- /yule/Builtins.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Builtins(yulBuiltins) where 3 | import Data.String 4 | import Language.Yul 5 | 6 | yulBuiltins :: Yul 7 | yulBuiltins = Yul [] 8 | 9 | revertStmt :: String -> [YulStmt] 10 | revertStmt s = [ YExp $ YCall "mstore" [yulInt 0, YLit (YulString s)] 11 | , YExp $ YCall "revert" [yulInt 0, yulInt (length s)] 12 | ] 13 | 14 | {- 15 | poisonBuiltin :: [YulStmt] 16 | poisonBuiltin = 17 | [ YFun "$poison" [] (YReturns ["_dummy"]) (revertStmt "Dying from poison!") ] 18 | -} 19 | -------------------------------------------------------------------------------- /yule/Compress.hs: -------------------------------------------------------------------------------- 1 | module Compress where 2 | import Language.Core 3 | 4 | class Compress a where 5 | compress :: a -> a 6 | 7 | instance Compress Type where 8 | compress (TNamed n t@(TSum _ _)) = foldSum t 9 | compress t = t 10 | 11 | foldSum :: Type -> Type 12 | foldSum t = TSumN (go t) where 13 | go :: Type -> [Type] 14 | go (TSum t1 t2) = go t1 ++ go t2 15 | go t = [t] 16 | 17 | -- foldIns :: Type -> Expr -> Expr 18 | -- treat expressions of the form: 19 | -- - inl(inr*(e)) e.g. inl(inr(e)) becomes in(1)(e) 20 | -- inl(e) becomes in(0)(e) 21 | -- - inr+(e) e.g. inr(inr(e)) becomes in(2)(e) 22 | -- Note: for complex types, such as Option{(unit + Option{(unit + word)})} 23 | -- inr(inr(x)) becomes in1(in1(x)) rather than in2(x) 24 | compressInjections ty@(TSumN ts) e = go 0 e where 25 | arity = length ts 26 | go k e | k == arity-1 = EInK k ty (compress e) 27 | go k (EInr _ e) = go (k+1) e 28 | go k (EInl _ e) = EInK k ty e 29 | -- go k e = EInK k ty (compress e) 30 | 31 | {- Compress match statements 32 | match e with { 33 | inl(x) => s1 34 | inr(y) => s2 } 35 | becomes 36 | match e with { 37 | in1(x) => s1 38 | in2(x) => s2 } 39 | even if s2 is a match statement 40 | 41 | match e with { 42 | inl(x) => s1 43 | inr(y) => match y with { 44 | } 45 | } 46 | 47 | To do this we need to know the scrutinee type 48 | -} 49 | compressMatch cty@(TSumN ts) top@(SMatch ty e alts) = SMatch ty' e' (go 0 top) where 50 | ty' = compress ty 51 | e' = compress e 52 | arity = length ts 53 | alt = ConAlt 54 | go k s@(SMatch t@(TNamed n ty) e alts) = go k (SMatch ty e alts) 55 | go k s@(SMatch t@(TSum lty rty) e [ConAlt CInl ln left, ConAlt CInr rn right]) 56 | -- last two alternatives in the chain 57 | | k == arity-2 = [alt (CInK k )ln left', alt (CInK (k+1)) rn right'] 58 | -- not reached the end of the chain yet 59 | | otherwise = firstAlt:rest 60 | where 61 | left' = compress left 62 | right' = compress right 63 | firstAlt = alt (CInK k) ln left' 64 | rest = go (k+1) right 65 | go k (SBlock [s]) = go k s 66 | go k s = error $ concat["compressMatch unimplemented for k=",show k," stmt: ", show s] 67 | 68 | instance Compress Contract where 69 | compress c = c { ccStmts = map compress (ccStmts c) } 70 | 71 | instance Compress a => Compress [a] where 72 | compress = map compress 73 | 74 | instance Compress Stmt where 75 | compress (SFunction n args t stmts) = SFunction n 76 | (compress args) 77 | (compress t) 78 | (map compress stmts) 79 | compress (SReturn e) = SReturn (compress e) 80 | compress (SMatch t e alts) = compressMatch (compress t) (SMatch t e alts) 81 | compress s = s 82 | 83 | instance Compress Arg where 84 | compress (TArg n t) = TArg n (compress t) 85 | 86 | instance Compress Expr where 87 | compress e@(EInl ty _) = compressInjections (compress ty) e 88 | compress e@(EInr ty _) = compressInjections (compress ty) e 89 | compress (ECall n es) = ECall n (compress es) 90 | compress e = e -------------------------------------------------------------------------------- /yule/Locus.hs: -------------------------------------------------------------------------------- 1 | module Locus where 2 | import Data.String 3 | {- 4 | Location tree with addresses a: 5 | - location for Int is a single cell 6 | - location for pair is a pair of locations for components 7 | - location for sum is a location for tag and locations for payload 8 | -} 9 | data LocTree a 10 | = LocWord Integer -- int literal 11 | | LocBool Bool -- bool literal 12 | | LocStack a -- stack location 13 | | LocNamed String -- named location (e.g. argument/result) 14 | | LocSeq [LocTree a] -- sequence of locations 15 | | LocEmpty Int -- empty location of given size 16 | deriving (Eq, Show) 17 | 18 | pattern LocPair a b = LocSeq [a, b] 19 | pattern LocUnit = LocSeq [] 20 | 21 | type Location = LocTree Int 22 | 23 | stkLoc :: IsString name => Int -> name 24 | stkLoc i = fromString("_v" ++ show i) -------------------------------------------------------------------------------- /yule/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | import Language.Core(Contract(..)) 4 | import Language.Core.Parser 5 | import Common.Pretty(Pretty(..), nest, render) 6 | import Builtins(yulBuiltins) 7 | import Compress 8 | import TM 9 | import Translate 10 | import Language.Yul(wrapInSolFunction, wrapInContract) 11 | import qualified Options 12 | import Options(parseOptions) 13 | import Control.Monad(when) 14 | import Data.String(fromString) 15 | 16 | 17 | main :: IO () 18 | main = do 19 | options <- parseOptions 20 | -- print options 21 | let filename = Options.input options 22 | src <- readFile filename 23 | let coreContract = parseContract filename src 24 | let core = ccStmts coreContract 25 | when (Options.verbose options) $ do 26 | putStrLn "/* Core:" 27 | putStrLn (render (nest 2 (ppr coreContract))) 28 | putStrLn "*/" 29 | let oCompress = Options.compress options 30 | let source = if oCompress then compress core else core 31 | when oCompress $ do 32 | putStrLn "Compressing sums" 33 | putStrLn (render (nest 2 (ppr source))) 34 | generatedYul <- runTM options (translateStmts source) 35 | let fooFun = wrapInSolFunction "wrapper" (yulBuiltins <> generatedYul) 36 | let doc = wrapInContract (fromString (ccName coreContract)) "wrapper()" fooFun 37 | -- putStrLn (render doc) 38 | putStrLn ("writing output to " ++ Options.output options) 39 | writeFile (Options.output options) (render doc) 40 | -------------------------------------------------------------------------------- /yule/Options.hs: -------------------------------------------------------------------------------- 1 | module Options where 2 | 3 | import Options.Applicative 4 | 5 | data Options = Options 6 | { input :: FilePath 7 | , contract :: String 8 | , output :: FilePath 9 | , verbose :: Bool 10 | , debug :: Bool 11 | , compress :: Bool 12 | } deriving Show 13 | 14 | optionsParser :: Parser Options 15 | optionsParser = Options 16 | <$> argument str 17 | ( metavar "FILE" 18 | <> help "Input file" ) 19 | <*> strOption 20 | ( long "contract" 21 | <> short 'c' 22 | <> metavar "NAME" 23 | <> help "Contract name" 24 | <> value "Output" 25 | <> showDefault 26 | ) 27 | <*> strOption 28 | ( long "output" 29 | <> short 'o' 30 | <> metavar "FILE" 31 | <> help "Output file" 32 | <> value "Output.sol" 33 | <> showDefault 34 | ) 35 | <*> switch 36 | ( long "verbose" 37 | <> short 'v' 38 | <> help "Verbosity level" 39 | ) 40 | <*> switch 41 | ( long "debug" 42 | <> short 'd' 43 | <> help "Diagnostic output" 44 | ) 45 | <*> switch 46 | ( long "compress" 47 | <> short 'O' 48 | <> help "Compress sums (experimental)" 49 | ) 50 | 51 | parseOptions :: IO Options 52 | parseOptions = execParser opts 53 | where 54 | opts = info (optionsParser <**> helper) 55 | ( fullDesc 56 | <> progDesc "Compile a Core program to Yul" 57 | <> header "yule - experiments with Yul codegen" ) -------------------------------------------------------------------------------- /yule/README.md: -------------------------------------------------------------------------------- 1 | Compiles core language to Yul wrapped in a Solidity contract, 2 | ready to be run with forge 3 | 4 | ## Example 5 | 6 | ``` 7 | $ cabal run -- yule 8 | Missing: FILE 9 | 10 | Usage: yule FILE [-c|--contract NAME] [-o|--output FILE] [-v|--verbose] 11 | 12 | Compile a Core program to Yul 13 | 14 | $ cabal run -- yule examples/core/02sum.core --contract Sum -o Sum.sol 15 | writing output to Sum.sol 16 | 17 | $ forge script Sum.sol 18 | [.] Compiling... 19 | [.] Compiling 1 files with 0.8.23 20 | [.] Solc 0.8.23 finished in 284.26ms 21 | Compiler run successful! 22 | Script ran successfully. 23 | Gas used: 24357 24 | 25 | == Logs == 26 | RESULT --> 42 27 | ``` -------------------------------------------------------------------------------- /yule/TM.hs: -------------------------------------------------------------------------------- 1 | module TM 2 | ( TM 3 | , runTM 4 | , CEnv(..) 5 | --, module RIO 6 | , module Locus 7 | , FunInfo(..) 8 | , getCounter 9 | , setCounter 10 | , freshId 11 | , lookupVar 12 | , insertVar 13 | , lookupFun 14 | , insertFun 15 | , getVarEnv 16 | , putVarEnv 17 | , withLocalEnv 18 | , debug 19 | ) where 20 | import Common.Monad 21 | import Common.RIO 22 | import Control.Monad(when) 23 | import qualified Data.Map as Map 24 | import Data.Map(Map) 25 | 26 | import Locus 27 | import Language.Core qualified as Core 28 | import qualified Options 29 | import Options(Options) 30 | 31 | type VarEnv = Map String Location 32 | type FunEnv = Map String FunInfo 33 | data FunInfo = FunInfo { fun_args :: [Core.Type], fun_result :: Core.Type} 34 | data CEnv = CEnv 35 | { env_counter :: IORef Int 36 | , env_vars :: IORef VarEnv 37 | , env_funs :: IORef FunEnv 38 | , env_options :: Options 39 | } 40 | 41 | type TM a = RIO CEnv a 42 | 43 | runTM :: Options -> TM a -> IO a 44 | runTM options m = do 45 | counter <- newIORef 0 46 | vars <- newIORef Map.empty 47 | funs <- newIORef (Map.fromList builtinFuns) 48 | runRIO m (CEnv counter vars funs options) 49 | 50 | getCounter :: TM Int 51 | getCounter = reader env_counter >>= load 52 | 53 | setCounter :: Int -> TM () 54 | setCounter n = reader env_counter >>= flip store n 55 | 56 | getDebug :: TM Bool 57 | getDebug = reader (Options.debug . env_options) 58 | 59 | whenDebug m = do 60 | debugp <- getDebug 61 | when debugp m 62 | 63 | debug :: [String] -> TM () 64 | debug msg = whenDebug $ writes msg 65 | 66 | freshId :: TM Int 67 | freshId = do 68 | counter <- reader env_counter 69 | n <- load counter 70 | store counter (n+1) 71 | return n 72 | 73 | lookupVar :: String -> TM Location 74 | lookupVar x = do 75 | vars <- getVarEnv 76 | case Map.lookup x vars of 77 | Just n -> return n 78 | Nothing -> error ("Variable not found: " ++ x) 79 | 80 | insertVar :: String -> Location -> TM () 81 | insertVar x n = do 82 | vars <- reader env_vars 83 | update vars (Map.insert x n) 84 | 85 | lookupFun :: String -> TM FunInfo 86 | lookupFun f = do 87 | funs <- getFunEnv 88 | case Map.lookup f funs of 89 | Just n -> return n 90 | Nothing -> error ("Function not found: " ++ f) 91 | 92 | insertFun :: String -> FunInfo -> TM () 93 | insertFun f n = do 94 | funs <- reader env_funs 95 | update funs (Map.insert f n) 96 | 97 | getVarEnv :: TM VarEnv 98 | getVarEnv = load =<< reader env_vars 99 | 100 | putVarEnv :: VarEnv -> TM () 101 | putVarEnv m = do 102 | vars <- reader env_vars 103 | store vars m 104 | 105 | getFunEnv :: TM FunEnv 106 | getFunEnv = load =<< reader env_funs 107 | 108 | putFunEnv :: FunEnv -> TM () 109 | putFunEnv m = do 110 | funs <- reader env_funs 111 | store funs m 112 | 113 | withLocalEnv :: TM a -> TM a 114 | withLocalEnv m = do 115 | vars <- getVarEnv 116 | funs <- getFunEnv 117 | x <- m 118 | putVarEnv vars 119 | putFunEnv funs 120 | return x 121 | 122 | builtinFuns :: [(String, FunInfo)] 123 | builtinFuns = 124 | [ ("stop", FunInfo [] Core.TUnit) 125 | , ("add", FunInfo [Core.TWord, Core.TWord] Core.TWord) 126 | , ("mul", FunInfo [Core.TWord, Core.TWord] Core.TWord) 127 | , ("sub", FunInfo [Core.TWord, Core.TWord] Core.TWord) 128 | , ("div", FunInfo [Core.TWord, Core.TWord] Core.TWord) 129 | , ("sdiv", FunInfo [Core.TWord, Core.TWord] Core.TWord) 130 | , ("mod", FunInfo [Core.TWord, Core.TWord] Core.TWord) 131 | , ("smod", FunInfo [Core.TWord, Core.TWord] Core.TWord) 132 | , ("addmod", FunInfo [Core.TWord, Core.TWord, Core.TWord] Core.TWord) 133 | , ("mulmod", FunInfo [Core.TWord, Core.TWord, Core.TWord] Core.TWord) 134 | , ("exp", FunInfo [Core.TWord, Core.TWord] Core.TWord) 135 | ] 136 | --------------------------------------------------------------------------------