├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── compile-to-core ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── compile-to-core.cabal ├── files │ └── Preamble.pkore ├── stack.yaml └── test │ ├── .gitignore │ ├── Spec.hs │ └── test.sh ├── docs ├── RESOURCES.md └── core-spec.pdf ├── script └── krunhaskell.sh ├── setup.sh ├── src ├── .gitignore ├── haskell-core-execution.k ├── haskell-core-syntax.k ├── haskell-core.k └── old-stuff │ ├── haskell-core.k │ ├── lambda.core │ ├── types-syntax.k │ └── types.k └── test ├── .gitignore ├── Sample.hcr ├── config.xml ├── gen_core.sh ├── haskell ├── Bools.hs ├── BouncyNumbers.hs ├── Cases.hs ├── ChurchBool.hs ├── ChurchNat.hs ├── ChurchNat2.hs ├── ChurchNat3.hs ├── Compose.hs ├── Disequality.hs ├── Equality.hs ├── Identity.hs ├── Imports.hs ├── Integers.hs ├── LetRec.hs ├── Nats.hs ├── Primes.hs ├── Rationals.hs └── Sum.hs ├── kast_all.sh ├── pkore-samples ├── Case.pkore ├── ChurchBool.pkore ├── ChurchNat.pkore ├── ChurchNat2.pkore ├── ChurchNat3.pkore ├── Identity.pkore ├── Lambda.pkore ├── Let-1.pkore ├── Let-2.pkore ├── Let-3.pkore ├── Let-4.pkore ├── Let-5.pkore └── Nats.pkore └── test_all.sh /.gitignore: -------------------------------------------------------------------------------- 1 | haskell-core-kompiled 2 | *.hi 3 | *.o 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: java 2 | 3 | dist: trusty 4 | 5 | branches: 6 | only: 7 | - master 8 | 9 | sudo: false 10 | 11 | before_install: 12 | - cd $HOME 13 | - if [ ! -d k ]; then git clone https://github.com/kframework/k/; fi 14 | - cd k 15 | - ls 16 | - mvn package -DskipTests; 17 | - export PATH=$PATH:$(pwd)/k-distribution/target/release/k/bin 18 | - cd $TRAVIS_BUILD_DIR 19 | 20 | install: 21 | - make 22 | 23 | script: 24 | - cd test 25 | - ktest config.xml 26 | 27 | cache: 28 | directories: 29 | - $HOME/k 30 | - $HOME/.m2 31 | 32 | notifications: 33 | email: 34 | recipients: 35 | - tosun2@illinois.edu 36 | - lpena7@illinois.edu 37 | on_failure: always # default: always 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ============================================================================== 2 | The Haskell Core Semantics in K Release License 3 | ============================================================================== 4 | University of Illinois/NCSA 5 | Open Source License 6 | 7 | Copyright (c) 2017 University of Illinois at Urbana-Champaign. 8 | All rights reserved. 9 | 10 | Developed by: 11 | 12 | K Team (http://kframework.org) 13 | with members from: 14 | 15 | * University of Illinois at Urbana-Champaign (http://fsl.cs.illinois.edu/) 16 | * Runtime Verification, Inc (https://www.runtimeverification.com) 17 | * University Alexandru-Ioan Cuza, Romania (https://fmse.info.uaic.ro) 18 | 19 | Permission is hereby granted, free of charge, to any person obtaining a copy of 20 | this software and associated documentation files (the "Software"), to deal with 21 | the Software without restriction, including without limitation the rights to 22 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 23 | of the Software, and to permit persons to whom the Software is furnished to do 24 | so, subject to the following conditions: 25 | 26 | 27 | * Redistributions of source code must retain the above copyright notice, 28 | this list of conditions and the following disclaimers. 29 | 30 | * Redistributions in binary form must reproduce the above copyright notice, 31 | this list of conditions and the following disclaimers in the 32 | documentation and/or other materials provided with the distribution. 33 | 34 | * Neither the names of the K Team, Runtime Verification, the University of 35 | Illinois at Urbana-Champaign, the University Alexandru-Ioan Cuza, nor 36 | the names of its contributors may be used to endorse or promote products 37 | derived from this Software without specific prior written permission. 38 | 39 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 40 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 41 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 42 | CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 43 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 44 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE 45 | SOFTWARE. 46 | 47 | ============================================================================== 48 | Copyrights and Licenses for Third Party Software Distributed with the C 49 | Semantics in K: 50 | ============================================================================== 51 | The C Semantics in K software contains code written by third parties. 52 | Licenses for this software can be found in the licenses directory 53 | in the file as specified below. These files will describe the copyrights, 54 | license, and restrictions which apply to that code. 55 | 56 | The disclaimer of warranty in the University of Illinois Open Source License 57 | applies to all code in the C Semantics in K Distribution, and nothing in any of 58 | the other licenses gives permission to use the names of the K Team, Runtime 59 | Verification, the University of Illinois, or the University Alexandru-Ioan Cuza 60 | to endorse or promote products derived from this Software. 61 | 62 | The following pieces of software have additional or alternate copyrights, 63 | licenses, and/or restrictions: 64 | 65 | Program Directory 66 | ------- --------- 67 | compile-to-core compile-to-core/ 68 | Haskell Core Semantics src/ 69 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | kompile --debug --verbose --syntax-module HASKELL-CORE-SYNTAX src/haskell-core.k 3 | rm -rf haskell-core-kompiled 4 | mv -f src/haskell-core-kompiled . 5 | 6 | clean: 7 | rm -rf haskell-core-kompiled 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GHC Core in **K** 2 | 3 | Our ongoing work on the implementation of GHC's 4 | [Core](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/CoreSynType) 5 | language lives in this repository. 6 | 7 | ## Running 8 | 9 | ### Prerequisites 10 | 11 | First make sure that you have [**K**](https://github.com/kframework/k) (latest 12 | release) as well as [Haskell 13 | Stack](https://docs.haskellstack.org/en/stable/README/) installed. Then: 14 | 15 | * Run `make` in the root of the repository. 16 | * Run `stack install` inside `compile-to-core`. This will build and install 17 | our tool that converts Haskell programs into an intermediate representation of 18 | of Haskell Core. To find out how to experiment with this tool, you can run 19 | `to-core --help`. 20 | 21 | ### Running Haskell 22 | 23 | You can use `script/krunhaskell.sh` to directly run Haskell code. First run 24 | `source setup.sh` to configure the environment variable 25 | `HASKELL_CORE_SEMANTICS_DIR` that will be needed. This will also alias 26 | `krunhaskell` to the absolute path of `script/krunhaskell.sh` so that you can 27 | use it anywhere. 28 | 29 | In a Haskell file `Foo.hs` that you want to run, designate an expression by 30 | adding a top-level declaration with the definiendum `result`; the definiens of 31 | this declaration is the expression whose evaluation will be forced. For example, 32 | `Foo.hs` might look like: 33 | ```haskell 34 | module Foo where 35 | 36 | result = (\x -> \y -> (\x -> x) x) 3 5 37 | ``` 38 | Then running 39 | ```bash 40 | krunhaskell Foo 41 | ``` 42 | yields 43 | ``` 44 | lit ( litInt ( 3 , [type omitted] ) ) 45 | ``` 46 | which is what the result of running the Core program generated by `Foo.hs` 47 | throught the Core semantics is. Our concrete representation of GHC Core [is 48 | documented 49 | here](https://github.com/kframework/haskell-core-semantics/blob/master/compile-to-core/README.md). 50 | -------------------------------------------------------------------------------- /compile-to-core/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | TAGS 3 | *.hi 4 | *.o 5 | -------------------------------------------------------------------------------- /compile-to-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Ayberk Tosun (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ayberk Tosun nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /compile-to-core/README.md: -------------------------------------------------------------------------------- 1 | # compile-to-core 2 | 3 | To run the examples, first build with `stack build`. If you have a Haskell module named `Foo` run `stack exec to-core Foo` in the directory 4 | of the file `Foo.hs`. 5 | 6 | Currently, the following simple definition: 7 | ```haskell 8 | one :: Integer 9 | one = 1 10 | ``` 11 | results in: 12 | ``` 13 | nonRec(tmVar(tyConApp(algTyCon(Integer, tyConApp(primTyCon(TYPE), tyConApp(promDataCon(dataCon(PtrRepLifted)))))), rn8), 14 | litInt(1, tyConApp(algTyCon(Integer, tyConApp(primTyCon(TYPE), tyConApp(promDataCon(dataCon(PtrRepLifted)))))))) 15 | `````` 16 | 17 | You can use the `--no-types` flag to omit the type information. For `one`, this results in the following: 18 | ```haskell 19 | nonRec(tmVar([type omitted], r1), litInt(1, [type omitted])) 20 | ``` 21 | 22 | ## The output format 23 | 24 | We give the list of operators with their 25 | arities in the style of sorted algebra. The only syntactic definition we have 26 | is for the case of an operator `f` of arity `S₁ ⋯ Sₙ ⟶ S` being applied to 27 | arguments `k₁, ..., kₙ` of sorts `S₁, ..., Sₙ` which is denoted: 28 | ``` 29 | f(k₁, ..., kₙ) 30 | ``` 31 | 32 | The syntactic forms of the constants (for example, the sort `Literal`) will 33 | be explained in their corresponding sections. 34 | 35 | ### Type synonyms 36 | 37 | Some of these type synonyms defined in the GHC source code can be confusing 38 | to those who are not familiar with the implementation of Core. We list them to 39 | prevent confusion: 40 | * [`type CoreBndr = Var`](https://github.com/ghc/ghc/blob/6df8bef054db0b95bb8f9e55bb82580e27d251d6/compiler/coreSyn/CoreSyn.hs#L1734) 41 | 42 | 43 | ### `Name` 44 | 45 | __TODO__: this uses `showSDocUnsafe`. 46 | 47 | ### `Var` 48 | 49 | There are 2 operators of sort `Var`. 50 | ``` 51 | tmVar : Type Name ⟶ Var 52 | tyVar : Type Name ⟶ Var 53 | ``` 54 | 55 | ### `Rational` 56 | 57 | __TODO__ 58 | 59 | ### `Literal` 60 | 61 | There are 14 operators of sort `Literal`. 62 | ``` 63 | machChar : Char ⟶ Literal 64 | machStr : ByteString ⟶ Literal 65 | nullAddr : ⟶ Literal 66 | machInt : Integer ⟶ Literal 67 | machInt64 : Integer ⟶ Literal 68 | machWord : Integer ⟶ Literal 69 | machWord64 : Integer ⟶ Literal 70 | machFloat : Rational ⟶ Literal 71 | machDouble : Rational ⟶ Literal 72 | machLabelFunSome : String Int ⟶ Literal 73 | machLabelDataSome : String Int ⟶ Literal 74 | machLabelFunNone : String ⟶ Literal 75 | machLabelDataNone : String ⟶ Literal 76 | litInt : Integer Type ⟶ Literal 77 | ``` 78 | 79 | ### `Expr` (`CoreExpr` in GHC Core) 80 | 81 | There are 10 operators of sort `Expr`. 82 | ``` 83 | var : Id ⟶ Expr 84 | lit : Literal ⟶ Expr 85 | app : Expr Expr ⟶ Expr 86 | lam : Binding Expr ⟶ Expr 87 | let : Binding Expr ⟶ Expr 88 | case : Expr Binding Type AltList ⟶ Expr 89 | cast : Expr Coercion ⟶ Expr 90 | tick : Tickish Expr ⟶ Expr 91 | type : Type ⟶ Expr 92 | coerce : Coercion ⟶ Expr 93 | ``` 94 | 95 | ### `Binding` (`Bind CoreBndr` in GHC Core) 96 | 97 | There are 2 operators of sort `Binding`. 98 | ``` 99 | nonRec : Var Expr ⟶ Binding 100 | rec : BindingList ⟶ Binding 101 | ``` 102 | 103 | ### `BindingList` 104 | 105 | There are 2 operators of sort `BindingList`. 106 | ``` 107 | emptyBind : ⟶ BindingList 108 | bind : Var Expr BindingList ⟶ BindingList 109 | ``` 110 | 111 | ### `Tickish` 112 | 113 | There are 4 operators of sort `Tickish`. 114 | ``` 115 | profNote : ⟶ Tickish 116 | hpcTick : ⟶ Tickish 117 | breakpoint : ⟶ Tickish 118 | sourceNote : ⟶ Tickish 119 | ``` 120 | 121 | ### `Arity` 122 | 123 | `Arity` is an `Integer`. 124 | 125 | ### `DataCon` 126 | 127 | There is one operator of sort `DataCon`. 128 | ``` 129 | dataCon : Name Arity ⟶ DataCon 130 | ``` 131 | 132 | ### `AlgTyConRhs` 133 | 134 | There are 4 operators of sort `AlgTyConRhs`. 135 | 136 | ``` 137 | dataTyCon : DataConList ⟶ AlgTyConRhs 138 | abstractTyCon : ⟶ AlgTyConRhs 139 | newTyCon : DataCon ⟶ AlgTyConRhs 140 | ``` 141 | 142 | ### `AltCon` 143 | 144 | There are three operators of sort `AltCon`. 145 | ``` 146 | dataAlt : DataCon ⟶ AltCon 147 | litAlt : Literal ⟶ AltCon 148 | defaultAlt : ⟶ AltCon 149 | ``` 150 | 151 | ### `Type` 152 | 153 | __TODO__: Leaving this out for now as it is not a priority. 154 | 155 | ### `TyCon` 156 | 157 | There are 6 operators of sort `TyCon`. 158 | 159 | ``` 160 | arrTyCon : ⟶ TyCon 161 | synTyCon : ⟶ TyCon 162 | tupleTyCon : ⟶ TyCon 163 | algTyCon : Name Type AlgTyConRhs ⟶ TyCon 164 | primTyCon : PrimTyCon ⟶ TyCon 165 | ``` 166 | 167 | ### `VisibilityFlag` 168 | 169 | __TODO___ 170 | 171 | ### `TyLit` 172 | 173 | __TODO__ 174 | 175 | ### `UnivCoProvenance` 176 | 177 | __TODO__ 178 | 179 | ### `Role` 180 | 181 | There are 3 constants of sort `Role`. 182 | 183 | ``` 184 | nom : ⟶ Role 185 | repr : ⟶ Role 186 | phant : ⟶ Role 187 | ``` 188 | 189 | ### `Coercion` 190 | 191 | __TODO__ 192 | 193 | ### `CoAxiom` 194 | 195 | __TODO__ 196 | 197 | ### `CoAxBranch` 198 | 199 | __TODO__ 200 | -------------------------------------------------------------------------------- /compile-to-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /compile-to-core/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnicodeSyntax #-} 2 | 3 | module Main where 4 | 5 | import BasicTypes (Arity, FunctionOrData (..)) 6 | import CoAxiom (Branched, CoAxBranch (..), CoAxiom (..), 7 | CoAxiomRule (..), Role (..), cab_lhs, 8 | cab_rhs, co_ax_tc, fromBranches) 9 | import Control.Monad ((<=<)) 10 | import CoreSyn 11 | import Data.ByteString.Char8 (unpack) 12 | import Data.List (intercalate) 13 | import Data.Semigroup ((<>)) 14 | import DataCon (dataConSourceArity) 15 | import FastString (unpackFS) 16 | import GHC 17 | import GHC.Paths (libdir) 18 | import HscTypes (mg_binds, mg_tcs) 19 | import Literal 20 | import Options.Applicative 21 | import qualified Outputable as OP 22 | import System.Environment (getEnv) 23 | import TyCon (AlgTyConRhs (..), algTyConRhs, 24 | isAlgTyCon, isPromotedDataCon, 25 | isPromotedDataCon_maybe, isTupleTyCon, 26 | tyConKind, tyConName) 27 | import TyCoRep (Coercion (..), LeftOrRight (..), 28 | TyBinder (..), TyLit (..), Type (..), 29 | UnivCoProvenance (..), 30 | VisibilityFlag (..)) 31 | import Var (Var, isId, isTyVar, varName, varType) 32 | 33 | errorTODO :: a 34 | errorTODO = error "TODO" 35 | 36 | type ShouldOmitTypes = Bool 37 | 38 | data Flags = Flags 39 | { shouldOmitTypes :: ShouldOmitTypes 40 | , shouldUseColor :: Bool 41 | , shouldStripResult :: Bool 42 | } 43 | 44 | args :: [String] -> String 45 | args ss = "(" ++ intercalate ", " ss ++ ")" 46 | 47 | prVar :: Flags -> Var -> String 48 | prVar flg e 49 | | isId e = "tmVar" ++ args [prType flg (varType e), prName $ varName e] 50 | | isTyVar e = "tyVar" ++ args [prType flg (varType e), prName $ varName e] 51 | | otherwise = error "this case should not happen." 52 | 53 | prList :: String -> [String] -> String 54 | prList t [] = t ++ "Empty" 55 | prList t (x:xs) = (t ++ "Cons") ++ args [x, prList t xs] 56 | 57 | prName :: Name -> String 58 | prName n = "name" ++ args [OP.showSDocUnsafe (OP.ppr n)] 59 | 60 | prAlt :: Flags -> Alt Var -> String 61 | prAlt flg (ac, bs, e) = 62 | let acs = prAltCon flg ac 63 | bss = prList "Var" $ prVar flg <$> bs 64 | es = prExpr flg e 65 | in "alt" ++ args [acs, bss, es] 66 | 67 | prArity :: Arity -> String 68 | prArity x = "arity" ++ args [show x] 69 | 70 | prDataCon :: DataCon -> String 71 | prDataCon dc = 72 | let arg1 = prName $ getName dc 73 | -- As we are ignoring types for now it is okay to just use 74 | -- `dataConSourceArity`. In the future, however, we might need to use 75 | -- `dataConOrigArgTys`, that gives the typed arity information. 76 | arg2 = prArity $ dataConSourceArity dc 77 | in "dataCon" ++ args [arg1, arg2] 78 | 79 | prAltCon :: Flags -> AltCon -> String 80 | prAltCon _ (DataAlt dc) = "dataAlt" ++ args [prDataCon dc] 81 | prAltCon flg (LitAlt lit) = "litAlt" ++ args [prLit flg lit] 82 | prAltCon _ DEFAULT = "defaultAlt()" 83 | 84 | prAlgTyConRhs :: AlgTyConRhs -> String 85 | prAlgTyConRhs (DataTyCon dcs _) = 86 | "dataTyCon" ++ args [prList "DataCon" $ prDataCon <$> dcs] 87 | -- The omitted information in the following case might be needed in the future. 88 | prAlgTyConRhs (AbstractTyCon _) = "abstractTyCon()" 89 | prAlgTyConRhs (NewTyCon dc _ _ _) = "newTyCon" ++ args [prDataCon dc] 90 | prAlgTyConRhs _ = error "Many cases of prAlgTyConRhs not implemented yet." 91 | 92 | prTyCon :: Flags -> TyCon -> String 93 | prTyCon flg tc 94 | | isFunTyCon tc = 95 | "arrTyCon()" 96 | | isTypeSynonymTyCon tc = 97 | "synTyCon" ++ args [prType flg $ tyConKind tc] 98 | | isTupleTyCon tc = 99 | "tupleTyCon()" ++ args [prType flg $ tyConKind tc] 100 | | isAlgTyCon tc = 101 | let arg1 = prName $ tyConName tc 102 | arg2 = prType flg $ tyConKind tc 103 | arg3 = prAlgTyConRhs $ algTyConRhs tc 104 | in "algTyCon" ++ args [arg1, arg2, arg3] 105 | | isPrimTyCon tc = "primTyCon" ++ args [prName $ tyConName tc] 106 | | isPromotedDataCon tc = 107 | case isPromotedDataCon_maybe tc of 108 | Just tc' -> "promDataCon" ++ args [prDataCon tc'] 109 | Nothing -> error "there should be a dataCon" 110 | | otherwise = error "InternalError: this case must not have happened." 111 | 112 | prRole :: Role -> String 113 | prRole Nominal = "nom" 114 | prRole Representational = "repr" 115 | prRole Phantom = "phant" 116 | 117 | prCoAxBranch :: Flags -> CoAxBranch -> String 118 | prCoAxBranch flg cab = 119 | let 120 | tvs = prList "tyVar" $ prVar flg <$> cab_tvs cab 121 | roles = prList "role" $ prRole <$> cab_roles cab 122 | lhs_str = args $ prType flg <$> cab_lhs cab 123 | rhs_str = prType flg $ cab_rhs cab 124 | in 125 | "coAxBranch" ++ args [tvs, roles, lhs_str, rhs_str] 126 | 127 | prCoAxiom :: Flags -> CoAxiom Branched -> String 128 | prCoAxiom flg ca = 129 | let 130 | t = prTyCon flg $ co_ax_tc ca 131 | rho = prRole $ co_ax_role ca 132 | branches = fromBranches (co_ax_branches ca) 133 | axBranchList = prList "CoAxBranch" $ prCoAxBranch flg <$> branches 134 | in 135 | "coAxiom" ++ args [t, rho, axBranchList] 136 | 137 | prProvenance :: UnivCoProvenance -> String 138 | prProvenance UnsafeCoerceProv = "unsafeProv" 139 | prProvenance (PhantomProv _) = "phantProv" 140 | prProvenance (ProofIrrelProv _) = "proofIrrelProv" 141 | prProvenance (PluginProv _) = "pluginProv" 142 | prProvenance (HoleProv _) = "holeProv" 143 | 144 | -- TODO: Make sure that this is what we want. 145 | prCoAxiomRule :: CoAxiomRule -> String 146 | prCoAxiomRule car = unpackFS $ coaxrName car 147 | 148 | prCoercion :: Flags -> Coercion -> String 149 | prCoercion flg (Refl r ty) = "refl" ++ args [prRole r, prType flg ty] 150 | prCoercion flg (TyConAppCo role tc cs) = 151 | let csArg = prList "coercion" (prCoercion flg <$> cs) 152 | in "tyConAppCo" ++ args [prRole role, prTyCon flg tc, csArg] 153 | prCoercion flg (AppCo coe1 coe2) = 154 | "appCo" ++ args (prCoercion flg <$> [coe1, coe2]) 155 | -- TODO: Make sure that this is what we want for the `CoVarCo` case. 156 | prCoercion flg (CoVarCo x) = "coVarCo" ++ args [prVar flg x] 157 | prCoercion flg (AxiomInstCo cab bi cs) = 158 | let csArgs = prList "coercion" $ prCoercion flg <$> cs 159 | biArg = "brIndex" ++ args [show bi] 160 | in "axiomInstCo" ++ args [prCoAxiom flg cab, biArg, csArgs] 161 | prCoercion flg (UnivCo prov r ty1 ty2) = 162 | let arg1 = prProvenance prov 163 | arg2 = prType flg ty1 164 | arg3 = prType flg ty2 165 | arg4 = prRole r 166 | in "univCo" ++ args [arg1, arg2, arg3, arg4] 167 | prCoercion flg (SymCo co) = 168 | "symCo" ++ args [prCoercion flg co] 169 | prCoercion flg (TransCo co1 co2) = 170 | "transCo" ++ args [prCoercion flg co1, prCoercion flg co2] 171 | prCoercion flg (AxiomRuleCo car cs) = 172 | "axiomRuleCo" ++ args (prCoAxiomRule car : (prCoercion flg <$> cs)) 173 | prCoercion flg (NthCo i co) = 174 | "nthCo" ++ args [show i, prCoercion flg co] 175 | prCoercion flg (LRCo CLeft co) = 176 | "leftProjCo" ++ args [prCoercion flg co] 177 | prCoercion flg (LRCo CRight co) = 178 | "rightProjCo" ++ args [prCoercion flg co] 179 | prCoercion flg (InstCo co1 co2) = 180 | "instCo" ++ args [prCoercion flg co1, prCoercion flg co2] 181 | prCoercion flg (CoherenceCo co kco) = 182 | "coherenceCo" ++ args [prCoercion flg co, prCoercion flg kco] 183 | prCoercion flg (KindCo co) = 184 | "kindCo" ++ args [prCoercion flg co] 185 | prCoercion flg (SubCo co) = 186 | "subCo" ++ args [prCoercion flg co] 187 | prCoercion flg (ForAllCo tv kc c) = 188 | "forAllCo" ++ args [prVar flg tv, prCoercion flg kc, prCoercion flg c] 189 | 190 | prVisibilityFlag :: VisibilityFlag -> String 191 | prVisibilityFlag Visible = "visible" 192 | prVisibilityFlag Specified = "specified" 193 | prVisibilityFlag Invisible = "invisible" 194 | 195 | prType :: Flags -> Type -> String 196 | prType flg ty' 197 | | shouldOmitTypes flg && shouldUseColor flg = "\x1b[31m[type omitted]\x1b[0m" 198 | | shouldOmitTypes flg = "[type omitted]" 199 | | otherwise = 200 | case ty' of 201 | TyVarTy x -> prVar flg x 202 | AppTy ty1 ty2 -> 203 | "appTy" ++ args [prType flg ty1 , prType flg ty2] 204 | TyConApp tc kt -> 205 | "tyConApp" ++ args (prTyCon flg tc : (prType flg <$> kt)) 206 | ForAllTy (Named tyvar vf) ty -> 207 | "forallTy" ++ args [prVar flg tyvar, prVisibilityFlag vf, prType flg ty] 208 | ForAllTy (Anon ty1) ty2 -> 209 | "arr" ++ args [prType flg ty1, prType flg ty2] 210 | LitTy tyl -> prTyLit tyl 211 | CastTy ty kindco -> 212 | "castTy" ++ args [prType flg ty, prCoercion flg kindco] 213 | CoercionTy co -> 214 | "coercionTy" ++ args [prCoercion flg co] 215 | 216 | -- TODO: Get this into KORE format. 217 | prLit :: Flags -> Literal -> String 218 | prLit _ (MachChar c) = "machChar" ++ args [[c]] 219 | prLit _ (MachStr bs) = "machStr" ++ args ["\"" ++ unpack bs ++ "\""] 220 | prLit _ MachNullAddr = "nullAddr" 221 | prLit _ (MachInt n) = "machInt" ++ args [show n] 222 | prLit _ (MachInt64 n) = "machInt64" ++ args [show n] 223 | prLit _ (MachWord n) = "machWord" ++ args [show n] 224 | prLit _ (MachWord64 n) = "machWord64" ++ args [show n] 225 | prLit _ (MachFloat r) = "machFloat" ++ args [show r] 226 | prLit _ (MachDouble r) = "machDouble" ++ args [show r] 227 | -- TODO: It might be nice to consider an alternative way of handling 228 | -- instead of having separate operators `Maybe Integer`. 229 | prLit _ (MachLabel fs (Just n) IsFunction) = 230 | "machLabelFunSome" ++ args [unpackFS fs, show n] 231 | prLit _ (MachLabel fs (Just n) IsData) = 232 | "machLabelDataSome" ++ args [unpackFS fs, show n] 233 | prLit _ (MachLabel fs Nothing IsFunction) = 234 | "machLabelFunNone" ++ args [unpackFS fs] 235 | prLit _ (MachLabel fs Nothing IsData) = 236 | "machLabelDataNone" ++ args [unpackFS fs] 237 | prLit flg (LitInteger n ty) = "litInt" ++ args [show n, prType flg ty] 238 | 239 | prTyLit :: TyLit -> String 240 | prTyLit (NumTyLit n) = "numTyLit" ++ args [show n] 241 | prTyLit (StrTyLit fs) = "strTyLit" ++ args [unpackFS fs] 242 | 243 | prBinding :: Flags -> Bind CoreBndr -> String 244 | prBinding flg (NonRec b e) = 245 | let definiendum = prVar flg b in 246 | case definiendum of 247 | "tmVar([type omitted], name(result))" | shouldStripResult flg 248 | -> prExpr flg e 249 | _ -> "nonRec" ++ args [definiendum, prExpr flg e] 250 | prBinding flg (Rec bs) = 251 | let prBindingList [] = "emptyBind" 252 | prBindingList ((b, e):bs') = 253 | let arglist = [prVar flg b, prExpr flg e, prBindingList bs'] 254 | in "bind" ++ args arglist 255 | in "rec" ++ args [prBindingList bs] 256 | 257 | prTickish :: Tickish Id -> String 258 | -- TODO: Figure out what these `Tickish` constructors are about. 259 | prTickish ProfNote {} = "profNote()" 260 | prTickish HpcTick {} = "hpcTick()" 261 | prTickish Breakpoint {} = "breakpoint()" 262 | prTickish SourceNote {} = "sourceNote()" 263 | 264 | prExpr :: Flags -> CoreExpr -> String 265 | prExpr flg (Var x) = "var" ++ args [prVar flg x] 266 | prExpr flg (Lit a) = "lit" ++ args [prLit flg a] 267 | prExpr flg (App e1 e2) = "app" ++ args (prExpr flg <$> [e1, e2]) 268 | -- TODO: Figure out how to print `CoreBndr` 269 | prExpr flg (Lam x e) = "lam" ++ args [prVar flg x, prExpr flg e] 270 | prExpr flg (Let b e) = "let" ++ args [prBinding flg b, prExpr flg e] 271 | prExpr flg (Case e b ty alts) = 272 | let altsStr = prList "alt" $ prAlt flg <$> alts 273 | in "case" ++ args [prExpr flg e, prVar flg b, prType flg ty, altsStr] 274 | prExpr flg (Cast e co) = "cast" ++ args [prExpr flg e, prCoercion flg co] 275 | prExpr flg (Tick tid e) = "tick" ++ args [prTickish tid, prExpr flg e] 276 | prExpr flg (Type ty) = "type" ++ args [prType flg ty] 277 | prExpr flg (Coercion co) = "coerce" ++ args [prCoercion flg co] 278 | 279 | getCoreBinds :: DesugaredModule -> IO [CoreBind] 280 | getCoreBinds dsm = return $ mg_binds . coreModule $ dsm 281 | 282 | getTyCons :: DesugaredModule -> IO [TyCon] 283 | getTyCons dsm = return $ mg_tcs . coreModule $ dsm 284 | 285 | getDesugaredModule :: String -> IO DesugaredModule 286 | getDesugaredModule modName = runGhc (Just libdir) $ do 287 | _ <- setSessionDynFlags =<< getSessionDynFlags 288 | target <- guessTarget (modName ++ ".hs") Nothing 289 | setTargets [target] 290 | _ <- load LoadAllTargets 291 | desugarModule <=< typecheckModule 292 | <=< parseModule 293 | <=< getModSummary $ mkModuleName modName 294 | 295 | data Args = Args 296 | { moduleName :: String 297 | , noTypes :: Bool 298 | , stripResult :: Bool 299 | , colorful :: Bool 300 | , outFile :: Maybe String } 301 | 302 | isResult :: Flags -> CoreBind -> Bool 303 | isResult flg (NonRec b _) = prVar flg b == "tmVar([type omitted], name(result))" 304 | isResult _ _ = False 305 | 306 | getDefiniens :: Flags -> CoreBind -> String 307 | getDefiniens flg (NonRec _ e) = prExpr flg e 308 | getDefiniens _ _ = error "result is a recursive binding" 309 | 310 | argParse :: Parser Args 311 | argParse = Args 312 | <$> argument str (metavar "MODULE") 313 | <*> switch (long "no-types" <> help "Omit type information") 314 | <*> switch ( long "strip-result" 315 | <> help "If there is a top-level declaration of a \ 316 | \definiendum named `result`, strip its definiens \ 317 | \out as a naked expression.") 318 | <*> switch (long "color" <> short 'c' <> help "Enable colorful output") 319 | <*> optional (strOption 320 | ( long "output-file" 321 | <> short 'o' 322 | <> help "File to dump output in" 323 | <> metavar "OUTFILE")) 324 | 325 | runWithArgs :: Args -> IO () 326 | runWithArgs (Args mn nt srd clr mybfname) = do 327 | let flg = Flags nt clr srd 328 | dsm <- getDesugaredModule mn 329 | cbs <- getCoreBinds dsm 330 | tcs <- getTyCons dsm 331 | hcsDir <- getEnv "HASKELL_CORE_SEMANTICS_DIR" 332 | preamble <- readFile $ hcsDir ++ "/compile-to-core/files/Preamble.pkore" 333 | let tcsStr = intercalate "\n\n" (prTyCon flg <$> tcs) 334 | let bindings = if srd then filter (not . isResult flg) cbs else cbs 335 | let bindingsStr = intercalate "\n\n" (prBinding flg <$> bindings) 336 | let output = if srd 337 | then 338 | let result = case filter (isResult flg) cbs of 339 | [result'] -> getDefiniens flg result' 340 | _ -> undefined 341 | in tcsStr ++ "\n\n" ++ bindingsStr ++ "\n\n" ++ result 342 | else tcsStr ++ "\n\n" ++ bindingsStr 343 | let output' = preamble ++ "// END OF PREAMBLE" ++ output 344 | case mybfname of 345 | Just fname -> writeFile fname output' 346 | Nothing -> putStrLn output' 347 | 348 | main :: IO () 349 | main = do 350 | let pdStr = "Compile Haskell to KORE representation of GHC Core" 351 | let hdrStr = "compile-to-core - Compile GHC Core to KORE" 352 | let opts = info (argParse <**> helper) (fullDesc <> progDesc pdStr <> header hdrStr) 353 | runWithArgs =<< execParser opts 354 | -------------------------------------------------------------------------------- /compile-to-core/compile-to-core.cabal: -------------------------------------------------------------------------------- 1 | name: compile-to-core 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/kframework/haskell-core-semantics/tree/master/compile-to-core 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Ayberk Tosun 9 | maintainer: ayberk.tosun@gmail.com 10 | copyright: Ayberk Tosun 2015 11 | category: Natural language processing 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | executable to-core 17 | hs-source-dirs: app 18 | main-is: Main.hs 19 | ghc-options: -Wall -O0 -threaded -rtsopts -with-rtsopts=-N 20 | build-depends: base 21 | , bytestring >= 0.10.8.1 22 | , ghc >= 8.0.2 23 | , ghc-paths >= 0.1.0.9 24 | , optparse-applicative >= 0.13.0.0 25 | default-language: Haskell2010 26 | 27 | test-suite compile-to-core-test 28 | type: exitcode-stdio-1.0 29 | hs-source-dirs: test 30 | main-is: Spec.hs 31 | build-depends: base 32 | , compile-to-core 33 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 34 | default-language: Haskell2010 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/ayberkt/compile-to-core 39 | -------------------------------------------------------------------------------- /compile-to-core/files/Preamble.pkore: -------------------------------------------------------------------------------- 1 | algTyCon(name(Bool), 2 | [type omitted], 3 | dataTyCon(DataConCons(dataCon(name(True), arity(0)), 4 | DataConCons(dataCon(name(False), arity(0)), 5 | DataConEmpty)))) 6 | 7 | nonRec(tmVar([type omitted], name(==)), 8 | lam(tyVar([type omitted], name(t)), 9 | lam(tmVar([type omitted], name(f)), 10 | lam(tmVar([type omitted], name(x)), 11 | lam(tmVar([type omitted], name(y)), 12 | keq(var(tmVar([type omitted], name(x))), 13 | var(tmVar([type omitted], name(y))))))))) 14 | 15 | nonRec(tmVar([type omitted], name($fEqInteger)), lit(machInt(-1))) 16 | -------------------------------------------------------------------------------- /compile-to-core/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.13 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - ghc-core-0.5.6 44 | - colorize-haskell-1.0.1 45 | 46 | # Override default flag values for local packages and extra-deps 47 | flags: {} 48 | 49 | # Extra package databases containing global packages 50 | extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.2" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor 69 | -------------------------------------------------------------------------------- /compile-to-core/test/.gitignore: -------------------------------------------------------------------------------- 1 | Foo.hs 2 | output 3 | -------------------------------------------------------------------------------- /compile-to-core/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /compile-to-core/test/test.sh: -------------------------------------------------------------------------------- 1 | stack exec to-core -- --no-types -o output Foo 2 | -------------------------------------------------------------------------------- /docs/RESOURCES.md: -------------------------------------------------------------------------------- 1 | # Useful resources on Core 2 | 3 | * [StackOverflow: Reading GHC Core](http://stackoverflow.com/questions/6121146/reading-ghc-core) 4 | * ["Hello, Core!" by Gabriel Gonzalez](http://www.haskellforall.com/2012/10/hello-core.html) 5 | * [`CoreSyn.hs`](https://github.com/ghc/ghc/blob/8c7250379d0d2bad1d07dfd556812ff7aa2c42e8/compiler/coreSyn/CoreSyn.hs) 6 | * [Ott definition](https://github.com/ghc/ghc/blob/master/docs/core-spec/CoreSyn.ott) 7 | * [Documentation of the GHC API](https://downloads.haskell.org/~ghc/7.10-latest/docs/html/libraries/ghc-7.10.3/GHC.html) 8 | -------------------------------------------------------------------------------- /docs/core-spec.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kframework/haskell-core-semantics/6dc257b34993970873cf0ea47f29b3d4fad13b1f/docs/core-spec.pdf -------------------------------------------------------------------------------- /script/krunhaskell.sh: -------------------------------------------------------------------------------- 1 | to-core --no-types --strip-result -o $1.pkore $1 2 | echo "krun -d $HASKELL_CORE_SEMANTICS_DIR $1.pkore" 3 | krun -d $HASKELL_CORE_SEMANTICS_DIR $1.pkore 4 | rm $1.pkore 5 | -------------------------------------------------------------------------------- /setup.sh: -------------------------------------------------------------------------------- 1 | export HASKELL_CORE_SEMANTICS_DIR=$(realpath .) 2 | alias krunhaskell=$(realpath script/krunhaskell.sh) 3 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *-kompiled 2 | -------------------------------------------------------------------------------- /src/haskell-core-execution.k: -------------------------------------------------------------------------------- 1 | require "haskell-core-syntax.k" 2 | 3 | module HASKELL-CORE-EXECUTION 4 | imports HASKELL-CORE-COMMON 5 | imports INT 6 | imports K-REFLECTION 7 | imports MAP 8 | 9 | // Addresses in the store 10 | syntax Locs ::= List{Loc, ";"} [klabel(locList)] 11 | syntax Loc ::= Int 12 | | freshLoc(Int) [freshGenerator, function] 13 | 14 | rule freshLoc(X:Int) => X 15 | 16 | // Contents of the store 17 | syntax Object ::= data(DataCon, Locs) 18 | | closure(Name, Expr, Map) // closure 19 | | tyabs(Expr, Map) // type abstraction closure 20 | | thunk(Expr, Map) 21 | | indirection(Loc) 22 | | litObj(LitExpr) 23 | 24 | syntax DataConVal ::= dc(Name) 25 | 26 | syntax KResult ::= val(Loc) /* val should be used only 27 | with evaluated constants. */ 28 | | LitExpr 29 | | DataConVal 30 | 31 | syntax Expr ::= KResult 32 | 33 | // doBind: binds Id to Expr (for evaluation in K) without forcing 34 | // the evaluation of Expr. 35 | syntax K ::= doBind(Name, Expr, K) 36 | | doBindMap(Name, Expr, Map, K) 37 | | bindVals(Names, Locs, K) 38 | | scope(K) 39 | | restoreEnv(Map) // environment to reinstate 40 | | force(Expr, Map, Loc) 41 | | update(Expr, Loc) [strict(1)] 42 | 43 | syntax Names ::= List{Name, ";"} [klabel(nameList)] 44 | syntax Names ::= getTmVars(VarList) [function] 45 | 46 | /* TODO: Consider the possibility of this being tagged as a function. */ 47 | syntax K ::= evalDecl(SeqDecl, Expr) 48 | 49 | rule evalDecl(nonRec(tmVar(_, R), E1), E2:Expr) 50 | => doBind(R, E1, E2) 51 | rule evalDecl(nonRec(tmVar(_, R), E1) DS:SeqDecl, E2:Expr) 52 | => doBind(R, E1, evalDecl(DS, E2)) 53 | rule evalDecl(algTyCon(_, _, dataTyCon(DataConEmpty)), E:Expr) 54 | => E 55 | rule evalDecl(algTyCon(_, _, dataTyCon(DataConEmpty)) DS:SeqDecl, E:Expr) 56 | => evalDecl(DS, E) 57 | rule 58 | 59 | evalDecl(algTyCon(TN, TAU, dataTyCon(DataConCons(dataCon(R, Ar), DCS))), 60 | E:Expr) 61 | => evalDecl(algTyCon(TN, TAU, dataTyCon(DCS)), E) 62 | ... 63 | 64 | 65 | M:Map => M[R <- Ar] 66 | 67 | rule 68 | 69 | evalDecl(algTyCon(TN, TAU, dataTyCon(DataConCons(dataCon(R, Ar), DCS))) 70 | DS:SeqDecl, 71 | E:Expr) 72 | => evalDecl(algTyCon(TN, TAU, dataTyCon(DCS)) DS, E) 73 | ... 74 | 75 | 76 | M:Map => M[R <- Ar] 77 | 78 | 79 | rule DS:SeqDecl E:Expr => evalDecl(DS, E) 80 | 81 | // Get Ids out of VarList 82 | rule getTmVars(VarEmpty) => .Names 83 | rule getTmVars(VarCons(tmVar(_, N), Vars)) => N; getTmVars(Vars) 84 | rule getTmVars(VarCons(tyVar(_, _), Vars)) => getTmVars(Vars) 85 | 86 | // NB: Some rules in core_spec.pdf are accounted for due to strictness of the 87 | // literal case, i.e. S_Case, S_Tick, S_App, etc. 88 | 89 | /*(1 |-> closure(name(tau), 90 | closure(name(f), 91 | closure(name(x), 92 | closure(name(y), 93 | app(app(name(f), 94 | name(x)), 95 | name(y)), 96 | .Map), 97 | .Map), 98 | .Map), 99 | .Map) 100 | 2 |-> closure(name(x), 101 | closure(name(y), 102 | keq(name(x), name(y)), .Map), .Map))*/ 103 | configuration 104 | 105 | $PGM:K 106 | .Map // Loc |-> Object 107 | .Map // Name |-> Loc 108 | .Map // Name |-> Arity 109 | 0::Int 110 | 111 | 112 | /*------------------------------------------------------------ 113 | RULES FOR VAR 114 | ------------------------------------------------------------*/ 115 | rule 116 | var(tmVar(_, R)) => val(L) ... 117 | ... L |-> data(_, _) ... 118 | ... R |-> L ... 119 | rule 120 | var(tmVar(_, R)) => val(L) ... 121 | ... L |-> closure(_, _, _) ... 122 | ... R |-> L ... 123 | rule 124 | var(tmVar(_, R)) => val(L) ... 125 | ... L |-> tyabs(_, _) ... 126 | ... R |-> L ... 127 | rule 128 | var(tmVar(_, R)) => val(L) ... 129 | ... L |-> litObj(_) ... 130 | ... R |-> L ... 131 | rule // could shortcut the store entry also 132 | var(tmVar(_, R)) ... 133 | ... L |-> indirection(L') ... 134 | ... R |-> (L => L') ... 135 | rule 136 | var(tmVar(_, R)) => dc(R) ... 137 | ... R |-> arity(0) ... 138 | rule 139 | (. => force(E, Env, L)) ~> var(tmVar(_, R)) ... 140 | ... L |-> thunk(E, Env) ... 141 | ... R |-> L ... 142 | rule 143 | force(E, Env, L) => update(E, L) ~> restoreEnv(EOld) ... 144 | EOld => Env 145 | rule 146 | update(val(L'), L) => . ... 147 | ... L |-> (_ => indirection(L')) ... 148 | rule 149 | update(lit(M), L) => . ... 150 | ... L |-> (_ => litObj(lit(M))) ... 151 | 152 | // `keq` should be rewritten to a Haskell Bool. 153 | rule 154 | keq(LE:LitExpr, LE:LitExpr) => val(!L) ... 155 | 156 | ... 157 | .Map => !L |-> 158 | data(dataCon(name(#parseToken("HsId@HASKELL-CORE-COMMON", "True")), 159 | arity(0)), 160 | .Locs) 161 | ... 162 | 163 | rule 164 | keq(LE1:LitExpr, LE2:LitExpr) => val(!L) ... 165 | 166 | ... 167 | .Map => !L |-> 168 | data(dataCon(name(#parseToken("HsId@HASKELL-CORE-COMMON", "False")), 169 | arity(0)), 170 | .Locs) 171 | ... 172 | 173 | when LE1 =/=K LE2 174 | rule 175 | keq(val(L1), val(L2)) => keq(LE1, LE2) ... 176 | ... L1 |-> litObj(LE1) L2 |-> litObj(LE2) ... 177 | 178 | // App 179 | rule 180 | 181 | app(val(L), E2) => doBindMap(R, E2, Env, Body) ~> restoreEnv(EOld) ... 182 | 183 | EOld 184 | ... L |-> closure(R, Body, Env) ... 185 | rule 186 | app(val(L), _) => Body ~> restoreEnv(EOld) ... 187 | EOld => Env 188 | ... L |-> tyabs(Body, Env) ... 189 | 190 | // Lam 191 | rule 192 | lam(tyVar(_, _), Body) => val(!L) ... 193 | Env 194 | ... (. => !L |-> tyabs(Body, Env)) ... 195 | rule 196 | lam(tmVar(_, R), Body) => val(!L) ... 197 | Env 198 | ... (. => !L |-> closure(R, Body, Env)) ... 199 | 200 | // Let 201 | /* TODO: Let's might need flattening and so on (look at S_LetRecFlat). */ 202 | rule let(nonRec(tmVar(_, V), E2), E1) => scope(doBind(V, E2, E1)) 203 | rule let(rec(Binds), E) => scope(bindRec(Binds, .LocDefs, E)) 204 | 205 | // letrec helpers 206 | syntax LocDef ::= locDef(Int, Expr) 207 | syntax LocDefs ::= List{LocDef, ";"} [klabel(locDefList)] 208 | // `bindRec` seems to be just a list of `doBind`s. 209 | syntax K ::= bindRec(BindingList, LocDefs, Expr) 210 | 211 | // Make a new scope with all bindings 212 | rule bindRec((bind(tyVar(_, _), _, Binds) => Binds), _, _) 213 | rule 214 | 215 | bindRec((bind(tmVar(_, V), Def, Binds) => Binds), 216 | (L => locDef(!Loc, Def); L), E) 217 | ... 218 | 219 | Env => Env [ V <- !Loc ] 220 | // once all bindings are processed we have the final environment, 221 | // create the recursive thunks 222 | rule 223 | bindRec(emptyBind, LocDefs, E) => E ... 224 | Env 225 | ... (. => mkRecStore(Env, LocDefs)) ... 226 | 227 | // We create a mapping of locations to thunks for lazy evaluation. 228 | syntax Map ::= mkRecStore(Map, LocDefs) [function] 229 | rule mkRecStore(Env, .LocDefs) => .Map 230 | rule mkRecStore(Env, locDef(L, D); LocDefs) 231 | => (L |-> thunk(D, Env)) mkRecStore(Env, LocDefs) 232 | 233 | // Case 234 | // default 235 | rule case(val(L), tmVar(_, R), _, altCons(alt(defaultAlt(), _, E), _)) 236 | => scope(doBind(R, val(L), E)) 237 | 238 | // Matching Lit for the default case. 239 | rule case(lit(M), tmVar(_, R), _, altCons(alt(defaultAlt(), _, E), _)) 240 | => scope(doBind(R, lit(M), E)) 241 | 242 | // matching constructor 243 | rule 244 | 245 | case(val(V), tmVar(_, R), _, altCons(alt(dataAlt(C), VL, E), _)) 246 | => scope(doBind(R, val(V), bindVals(getTmVars(VL), Fields, E))) 247 | ... 248 | 249 | ... V |-> data(C, Fields) ... 250 | 251 | // different constructor 252 | rule 253 | 254 | case(val(V), _, _, (altCons(alt(dataAlt(C1), _, E:Expr), AL) => AL)) 255 | ... 256 | 257 | ... V |-> data(C2, _) ... 258 | requires C1 =/=K C2 259 | 260 | // matching lit 261 | rule case(lit(L), tmVar(_, R), _, altCons(alt(litAlt(L), _, E), _)) 262 | => scope(doBind(R, lit(L), E)) 263 | // different lit 264 | rule 265 | case(lit(L1), _, _, (altCons(alt(litAlt(L2), _, E), AltList) => AltList)) 266 | requires L1 =/=K L2 267 | 268 | // Cast 269 | rule cast(E, _) => E 270 | 271 | // Tick (debugging info) 272 | rule tick(_, E) => E 273 | 274 | // Type 275 | // does not need any evaluation rules, 276 | // all type applications should discard the argument. 277 | 278 | rule restoreEnv(Env) => . ... 279 | _ => Env 280 | rule val(I) ~> restoreEnv(Env) => val(I) ... 281 | _ => Env 282 | rule dc(R) ~> restoreEnv(Env) => dc(R) ... 283 | _ => Env 284 | 285 | rule scope(K) => K ~> restoreEnv(Env) ... 286 | Env 287 | 288 | syntax Bool ::= isExpVar(Expr) [function] 289 | 290 | rule isExpVar(var(_)) => true 291 | rule isExpVar(_) => false [owise] 292 | 293 | rule 294 | doBind(V, E, Body) => doBindMap(V, E, Env, Body) ... 295 | Env 296 | 297 | // Temporarily modify the environment to handle `doBind`. 298 | rule 299 | doBindMap(V, E, ENew, Body) => Body ... 300 | Env => ENew[V <- !L:Int] 301 | ... .Map => !L |-> thunk(E, Env) ... 302 | requires notBool isExpVar(E) 303 | rule 304 | doBindMap(V, lit(M), ENew, Body) => Body ... 305 | Env => ENew[V <- !L:Int] 306 | ... .Map => !L |-> litObj(lit(M)) ... 307 | rule 308 | doBindMap(V, var(tmVar(_, R)), ENew, Body) => Body ... 309 | Env:Map (R |-> L) => ENew[V <- L] 310 | 311 | rule 312 | val(L) => O 313 | Sto:Map (L |-> O) => .Map 314 | _ => .Map 315 | rule 316 | dc(R) 317 | M:Map (_ |-> _) => .Map 318 | rule 319 | dc(R) 320 | M:Map (_ |-> _) => .Map 321 | 322 | endmodule 323 | -------------------------------------------------------------------------------- /src/haskell-core-syntax.k: -------------------------------------------------------------------------------- 1 | module HASKELL-CORE-COMMON 2 | 3 | syntax Var ::= "tmVar" "(" Type "," Name ")" 4 | | "tyVar" "(" Type "," Name ")" 5 | 6 | syntax Rational ::= Int "%" Int 7 | 8 | // TODO: Native support for chars and rationals (char, float, double) 9 | syntax Lit ::= "machChar" 10 | | "machStr" "(" String ")" 11 | | "nullAddr" 12 | | "machInt" "(" Int ")" 13 | | "machInt64" "(" Int ")" 14 | | "machWord" "(" Int ")" 15 | | "machWord64" "(" Int ")" 16 | | "machFloat" "(" Rational ")" 17 | | "machDouble" "(" Rational ")" 18 | | "machLabelFunSome" "(" String "," Int ")" 19 | | "machLabelDataSome" "(" String "," Int ")" 20 | | "machLabelFunNone" "(" String ")" 21 | | "machLabelDataNone" "(" String ")" 22 | | "litInt" "(" Int "," Type ")" 23 | 24 | syntax BindingList ::= "emptyBind" 25 | | "bind" "(" Var "," Expr "," BindingList ")" 26 | 27 | syntax Binding ::= "nonRec" "(" Var "," Expr ")" 28 | | "rec" "(" BindingList ")" 29 | 30 | syntax VarList ::= "VarEmpty" 31 | | "VarCons" "(" Var "," VarList ")" 32 | 33 | // For creating explicit HsIds in rules 34 | syntax HsId ::= "#parseToken" "(" String "," String ")" 35 | [function, hook(STRING.string2token)] 36 | 37 | syntax Name ::= "name" "(" HsId ")" 38 | 39 | syntax Arity ::= "arity" "(" Int ")" 40 | 41 | syntax DataCon ::= "dataCon" "(" Name "," Arity ")" 42 | 43 | syntax DataConList ::= "DataConEmpty" 44 | | "DataConCons" "(" DataCon "," DataConList ")" 45 | 46 | syntax AlgTyConRhs ::= "dataTyCon" "(" DataConList ")" 47 | | "abstractTyCon" "(" ")" 48 | | "newTyCon" "(" DataCon ")" 49 | 50 | syntax TyCon ::= "algTyCon" "(" Name "," Type "," AlgTyConRhs ")" 51 | 52 | syntax AltCon ::= "dataAlt" "(" DataCon ")" 53 | | "litAlt" "(" Lit ")" 54 | | "defaultAlt" "(" ")" 55 | 56 | syntax Alt ::= "alt" "(" AltCon "," VarList "," Expr ")" 57 | 58 | syntax AltList ::= "altEmpty" 59 | | "altCons" "(" Alt "," AltList ")" 60 | 61 | syntax Tickish ::= "profNote" "(" ")" 62 | | "hpcTick" "(" ")" 63 | | "breakpoint" "(" ")" 64 | | "sourceNote" "(" ")" 65 | 66 | /* TODO: type system will eventually be implemented. */ 67 | syntax Type ::= "[type omitted]" 68 | 69 | syntax Coercion ::= "TODO" 70 | 71 | syntax Expr ::= "var" "(" Var ")" 72 | | LitExpr 73 | | "app" "(" Expr "," Expr ")" [strict(1)] 74 | | "lam" "(" Var "," Expr ")" 75 | | "let" "(" Binding "," Expr ")" 76 | | "case" "(" Expr "," Var "," Type "," AltList ")" 77 | [strict(1)] 78 | | "cast" "(" Expr "," Coercion ")" 79 | | "tick" "(" Tickish "," Expr ")" 80 | | "type" "(" Type ")" 81 | | Coercion 82 | // Primitive equality 83 | | "keq" "(" Expr "," Expr ")" [seqstrict] 84 | 85 | syntax LitExpr ::= "lit" "(" Lit ")" 86 | 87 | syntax Declaration ::= Binding | TyCon 88 | 89 | syntax SeqDecl ::= Declaration 90 | | Declaration SeqDecl [klabel(decls)] 91 | 92 | syntax Program ::= Expr | SeqDecl Expr 93 | 94 | endmodule 95 | 96 | module HASKELL-CORE-SYNTAX 97 | 98 | imports HASKELL-CORE-COMMON 99 | syntax HsId ::= 100 | r"[a-zA-Z0-9\\_$#:\\[\\]'/\\-+=&<>][a-zA-Z0-9\\_$#:\\[\\]'/\\-+=&<>]*" 101 | [token] 102 | 103 | endmodule 104 | -------------------------------------------------------------------------------- /src/haskell-core.k: -------------------------------------------------------------------------------- 1 | require "haskell-core-syntax.k" 2 | require "haskell-core-execution.k" 3 | 4 | module HASKELL-CORE 5 | import HASKELL-CORE-SYNTAX 6 | import HASKELL-CORE-EXECUTION 7 | endmodule 8 | -------------------------------------------------------------------------------- /src/old-stuff/haskell-core.k: -------------------------------------------------------------------------------- 1 | require "haskell-core-syntax.k" 2 | 3 | module HASKELL-CORE 4 | imports HASKELL-CORE-SYNTAX 5 | 6 | syntax KResult ::= Type 7 | 8 | configuration 9 | $PGM:Expr 10 | .Map 11 | 12 | 13 | rule X:Id => T ... 14 | ... X |-> T ... 15 | 16 | syntax Expr ::= Int 17 | 18 | syntax Expr ::= Type 19 | syntax Type ::= "typeVar" 20 | | "typeApp" 21 | | "typeConApp" 22 | | "forAllTypeAnon" 23 | | "forAllTypeNamed" 24 | | "kindCast" 25 | | "typeCoercion" 26 | 27 | rule _:TypeVariable => typeVar 28 | rule _:TypeApplication => typeApp 29 | rule _:TypeConApplication => typeConApp 30 | rule _:ForAllTypeAnonymous => forAllTypeAnon 31 | rule _:ForAllTypeNamed => forAllTypeNamed 32 | rule _:KindCast => kindCast 33 | rule _:TypeCoercion => typeCoercion 34 | 35 | rule (Tick T:Type) => T // TM_TICK 36 | 37 | rule X:Id => T ... 38 | ... X |-> T ... 39 | 40 | rule (Lam T1:Type T2:Type) => ForAllTyAnon T1 T2 41 | 42 | rule (App T1:Type T2:Type) => App T1 T2 43 | 44 | 45 | 46 | endmodule 47 | -------------------------------------------------------------------------------- /src/old-stuff/lambda.core: -------------------------------------------------------------------------------- 1 | lambda n . e 2 | -------------------------------------------------------------------------------- /src/old-stuff/types-syntax.k: -------------------------------------------------------------------------------- 1 | module TYPES-SYNTAX 2 | 3 | // Defined in `types/TyCoRep.lhs` as `Type`. 4 | syntax Type ::= TypeVariable // Variable 5 | | TypeApplication // Application 6 | | TypeConApplication // Application of type constructor 7 | | ForAllTypeAnonymous // Function 8 | | ForAllTypeNamed // Type and coercion polymorphism 9 | | KindCast // Kind cast 10 | | TypeCoercion // Coercion used in type. 11 | 12 | // syntax Type ::= "TyVarTy" Id 13 | // | "AppTy" Type Type 14 | // | "TyConApp" Types 15 | // | "ForAllTyAnon" Type Type 16 | // | "ForAllTyNamed" Id Type 17 | // | "CastTy" Type Coercion 18 | // | "CoercionTy" Coercion 19 | 20 | // The names in the definition of the following sorts follow the actual 21 | // constructors used in `types/TyCoRep.lhs`. 22 | syntax TypeVariable ::= "TyVarTy" Id 23 | syntax TypeApplication ::= "AppTy" Type Type 24 | syntax TypeConApplication ::= "TyConApp" Types 25 | syntax ForAllTypeAnonymous ::= "ForAllTyAnon" Type Type 26 | syntax ForAllTypeNamed ::= "ForAllTyName" Id Type 27 | syntax KindCast ::= "CastTy" Type Coercion 28 | syntax TypeCoercion ::= "CoercionTy" Coercion 29 | 30 | syntax Types ::= List{Type,","} 31 | 32 | // As defined in `types/TyCoRep.lhs:Coercion`. 33 | syntax Coercion ::= // Reflexivity 34 | "Refl" Role Types // Reflexivity 35 | // Type constructor application 36 | | "TyConAppCo" TyCon Role Coercions 37 | // Application 38 | | "AppCo" Coercion Coercion 39 | // Polymorphism 40 | | "ForAllCo" Coercion Coercion 41 | // Variable 42 | | "CoVarCo" Id 43 | // Axiom application 44 | | "AxiomInstCo" Coercions 45 | // Bunch of other stuff 46 | 47 | syntax Coercions ::= List{Coercion,","} 48 | 49 | // `UnivCo` provenance as defined in `types/TyCoRep.lhs:UnivCoProvenance`. 50 | syntax Prov ::= "unsafe" 51 | | "phant" 52 | | "irrel" 53 | 54 | // Roles label what equality relation a coerceion is a witness of. Nominal 55 | // equality means that two types are identical (have the same name); 56 | // representational equality means that two types have the same 57 | // representation; and phantom equality includes all types. 58 | syntax Role ::= "N" // Nominal 59 | | "R" // Representational 60 | | "P" // Phantom 61 | 62 | // Left or right deconstructor. 63 | // Defined in `types/TyCoRep.lhs/LeftOrRight`. 64 | syntax LorR ::= "left" 65 | | "right" 66 | 67 | syntax Axiom ::= "CoAxiom" TyCon Role AxBranches 68 | 69 | // TODO 70 | // syntax AxBranch ::= 71 | 72 | syntax AxBranches ::= "TODO" 73 | 74 | syntax TyCon ::= "FunTyCon" 75 | // Either AlgTyCon, TupleTyCon, SynTyCon. We are not 76 | // interested in the differences between these for semantic 77 | // purposes. 78 | | "Exponent" Type 79 | | "PrimTyCon" PrimTyCon 80 | | "PromotedDataCon" 81 | 82 | syntax PrimTyCon ::= "intPrimTyCon" 83 | | "eqPrimTyCon" TyCon TyCon // Unboxed equality 84 | | "eqReprPrimTyCon" TyCon TyCon // 85 | | "liftedTypeKindTyCon" 86 | | "unliftedTypeKindTyCon" 87 | | "openTypeKindTyCon" 88 | | "constraintTyCon" 89 | | "TYPETyCon" 90 | | "LevityTyCon" Levity 91 | 92 | syntax Levity ::= "Lifted" | "Unlifted" 93 | 94 | endmodule 95 | -------------------------------------------------------------------------------- /src/old-stuff/types.k: -------------------------------------------------------------------------------- 1 | require "types-syntax.k" 2 | 3 | module TYPES 4 | imports TYPES-SYNTAX 5 | 6 | configuration 7 | 8 | .Map 9 | 10 | 11 | endmodule -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | core 2 | -------------------------------------------------------------------------------- /test/Sample.hcr: -------------------------------------------------------------------------------- 1 | %module Main 2 | 3 | Main.main :: PrelGHC.Statezh PrelGHC.RealWorld -> Bar = 4 | PrelIO.putStrLn (PrelBase.unpackCStringzh ("hello world" :: PrelGHC.Addrzh)); 5 | -------------------------------------------------------------------------------- /test/config.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /test/gen_core.sh: -------------------------------------------------------------------------------- 1 | mkdir -p core 2 | cd haskell 3 | for i in `ls *.hs`; do 4 | echo "Writing $i..." 5 | to-core --no-types --strip-result $@ $(basename $i .hs) -o ../core/$(basename $i .hs).pkore; 6 | # echo "- Writing core/$(basename $i .hs).pkore..." 7 | done 8 | -------------------------------------------------------------------------------- /test/haskell/Bools.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Bools where 4 | 5 | data Bool = True | False 6 | 7 | result = True 8 | -------------------------------------------------------------------------------- /test/haskell/BouncyNumbers.hs: -------------------------------------------------------------------------------- 1 | module BouncyNumbers where 2 | 3 | digits :: Integer -> [Integer] 4 | digits n = reverse $ inverseDigits n 5 | where inverseDigits n' 6 | | n' == 0 = [] 7 | | otherwise = (n' `mod` 10) : inverseDigits (n' `div` 10) 8 | 9 | differences :: [Integer] -> [Integer] 10 | differences [] = [] 11 | differences [_] = [] 12 | differences (x:xs) = x - head xs : differences xs 13 | 14 | bouncy :: Integer -> Bool 15 | bouncy n = any (> 0) diffs && any (< 0) diffs 16 | where diffs = differences $ digits n 17 | 18 | countBouncyNumbers :: Integer 19 | countBouncyNumbers = iterateCount 0 0 1 20 | where 21 | iterateCount :: Integer -> Integer -> Integer 22 | -> Integer 23 | iterateCount iter count num 24 | | ratio == (0.99 :: Double) = num - 1 25 | | otherwise = if bouncy num 26 | then iterateCount (iter + 1) (count + 1) (num + 1) 27 | else iterateCount (iter + 1) count (num + 1) 28 | where 29 | ratio = fromIntegral count / fromIntegral iter 30 | 31 | result :: Integer 32 | result = countBouncyNumbers 33 | -------------------------------------------------------------------------------- /test/haskell/Cases.hs: -------------------------------------------------------------------------------- 1 | module Cases where 2 | 3 | result = 4 | case 1 of 5 | 1 -> "correct" 6 | x -> "incorrect" 7 | -------------------------------------------------------------------------------- /test/haskell/ChurchBool.hs: -------------------------------------------------------------------------------- 1 | module ChurchBool where 2 | 3 | result :: Integer 4 | result = 5 | let true = (\x -> \y -> x) 6 | false = (\x -> \y -> y) 7 | not p = p false true 8 | in (not true) 1 2 9 | -------------------------------------------------------------------------------- /test/haskell/ChurchNat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module ChurchNat where 3 | 4 | zero = \s -> \z -> z 5 | one = \s -> \z -> s z 6 | 7 | succ = \n -> (\s -> \z -> s (n s z)) 8 | 9 | two = succ one 10 | 11 | three = succ two 12 | 13 | result = three (\x -> x) 0 14 | -------------------------------------------------------------------------------- /test/haskell/ChurchNat2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module ChurchNat2 where 3 | 4 | zero = \s -> \z -> z 5 | one = \s -> \z -> s z 6 | 7 | succ = \n -> \s -> \z -> s (n s z) 8 | two = succ one 9 | three = succ two 10 | 11 | plus = \n1 -> \n2 -> (\s -> \z -> n2 s (n1 s z)) 12 | 13 | pair = \f s b -> b f s 14 | 15 | true = \x -> \y -> x 16 | false = \x -> \y -> y 17 | 18 | first = \p -> p true 19 | second = \p -> p false 20 | 21 | zz = pair zero zero 22 | ss = \p -> pair (second p) (plus one (second p)) 23 | prd = \m -> first (m ss zz) 24 | 25 | isZero = \m -> m (\x -> false) true 26 | land = \p -> \q -> p q false 27 | 28 | minus = \n1 -> \n2 -> n1 prd n2 29 | 30 | nine = succ (succ (succ (succ (succ (succ three))))) 31 | 32 | result = 33 | let x = succ three 34 | y = succ (succ (three)) 35 | in (isZero (plus x y)) 1 0 36 | -------------------------------------------------------------------------------- /test/haskell/ChurchNat3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module ChurchNat3 where 3 | 4 | zero = \s -> \z -> z 5 | one = \s -> \z -> s z 6 | 7 | succ = \n -> \s -> \z -> s (n s z) 8 | two = succ one 9 | three = succ two 10 | 11 | plus = \n1 -> \n2 -> (\s -> \z -> n2 s (n1 s z)) 12 | 13 | pair = \f s b -> b f s 14 | 15 | true = \x -> \y -> x 16 | false = \x -> \y -> y 17 | 18 | first = \p -> p true 19 | second = \p -> p false 20 | 21 | zz = pair zero zero 22 | ss = \p -> pair (second p) (plus one (second p)) 23 | prd = \m -> first (m ss zz) 24 | 25 | isZero = \m -> m (\x -> false) true 26 | land = \p -> \q -> p q false 27 | 28 | minus = \n1 -> \n2 -> n1 prd n2 29 | 30 | nine = succ (succ (succ (succ (succ (succ three))))) 31 | 32 | result = isZero (prd (prd (prd (plus one two)))) 1 0 33 | -------------------------------------------------------------------------------- /test/haskell/Compose.hs: -------------------------------------------------------------------------------- 1 | module Compose where 2 | 3 | comp :: (b -> c) -> (a -> b) -> a -> c 4 | comp f g x = f (g x) 5 | 6 | result = comp (\x -> x) (\y -> y) 7 | -------------------------------------------------------------------------------- /test/haskell/Disequality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Disequality where 4 | 5 | import qualified Prelude as P 6 | 7 | result = 1 P.== 2 8 | -------------------------------------------------------------------------------- /test/haskell/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Equality where 4 | 5 | import qualified Prelude as P 6 | 7 | result = 1 P.== 1 8 | -------------------------------------------------------------------------------- /test/haskell/Identity.hs: -------------------------------------------------------------------------------- 1 | module Identity where 2 | 3 | nid :: a -> a 4 | nid x = x 5 | 6 | result :: String 7 | result = nid "1" 8 | -------------------------------------------------------------------------------- /test/haskell/Imports.hs: -------------------------------------------------------------------------------- 1 | module Imports where 2 | 3 | import Data.List (intersperse) 4 | 5 | result :: [String] 6 | result = intersperse ";" ["a", "b", "c"] 7 | -------------------------------------------------------------------------------- /test/haskell/Integers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | 3 | module Integers where 4 | 5 | x :: Int 6 | x = 1 7 | 8 | y :: Int 9 | y = 2 10 | 11 | result :: Bool 12 | result = x == y 13 | -------------------------------------------------------------------------------- /test/haskell/LetRec.hs: -------------------------------------------------------------------------------- 1 | module LetRec where 2 | 3 | -- result :: Integer 4 | -- result = let f x' = (\x -> x) (f x') in f 1 5 | 6 | result :: a 7 | result = 8 | let foo x = bar x 9 | bar y = foo y 10 | in foo 1 11 | -------------------------------------------------------------------------------- /test/haskell/Nats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Nats where 3 | 4 | data Nat = Z | S Nat 5 | 6 | result = S Z 7 | -------------------------------------------------------------------------------- /test/haskell/Primes.hs: -------------------------------------------------------------------------------- 1 | module Primes where 2 | 3 | primes :: [Integer] 4 | primes = filterPrime [2..] 5 | where filterPrime (p:xs) = 6 | p : filterPrime [x | x <- xs, x `mod` p /= 0] 7 | 8 | 9 | result = take 100 primes 10 | -------------------------------------------------------------------------------- /test/haskell/Rationals.hs: -------------------------------------------------------------------------------- 1 | module Rationals where 2 | 3 | result :: Float 4 | result = 2.0 + 2.0 - 1.0 5 | -------------------------------------------------------------------------------- /test/haskell/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Sum where 4 | 5 | import qualified Prelude as P 6 | 7 | result :: P.Integer 8 | result = P.foldr (P.+) 0 P.$ P.filter (\x -> 5 `P.div` x P.== 0) [1..100] 9 | -------------------------------------------------------------------------------- /test/kast_all.sh: -------------------------------------------------------------------------------- 1 | ./gen_core.sh 2 | echo "\n\n" 3 | cd .. 4 | for i in `ls test/core`; do 5 | echo "RUNNING \`kast test/core/$i\`" 6 | echo "--------------------------------------------------------------------------------" 7 | time kast test/core/$i | fold -w 80 8 | echo "\n" 9 | done 10 | -------------------------------------------------------------------------------- /test/pkore-samples/Case.pkore: -------------------------------------------------------------------------------- 1 | case( 2 | lit(machStr("seventeen")), 3 | tmVar([type omitted], name(x)), 4 | [type omitted], 5 | altCons( 6 | alt( 7 | defaultAlt(), 8 | VarEmpty, 9 | lit(machInt(42)) 10 | ), 11 | altEmpty 12 | ) 13 | ) 14 | -------------------------------------------------------------------------------- /test/pkore-samples/ChurchBool.pkore: -------------------------------------------------------------------------------- 1 | let(nonRec(tmVar([type omitted], name(false)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(y)))))))), let(nonRec(tmVar([type omitted], name(true)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(x)))))))), app(app(app(app(app(app(app(app(lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(app(var(tmVar([type omitted], name(p))), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted]))), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted]))))))))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted]))), lit(litInt(1, [type omitted]))), lit(litInt(2, [type omitted]))))) 2 | 3 | -------------------------------------------------------------------------------- /test/pkore-samples/ChurchNat.pkore: -------------------------------------------------------------------------------- 1 | nonRec(tmVar([type omitted], name($trModule)), app(app(var(tmVar([type omitted], name(Module))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("main")))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("ChurchNat"))))) 2 | 3 | nonRec(tmVar([type omitted], name(zero)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), var(tmVar([type omitted], name(z)))))))) 4 | 5 | nonRec(tmVar([type omitted], name(one)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), var(tmVar([type omitted], name(z))))))))) 6 | 7 | nonRec(tmVar([type omitted], name(succ)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), app(app(var(tmVar([type omitted], name(n))), var(tmVar([type omitted], name(s)))), var(tmVar([type omitted], name(z)))))))))))) 8 | 9 | nonRec(tmVar([type omitted], name(two)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))))) 10 | 11 | nonRec(tmVar([type omitted], name(three)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(two))), type([type omitted]))))) 12 | 13 | app(app(app(var(tmVar([type omitted], name(three))), type([type omitted])), lam(tmVar([type omitted], name(x)), var(tmVar([type omitted], name(x))))), lit(litInt(0, [type omitted]))) 14 | 15 | -------------------------------------------------------------------------------- /test/pkore-samples/ChurchNat2.pkore: -------------------------------------------------------------------------------- 1 | nonRec(tmVar([type omitted], name(zero)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), var(tmVar([type omitted], name(z)))))))) 2 | 3 | nonRec(tmVar([type omitted], name(one)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), var(tmVar([type omitted], name(z))))))))) 4 | 5 | nonRec(tmVar([type omitted], name(succ)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), app(app(var(tmVar([type omitted], name(n))), var(tmVar([type omitted], name(s)))), var(tmVar([type omitted], name(z)))))))))))) 6 | 7 | nonRec(tmVar([type omitted], name(two)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))))) 8 | 9 | nonRec(tmVar([type omitted], name(three)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(two))), type([type omitted]))))) 10 | 11 | nonRec(tmVar([type omitted], name(nine)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(three))), type([type omitted])))))))))) 12 | 13 | nonRec(tmVar([type omitted], name(plus)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n1)), lam(tmVar([type omitted], name(n2)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(app(var(tmVar([type omitted], name(n2))), var(tmVar([type omitted], name(s)))), app(app(var(tmVar([type omitted], name(n1))), var(tmVar([type omitted], name(s)))), var(tmVar([type omitted], name(z)))))))))))))) 14 | 15 | nonRec(tmVar([type omitted], name(pair)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(f)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(b)), app(app(var(tmVar([type omitted], name(b))), var(tmVar([type omitted], name(f)))), var(tmVar([type omitted], name(s))))))))))) 16 | 17 | nonRec(tmVar([type omitted], name(zz)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), app(app(app(app(app(var(tmVar([type omitted], name(pair))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(zero))), type([type omitted])), type([type omitted]))), app(app(var(tmVar([type omitted], name(zero))), type([type omitted])), type([type omitted]))))))))) 18 | 19 | nonRec(tmVar([type omitted], name(true)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(x)))))))) 20 | 21 | nonRec(tmVar([type omitted], name(first)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(var(tmVar([type omitted], name(p))), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted])))))))) 22 | 23 | nonRec(tmVar([type omitted], name(false)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(y)))))))) 24 | 25 | nonRec(tmVar([type omitted], name(second)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(var(tmVar([type omitted], name(p))), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))))))) 26 | 27 | nonRec(tmVar([type omitted], name(ss)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(app(app(app(app(var(tmVar([type omitted], name(pair))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(second))), type([type omitted])), type([type omitted])), type([type omitted])), var(tmVar([type omitted], name(p))))), app(app(app(app(app(app(var(tmVar([type omitted], name(plus))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))), app(app(app(app(var(tmVar([type omitted], name(second))), type([type omitted])), type([type omitted])), type([type omitted])), var(tmVar([type omitted], name(p)))))))))))))) 28 | 29 | nonRec(tmVar([type omitted], name(prd)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(m)), app(app(app(app(var(tmVar([type omitted], name(first))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(m))), app(app(app(app(app(app(var(tmVar([type omitted], name(ss))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted]))), app(app(app(app(app(var(tmVar([type omitted], name(zz))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])))))))))))))))))))) 30 | 31 | nonRec(tmVar([type omitted], name(minus)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n1)), lam(tmVar([type omitted], name(n2)), app(app(var(tmVar([type omitted], name(n1))), app(app(app(app(app(app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(prd))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted]))), var(tmVar([type omitted], name(n2))))))))))))))))))))))) 32 | 33 | nonRec(tmVar([type omitted], name(land)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), lam(tmVar([type omitted], name(q)), app(app(var(tmVar([type omitted], name(p))), var(tmVar([type omitted], name(q)))), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))))))))) 34 | 35 | nonRec(tmVar([type omitted], name(isZero)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(m)), app(app(var(tmVar([type omitted], name(m))), lam(tmVar([type omitted], name(di_auk)), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted]))))))))))) 36 | 37 | nonRec(tmVar([type omitted], name($trModule)), app(app(var(tmVar([type omitted], name(Module))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("main")))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("ChurchNat2"))))) 38 | 39 | app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(isZero))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(app(app(var(tmVar([type omitted], name(plus))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(three))), type([type omitted])))), type([type omitted]))), app(lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(three))), type([type omitted]))))), type([type omitted])))), lit(litInt(1, [type omitted]))), lit(litInt(0, [type omitted]))) 40 | -------------------------------------------------------------------------------- /test/pkore-samples/ChurchNat3.pkore: -------------------------------------------------------------------------------- 1 | nonRec(tmVar([type omitted], name(zero)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), var(tmVar([type omitted], name(z)))))))) 2 | 3 | nonRec(tmVar([type omitted], name(one)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), var(tmVar([type omitted], name(z))))))))) 4 | 5 | nonRec(tmVar([type omitted], name(succ)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(var(tmVar([type omitted], name(s))), app(app(var(tmVar([type omitted], name(n))), var(tmVar([type omitted], name(s)))), var(tmVar([type omitted], name(z)))))))))))) 6 | 7 | nonRec(tmVar([type omitted], name(two)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))))) 8 | 9 | nonRec(tmVar([type omitted], name(three)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(two))), type([type omitted]))))) 10 | 11 | nonRec(tmVar([type omitted], name(nine)), lam(tyVar([type omitted], name(t)), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(succ))), type([type omitted])), type([type omitted])), type([type omitted])), app(var(tmVar([type omitted], name(three))), type([type omitted])))))))))) 12 | 13 | nonRec(tmVar([type omitted], name(plus)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n1)), lam(tmVar([type omitted], name(n2)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(z)), app(app(var(tmVar([type omitted], name(n2))), var(tmVar([type omitted], name(s)))), app(app(var(tmVar([type omitted], name(n1))), var(tmVar([type omitted], name(s)))), var(tmVar([type omitted], name(z)))))))))))))) 14 | 15 | nonRec(tmVar([type omitted], name(pair)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(f)), lam(tmVar([type omitted], name(s)), lam(tmVar([type omitted], name(b)), app(app(var(tmVar([type omitted], name(b))), var(tmVar([type omitted], name(f)))), var(tmVar([type omitted], name(s))))))))))) 16 | 17 | nonRec(tmVar([type omitted], name(zz)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), app(app(app(app(app(var(tmVar([type omitted], name(pair))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(zero))), type([type omitted])), type([type omitted]))), app(app(var(tmVar([type omitted], name(zero))), type([type omitted])), type([type omitted]))))))))) 18 | 19 | nonRec(tmVar([type omitted], name(true)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(x)))))))) 20 | 21 | nonRec(tmVar([type omitted], name(first)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(var(tmVar([type omitted], name(p))), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted])))))))) 22 | 23 | nonRec(tmVar([type omitted], name(false)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(x)), lam(tmVar([type omitted], name(y)), var(tmVar([type omitted], name(y)))))))) 24 | 25 | nonRec(tmVar([type omitted], name(second)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(var(tmVar([type omitted], name(p))), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))))))) 26 | 27 | nonRec(tmVar([type omitted], name(ss)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), app(app(app(app(app(var(tmVar([type omitted], name(pair))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(var(tmVar([type omitted], name(second))), type([type omitted])), type([type omitted])), type([type omitted])), var(tmVar([type omitted], name(p))))), app(app(app(app(app(app(var(tmVar([type omitted], name(plus))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))), app(app(app(app(var(tmVar([type omitted], name(second))), type([type omitted])), type([type omitted])), type([type omitted])), var(tmVar([type omitted], name(p)))))))))))))) 28 | 29 | nonRec(tmVar([type omitted], name(prd)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(m)), app(app(app(app(var(tmVar([type omitted], name(first))), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(m))), app(app(app(app(app(app(var(tmVar([type omitted], name(ss))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted]))), app(app(app(app(app(var(tmVar([type omitted], name(zz))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])))))))))))))))))))) 30 | 31 | nonRec(tmVar([type omitted], name(minus)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(n1)), lam(tmVar([type omitted], name(n2)), app(app(var(tmVar([type omitted], name(n1))), app(app(app(app(app(app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(prd))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted]))), var(tmVar([type omitted], name(n2))))))))))))))))))))))) 32 | 33 | nonRec(tmVar([type omitted], name(land)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(p)), lam(tmVar([type omitted], name(q)), app(app(var(tmVar([type omitted], name(p))), var(tmVar([type omitted], name(q)))), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))))))))) 34 | 35 | nonRec(tmVar([type omitted], name(isZero)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tyVar([type omitted], name(t)), lam(tmVar([type omitted], name(m)), app(app(var(tmVar([type omitted], name(m))), lam(tmVar([type omitted], name(di_auu)), app(app(var(tmVar([type omitted], name(false))), type([type omitted])), type([type omitted])))), app(app(var(tmVar([type omitted], name(true))), type([type omitted])), type([type omitted]))))))))))) 36 | 37 | nonRec(tmVar([type omitted], name($trModule)), app(app(var(tmVar([type omitted], name(Module))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("main")))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("ChurchNat3"))))) 38 | 39 | app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(isZero))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(app(app(app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(prd))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(app(app(app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(prd))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(app(app(app(app(app(app(app(app(app(app(app(var(tmVar([type omitted], name(prd))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(app(app(app(app(var(tmVar([type omitted], name(plus))), type([type omitted])), type([type omitted])), type([type omitted])), type([type omitted])), app(app(var(tmVar([type omitted], name(one))), type([type omitted])), type([type omitted]))), app(var(tmVar([type omitted], name(two))), type([type omitted]))))))), lit(litInt(1, [type omitted]))), lit(litInt(0, [type omitted]))) 40 | -------------------------------------------------------------------------------- /test/pkore-samples/Identity.pkore: -------------------------------------------------------------------------------- 1 | app(lam(tmVar([type omitted], name(foo)), var(tmVar([type omitted], name(foo)))), lit(litInt(17, [type omitted]))) 2 | -------------------------------------------------------------------------------- /test/pkore-samples/Lambda.pkore: -------------------------------------------------------------------------------- 1 | app(lam(tmVar([type omitted], name(foo)), var(tmVar([type omitted], name(foo)))), lit(litInt(17, [type omitted]))) 2 | -------------------------------------------------------------------------------- /test/pkore-samples/Let-1.pkore: -------------------------------------------------------------------------------- 1 | nonRec(tmVar([type omitted], name($trModule)), 2 | app(app(var(tmVar([type omitted], 3 | name(Module))), app(var(tmVar([type omitted], name(TrNameS))), 4 | lit(machStr("main")))), app(var(tmVar([type omitted], name(TrNameS))), 5 | 6 | lit(machStr("Foo")))))let(nonRec(tmVar([type omitted], name(foo)), lit(machInt(17))), 7 | var(tmVar([type omitted], name(foo)))) 8 | -------------------------------------------------------------------------------- /test/pkore-samples/Let-2.pkore: -------------------------------------------------------------------------------- 1 | let(nonRec(tmVar([type omitted], name(foo)), 2 | lam(tmVar([type omitted], name(foo)), var(tmVar([type omitted], name(foo))))), 3 | var(tmVar([type omitted], name(foo)))) 4 | -------------------------------------------------------------------------------- /test/pkore-samples/Let-3.pkore: -------------------------------------------------------------------------------- 1 | let(nonRec(tmVar([type omitted], name(foo)), 2 | app(lam(tmVar([type omitted], name(a)), 3 | lam(tmVar([type omitted], name(b)), 4 | app(var(tmVar([type omitted], name(a))), var(tmVar([type omitted], name(b)))))), 5 | lam(tmVar([type omitted], name(x)), var(tmVar([type omitted], name(x)))))), 6 | app(var(tmVar([type omitted], name(foo))), lit(litInt(3, [type omitted])))) 7 | -------------------------------------------------------------------------------- /test/pkore-samples/Let-4.pkore: -------------------------------------------------------------------------------- 1 | let(nonRec(tmVar([type omitted], name(f)), 2 | lam(tmVar([type omitted], name(x)), var(tmVar([type omitted], name(x))))), 3 | app(var(tmVar([type omitted], name(f))), 4 | lam(tmVar([type omitted], name(z)), var(tmVar([type omitted], name(z)))))) 5 | -------------------------------------------------------------------------------- /test/pkore-samples/Let-5.pkore: -------------------------------------------------------------------------------- 1 | let(nonRec(tmVar([type omitted], name(f)), 2 | lam(tmVar([type omitted], name(x)), var(tmVar([type omitted], name(x))))), 3 | lam(tmVar([type omitted], name(z)), 4 | app(var(tmVar([type omitted], name(f))), 5 | var(tmVar([type omitted], name(z)))))) 6 | -------------------------------------------------------------------------------- /test/pkore-samples/Nats.pkore: -------------------------------------------------------------------------------- 1 | algTyCon(name(Nat), [type omitted], dataTyCon(DataConCons(dataCon(name(Z), arity(0)), DataConCons(dataCon(name(S), arity(1)), DataConEmpty)))) 2 | 3 | nonRec(tmVar([type omitted], name($trModule)), app(app(var(tmVar([type omitted], name(Module))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("main")))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("Nats"))))) 4 | 5 | nonRec(tmVar([type omitted], name($tc'S)), app(app(app(app(var(tmVar([type omitted], name(TyCon))), lit(machWord(12426001258065732468))), lit(machWord(9279490369260619146))), var(tmVar([type omitted], name($trModule)))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("'S"))))) 6 | 7 | nonRec(tmVar([type omitted], name($tc'Z)), app(app(app(app(var(tmVar([type omitted], name(TyCon))), lit(machWord(14535021931178511601))), lit(machWord(8318178752716723486))), var(tmVar([type omitted], name($trModule)))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("'Z"))))) 8 | 9 | nonRec(tmVar([type omitted], name($tcNat)), app(app(app(app(var(tmVar([type omitted], name(TyCon))), lit(machWord(2060505253030016228))), lit(machWord(5589491301001427379))), var(tmVar([type omitted], name($trModule)))), app(var(tmVar([type omitted], name(TrNameS))), lit(machStr("Nat"))))) -------------------------------------------------------------------------------- /test/test_all.sh: -------------------------------------------------------------------------------- 1 | cd .. 2 | for file in `ls test/pkore-samples/*.pkore`; 3 | do 4 | echo "Running $file..." 5 | echo "--------------------------------------------------------------------------------" 6 | krun $file | tidy -i -q -xml | sed -e "s/~>/⇝/g" | sed -e "s/|->/↦/g" 7 | echo "" 8 | done 9 | 10 | echo "Have youn gen_core.sh?" 11 | for file in `ls test/core/*.pkore`; 12 | do 13 | echo "Running $file..." 14 | echo "--------------------------------------------------------------------------------" 15 | krun $file | tidy -i -q -xml | sed -e "s/~>/⇝/g" | sed -e "s/|->/↦/g" 16 | echo "" 17 | done 18 | --------------------------------------------------------------------------------