├── .gitignore
├── .ruby-version
├── .travis.yml
├── LICENSE
├── Makefile
├── README.md
├── Setup.hs
├── app
    └── Main.hs
├── forest-compiler.cabal
├── js
    └── string.js
├── logo.svg
├── nix
    ├── dependencies.nix
    ├── test-shell.nix
    └── wabt.nix
├── samples
    ├── addOne.tree
    ├── annotation.tree
    ├── arithmetic.tree
    ├── bool.tree
    ├── closure.tree
    ├── deconstruction.tree
    ├── fib.tree
    ├── let.tree
    ├── list.tree
    ├── maybe.tree
    ├── moving_block
    │   ├── index.html
    │   └── moving_block.tree
    ├── result.tree
    ├── spring.tree
    ├── string.tree
    └── test.tree
├── shell.nix
├── src
    ├── Compiler.hs
    ├── HaskellSyntax.hs
    ├── Language.hs
    ├── TypeChecker.hs
    └── Wasm.hs
├── stack.yaml
├── stack.yaml.lock
├── test
    ├── Arbitrary.hs
    ├── HaskellSyntaxSpec.hs
    ├── SampleSpec.hs
    ├── Spec.hs
    ├── TypeCheckerSpec.hs
    ├── WasmSpec.hs
    ├── fixtures
    │   ├── case-deconstruction.tree
    │   ├── case-statement-and-more.tree
    │   ├── case-statement.tree
    │   ├── deconstruction.tree
    │   ├── let.tree
    │   └── multiple-assignments.tree
    ├── integration.rb
    └── samples
    │   ├── invalid
    │       ├── incomplete_definition.tree
    │       └── mistyped_argument_deconstruction.tree
    │   └── valid
    │       ├── argument_deconstruction.tree
    │       ├── float.tree
    │       ├── list.tree
    │       ├── nested_deconstruction.tree
    │       ├── result.tree
    │       ├── simple_int_defintion.tree
    │       └── simple_string_definition.tree
├── wasm-interp
└── wasm-server


/.gitignore:
--------------------------------------------------------------------------------
 1 | dist
 2 | dist-*
 3 | cabal-dev
 4 | *.o
 5 | *.hi
 6 | *.chi
 7 | *.chs.h
 8 | *.dyn_o
 9 | *.dyn_hi
10 | .hpc
11 | .hsenv
12 | .cabal-sandbox/
13 | cabal.sandbox.config
14 | *.prof
15 | *.aux
16 | *.hp
17 | *.eventlog
18 | .stack-work/
19 | cabal.project.local
20 | .HTF/
21 | .ghc.environment.*
22 | failures/
23 | nixpkgs*
24 | 


--------------------------------------------------------------------------------
/.ruby-version:
--------------------------------------------------------------------------------
1 | 2.4.3
2 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | # Use new container infrastructure to enable caching
 2 | sudo: false
 3 | 
 4 | # Do not choose a language; we provide our own build tools.
 5 | language: nix
 6 | 
 7 | # Caching so the next build will be fast too.
 8 | cache:
 9 |   directories:
10 |   - $HOME/.stack
11 |   - $HOME/nix.store
12 | 
13 | 
14 | # Ensure necessary system libraries are present
15 | addons:
16 |   apt:
17 |     packages:
18 |       - libgmp-dev
19 | 
20 | before_install:
21 | # Download and unpack the stack executable
22 | - mkdir -p ~/.local/bin
23 | - export PATH=$HOME/.local/bin:$PATH
24 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
25 | - sudo mkdir -p /etc/nix
26 | - echo "substituters = https://cache.nixos.org/ file://$HOME/nix.store" | sudo tee -a /etc/nix/nix.conf > /dev/null
27 | - echo 'require-sigs = false' | sudo tee -a /etc/nix/nix.conf > /dev/null
28 | 
29 | before_cache:
30 | - mkdir -p $HOME/nix.store
31 | - nix copy --to file://$HOME/nix.store -f shell.nix --arg ghc "with (import <nixpkgs> {}); haskell.compiler.ghc822"  buildInputs
32 | 
33 | before_script:
34 |   - echo 'sandbox = true' | sudo tee /etc/nix/nix.conf
35 | 
36 | install:
37 | # Build dependencies
38 | - stack --no-terminal --install-ghc test --only-dependencies
39 | 
40 | script:
41 | # Build the package, its tests, and its docs and run the tests
42 | - make
43 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | Copyright (c) 2017 Nick Johnstone
 3 | 
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
19 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
20 | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
21 | OR OTHER DEALINGS IN THE SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | 
 2 | default: build-bins test
 3 | 
 4 | build-bins:
 5 | 	stack build --copy-bins
 6 | 
 7 | build:
 8 | 	stack build
 9 | 
10 | test: unit integration
11 | 
12 | unit:
13 | 	stack test
14 | 
15 | integration:
16 | 	nix-shell ./nix/test-shell.nix --run "ruby test/integration.rb"
17 | 
18 | .PHONY: build test unit integration
19 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # forest-lang
  2 | 
  3 | Forest is a functional programming language that compiles to WebAssembly. This repository contains the compiler and core syntaxes, currently implemented in Haskell.
  4 | 
  5 | Forest is pre-alpha experimental conceptual research software. Imagine this documentation as a preview of what Forest might be.
  6 | 
  7 | Design principles
  8 | ----
  9 | 
 10 | * Ease of collaboration outweighs all other priorities.
 11 | * For the sake of collaboration, we agree on structure and semantics, and agree to disagree on syntax.
 12 | * Forest will be fast enough to make complex games, so normal web apps will be blazing fast.
 13 | * Testing aids collaboration, so it should be as painless as possible.
 14 | * Since we want to write tests, effect execution and logic should be separate.
 15 | * What if everything was a dataflow graph?
 16 | 
 17 | Features
 18 | -----
 19 | 
 20 |  * Statically typed
 21 |  * Pattern matching
 22 |  * Immutable datastructures (with mutable optimizations for common cases)
 23 |  * Ref-counted, incremental cleanup that can be scheduled. No automatic stop the world GC.
 24 |  * Multiple syntaxes, users can create and customize syntaxes, and project between.
 25 |  * Automatic code formatting
 26 |  * Dev virtual filesystem powered by FUSE to project code into desired syntax.
 27 |  * Visual editor
 28 |  
 29 | FAQ
 30 | ---
 31 | 
 32 | **Why are you making this? What's your point of difference from other languages?**
 33 | 
 34 | A few reasons. I work on Cycle.js and build apps with it. I wanted to build a visual editor for Cycle.js, but also wanted to be able to edit a textual representation. Rather than retrofitting a complex system to enable that on top of a language with suboptimal semantics, I preferred to start fresh.
 35 | 
 36 | I also started working more with Elm, and while I like many aspects of Elm's type system and syntax, I missed being able to build applications as dataflow graphs.
 37 | 
 38 | On top of all of that, I have a keen interest in making games on the web, but I am frustrated by the memory model in JavaScript. The hiccups introduced by uncontrollable stop the world garbage collection tear at my soul. I view WebAssembly as an amazing opportunity to eliminate much of the cruft that bloats the web platform.
 39 | 
 40 | **What does the syntax look like?**
 41 | 
 42 | Since Forest supports multiple syntaxes, it might look very different to different developers.
 43 | 
 44 | The first syntax in development is inspired by Haskell and Elm.
 45 | 
 46 | For example, here is fibonacci implemented in Forest:
 47 | 
 48 | ```elm
 49 | fib i =
 50 |   case i of
 51 |     0 -> 1
 52 |     1 -> 1
 53 |     i -> fib (i - 2) + fib (i - 1)
 54 | ```
 55 | 
 56 | However, this could just as easily be written using another syntax more comparable to JavaScript:
 57 | 
 58 | ```js
 59 | function fib(i) {
 60 |   switch (i) {
 61 |     case 0: 1;
 62 |     case 1: 1;
 63 |     case i: fib(i - 2) + fib(i - 1);
 64 |   }
 65 | }
 66 | ```
 67 | 
 68 | Notice that while the syntax in these examples differs, the underlying semantics are the same (implicit returns, pattern matching).
 69 | 
 70 | **If every dev can use different syntax, what do we store in the repo?**
 71 | 
 72 | You only need to store a single representation of the syntax in source control, which we'll call the canonical representation. The syntax for this representation would be agreed by the project's collaborators, but is largely unimportant.
 73 | 
 74 | **What's the point of having different syntaxes?**
 75 | 
 76 | Syntax is polarising. I know people who love Ruby's syntax, and people who hate it. I know people who love Haskell syntax, and people who hate it. The syntax of your language immediately alienates a large swathe of the community.
 77 | 
 78 | Beyond languages, the arguments go on. Tabs vs spaces? Whitespace sensitive or curly braces? Semicolons or not?
 79 | 
 80 | If everyone can use the syntax they desire, we don't need to have those arguments anymore. How much time does your team spend talking style?
 81 | 
 82 | In current languages, new syntax is headline news. Some of the best parts of ES2015 were simply syntactic sugar. If we push syntax to userland, each developer can have their preferred sugar and we can iterate without the need for major version changes to languages.
 83 | 
 84 | Additionally, having a variety of different syntaxes might aid beginners in learning the language and contributing to projects. Maybe the maintainers of a project personally like the Haskell syntax with the [sweet unicode greek alphabet generics](https://hackage.haskell.org/package/wai-cors-0.2.5/docs/src/Network.Wai.Middleware.Cors.html#sshow), but perhaps a new contributor is more accustomed to a Python style syntax. Why shouldn't they be able to work together?
 85 | 
 86 | **Won't the docs be in a different syntax than what I prefer? What about code snippets?**
 87 | 
 88 | A medium term goal is for the Forest compiler to be written in Forest. This means syntaxes will also be written in Forest, which means we can run them in a web browser. So it would be possible to display docs in your preferred syntax, or at least your favourite core syntax. As for code snippets, we could build a code snippet sharing website that projects the snippet to your preferred syntax.
 89 | 
 90 | **How do I edit the code in my preferred syntax? Do I need an editor plugin?**
 91 | 
 92 | When working on the project, each developer runs `forest dev`, which mounts a virtual filesystem in the local directory using FUSE, called `dev/`.
 93 | 
 94 | `dev/` contains all of the source files, projected into the developer's syntax of choice. The developer can read and write these files using their text editor of choice, modifying the canonical representation, with no need to install an editor plugin. Their syntax automatically generates syntax highlighting files for all common editors.
 95 | 
 96 | **What about reviewing changes in the command line and web?**
 97 | 
 98 | Source control tools such as git can be configured to diff using `forest diff`, which shows the diffs in the developer's preferred syntax.
 99 | 
100 | When reviewing pull requests on the web, developers use WebExtensions to project the changes to their preferred syntax.
101 | 
102 | **Aren't immutable data structures memory innefficient? Won't that limit your performance with complex games?**
103 | 
104 | Immutable data structures can have suboptimal characteristics for some classes of high performance applications. This is due to the need to allocate new memory for every change, and in garbage collected languages the need to cleanup unused previous structures.
105 | 
106 | In Forest, a simple reference counting strategy is used to keep track of allocated memory. When an immutable update is performed, if there is only a single reference to the memory that is being updated, we can simply update the memory in-place. This saves the need to garbage collect the old version that is no longer referenced.
107 | 
108 | Forest will automatically free any memory when it is no longer referenced. By default, this happens automatically as the code executes. Users can optionally disable this and instead run incremental cleanup for a specified number of milliseconds. In applications trying to maintain a smooth framerate, this allows for fine control over cleanup pauses.
109 | 
110 | **Why compile directly to WebAssembly? Why not compile to LLVM and get WASM support for free, along with many other platforms?**
111 | 
112 | There are a few reasons for this. The first is that I'm interested in learning about WebAssembly, and compiling to it is a great way to learn how it works. The second is that Forest aims to squeeze as much performance out of the browser as is reasonably possible. Compiling directly to WebAssembly means we can ensure we produce the smallest reasonable number of instructions to run a program.
113 | 
114 | Support for compiling to other platforms is planned, as Forest aspires to be a general purpose language. However, the web comes first.
115 | 
116 | **How close is Forest to being ready for real use?**
117 | 
118 | Forest is just a sprout right now, it has a long way to go.
119 | 
120 | Right now, it supports:
121 |  * numbers
122 |  * infix arithmetic
123 |  * function declaration and calls
124 |  * pattern matching
125 |  * let expressions
126 |  * auto code formatting!
127 |  * strings!
128 |  * memory management (kinda)
129 |  * a type system (simple but there)
130 |  * ADTs
131 |  * lists
132 | 
133 | Critical missing features:
134 |   * an effect system
135 |   * a standard library of data structures
136 |   * a module system
137 |   * a way to install and share packages
138 | 
139 | So, very not ready for even simple applications.
140 | 
141 | Using Forest
142 | ---
143 | 
144 | First, you'll need to make sure you have [Stack](https://docs.haskellstack.org/en/stable/README/) and [Nix](https://nixos.org/nix/download.html) installed.
145 | 
146 | Next, clone this project and run `make`. If you want to make changes and submit a pull request, make a fork and clone that.
147 | 
148 | ```
149 | git clone https://github.com/forest-lang/forest-compiler.git
150 | 
151 | cd forest-compiler
152 | 
153 | make
154 | ```
155 | 
156 | `make` will build Forest and copy the binary to your path. It will also run the tests.
157 | 
158 | Forest has a single binary right now, named `forest`. It has two commands, `forest build <file>`, which produces text-format WebAssembly, and `forest format <file>`, which reprints the given file to stdout.
159 | 
160 | To run the generated Wast, you can either use the provided `wasm-interp` script, run it yourself with Node, or in a WebAssembly compatible browser.
161 | 
162 | See [MDN](https://developer.mozilla.org/en-US/docs/WebAssembly/Using_the_JavaScript_API) for more info.
163 | 
164 | This is a rough experience right now, and is an area that should be better.
165 | 
166 | **I have a question not answered here?**
167 | 
168 | Please [open an issue](https://github.com/forest-lang/forest-compiler/issues/new) and ask questions, offer to help, point out bugs or suggest features.
169 |  
170 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | 
3 | main = defaultMain
4 | 


--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE QuasiQuotes #-}
  4 | 
  5 | module Main where
  6 | 
  7 | import qualified Data.ByteString as BS
  8 | import Data.List (intersperse)
  9 | import Data.List.NonEmpty (NonEmpty, toList)
 10 | import Data.Maybe
 11 | import Data.Semigroup
 12 | import Data.Text (Text, intercalate, pack, strip, unpack)
 13 | import qualified Data.Text as Text
 14 | import qualified Data.Text.IO as TIO
 15 | import Rainbow hiding ((<>))
 16 | import Safe
 17 | import System.Environment
 18 | import System.Exit
 19 | import System.IO
 20 | import Text.Megaparsec hiding (chunk)
 21 | import Text.Megaparsec.Error
 22 | import Text.RawString.QQ
 23 | 
 24 | import Compiler
 25 | import HaskellSyntax
 26 | import TypeChecker
 27 | 
 28 | showT :: Show a => a -> Text
 29 | showT = Text.pack . show
 30 | 
 31 | usage :: Text
 32 | usage =
 33 |   strip
 34 |     [r|
 35 | usage: forest command path
 36 | 
 37 | commands:
 38 | 
 39 |   build - typechecks and compiles the given file to Wast
 40 |   format - format and print the given file
 41 |   check - typechecks the given file
 42 | |]
 43 | 
 44 | main :: IO ()
 45 | main = do
 46 |   args <- getArgs
 47 |   case args of
 48 |     ["build", filename] -> do
 49 |       contents <- TIO.readFile filename
 50 |       let (printText, exitCode) =
 51 |             case compile contents of
 52 |               Success compiledWast -> (TIO.putStrLn compiledWast, ExitSuccess)
 53 |               ParseErr err ->
 54 |                 ( TIO.hPutStrLn stderr $ reportParseError filename err
 55 |                 , ExitFailure 1)
 56 |               CompileErr errors ->
 57 |                 let errorChunks :: [[Chunk Text]]
 58 |                     errorChunks = toList $ printError contents <$> errors
 59 |                     divider = [chunk "\n\n-----------\n\n"]
 60 |                     chunks =
 61 |                       intersperse divider errorChunks <>
 62 |                       [[chunk ("\n" :: Text)]]
 63 |                  in (printChunks $ concat chunks, ExitFailure 2)
 64 |       printText >> exitWith exitCode
 65 |     ["format", filename] -> do
 66 |       contents <- TIO.readFile filename
 67 |       case format contents of
 68 |         Right formattedCode ->
 69 |           TIO.writeFile filename formattedCode >>
 70 |           TIO.putStrLn "Formatted successfully."
 71 |         Left err ->
 72 |           (TIO.hPutStrLn stderr $ reportParseError filename err) >>
 73 |           exitWith (ExitFailure 1)
 74 |     ["check", filename] -> do
 75 |       contents <- TIO.readFile filename
 76 |       let (printText, exitCode) =
 77 |             case typeCheck contents of
 78 |               Success _ -> (TIO.putStrLn "No errors found.", ExitSuccess)
 79 |               ParseErr err ->
 80 |                 ( TIO.hPutStrLn stderr $ reportParseError filename err
 81 |                 , ExitFailure 1)
 82 |               CompileErr errors ->
 83 |                 let errorChunks :: [[Chunk Text]]
 84 |                     errorChunks = toList $ printError contents <$> errors
 85 |                     divider = [chunk "\n\n-----------\n\n"]
 86 |                     chunks =
 87 |                       intersperse divider errorChunks <>
 88 |                       [[chunk ("\n" :: Text)]]
 89 |                  in (printChunks $ concat chunks, ExitFailure 2)
 90 |       printText >> exitWith exitCode
 91 |     _ -> TIO.hPutStrLn stderr usage >> exitFailure
 92 |   where
 93 |     positionText p =
 94 |       case p of
 95 |         Just (start, end) ->
 96 |           Text.pack (sourcePosPretty start <> "-" <> sourcePosPretty end)
 97 |         Nothing -> ""
 98 |     printError contents (CompileError error maybeSourceRange message) =
 99 |       case error of
100 |         ExpressionError expression ->
101 |           case maybeSourceRange of
102 |             Just (start, end) ->
103 |               let contextRangeStart = unPos (sourceLine start) - 2
104 |                   contextRangeEnd = unPos (sourceLine end) + 1
105 |                   contentLines = Text.lines contents
106 |                   colorLine line =
107 |                     let (lineStart, remainder) =
108 |                           Text.splitAt (unPos (sourceColumn start) + 3) line
109 |                         (highlight, lineEnd) = Text.splitAt (unPos (sourceColumn end) - unPos (sourceColumn start) + 1) remainder
110 |                      in [ chunk lineStart
111 |                         , chunk highlight & underline & fore brightRed
112 |                         , chunk lineEnd
113 |                         ]
114 |                   color lineNumber line =
115 |                     if lineNumber >= unPos (sourceLine start) &&
116 |                        lineNumber <= unPos (sourceLine end)
117 |                       then colorLine line
118 |                       else [chunk line]
119 |                   -- TODO rightpad line numbers so that they don't change when the number of digits varies
120 |                   contextLines =
121 |                     concatMap
122 |                       (\(lineNumber, line) ->
123 |                          color
124 |                            lineNumber
125 |                            (showT lineNumber <> " | " <> line <> "\n"))
126 |                       (filter
127 |                          (\(i, _) ->
128 |                             i >= contextRangeStart && i <= contextRangeEnd)
129 |                          (zip [1 ..] contentLines))
130 |                in [chunk $ "Error: ", chunk $ message <> "\n"] <> contextLines
131 |             Nothing ->
132 |               [ chunk $
133 |                 "Encountered a type error in an expression:\n" <> "\n" <>
134 |                 indent2 (printExpression expression) <>
135 |                 "\n\n" <>
136 |                 message
137 |               ]
138 |         DeclarationError declaration ->
139 |           [ chunk $
140 |             "Encountered a type error in a declaration:\n" <>
141 |             positionText maybeSourceRange <>
142 |             "\n" <>
143 |             indent2 (printDeclaration declaration) <>
144 |             "\n\n" <>
145 |             message
146 |           ]
147 |         DataTypeError dataType ->
148 |           [ chunk $
149 |             "Encountered a type error in a datatype:\n" <>
150 |             positionText maybeSourceRange <>
151 |             "\n" <>
152 |             indent2 (printDataType dataType) <>
153 |             "\n\n" <>
154 |             message
155 |           ]
156 | 
157 | printChunks :: [Chunk Text] -> IO ()
158 | printChunks chunks = do
159 |   printer <- byteStringMakerFromEnvironment
160 |   mapM_ (BS.hPut stderr) . chunksToByteStrings printer $ chunks
161 | 
162 | reportParseError :: String -> ParseError' -> Text
163 | reportParseError filename parseError =
164 |   "Syntax error in " <> pack filename <> "\n" <>
165 |   pack (errorBundlePretty parseError)
166 | 


--------------------------------------------------------------------------------
/forest-compiler.cabal:
--------------------------------------------------------------------------------
 1 | name:                forest-compiler
 2 | version:             0.1.0.0
 3 | -- synopsis:
 4 | -- description:
 5 | homepage:            https://github.com/githubuser/forest-compiler#readme
 6 | license:             BSD3
 7 | license-file:        LICENSE
 8 | author:              Nick Johnstone
 9 | maintainer:          ncwjohnstone@gmail.com
10 | copyright:           2017 Nick Johnstone
11 | category:            Web
12 | build-type:          Simple
13 | extra-source-files:  README.md
14 | cabal-version:       >=1.10
15 | 
16 | library
17 |   ghc-options:       -Werror -Wunused-matches -Wunused-local-binds -Wmissing-signatures -Wincomplete-patterns -Wincomplete-uni-patterns -Wincomplete-record-updates
18 |   hs-source-dirs:      src
19 |   exposed-modules:     HaskellSyntax
20 |                      , Wasm
21 |                      , Compiler
22 |                      , Language
23 |                      , TypeChecker
24 |   build-depends:       base >= 4.7 && < 5
25 |                      , megaparsec
26 |                      , generic-deriving
27 |                      , text
28 |                      , raw-strings-qq
29 |                      , safe
30 |                      , containers
31 |                      , ordered-containers
32 |                      , transformers
33 |                      , parser-combinators
34 |                      , mtl
35 |   default-language:    Haskell2010
36 | 
37 | executable forest
38 |   hs-source-dirs:      app
39 |   main-is:             Main.hs
40 |   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Werror -Wunused-matches -Wunused-local-binds -Wmissing-signatures -Wincomplete-patterns -Wincomplete-uni-patterns -Wincomplete-record-updates
41 |   build-depends:       base
42 |                      , forest-compiler
43 |                      , megaparsec
44 |                      , safe
45 |                      , text
46 |                      , raw-strings-qq
47 |                      , rainbow
48 |                      , bytestring
49 |   default-language:    Haskell2010
50 | 
51 | test-suite forest-compiler-test
52 |   type:                exitcode-stdio-1.0
53 |   hs-source-dirs:      test
54 |   main-is:             Spec.hs
55 |   other-modules:       HaskellSyntaxSpec
56 |                      , TypeCheckerSpec
57 |                      , WasmSpec
58 |                      , SampleSpec
59 |                      , Arbitrary
60 |   build-depends:       base
61 |                      , forest-compiler
62 |                      , QuickCheck
63 |                      , hspec
64 |                      , megaparsec
65 |                      , process
66 |                      , raw-strings-qq
67 |                      , temporary
68 |                      , text
69 |                      , directory
70 |                      , containers
71 |                      , ordered-containers
72 |                      , transformers
73 |   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Werror -Wunused-matches -Wunused-local-binds -Wmissing-signatures -Wincomplete-patterns -Wincomplete-uni-patterns -Wincomplete-record-updates
74 |   default-language:    Haskell2010
75 | 
76 | source-repository head
77 |   type:     git
78 |   location: https://github.com/githubuser/forest-compiler
79 | 


--------------------------------------------------------------------------------
/js/string.js:
--------------------------------------------------------------------------------
 1 | const fs = require('fs');
 2 | 
 3 | const bytes = fs.readFileSync('./output.wasm');
 4 | 
 5 | function loadString(exports, str) {
 6 |   const buffer = new Uint8Array(exports.memory.buffer);
 7 | 
 8 |   const address = exports.malloc(str.length + 1);
 9 | 
10 |   buffer[address] = str.length + 1;
11 | 
12 |   for(let i = 0; i <= str.length; i++) {
13 |     buffer[address + 1 + i] = str.codePointAt(i);
14 |   }
15 | 
16 |   return address;
17 | }
18 | 
19 | function readString(exports, address) {
20 |   const buffer = new Uint8Array(exports.memory.buffer);
21 | 
22 |   let output = '';
23 | 
24 |   let length = buffer[address] - 1;
25 | 
26 |   for(let i = 1; i <= length; i++) {
27 |     output += String.fromCodePoint(buffer[address + i]);
28 |   }
29 | 
30 |   return output;
31 | }
32 | 
33 | WebAssembly.instantiate(bytes).then(m => {
34 |   const exports = m.instance.exports;
35 | 
36 |   const string = s => loadString(exports, s);
37 | 
38 |   const name = process.argv[2];
39 | 
40 |   const address = exports.main(string(name));
41 | 
42 |   console.log(readString(exports, address));
43 | });
44 | 
45 | 


--------------------------------------------------------------------------------
/logo.svg:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="windows-1252"?>
 2 | <!-- Icon made by Freepik (www.freepik.com) from FlatIcon (www.flaticon.com) is licensed by CC 3.0 BY -->
 3 | <!-- Generator: Adobe Illustrator 19.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0)  -->
 4 | <svg version="1.1" id="Capa_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" viewBox="0 0 512 512" style="enable-background:new 0 0 512 512;" xml:space="preserve">
 5 | <rect x="155.18" y="307.18" style="fill:#C75E0B;" width="40.788" height="98.49"/>
 6 | <polygon style="fill:#0CC27C;" points="285.342,352.052 231.51,271.577 265.257,271.577 212.18,192.232 246.682,192.232   175.576,85.934 104.469,192.232 138.971,192.232 85.895,271.577 119.641,271.577 65.809,352.052 "/>
 7 | <rect x="316.03" y="307.18" style="fill:#C75E0B;" width="40.788" height="98.49"/>
 8 | <polygon style="fill:#0C967C;" points="446.191,352.052 392.359,271.577 426.106,271.577 373.029,192.232 407.531,192.232   336.425,85.934 265.318,192.232 299.82,192.232 246.744,271.577 280.49,271.577 226.658,352.052 "/>
 9 | <rect x="232.16" y="315" style="fill:#D66D1C;" width="47.687" height="112.67"/>
10 | <rect x="255.95" y="315" style="fill:#C75E0B;" width="23.891" height="112.67"/>
11 | <polygon style="fill:#39B54A;" points="384.333,366.333 321.396,274.273 360.85,274.274 298.796,183.506 339.134,183.506   256,61.905 172.866,183.506 213.204,183.506 151.15,274.273 190.605,274.273 127.667,366.333 "/>
12 | <polygon style="fill:#83E276;" points="172.866,183.506 213.204,183.506 151.15,274.273 190.605,274.273 127.667,366.333   255.952,366.333 256,61.905 "/>
13 | <polygon style="fill:#0CC27C;" points="321.396,274.273 360.85,274.274 298.796,183.506 339.134,183.506 256,61.905 256,61.905   255.952,366.333 384.333,366.333 "/>
14 | <g>
15 | </g>
16 | <g>
17 | </g>
18 | <g>
19 | </g>
20 | <g>
21 | </g>
22 | <g>
23 | </g>
24 | <g>
25 | </g>
26 | <g>
27 | </g>
28 | <g>
29 | </g>
30 | <g>
31 | </g>
32 | <g>
33 | </g>
34 | <g>
35 | </g>
36 | <g>
37 | </g>
38 | <g>
39 | </g>
40 | <g>
41 | </g>
42 | <g>
43 | </g>
44 | </svg>
45 | 


--------------------------------------------------------------------------------
/nix/dependencies.nix:
--------------------------------------------------------------------------------
1 | { pkgs ? import <nixpkgs> {} }:
2 | 
3 | with pkgs;
4 | 
5 | [ nodejs-10_x ruby wabt ]
6 | 


--------------------------------------------------------------------------------
/nix/test-shell.nix:
--------------------------------------------------------------------------------
 1 | { pkgs ? import <nixpkgs> {} }:
 2 | 
 3 | with pkgs;
 4 | 
 5 | let
 6 |   dependencies = import ./dependencies.nix {};
 7 | in
 8 | stdenv.mkDerivation {
 9 |   name = "test-environment";
10 |   buildInputs = dependencies;
11 | }
12 | 
13 | 


--------------------------------------------------------------------------------
/nix/wabt.nix:
--------------------------------------------------------------------------------
 1 | { pkgs ? import <nixpkgs> {} }:
 2 | 
 3 | with pkgs;
 4 | 
 5 | stdenv.mkDerivation {
 6 |   name = "wabt";
 7 |   src = fetchFromGitHub {
 8 |     owner = "WebAssembly";
 9 |     repo = "wabt";
10 |     rev = "71ce746f1be4290b8d20449ff35b852b5cc374d2";
11 |     sha256 = "0szkr01vdigs3h68qnfzhcl385394b4cfbdd14s3hkk7jm61z0a2";
12 |   };
13 |   nativeBuildInputs = [ cmake python ];
14 |   enableParallelBuilding = true;
15 |   cmakeFlags = ["-DBUILD_TESTS=OFF"];
16 | }
17 | 
18 | 


--------------------------------------------------------------------------------
/samples/addOne.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | add :: Int -> Int -> Int
 3 | add a b = a + b
 4 | 
 5 | addOne :: Int -> Int
 6 | addOne n = add 5 10
 7 | 
 8 | add :: String -> String -> String
 9 | add a b = a ++ b
10 | 
11 | addOne :: String -> String
12 | addOne n = add n "one"
13 | 


--------------------------------------------------------------------------------
/samples/annotation.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | add :: Int -> Int -> Int
 3 | add a b = a + b
 4 | 
 5 | main :: Int
 6 | main = add (add 10 15) 15
 7 | 
 8 | updateNumber :: (Int -> Int) -> Int -> Int
 9 | updateNumber f i = f i
10 | 


--------------------------------------------------------------------------------
/samples/arithmetic.tree:
--------------------------------------------------------------------------------
1 | add x y = x + y
2 | 


--------------------------------------------------------------------------------
/samples/bool.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | data Bool
 3 |   = True
 4 |   | False
 5 | 
 6 | and :: Bool -> Bool -> Bool
 7 | and a b =
 8 |   case a of
 9 |     True -> b
10 |     False -> False
11 | 
12 | or :: Bool -> Bool -> Bool
13 | or a b =
14 |   case a of
15 |     True -> True
16 |     False -> b
17 | 
18 | not :: Bool -> Bool
19 | not a =
20 |   case a of
21 |     True -> False
22 |     False -> True
23 | 
24 | equals :: Bool -> Bool -> Bool
25 | equals a b = or (and a b) (and (not a) (not b))
26 | 


--------------------------------------------------------------------------------
/samples/closure.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | main :: Int
 3 | main =
 4 |   let
 5 |     a :: Int
 6 |     a = 5
 7 | 
 8 |     calc :: Int -> Int
 9 |     calc n = n + a
10 |   in
11 |     calc 7
12 | 


--------------------------------------------------------------------------------
/samples/deconstruction.tree:
--------------------------------------------------------------------------------
 1 | data Maybe a
 2 |   = Just a
 3 |   | Nothing
 4 | 
 5 | test :: Maybe Int -> Int
 6 | test m =
 7 |   case m of
 8 |     Just a -> a
 9 |     Nothing -> 5
10 | 
11 | main :: Int
12 | main = test (Just 10)
13 | 


--------------------------------------------------------------------------------
/samples/fib.tree:
--------------------------------------------------------------------------------
 1 | fib :: Int -> Int
 2 | fib i =
 3 |   case i of
 4 |     0 -> 1
 5 |     1 -> 1
 6 |     n -> fib (i - 2) + fib (i - 1)
 7 | 
 8 | main :: Int
 9 | main =
10 |   fib 10
11 | 


--------------------------------------------------------------------------------
/samples/let.tree:
--------------------------------------------------------------------------------
 1 | main :: Int
 2 | main =
 3 |   let
 4 |     x :: Int
 5 |     x =
 6 |       5
 7 |     y :: Int
 8 |     y =
 9 |       10
10 |   in
11 |     x + y
12 | 


--------------------------------------------------------------------------------
/samples/list.tree:
--------------------------------------------------------------------------------
 1 | add :: Int -> Int -> Int
 2 | add a b = a + b
 3 | 
 4 | data List a
 5 |   = Cons a (List a)
 6 |   | Empty
 7 | 
 8 | fib :: List Int
 9 | fib = Cons 1 (Cons 1 (Cons 2 (Cons 3 (Cons 5 (Cons 8 Empty)))))
10 | 
11 | map :: (a -> b) -> List a -> List b
12 | map f list =
13 |   case list of
14 |     Cons x xs -> Cons (f x) (map f xs)
15 |     Empty -> Empty
16 | 
17 | test :: List Int
18 | test = map (add 5) (Cons 1 Empty)
19 | 
20 | doubledFib :: List Int
21 | doubledFib =
22 |   let
23 |     double :: Int -> Int
24 |     double n = n * 2
25 |   in
26 |     map double fib
27 | 
28 | foldl :: (a -> a -> a) -> a -> List a -> a
29 | foldl f acc list =
30 |   case list of
31 |     Cons x xs -> foldl f (f acc x) xs
32 |     Empty -> acc
33 | 
34 | sum :: List Int -> Int
35 | sum = foldl add 0
36 | 
37 | data NonEmptyList a
38 |   = NonEmptyList a (List a)
39 | 
40 | main :: NonEmptyList String
41 | main = NonEmptyList "foo" (Cons "bar" Empty)
42 | 
43 | data Maybe a
44 |   = Just a
45 |   | Nothing
46 | 
47 | fromList :: List a -> Maybe (NonEmptyList a)
48 | fromList l =
49 |   case l of
50 |     Cons x xs -> Just (NonEmptyList x xs)
51 |     Empty -> Nothing
52 | 
53 | 


--------------------------------------------------------------------------------
/samples/maybe.tree:
--------------------------------------------------------------------------------
 1 | data Maybe a
 2 |   = Just a
 3 |   | Nothing
 4 | 
 5 | foo :: Int -> Maybe Int
 6 | foo n =
 7 |   case n of
 8 |     5 -> Just 10
 9 |     n -> Nothing
10 | 
11 | main :: Maybe Int
12 | main = foo 5
13 | 
14 | map :: (a -> b) -> Maybe a -> Maybe b
15 | map f m =
16 |   case m of
17 |     Just n -> Just (f n)
18 |     Nothing -> Nothing
19 | 
20 | withDefault :: a -> Maybe a -> a
21 | withDefault d m =
22 |   case m of
23 |     Just a -> a
24 |     Nothing -> d
25 | 
26 | test :: Maybe Int
27 | test =
28 |   let
29 |     addOne :: Int -> Int
30 |     addOne n = n + 1
31 |   in
32 |     map addOne (Just 1)
33 | 
34 | test2 :: Maybe Int -> Int
35 | test2 m = withDefault 5 m
36 | 
37 | test3 :: Int
38 | test3 = test2 (Nothing)
39 | 


--------------------------------------------------------------------------------
/samples/moving_block/index.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE HTML>
 2 | <head>
 3 | </head>
 4 | <body>
 5 |   <canvas width="500" height="500"></canvas>
 6 | </body>
 7 | <script>
 8 |   var canvas = document.querySelector('canvas');
 9 |   var context = canvas.getContext('2d');
10 | 
11 |   function runGame(exports) {
12 |     var state = exports.init_37();
13 |     var input = exports.NoInput_11();
14 | 
15 |     document.addEventListener('keydown', (event) => {
16 |       if (event.key == 'w') {
17 |         input = exports.Up_7();
18 |       }
19 | 
20 |       if (event.key == 'a') {
21 |         input = exports.Left_9();
22 |       }
23 | 
24 |       if (event.key == 's') {
25 |         input = exports.Down_8();
26 |       }
27 | 
28 |       if (event.key == 'd') {
29 |         input = exports.Right_10();
30 |       }
31 |     });
32 | 
33 |     function loop() {
34 |       state = exports.update_20(state, input);
35 |       input = exports.NoInput_11();
36 | 
37 |       context.fillStyle = 'white';
38 |       context.fillRect(0, 0, canvas.width, canvas.height);
39 | 
40 |       context.fillStyle = 'black';
41 |       var position = exports.getPosition_38(state);
42 |       var x = exports.getX_12(position);
43 |       var y = exports.getY_16(position);
44 |       context.fillRect(x, y, 50, 50);
45 | 
46 |       requestAnimationFrame(loop);
47 |     }
48 | 
49 |     requestAnimationFrame(loop);
50 |   }
51 | 
52 |   WebAssembly.instantiateStreaming(fetch('output.wasm'), {})
53 |     .then(results => {
54 |       console.log('hi');
55 |       var exports = results.instance.exports;
56 |       runGame(exports);
57 |       // Do something with the results!
58 |     });
59 | </script>
60 | 
61 | 


--------------------------------------------------------------------------------
/samples/moving_block/moving_block.tree:
--------------------------------------------------------------------------------
 1 | data Vector2
 2 |   = Vector2 Float Float
 3 | 
 4 | data State
 5 |   = State Vector2 Vector2
 6 | 
 7 | data Input
 8 |   = Up
 9 |   | Down
10 |   | Left
11 |   | Right
12 |   | NoInput
13 | 
14 | getX :: Vector2 -> Float
15 | getX (Vector2 x y) = x
16 | 
17 | getY :: Vector2 -> Float
18 | getY (Vector2 x y) = y
19 | 
20 | update :: State -> Input -> State
21 | update (State (Vector2 x y) (Vector2 vx vy)) input =
22 |   let
23 |     accel :: Float
24 |     accel = 0.1
25 | 
26 |     newVelocity :: Vector2
27 |     newVelocity =
28 |       case input of
29 |         Up ->
30 |           Vector2 vx (vy - accel)
31 |         Down ->
32 |           Vector2 vx (vy + accel)
33 |         Left ->
34 |           Vector2 (vx - accel) vy
35 |         Right ->
36 |           Vector2 (vx + accel) vy
37 |         NoInput ->
38 |           Vector2 vx vy
39 | 
40 |     newPosition :: Vector2
41 |     newPosition = Vector2 (x + getX newVelocity) (y + getY newVelocity)
42 |   in
43 |     State (newPosition) (newVelocity)
44 | 
45 | init :: State
46 | init = State (Vector2 80.0 50.0) (Vector2 0.0 0.0)
47 | 
48 | getPosition :: State -> Vector2
49 | getPosition (State p v) = p
50 | 
51 | 


--------------------------------------------------------------------------------
/samples/result.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | data Result error value
 3 |   = Err error
 4 |   | Ok value
 5 | 
 6 | data Maybe a
 7 |   = Just a
 8 |   | Nothing
 9 | 
10 | map :: (a -> b) -> Result e a -> Result e b
11 | map f result =
12 |     case result of
13 |       Ok  v -> Ok (f v)
14 |       Err e -> Err e
15 | 
16 | andThen :: Result e a -> (a -> Result e b) -> Result e b
17 | andThen result callback =
18 |     case result of
19 |       Ok value -> callback value
20 |       Err msg -> Err msg
21 | 
22 | formatError :: (e -> fe) -> Result e a -> Result fe a
23 | formatError f result =
24 |     case result of
25 |       Ok  v -> Ok v
26 |       Err e -> Err (f e)
27 | 
28 | toMaybe :: Result e a -> Maybe a
29 | toMaybe result =
30 |     case result of
31 |       Ok  v -> Just v
32 |       Err err -> Nothing
33 | 
34 | fromMaybe :: e -> Maybe a -> Result e a
35 | fromMaybe err maybe =
36 |     case maybe of
37 |       Just v  -> Ok v
38 |       Nothing -> Err err
39 | 


--------------------------------------------------------------------------------
/samples/spring.tree:
--------------------------------------------------------------------------------
 1 | -- most of this is aspirational, not real syntax yet
 2 | 
 3 | type Vector (Num => t) = { x: t, y: t }
 4 | 
 5 | operate : (t -> t -> t) -> Vector t -> Vector t -> Vector t
 6 | operate f a b =
 7 |   let
 8 |     x = f a.x b.x
 9 |     y = f a.y b.y
10 |   in
11 |     { x, y }
12 | 
13 | operate' : (t -> t -> t) -> Vector t -> t -> Vector t
14 | operate' f v t =
15 |   let
16 |     x = f a.x t
17 |     y = f a.y t
18 |   in
19 |     { x, y }
20 | 
21 | (+) : Vector t -> Vector t -> Vector t
22 | (+) = operate (+)
23 | 
24 | (-) : Vector t -> Vector t -> Vector t
25 | (-) = operate (-)
26 | 
27 | (*) : Vector t -> t -> Vector t
28 | (*) = operate' (*)
29 | 
30 | (/) : Vector t -> t -> Vector t
31 | (/) = operate' (/)
32 | 
33 | update : State -> Vector -> State
34 | update state position =
35 |   let
36 |     difference = position - state
37 |   in
38 |     state + difference / 10
39 | 
40 | view : State -> HTML
41 | view state =
42 |   div { class: "point", style: { left: "#{state.x}px", right: "#{state.y}px" } } ""
43 | 
44 | main : Mouse -> Animation -> DOM
45 | main Mouse Animation =
46 |   let
47 |     initialState   = { x: 300, y: 300 }
48 |     mousePosition$ = sample Mouse.position$ Animation.frame$
49 |     state$         = fold update initialState mousePosition$
50 |   in
51 |     DOM = map view state$
52 | 


--------------------------------------------------------------------------------
/samples/string.tree:
--------------------------------------------------------------------------------
1 | main name =
2 |   "Hello " ++ name ++ "!"
3 | 


--------------------------------------------------------------------------------
/samples/test.tree:
--------------------------------------------------------------------------------
1 | a :: A
2 | n e =
3 |   ""
4 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | {ghc}:
 2 | with (import <nixpkgs> {});
 3 | 
 4 | let
 5 |   dependencies = import ./nix/dependencies.nix {};
 6 | in
 7 | haskell.lib.buildStackProject {
 8 |   inherit ghc;
 9 |   name = "forest-compiler";
10 |   buildInputs = dependencies;
11 | }
12 | 


--------------------------------------------------------------------------------
/src/Compiler.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveFunctor #-}
 2 | 
 3 | module Compiler
 4 |   ( compile
 5 |   , format
 6 |   , typeCheck
 7 |   , Result(..)
 8 |   ) where
 9 | 
10 | import Data.List.NonEmpty (NonEmpty)
11 | import Debug.Trace (trace)
12 | import Data.Text (Text)
13 | 
14 | import HaskellSyntax
15 | import TypeChecker
16 | import Wasm
17 | 
18 | data Result a
19 |   = Success a
20 |   | ParseErr ParseError'
21 |   | CompileErr (NonEmpty CompileError)
22 |   deriving (Show, Functor)
23 | 
24 | typeCheck :: Text -> Result TypedModule
25 | typeCheck code =
26 |   case parseModuleWithLineInformation code of
27 |     Left parseError -> ParseErr parseError
28 |     Right (forestModule, lineInformation) ->
29 |       case checkModuleWithLineInformation forestModule (Just lineInformation) of
30 |         Left compileError -> CompileErr compileError
31 |         Right typedModule -> Success typedModule
32 | 
33 | compile :: Text -> Result Text
34 | compile code = printWasm . forestModuleToWasm <$> typeCheck code
35 | 
36 | format :: Text -> Either ParseError' Text
37 | format s = printModule <$> parseModule s
38 | 


--------------------------------------------------------------------------------
/src/HaskellSyntax.hs:
--------------------------------------------------------------------------------
  1 | 
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | 
  4 | module HaskellSyntax
  5 |   ( printExpression
  6 |   , printModule
  7 |   , parseModule
  8 |   , parseModuleWithLineInformation
  9 |   , ParseError'
 10 |   , Parser
 11 |   , reservedWords
 12 |   , SourceRange
 13 |   , s
 14 |   , parseExpr
 15 |   , annotation
 16 |   , pType
 17 |   , dataType
 18 |   , operatorToString
 19 |   , printDeclaration
 20 |   , indent2
 21 |   , LineInformation(..)
 22 |   , printDataType
 23 |   ) where
 24 | 
 25 | import Language
 26 | 
 27 | import Control.Monad (void)
 28 | import Data.Functor.Identity ()
 29 | import Data.List.NonEmpty (NonEmpty(..))
 30 | import qualified Data.List.NonEmpty as NE
 31 | import Control.Monad.Trans.Class
 32 | import Control.Monad.Trans.State.Lazy
 33 | import Data.Map (Map)
 34 | import Data.Functor.Identity
 35 | import qualified Data.Map as Map
 36 | import Data.Semigroup
 37 | import Data.Text (Text, intercalate)
 38 | import qualified Data.Text as Text
 39 | import Data.Void (Void)
 40 | 
 41 | import Text.Megaparsec
 42 | import Text.Megaparsec.Char
 43 | import qualified Text.Megaparsec.Char.Lexer as Lexer
 44 | import Control.Monad.Combinators.Expr
 45 | showT :: Show a => a -> Text
 46 | showT = Text.pack . show
 47 | 
 48 | type Parser = StateT LineInformation (ParsecT Void Text Identity)
 49 | 
 50 | type ParseError' = ParseErrorBundle Text Void
 51 | 
 52 | type SourceRange = (SourcePos, SourcePos)
 53 | 
 54 | data LineInformation = LineInformation
 55 |   { expressions :: Map Expression SourceRange
 56 |   , topLevels :: Map TopLevel SourceRange
 57 |   } deriving (Show, Eq)
 58 | 
 59 | setTopLevelPosition :: TopLevel -> SourceRange -> LineInformation -> LineInformation
 60 | setTopLevelPosition tl pos (LineInformation expressions topLevels) =
 61 |   LineInformation expressions (Map.insert tl pos topLevels)
 62 | 
 63 | setExpressionPosition :: Expression -> SourceRange -> LineInformation -> LineInformation
 64 | setExpressionPosition expression pos (LineInformation expressions topLevels) =
 65 |   LineInformation (Map.insert expression pos expressions) topLevels
 66 | 
 67 | -- Parser combinators
 68 | lexeme :: Parser a -> Parser a
 69 | lexeme = Lexer.lexeme whiteSpace
 70 | 
 71 | symbol :: Text -> Parser Text
 72 | symbol = Lexer.symbol whiteSpace
 73 | 
 74 | parens' :: Parser a -> Parser a
 75 | parens' =
 76 |   between
 77 |     (symbol "(" *> whiteSpaceWithNewlines)
 78 |     (whiteSpaceWithNewlines <* symbol ")")
 79 | 
 80 | possiblyParenthesized :: Parser a -> Parser a
 81 | possiblyParenthesized parser = parens' parser <|> parser
 82 | 
 83 | maybeParse :: Parser a -> Parser (Maybe a)
 84 | maybeParse parser = (Just <$> try parser) <|> Nothing <$ symbol "" -- TODO fix symbol "" hack
 85 | 
 86 | -- Parsers
 87 | whiteSpace :: Parser ()
 88 | whiteSpace =
 89 |   Lexer.space
 90 |     (void $ takeWhile1P Nothing charIsWhiteSpace)
 91 |     lineComment
 92 |     Text.Megaparsec.empty <?>
 93 |   "whitespace"
 94 |   where
 95 |     charIsWhiteSpace char = char == ' ' || char == '\t'
 96 | 
 97 | whiteSpaceWithNewlines :: Parser ()
 98 | whiteSpaceWithNewlines =
 99 |   Lexer.space space1 lineComment Text.Megaparsec.empty <?> "whitespace"
100 | 
101 | lineComment :: Parser ()
102 | lineComment = Lexer.skipLineComment "#"
103 | 
104 | parseTerm :: Parser Expression
105 | parseTerm =
106 |   Lexer.lineFold whiteSpaceWithNewlines $ \whiteSpace' ->
107 |     terms >>= pApply whiteSpace'
108 |   where
109 |     terms =
110 |       choice [pCase, pLet, identifier, parens, try float, number, parseString] <?>
111 |       "term"
112 |     pApply whiteSpace' expression =
113 |       (foldl1 Apply . (:) expression <$>
114 |        (some (try (whiteSpace' *> terms)) <* whiteSpace)) <|>
115 |       return expression
116 | 
117 | parseExpr :: Parser Expression
118 | parseExpr = do
119 |   _ <- whiteSpace
120 |   startPos <- getSourcePos
121 |   expression <- makeExprParser (lexeme parseTerm) table <?> "expression"
122 |   endPos <- getSourcePos
123 |   modify (setExpressionPosition expression (startPos, endPos))
124 |   return expression
125 |   where
126 |     table :: [[Operator Parser Expression]]
127 |     table =
128 |       [ [InfixL (Infix Divide <$ char '/')]
129 |       , [InfixL (Infix Multiply <$ char '*')]
130 |       , [InfixL (Infix StringAdd <$ symbol "++")]
131 |       , [InfixL (Infix Add <$ char '+')]
132 |       , [InfixL (Infix Subtract <$ char '-')]
133 |       ]
134 | 
135 | parseString :: Parser Expression
136 | parseString =
137 |   String' . Text.pack <$>
138 |   between (string "\"") (string "\"") (many $ anySingleBut '"')
139 | 
140 | parens :: Parser Expression
141 | parens = BetweenParens <$> parens' parseExpr
142 | 
143 | float :: Parser Expression
144 | float =
145 |   Float <$> do
146 |     whiteSpace
147 |     integer <- Lexer.decimal
148 |     symbol "."
149 |     fractional <- Lexer.decimal
150 |     return $
151 |       fromIntegral integer +
152 |       (fromIntegral fractional / 10) * signumNoZero (fromIntegral integer)
153 | 
154 | signumNoZero :: Num a => Eq a => a -> a
155 | signumNoZero 0 = 1
156 | signumNoZero n = signum n
157 | 
158 | number :: Parser Expression
159 | number = Number <$> (whiteSpace *> Lexer.decimal)
160 | 
161 | reservedWords :: [Text] -- list of reserved words
162 | reservedWords = ["case", "of", "let"]
163 | 
164 | makeIdent :: Parser Char -> Parser Char -> Parser Ident
165 | makeIdent firstLetter rest = Text.pack <$> p >>= check -- TODO - can we make p return Text?
166 |   where
167 |     p = (:) <$> firstLetter <*> many rest
168 |     check text =
169 |       if text `elem` reservedWords
170 |         then fail $ "keyword " <> show text <> " cannot be an identifier"
171 |         else case text of
172 |                "" -> fail "identifier must be longer than zero characters"
173 |                _ ->
174 |                  return $
175 |                  Ident $ NonEmptyString (Text.head text) (Text.tail text)
176 | 
177 | pIdent :: Parser Ident
178 | pIdent = makeIdent letterChar alphaNumChar
179 | 
180 | pCapitalizedIdent :: Parser Ident
181 | pCapitalizedIdent = makeIdent upperChar alphaNumChar
182 | 
183 | pLowerCaseIdent :: Parser Ident
184 | pLowerCaseIdent = makeIdent lowerChar alphaNumChar
185 | 
186 | pCase :: Parser Expression
187 | pCase = Lexer.indentBlock whiteSpaceWithNewlines parseCaseStart
188 |   where
189 |     parseCaseStart =
190 |       indentArgs <$>
191 |       (symbol "case" *> whiteSpace *> parseExpr <* whiteSpaceWithNewlines <*
192 |        symbol "of")
193 |     makeCase caseExpr = return . Case caseExpr . NE.fromList
194 |     indentArgs caseExpr =
195 |       Lexer.IndentSome Nothing (makeCase caseExpr) caseBranch
196 |     caseBranch =
197 |       (,) <$> pArgument <*>
198 |       (whiteSpace *> symbol "->" *> whiteSpaceWithNewlines *> parseExpr)
199 | 
200 | pArgument :: Parser Argument
201 | pArgument =
202 |   whiteSpace *>
203 |   possiblyParenthesized (deconstruction <|> identifier <|> numberLiteral)
204 |   where
205 |     deconstruction = ADeconstruction <$> pCapitalizedIdent <*> arguments
206 |     arguments = many (try pArgument)
207 |     identifier = AIdentifier <$> pLowerCaseIdent
208 |     numberLiteral = ANumberLiteral <$> Lexer.decimal
209 | 
210 | pLet :: Parser Expression
211 | pLet =
212 |   Let <$> pDeclarations <* symbol "in" <* whiteSpaceWithNewlines <*> parseExpr
213 |   where
214 |     pDeclarations =
215 |       Lexer.indentBlock whiteSpaceWithNewlines parseLetDeclarations
216 |     parseLetDeclarations = do
217 |       _ <- symbol "let"
218 |       return $ Lexer.IndentSome Nothing (return . NE.fromList) declaration
219 | 
220 | identifier :: Parser Expression
221 | identifier = Identifier <$> pIdent
222 | 
223 | topLevelDeclaration :: Parser TopLevel
224 | topLevelDeclaration = do
225 |   _ <- whiteSpaceWithNewlines
226 |   startPos <- getSourcePos
227 |   topLevel <- Lexer.nonIndented whiteSpaceWithNewlines (dataType <|> function)
228 |   endPos <- getSourcePos
229 |   modify (setTopLevelPosition topLevel (startPos, endPos))
230 |   return topLevel
231 | 
232 | dataType :: Parser TopLevel
233 | dataType = DataType <$> (ADT <$> name <*> generics <*> (equals *> constructors))
234 |   where
235 |     name = symbol "data" *> whiteSpace *> pIdent
236 |     equals = (whiteSpaceWithNewlines <|> whiteSpace) *> symbol "="
237 |     constructors =
238 |       (:|) <$> pConstructor <*> otherConstructors <* whiteSpaceWithNewlines
239 |     otherConstructors =
240 |       many
241 |         (try
242 |            (whiteSpaceWithNewlines *> symbol "|" *> whiteSpace *> pConstructor))
243 |     generics = many (whiteSpace *> pIdent)
244 | 
245 | pConstructor :: Parser Constructor
246 | pConstructor =
247 |   Constructor <$> (whiteSpace *> pIdent) <*> maybeParse pConstructorType
248 |   where
249 |     pConstructorType = (parens <|> concrete) >>= applied
250 |     parens = CTParenthesized <$> try (whiteSpace *> parens' pConstructorType)
251 |     concrete = CTConcrete <$> (whiteSpace *> pIdent)
252 |     applied constructorType =
253 |       CTApplied constructorType <$> pConstructorType <|> return constructorType
254 | 
255 | function :: Parser TopLevel
256 | function = Function <$> declaration
257 | 
258 | declaration :: Parser Declaration
259 | declaration = Declaration <$> maybeAnnotation <*> name <*> args <*> expression
260 |   where
261 |     maybeAnnotation = maybeParse annotation
262 |     name = whiteSpace *> pIdent
263 |     args = many (try (whiteSpace *> possiblyParenthesized pArgument))
264 |     expression =
265 |       whiteSpace *> symbol "=" *> whiteSpaceWithNewlines *> parseExpr <*
266 |       whiteSpaceWithNewlines
267 | 
268 | annotation :: Parser Annotation
269 | annotation = Annotation <$> pIdent <*> types
270 |   where
271 |     types = whiteSpace *> symbol "::" *> whiteSpace *> annotationTypes
272 | 
273 | annotationTypes :: Parser (NE.NonEmpty AnnotationType)
274 | annotationTypes =
275 |   (:|) <$> pType <*> many (whiteSpace *> symbol "->" *> pType) <*
276 |   whiteSpaceWithNewlines
277 | 
278 | pType :: Parser AnnotationType
279 | pType = do
280 |   let typeInParens = parens' (Parenthesized <$> annotationTypes)
281 |       concreteType = Concrete <$> pIdent
282 |   parts <- some (try (whiteSpace *> (typeInParens <|> concreteType)))
283 |   return $
284 |     case parts of
285 |       [] -> error "well this can't rightly happen"
286 |       [x] -> x
287 |       xs -> foldl1 TypeApplication xs
288 | 
289 | parseModuleWithLineInformation :: Text -> Either ParseError' (Module, LineInformation)
290 | parseModuleWithLineInformation = parse (runStateT pModule (LineInformation Map.empty Map.empty)) ""
291 |   where
292 |     pModule = Module <$> many topLevelDeclaration <* eof
293 | 
294 | parseModule :: Text -> Either ParseError' Module
295 | parseModule = parse (evalStateT pModule (LineInformation Map.empty Map.empty)) ""
296 |   where
297 |     pModule = Module <$> many topLevelDeclaration <* eof
298 | 
299 | -- Printers
300 | printModule :: Module -> Text
301 | printModule (Module topLevel) = intercalate "\n\n" $ printTopLevel <$> topLevel
302 | 
303 | printTopLevel :: TopLevel -> Text
304 | printTopLevel topLevel =
305 |   case topLevel of
306 |     Function declaration' -> printDeclaration declaration'
307 |     DataType dataType' -> printDataType dataType'
308 | 
309 | printDataType :: ADT -> Text
310 | printDataType (ADT name generics constructors) =
311 |   "data " <> Text.unwords (s <$> name : generics) <> "\n" <>
312 |   indent2
313 |     ("= " <>
314 |      (intercalate "\n| " . NE.toList) (printConstructor <$> constructors))
315 |   where
316 |     printConstructor (Constructor name' types) =
317 |       s name' <> " " <> maybe "" printType types
318 |     printType constructorType =
319 |       case constructorType of
320 |         CTConcrete i -> s i
321 |         CTApplied a b -> printType a <> " " <> printType b
322 |         CTParenthesized constructorType ->
323 |           "(" <> printType constructorType <> ")"
324 | 
325 | printDeclaration :: Declaration -> Text
326 | printDeclaration (Declaration annotation' name args expression) =
327 |   annotationAsString <>
328 |   Text.unwords ([s name] <> (printArgument Parens <$> args) <> ["="]) <>
329 |   "\n" <>
330 |   indent2 (printExpression expression)
331 |   where
332 |     annotationAsString = maybe "" printAnnotation annotation'
333 | 
334 | printAnnotation :: Annotation -> Text
335 | printAnnotation (Annotation name types) =
336 |   s name <> " :: " <> printTypes types <> "\n"
337 |   where
338 |     printTypes types' = intercalate " -> " (NE.toList (printType <$> types'))
339 |     printType annotationType =
340 |       case annotationType of
341 |         Concrete identifier -> s identifier
342 |         Parenthesized types' -> "(" <> printTypes types' <> ")"
343 |         TypeApplication leftType rightType ->
344 |           printType leftType <> " " <> printType rightType
345 | 
346 | printExpression :: Expression -> Text
347 | printExpression expression =
348 |   case expression of
349 |     Number number -> showT number
350 |     Float float -> showT float
351 |     Infix operator leftExpression rightExpression ->
352 |       Text.unwords
353 |         [ printExpression leftExpression
354 |         , operatorToString operator
355 |         , printSecondInfix rightExpression
356 |         ]
357 |     Identifier name -> s name
358 |     Apply leftExpression rightExpression ->
359 |       printExpression leftExpression <> " " <> printExpression rightExpression
360 |     Case caseExpr patterns ->
361 |       if isComplex caseExpr
362 |         then "case\n" <> indent2 (printExpression caseExpr) <> "\nof\n" <>
363 |              indent2 (printPatterns patterns)
364 |         else "case " <> printExpression caseExpr <> " of\n" <>
365 |              indent2 (printPatterns patterns)
366 |     BetweenParens expression ->
367 |       if isComplex expression
368 |         then "(\n" <> indent2 (printExpression expression) <> "\n)"
369 |         else "(" <> printExpression expression <> ")"
370 |     Let declarations expression -> printLet declarations expression
371 |     String' string -> "\"" <> string <> "\""
372 | 
373 | printPatterns :: NonEmpty (Argument, Expression) -> Text
374 | printPatterns patterns = Text.unlines $ NE.toList $ printPattern <$> patterns
375 | 
376 | printPattern :: (Argument, Expression) -> Text
377 | printPattern (argument, resultExpression) =
378 |   printArgument NoParens argument <> " -> " <> printSecondInfix resultExpression
379 | 
380 | printLet :: NonEmpty Declaration -> Expression -> Text
381 | printLet declarations expression =
382 |   intercalate "\n" $
383 |   Prelude.concat
384 |     [ ["let"]
385 |     , indent2 . printDeclaration <$> NE.toList declarations
386 |     , ["in"]
387 |     , [indent2 $ printExpression expression]
388 |     ]
389 | 
390 | data UseParensForDeconstruction
391 |   = NoParens
392 |   | Parens
393 | 
394 | printArgument :: UseParensForDeconstruction -> Argument -> Text
395 | printArgument parens argument =
396 |   case (parens, argument) of
397 |     (_, AIdentifier i) -> s i
398 |     (_, ANumberLiteral t) -> showT t
399 |     (Parens, ADeconstruction ident args) ->
400 |       "(" <> (Text.intercalate " " $ s ident : (printArgument Parens <$> args)) <>
401 |       ")"
402 |     (NoParens, ADeconstruction ident args) ->
403 |       Text.intercalate " " $ s ident : (printArgument Parens <$> args)
404 | 
405 | printSecondInfix :: Expression -> Text
406 | printSecondInfix expression =
407 |   if isComplex expression
408 |     then "\n" <> indent2 (printExpression expression)
409 |     else printExpression expression
410 | 
411 | isComplex :: Expression -> Bool
412 | isComplex expr' =
413 |   case expr' of
414 |     Let {} -> True
415 |     Case {} -> True
416 |     Infix _ leftExpression rightExpression ->
417 |       isComplex leftExpression || isComplex rightExpression
418 |     _ -> False
419 | 
420 | indent :: Int -> Text -> Text
421 | indent level string =
422 |   intercalate "\n" $
423 |   (Text.replicate level " " <>) <$> Text.lines string
424 | 
425 | indent2 :: Text -> Text
426 | indent2 = indent 2
427 | 
428 | operatorToString :: OperatorExpr -> Text
429 | operatorToString operator =
430 |   case operator of
431 |     Add -> "+"
432 |     Subtract -> "-"
433 |     Multiply -> "*"
434 |     Divide -> "/"
435 |     StringAdd -> "++"
436 | 


--------------------------------------------------------------------------------
/src/Language.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | 
  3 | module Language
  4 |   ( NonEmptyString(..)
  5 |   , OperatorExpr(..)
  6 |   , Ident(..)
  7 |   , Expression(..)
  8 |   , Argument(..)
  9 |   , Declaration(..)
 10 |   , Annotation(..)
 11 |   , AnnotationType(..)
 12 |   , Module(..)
 13 |   , Constructor(..)
 14 |   , ConstructorType(..)
 15 |   , TopLevel(..)
 16 |   , ADT(..)
 17 |   , s
 18 |   , idToString
 19 |   , neToString
 20 |   ) where
 21 | 
 22 | import Data.List.NonEmpty (NonEmpty)
 23 | import qualified Data.List.NonEmpty as NE
 24 | import Data.Semigroup ((<>))
 25 | import Data.Text (Text)
 26 | import qualified Data.Text as T
 27 | import qualified Generics.Deriving as G
 28 | 
 29 | newtype Module =
 30 |   Module [TopLevel]
 31 |   deriving (Show, Eq, G.Generic)
 32 | 
 33 | data TopLevel
 34 |   = Function Declaration
 35 |   | DataType ADT
 36 |   deriving (Show, Eq, G.Generic, Ord)
 37 | 
 38 | data ADT =
 39 |   ADT Ident
 40 |       [Ident]
 41 |       (NonEmpty Constructor)
 42 |   deriving (Show, Eq, G.Generic, Ord)
 43 | 
 44 | data Declaration =
 45 |   Declaration (Maybe Annotation)
 46 |               Ident
 47 |               [Argument]
 48 |               Expression
 49 |   deriving (Show, Eq, G.Generic, Ord)
 50 | 
 51 | data Annotation =
 52 |   Annotation Ident
 53 |              (NonEmpty AnnotationType)
 54 |   deriving (Show, Eq, G.Generic, Ord)
 55 | 
 56 | data AnnotationType
 57 |   = Concrete Ident
 58 |   | Parenthesized (NonEmpty AnnotationType)
 59 |   | TypeApplication AnnotationType
 60 |                     AnnotationType
 61 |   deriving (Show, Eq, G.Generic, Ord)
 62 | 
 63 | data Expression
 64 |   = Identifier Ident
 65 |   | Number Int
 66 |   | Float Float
 67 |   | Infix OperatorExpr
 68 |           Expression
 69 |           Expression
 70 |   | Apply Expression
 71 |           Expression
 72 |   | Case Expression
 73 |          (NonEmpty (Argument, Expression))
 74 |   | Let (NonEmpty Declaration)
 75 |         Expression
 76 |   | BetweenParens Expression
 77 |   | String' Text
 78 |   deriving (Show, Eq, G.Generic, Ord)
 79 | 
 80 | data Argument
 81 |   = AIdentifier Ident
 82 |   | ADeconstruction Ident
 83 |                     [Argument]
 84 |   | ANumberLiteral Int
 85 |   deriving (Show, Eq, G.Generic, Ord)
 86 | 
 87 | data Constructor =
 88 |   Constructor Ident
 89 |               (Maybe ConstructorType)
 90 |   deriving (Show, Eq, G.Generic, Ord)
 91 | 
 92 | data ConstructorType
 93 |   = CTConcrete Ident
 94 |   | CTApplied ConstructorType
 95 |               ConstructorType
 96 |   | CTParenthesized ConstructorType
 97 |   deriving (Show, Eq, G.Generic, Ord)
 98 | 
 99 | data OperatorExpr
100 |   = Add
101 |   | Subtract
102 |   | Divide
103 |   | Multiply
104 |   | StringAdd
105 |   deriving (Show, Eq, G.Generic, Ord)
106 | 
107 | newtype Ident =
108 |   Ident NonEmptyString
109 |   deriving (Show, Eq, Ord)
110 | 
111 | data NonEmptyString =
112 |   NonEmptyString Char
113 |                  Text
114 |   deriving (Show, Eq, Ord)
115 | 
116 | s :: Ident -> Text
117 | s = idToString
118 | 
119 | idToString :: Ident -> Text
120 | idToString (Ident str) = neToString str
121 | 
122 | neToString :: NonEmptyString -> Text
123 | neToString (NonEmptyString c t) = T.singleton c <> t
124 | 


--------------------------------------------------------------------------------
/src/TypeChecker.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE LambdaCase #-}
  4 | {-# LANGUAGE TupleSections #-}
  5 | 
  6 | module TypeChecker
  7 |   ( checkModule
  8 |   , checkModuleWithLineInformation
  9 |   , BindingSymbol(..)
 10 |   , ConstructorSymbol(..)
 11 |   , CompileError(..)
 12 |   , Symbol(..)
 13 |   , TypedModule(..)
 14 |   , TypedDeclaration(..)
 15 |   , TypedExpression(..)
 16 |   , TypedArgument(..)
 17 |   , ClosureBinding(..)
 18 |   , typeOf
 19 |   , Type(..)
 20 |   , InvalidConstruct(..)
 21 |   , replaceGenerics
 22 |   , printType
 23 |   , TypeLambda(..)
 24 |   ) where
 25 | 
 26 | import Control.Monad
 27 | import Control.Monad.Except
 28 | import Control.Monad.Trans.Class
 29 | import Control.Monad.Trans.State.Lazy
 30 | import Data.Either
 31 | import qualified Data.Foldable as F
 32 | import Data.Functor.Identity
 33 | import Data.List (find, intercalate)
 34 | import Data.List.NonEmpty (NonEmpty(..), nonEmpty, toList)
 35 | import qualified Data.List.NonEmpty as NE
 36 | import Data.Map.Strict (Map)
 37 | import qualified Data.Map.Strict as Map
 38 | import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 39 | import Data.Semigroup
 40 | import Data.Set (Set)
 41 | import qualified Data.Set as Set
 42 | import Data.Set.Ordered (OSet)
 43 | import qualified Data.Set.Ordered as OSet
 44 | import Data.Text (Text)
 45 | import qualified Data.Text as T
 46 | import Debug.Trace (trace)
 47 | import qualified Generics.Deriving as G
 48 | import Safe
 49 | 
 50 | import HaskellSyntax
 51 | import Language
 52 | 
 53 | showT :: Show a => a -> Text
 54 | showT = T.pack . show
 55 | 
 56 | data CompileError =
 57 |   CompileError InvalidConstruct
 58 |                (Maybe SourceRange)
 59 |                Text
 60 |   deriving (Eq, Show)
 61 | 
 62 | data InvalidConstruct
 63 |   = DeclarationError Declaration
 64 |   | ExpressionError Expression
 65 |   | DataTypeError ADT
 66 |   deriving (Eq, Show)
 67 | 
 68 | data BindingType
 69 |   = Closure
 70 |   | Local
 71 |   deriving (Eq, Show)
 72 | 
 73 | data CompileState = CompileState
 74 |   { errors :: [CompileError]
 75 |   , typeLambdas :: [TypeLambda]
 76 |   , types :: Map Ident Type
 77 |   , typedDeclarations :: [(BindingType, TypedDeclaration)]
 78 |   , typeConstructors :: Map TypeLambda [TypedConstructor]
 79 |   } deriving (Eq, Show)
 80 | 
 81 | data TypedConstructor =
 82 |   TypedConstructor Symbol
 83 |                    Int
 84 |                    [Type]
 85 |   deriving (Eq, Show)
 86 | data Type
 87 |   = Num
 88 |   | Float' -- TODO a better name, perhaps declare in another module? :(
 89 |   | Str
 90 |   | Lambda Type
 91 |            Type
 92 |   | Applied Type
 93 |             Type
 94 |   | Generic Ident
 95 |   | TL TypeLambda
 96 |   deriving (Eq, Show, Ord)
 97 | 
 98 | newtype TypeLambda =
 99 |   TypeLambda Ident
100 |   deriving (Eq, Show, Ord)
101 | 
102 | newtype TypedModule =
103 |   TypedModule [TypedDeclaration]
104 |   deriving (Eq, Show)
105 | 
106 | data ClosureBinding =
107 |   ClosureBinding Symbol
108 |                  Type
109 |   deriving (Show, Eq, G.Generic, Ord)
110 | 
111 | data TypedDeclaration =
112 |   TypedDeclaration Symbol
113 |                    [TypedArgument]
114 |                    (OSet ClosureBinding)
115 |                    Type
116 |                    TypedExpression
117 |   deriving (Show, Eq, G.Generic)
118 | 
119 | data Symbol =
120 |   Symbol Int
121 |          Ident
122 |   deriving (Show, Eq, G.Generic, Ord)
123 | 
124 | data TypedExpression
125 |   = Identifier Type
126 |                Symbol
127 |                (OSet ClosureBinding)
128 |   | Number Int
129 |   | Float Float
130 |   | Infix Type
131 |           OperatorExpr
132 |           TypedExpression
133 |           TypedExpression
134 |   | Apply Type
135 |           TypedExpression
136 |           TypedExpression
137 |   | Case Type
138 |          TypedExpression
139 |          (NE.NonEmpty (TypedArgument, TypedExpression))
140 |   | Let (NE.NonEmpty TypedDeclaration)
141 |         TypedExpression
142 |   | BetweenParens TypedExpression
143 |   | String' Text
144 |   | ADTConstruction Int
145 |                     [TypedArgument]
146 |   deriving (Show, Eq, G.Generic)
147 | 
148 | data TypedArgument
149 |   = TAIdentifier Type
150 |                  Symbol
151 |   | TANumberLiteral Int
152 |   | TADeconstruction BindingSymbol
153 |                      ConstructorSymbol
154 |                      Int
155 |                      [TypedArgument]
156 |   deriving (Show, Eq, G.Generic)
157 | 
158 | newtype ConstructorSymbol =
159 |   ConstructorSymbol Symbol
160 |   deriving (Show, Eq, G.Generic)
161 | 
162 | newtype BindingSymbol =
163 |   BindingSymbol Symbol
164 |   deriving (Show, Eq, G.Generic)
165 | 
166 | data Symbols =
167 |   Symbols Int
168 |           (Map Int Symbol)
169 | 
170 | type CompilationSymbolsT a = ExceptT CompileError (StateT Symbols a)
171 | 
172 | type CompilationSymbols = CompilationSymbolsT Identity
173 | 
174 | type ClosureBindingsT = State (OSet ClosureBinding)
175 | 
176 | type DeclarationCompilation a = CompilationSymbolsT ClosureBindingsT a
177 | 
178 | liftCompilationState :: CompilationSymbols a -> DeclarationCompilation a
179 | liftCompilationState = mapExceptT (mapStateT transform)
180 |   where
181 |     transform ::
182 |          Identity (Either CompileError a, Symbols)
183 |       -> StateT (OSet ClosureBinding) Identity (Either CompileError a, Symbols)
184 |     transform = return . runIdentity
185 | 
186 | runClosureBindings ::
187 |      DeclarationCompilation a -> CompilationSymbols (a, OSet ClosureBinding)
188 | runClosureBindings = mapExceptT (mapStateT f)
189 |   where
190 |     f :: StateT (OSet ClosureBinding) Identity (Either CompileError a, Symbols)
191 |       -> Identity (Either CompileError (a, OSet ClosureBinding), Symbols)
192 |     f s =
193 |       let ((a, symbols), bindings) = runState s OSet.empty
194 |        in return ((, bindings) <$> a, symbols)
195 | 
196 | addClosureBinding :: ClosureBinding -> DeclarationCompilation ()
197 | addClosureBinding cb = lift $ lift $ modify (OSet.>| cb)
198 | 
199 | getSymbol :: Ident -> CompilationSymbols Symbol
200 | getSymbol i = do
201 |   (Symbols id symbolMap) <- lift $ get
202 |   let newId = id + 1
203 |   let symbol = Symbol newId i
204 |   let mapWithInsert = Map.insert newId symbol symbolMap
205 |   lift $ put (Symbols newId mapWithInsert)
206 |   return $ symbol
207 | 
208 | expressionPosition :: LineInformation -> Expression -> Maybe SourceRange
209 | expressionPosition (LineInformation expressionPositions _) expr =
210 |   Map.lookup expr expressionPositions
211 | 
212 | topLevelPosition :: LineInformation -> TopLevel -> Maybe SourceRange
213 | topLevelPosition (LineInformation _ topLevelPositions) topLevel =
214 |   Map.lookup topLevel topLevelPositions
215 | 
216 | addDeclarations :: CompileState -> [TypedDeclaration] -> CompileState
217 | addDeclarations state declarations =
218 |   state
219 |     { typedDeclarations =
220 |         ((Local, ) <$> declarations) <> typedDeclarations state
221 |     }
222 | 
223 | addError :: CompileState -> CompileError -> CompileState
224 | addError state error = state {errors = error : errors state}
225 | 
226 | addErrors :: CompileState -> [CompileError] -> CompileState
227 | addErrors state newErrors = state {errors = newErrors <> errors state}
228 | 
229 | addTypeLambda :: CompileState -> TypeLambda -> CompileState
230 | addTypeLambda state (TypeLambda name) =
231 |   state
232 |     { typeLambdas = TypeLambda name : typeLambdas state
233 |     , types = Map.insert name (TL (TypeLambda name)) (types state)
234 |     }
235 | 
236 | addTypeConstructors ::
237 |      CompileState -> TypeLambda -> [TypedConstructor] -> CompileState
238 | addTypeConstructors state typeLambda constructors =
239 |   state
240 |     { typeConstructors =
241 |         Map.insertWith (++) typeLambda constructors (typeConstructors state)
242 |     }
243 | 
244 | markClosureBoundary :: CompileState -> CompileState
245 | markClosureBoundary state =
246 |   state {typedDeclarations = (Closure, ) <$> (snd <$> typedDeclarations state)}
247 | 
248 | defaultTypes :: Map Ident Type
249 | defaultTypes =
250 |   Map.fromList [(ne "Int", Num), (ne "String", Str), (ne "Float", Float')]
251 | 
252 | checkModuleWithLineInformation ::
253 |      Module
254 |   -> Maybe LineInformation
255 |   -> Either (NonEmpty CompileError) TypedModule
256 | checkModuleWithLineInformation (Module topLevels) possibleLineInformation =
257 |   let initialState :: CompileState
258 |       initialState =
259 |         (CompileState
260 |            { typeLambdas = []
261 |            , errors = []
262 |            , typedDeclarations = []
263 |            , typeConstructors = Map.empty
264 |            , types = defaultTypes
265 |            })
266 |       lineInformation =
267 |         fromMaybe (LineInformation Map.empty Map.empty) possibleLineInformation
268 |       compileState :: CompileState
269 |       compileState =
270 |         let resultWithError =
271 |               foldM (checkTopLevel lineInformation) initialState topLevels
272 |             result =
273 |               evalState (runExceptT resultWithError) (Symbols 0 Map.empty)
274 |          in case result of
275 |               Right a -> a
276 |               Left e -> error $ "Encountered a problem compiling: " <> show e
277 |       possibleErrors :: Maybe (NonEmpty CompileError)
278 |       possibleErrors = nonEmpty $ errors compileState
279 |    in case possibleErrors of
280 |         Just errors -> Left errors
281 |         Nothing -> Right (TypedModule (snd <$> typedDeclarations compileState))
282 | 
283 | checkModule :: Module -> Either (NonEmpty CompileError) TypedModule
284 | checkModule m = checkModuleWithLineInformation m Nothing
285 | 
286 | -- TODO - make this function a bit easier to read
287 | checkDataType ::
288 |      CompileState -> ADT -> Maybe SourceRange -> CompilationSymbols CompileState
289 | checkDataType state adt@(ADT name generics constructors) position = do
290 |   (typedCtors, typedDecls, errors) <- result
291 |   case errors of
292 |     [] ->
293 |       let state' = addTypeLambda state typeLambda
294 |           state'' = addDeclarations state' typedDecls
295 |           state''' = addTypeConstructors state'' typeLambda typedCtors
296 |        in return state'''
297 |     _ -> return $ addErrors state errors
298 |   where
299 |     result = process (NE.toList constructors) 0 [] [] []
300 |     process ::
301 |          [Constructor]
302 |       -> Int
303 |       -> [TypedConstructor]
304 |       -> [TypedDeclaration]
305 |       -> [CompileError]
306 |       -> CompilationSymbols ( [TypedConstructor]
307 |                             , [TypedDeclaration]
308 |                             , [CompileError])
309 |     process ctors i typedCtors typedDecls errors =
310 |       case ctors of
311 |         x@(Constructor name _):xs ->
312 |           let doWork = do
313 |                 symbol <- getSymbol name
314 |                 constructor <- makeTypeConstructor (i, x, symbol)
315 |                 declaration <- makeDeclaration (i, x, symbol)
316 |                 process
317 |                   xs
318 |                   (i + 1)
319 |                   (typedCtors <> [constructor])
320 |                   (typedDecls <> [declaration])
321 |                   errors
322 |               handler e =
323 |                 process xs (i + 1) typedCtors typedDecls (errors <> [e])
324 |            in doWork `catchError` handler
325 |         [] -> return (typedCtors, typedDecls, errors)
326 |     typeLambda = TypeLambda name
327 |     returnType = foldl Applied (TL typeLambda) (Generic <$> generics)
328 |     makeDeclaration ::
329 |          (Int, Constructor, Symbol) -> CompilationSymbols TypedDeclaration
330 |     makeDeclaration (tag, (Constructor _ types'), symbol) =
331 |       let charToArgument :: (Char, Type) -> CompilationSymbols TypedArgument
332 |           charToArgument (char, argType) = do
333 |             symbol <- getSymbol (ne $ T.singleton char)
334 |             lift $ return $ TAIdentifier argType symbol
335 |           argList :: CompilationSymbols [Type]
336 |           argList = maybe (return []) constructorTypes types'
337 |           argsWithTypes :: CompilationSymbols [(Char, Type)]
338 |           argsWithTypes = (zip ['a' ..] <$> argList)
339 |           arguments :: CompilationSymbols [TypedArgument]
340 |           arguments = do
341 |             a <- argsWithTypes
342 |             sequence $ charToArgument <$> a
343 |           declarationFromType :: Type -> [TypedArgument] -> TypedDeclaration
344 |           declarationFromType t typedArgument =
345 |             TypedDeclaration
346 |               symbol
347 |               typedArgument
348 |               OSet.empty
349 |               t
350 |               (TypeChecker.ADTConstruction tag typedArgument)
351 |           rType :: CompilationSymbols Type
352 |           rType = (maybe (return returnType) constructorType types')
353 |        in declarationFromType <$> rType <*> arguments
354 |     makeTypeConstructor ::
355 |          (Int, Constructor, Symbol) -> CompilationSymbols TypedConstructor
356 |     makeTypeConstructor (tag, (Constructor _ types), symbol) =
357 |       TypedConstructor symbol tag <$> (maybe (return []) constructorTypes types)
358 |     constructorType :: ConstructorType -> CompilationSymbols Type
359 |     constructorType ct = foldr Lambda returnType <$> (constructorTypes ct)
360 |     errorMessage = CompileError (DataTypeError adt) position
361 |     constructorTypes :: ConstructorType -> CompilationSymbols [Type]
362 |     constructorTypes ct =
363 |       case ct of
364 |         CTConcrete identifier ->
365 |           (\x -> [x]) <$>
366 |           findTypeFromIdent
367 |             ((Map.insert name returnType) $ types state)
368 |             errorMessage
369 |             identifier
370 |         CTParenthesized (CTApplied (CTConcrete a) (CTConcrete b)) ->
371 |           return [Applied (TL (TypeLambda a)) (Generic b)]
372 |         CTParenthesized ct -> constructorTypes ct
373 |         CTApplied a b -> do
374 |           (<>) <$> constructorTypes a <*> constructorTypes b
375 | 
376 | checkTopLevel ::
377 |      LineInformation
378 |   -> CompileState
379 |   -> TopLevel
380 |   -> CompilationSymbols CompileState
381 | checkTopLevel lineInformation state topLevel =
382 |   case topLevel of
383 |     DataType adt -> checkDataType state adt position
384 |     Function declaration -> (checkFunc declaration) `catchError` handler
385 |   where
386 |     checkFunc :: Declaration -> CompilationSymbols CompileState
387 |     checkFunc declaration = do
388 |       result <- checkDeclaration state declaration position exprPosition
389 |       return $ addDeclarations state [result]
390 |     handler e = return $ addError state e
391 |     position = topLevelPosition lineInformation topLevel
392 |     exprPosition = expressionPosition lineInformation
393 | 
394 | newtype Constraints =
395 |   Constraints (Map Ident Type)
396 |   deriving (Eq, Show)
397 | 
398 | typeEq :: Type -> Type -> Bool
399 | typeEq a b =
400 |   case typeConstraints a b of
401 |     Just _ -> True
402 |     _ -> False
403 | 
404 | mergePossibleConstraints :: [Maybe Constraints] -> Maybe Constraints
405 | mergePossibleConstraints mConstraints =
406 |   case mConstraints of
407 |     [] -> Just (Constraints Map.empty)
408 |     (Nothing:_) -> Nothing
409 |     (Just constraints:xs) ->
410 |       mergeConstraints constraints <$> mergePossibleConstraints xs
411 | 
412 | mergeConstraints :: Constraints -> Constraints -> Constraints
413 | mergeConstraints (Constraints a) (Constraints b) = Constraints (Map.union a b) -- TODO handle clashes
414 | 
415 | -- you can't treat type a like an int
416 | -- but you can call a function that accepts type a with an int,
417 | -- as long as a is replaced with int in the interpretation of the type of that function
418 | --
419 | -- the rules for application differ from return type checking
420 | --
421 | -- for application, if we have a lambda with a generic value, we should replace that generic with our concrete value on the right
422 | -- for return type checking, we need to be able to understand that we cannot coerce an "a" to a "b"
423 | -- but that we can coerce a "Nothing :: Maybe a" to "Just 5 :: Maybe Int"
424 | --
425 | -- this is possible because the type of Nothing is really forall a. :: Maybe a
426 | -- typeConstraints is currentypeLambday used for both but that's a bad idea, it's only really good at application
427 | typeConstraints :: Type -> Type -> Maybe Constraints
428 | typeConstraints a b =
429 |   case (a, b) of
430 |     (Generic a', _) -> Just (Constraints (Map.insert a' b Map.empty))
431 |     (Applied (TL a') t', Applied (TL b') (Generic g)) ->
432 |       if a' == b'
433 |         then Just (Constraints (Map.insert g t' Map.empty))
434 |         else Nothing
435 |     (Applied a b, Applied a' b') ->
436 |       mergePossibleConstraints [typeConstraints a a', typeConstraints b b']
437 |     (Lambda a b, Lambda x y) ->
438 |       mergePossibleConstraints [typeConstraints a x, typeConstraints b y]
439 |     (a', b') ->
440 |       if a' == b'
441 |         then Just (Constraints Map.empty)
442 |         else Nothing
443 | 
444 | checkDeclaration ::
445 |      CompileState
446 |   -> Declaration
447 |   -> Maybe SourceRange
448 |   -> (Expression -> Maybe SourceRange)
449 |   -> CompilationSymbols TypedDeclaration
450 | checkDeclaration state declaration position exprPosition = do
451 |   let (Declaration _ name args expr) = declaration
452 |   symbol <- getSymbol name
453 |   annotationTypes <- inferDeclarationType state declaration position
454 |   -- TODO - is sequence right here?
455 |   argsWithTypes <-
456 |     sequence $
457 |     uncurry (inferArgumentType state compileError) <$>
458 |     zip (NE.toList annotationTypes) args
459 |   let locals = concatMap makeDeclarations argsWithTypes
460 |   expectedReturnType <-
461 |     (case (NE.drop (length args) annotationTypes) of
462 |        (x:xs) -> return $ collapseTypes (x :| xs)
463 |        _ -> throwError $ compileError "Not enough args") -- TODO - could be too many?
464 |   let typedDeclaration =
465 |         TypedDeclaration
466 |           symbol
467 |           argsWithTypes
468 |           OSet.empty
469 |           (foldr1 Lambda annotationTypes)
470 |           (TypeChecker.Number 0)
471 |   let actualReturnType =
472 |         inferType
473 |           (addDeclarations state (typedDeclaration : locals))
474 |           expr
475 |           exprPosition
476 |   let typeChecks ::
477 |            (TypedExpression, OSet ClosureBinding)
478 |         -> CompilationSymbols TypedDeclaration
479 |       typeChecks (typedExpression, closureBindings) =
480 |         if typeOf typedExpression `typeEq` expectedReturnType -- TODO use typeConstraints here
481 |           then return $
482 |                TypedDeclaration
483 |                  symbol
484 |                  argsWithTypes
485 |                  closureBindings
486 |                  (foldr1 Lambda annotationTypes)
487 |                  typedExpression
488 |           else throwError $
489 |                compileError
490 |                  ("Expected " <> s name <> " to return type " <>
491 |                   printType expectedReturnType <>
492 |                   ", but instead got type " <>
493 |                   printType (typeOf typedExpression))
494 |   (runClosureBindings actualReturnType) >>= typeChecks
495 |   where
496 |     compileError = CompileError (DeclarationError declaration) position
497 |     makeDeclarations :: TypedArgument -> [TypedDeclaration]
498 |     makeDeclarations typedArgument =
499 |       case typedArgument of
500 |         TAIdentifier t i -> [makeDeclaration t i]
501 |         TADeconstruction _ (ConstructorSymbol constructor) _ args ->
502 |           let declaration = find m (concat . Map.elems $ typeConstructors state)
503 |               m (TypedConstructor name _ _) = name == constructor -- TODO - should probably match on types as well!
504 |               declarations (TypedConstructor _ _ _) =
505 |                 concatMap makeDeclarations $ args
506 |            in maybe [] declarations declaration
507 |         TANumberLiteral _ -> []
508 |     makeDeclaration :: Type -> Symbol -> TypedDeclaration
509 |     makeDeclaration t i =
510 |       TypedDeclaration i [] OSet.empty t (TypeChecker.Identifier t i OSet.empty)
511 | 
512 | lambdaType :: Type -> Type -> [Type] -> Type
513 | lambdaType left right remainder =
514 |   case remainder of
515 |     [] -> Lambda left right
516 |     (x:xs) -> Lambda left (lambdaType right x xs)
517 | 
518 | typeOf :: TypedExpression -> Type
519 | typeOf t =
520 |   case t of
521 |     TypeChecker.Identifier t _ _ -> t
522 |     TypeChecker.Apply t _ _ -> t
523 |     TypeChecker.Number _ -> Num
524 |     TypeChecker.Float _ -> Float'
525 |     TypeChecker.Infix t _ _ _ -> t
526 |     TypeChecker.Case t _ _ -> t
527 |     TypeChecker.Let _ te -> typeOf te
528 |     TypeChecker.BetweenParens te -> typeOf te
529 |     TypeChecker.String' _ -> Str
530 |     TypeChecker.ADTConstruction _ _ -> Lambda Num Num -- TODO - make this real
531 | 
532 | inferApplicationType ::
533 |      CompileState
534 |   -> Expression
535 |   -> Expression
536 |   -> (Expression -> Maybe SourceRange)
537 |   -> (Text -> CompileError)
538 |   -> DeclarationCompilation TypedExpression
539 | inferApplicationType state a b exprPosition compileError =
540 |   let typedExprs =
541 |         (,) <$> inferType state a exprPosition <*>
542 |         inferType state b exprPosition
543 |       inferApplication ::
544 |            (TypedExpression, TypedExpression)
545 |         -> DeclarationCompilation TypedExpression
546 |       inferApplication (a, b) =
547 |         case (typeOf a, typeOf b) of
548 |           (Lambda x r, b') ->
549 |             case typeConstraints x b' of
550 |               Just constraints ->
551 |                 return
552 |                   (TypeChecker.Apply (replaceGenerics constraints r) a b)
553 |               Nothing ->
554 |                 throwError $
555 |                 compileError
556 |                   ("Function expected argument of type " <> printType x <>
557 |                    ", but instead got argument of type " <>
558 |                    printType b')
559 |           _ ->
560 |             throwError $
561 |             compileError $
562 |             "Tried to apply a value of type " <> printType (typeOf a) <>
563 |             " to a value of type " <>
564 |             printType (typeOf b)
565 |    in typedExprs >>= inferApplication
566 | 
567 | inferIdentifierType ::
568 |      CompileState
569 |   -> Ident
570 |   -> (Text -> CompileError)
571 |   -> DeclarationCompilation TypedExpression
572 | inferIdentifierType state name compileError =
573 |   case find (m name) declarations of
574 |     Just (Closure, TypedDeclaration s _ bindings t _) -> do
575 |       _ <- addClosureBinding $ ClosureBinding s t
576 |       _ <- sequence_ $ addClosureBinding <$> OSet.toAscList bindings
577 |       return $ TypeChecker.Identifier t s bindings
578 |     Just (_, TypedDeclaration s _ bindings t _) -> do
579 |       _ <- sequence_ $ addClosureBinding <$> OSet.toAscList bindings
580 |       return $ TypeChecker.Identifier t s bindings
581 |     Nothing ->
582 |       throwError $
583 |       compileError
584 |         ("It's not clear what \"" <> idToString name <> "\" refers to")
585 |   where
586 |     declarations = typedDeclarations state
587 |     m name (_, TypedDeclaration (Symbol _ name') _ _ _ _) = name == name'
588 | 
589 | inferInfixType ::
590 |      CompileState
591 |   -> OperatorExpr
592 |   -> Expression
593 |   -> Expression
594 |   -> (Expression -> Maybe SourceRange)
595 |   -> (Text -> CompileError)
596 |   -> DeclarationCompilation TypedExpression
597 | inferInfixType state op a b exprPosition compileError =
598 |   let validInfix a b =
599 |         case (op, b, typeEq a b) of
600 |           (StringAdd, Str, True) -> Just Str
601 |           (StringAdd, _, _) -> Nothing
602 |           (_, Num, True) -> Just Num
603 |           (_, Float', True) -> Just Float'
604 |           (_, _, _) -> Nothing
605 |       types =
606 |         (,) <$> inferType state a exprPosition <*>
607 |         inferType state b exprPosition
608 |       checkInfix ::
609 |            (TypedExpression, TypedExpression)
610 |         -> DeclarationCompilation TypedExpression
611 |       checkInfix (a, b) =
612 |         case validInfix (typeOf a) (typeOf b) of
613 |           Just returnType -> return $ (TypeChecker.Infix returnType op a b)
614 |           Nothing ->
615 |             throwError $
616 |             compileError
617 |               ("No function exists with type " <> printType (typeOf a) <> " " <>
618 |                operatorToString op <>
619 |                " " <>
620 |                printType (typeOf b))
621 |    in types >>= checkInfix
622 | 
623 | inferCaseType ::
624 |      CompileState
625 |   -> Expression
626 |   -> (NonEmpty (Argument, Expression))
627 |   -> (Expression -> Maybe SourceRange)
628 |   -> (Text -> CompileError)
629 |   -> DeclarationCompilation TypedExpression
630 | inferCaseType state value branches exprPosition compileError = do
631 |   typedValue <- inferType state value exprPosition
632 |   typedBranches <- sequence $ inferBranch typedValue <$> branches
633 |   allBranchesHaveSameType typedValue typedBranches
634 |   where
635 |     inferBranch v (a, b) = do
636 |       a' <-
637 |         liftCompilationState $ inferArgumentType state compileError (typeOf v) a
638 |       let argDeclarations = declarationsFromTypedArgument a'
639 |       b' <- inferType (addDeclarations state argDeclarations) b exprPosition
640 |       return (a', b')
641 |     allBranchesHaveSameType ::
642 |          TypedExpression
643 |       -> NonEmpty (TypedArgument, TypedExpression)
644 |       -> DeclarationCompilation TypedExpression
645 |     allBranchesHaveSameType value types =
646 |       case NE.groupWith (typeOf . snd) types of
647 |         [x] -> return (TypeChecker.Case (typeOf . snd $ NE.head x) value types)
648 |         -- TODO - there is a bug where we consider Result a b to be equal to Result c d,
649 |         --        failing to recognize the importance of whether a and b have been bound in the signature
650 |         types' ->
651 |           if all
652 |                (\case
653 |                   (x:y:_) -> x `typeEq` y || y `typeEq` x
654 |                   _ -> False)
655 |                (F.toList <$> replicateM 2 (typeOf . snd . NE.head <$> types'))
656 |             then return $
657 |                  (TypeChecker.Case
658 |                     (typeOf . snd $ NE.head (head types'))
659 |                     value
660 |                     types)
661 |             else throwError $
662 |                  compileError
663 |                    ("Case expression has multiple return types: " <>
664 |                     T.intercalate
665 |                       ", "
666 |                       (printType <$> NE.toList (typeOf . snd <$> types)))
667 | 
668 | inferLetType ::
669 |      CompileState
670 |   -> NonEmpty Declaration
671 |   -> Expression
672 |   -> (Expression -> Maybe SourceRange)
673 |   -> (Text -> CompileError)
674 |   -> DeclarationCompilation TypedExpression
675 | inferLetType state declarations' value exprPosition _ =
676 |   let branchTypes ::
677 |            [TypedDeclaration]
678 |         -> [Declaration]
679 |         -> CompilationSymbols [TypedDeclaration]
680 |       branchTypes typed untyped =
681 |         case untyped of
682 |           [] -> return []
683 |           (x:xs) ->
684 |             let concatBranchTypes t = (:) t <$> branchTypes (typed ++ [t]) xs
685 |                 inferBranchType =
686 |                   checkDeclaration
687 |                     (markClosureBoundary (addDeclarations state typed))
688 |                     x
689 |                     Nothing
690 |                     exprPosition
691 |              in inferBranchType >>= concatBranchTypes
692 |       types :: DeclarationCompilation [TypedDeclaration]
693 |       types = liftCompilationState $ branchTypes [] (NE.toList declarations')
694 |       expression :: [TypedDeclaration] -> DeclarationCompilation TypedExpression
695 |       expression b =
696 |         (TypeChecker.Let (NE.fromList b) <$>
697 |          inferType (addDeclarations state b) value exprPosition)
698 |    in types >>= expression
699 | 
700 | inferType ::
701 |      CompileState
702 |   -> Expression
703 |   -> (Expression -> Maybe SourceRange)
704 |   -> CompilationSymbolsT ClosureBindingsT TypedExpression
705 | inferType state expr exprPosition =
706 |   case expr of
707 |     Language.Number n -> return $ TypeChecker.Number n
708 |     Language.Float f -> return $ TypeChecker.Float f
709 |     Language.String' s -> return $ TypeChecker.String' s
710 |     Language.BetweenParens expr -> inferType state expr exprPosition
711 |     Language.Identifier name -> inferIdentifierType state name compileError
712 |     Language.Apply a b ->
713 |       inferApplicationType state a b exprPosition compileError
714 |     Language.Infix op a b ->
715 |       inferInfixType state op a b exprPosition compileError
716 |     Language.Case value branches ->
717 |       inferCaseType state value branches exprPosition compileError
718 |     Language.Let declarations' value ->
719 |       inferLetType state declarations' value exprPosition compileError
720 |   where
721 |     compileError = CompileError (ExpressionError expr) (exprPosition expr)
722 | 
723 | inferArgumentType ::
724 |      CompileState
725 |   -> (Text -> CompileError)
726 |   -> Type
727 |   -> Argument
728 |   -> CompilationSymbols TypedArgument
729 | inferArgumentType state err valueType arg =
730 |   case arg of
731 |     AIdentifier i -> do
732 |       symbol <- getSymbol i
733 |       return $ TAIdentifier valueType symbol
734 |     ANumberLiteral i ->
735 |       if valueType == Num
736 |         then return $ TANumberLiteral i
737 |         else throwError $
738 |              err $
739 |              "case branch is type Int when value is type " <>
740 |              printType valueType
741 |     ADeconstruction name args ->
742 |       let typeLambdaName v =
743 |             case v of
744 |               TL (TypeLambda i) -> Just i
745 |               Applied (TL (TypeLambda i)) _ -> Just i
746 |               Applied a _ -> typeLambdaName a
747 |               _ -> Nothing
748 |           typeLambda =
749 |             typeLambdaName valueType >>=
750 |             (\typeLambdaName ->
751 |                find
752 |                  (\(TypeLambda name') -> typeLambdaName == name')
753 |                  (typeLambdas state))
754 |           constructorsForValue =
755 |             typeLambda >>= flip Map.lookup (typeConstructors state)
756 |           matchingConstructor =
757 |             find (m name) (fromMaybe [] constructorsForValue)
758 |           m name (TypedConstructor (Symbol _ name') _ _) = name == name'
759 |           deconstructionFields fields =
760 |             sequence $
761 |             (\(a, t) -> inferArgumentType state err t a) <$> zip args fields
762 |        in case matchingConstructor of
763 |             Just (TypedConstructor ctSymbol@(Symbol _ name) tag fields) -> do
764 |               symbol <- BindingSymbol <$> getSymbol name
765 |               if length args == length fields
766 |                 then TADeconstruction symbol (ConstructorSymbol ctSymbol) tag <$>
767 |                      deconstructionFields fields
768 |                 else throwError $
769 |                      err $
770 |                      "Expected " <> s name <> " to have " <> showT (fields) <>
771 |                      " fields, instead found " <>
772 |                      showT (args) <>
773 |                      " arg: " <>
774 |                      showT (arg)
775 |                      -- TODO - make this error message prettier
776 |             Nothing ->
777 |               throwError $
778 |               err $
779 |               "no constructor named \"" <> s name <> "\" for " <>
780 |               printType valueType <>
781 |               " in scope."
782 | 
783 | inferDeclarationType ::
784 |      CompileState
785 |   -> Declaration
786 |   -> Maybe SourceRange
787 |   -> CompilationSymbols (NE.NonEmpty Type)
788 | inferDeclarationType state declaration lineInformation =
789 |   case annotation of
790 |     Just (Annotation _ types) -> sequence $ annotationTypeToType <$> types
791 |     Nothing -> throwError $ compileError "For now, annotations are required."
792 |   where
793 |     (Declaration annotation _ _ _) = declaration
794 |     compileError :: Text -> CompileError
795 |     compileError = CompileError (DeclarationError declaration) lineInformation
796 |     annotationTypeToType :: AnnotationType -> CompilationSymbols Type
797 |     annotationTypeToType t =
798 |       case t of
799 |         Concrete i -> findTypeFromIdent (types state) compileError i
800 |         Parenthesized types -> reduceTypes types
801 |         TypeApplication a b -> inferTypeApplication a b
802 |       where
803 |         m name (TypeLambda name') = name == name'
804 |         inferTypeApplication ::
805 |              AnnotationType -> AnnotationType -> CompilationSymbols Type
806 |         inferTypeApplication a b =
807 |           case a of
808 |             Concrete i ->
809 |               case find (m i) (typeLambdas state) of
810 |                 Just typeLambda ->
811 |                   Applied (TL typeLambda) <$> annotationTypeToType b
812 |                 Nothing ->
813 |                   throwError $
814 |                   compileError $ "Could not find type lambda: " <> idToString i
815 |             Parenthesized a' ->
816 |               Applied <$> reduceTypes a' <*> annotationTypeToType b
817 |             TypeApplication a' b' ->
818 |               Applied <$> inferTypeApplication a' b' <*> annotationTypeToType b
819 |     reduceTypes :: NE.NonEmpty AnnotationType -> CompilationSymbols Type
820 |     reduceTypes types =
821 |       collapseTypes <$> sequence (annotationTypeToType <$> types)
822 | 
823 | collapseTypes :: NE.NonEmpty Type -> Type
824 | collapseTypes = foldr1 Lambda
825 | 
826 | declarationsFromTypedArgument :: TypedArgument -> [TypedDeclaration]
827 | declarationsFromTypedArgument ta =
828 |   case ta of
829 |     TAIdentifier t n -> [TypedDeclaration n [] OSet.empty t (TypeChecker.Number 0)]
830 |     TANumberLiteral _ -> []
831 |     TADeconstruction _ _ _ args -> concatMap declarationsFromTypedArgument args
832 | 
833 | findTypeFromIdent ::
834 |      Map Ident Type
835 |   -> (Text -> CompileError)
836 |   -> Ident
837 |   -> CompilationSymbols Type
838 | findTypeFromIdent types compileError ident =
839 |   if T.toLower i == i
840 |     then return $ Generic ident
841 |     else case Map.lookup ident types of
842 |            Just t -> return t
843 |            Nothing ->
844 |              throwError $
845 |              compileError $ "Could not find type " <> s ident <> "."
846 |   where
847 |     i = s ident
848 | 
849 | printType :: Type -> Text
850 | printType t =
851 |   case t of
852 |     Str -> "String"
853 |     Num -> "Int"
854 |     Float' -> "Float"
855 |     Lambda a r -> printType a <> " -> " <> printType r
856 |     Applied a b -> printType a <> " " <> printType b
857 |     Generic n -> idToString n
858 |     TL (TypeLambda typeLambda) -> idToString typeLambda
859 | 
860 | printSignature :: [Type] -> Text
861 | printSignature types = T.intercalate " -> " (printType <$> types)
862 | 
863 | mapType :: (Type -> Type) -> Type -> Type
864 | mapType f t =
865 |   case t of
866 |     Num -> f t
867 |     Float' -> f t
868 |     Str -> f t
869 |     Lambda a b -> f (Lambda (mapType f a) (mapType f b))
870 |     Applied typeLambda t -> f (Applied typeLambda (mapType f t))
871 |     Generic _ -> f t
872 |     TL _ -> f t
873 | 
874 | replaceGenerics :: Constraints -> Type -> Type
875 | replaceGenerics (Constraints constraints) t =
876 |   Map.foldrWithKey replaceGeneric t constraints
877 | 
878 | replaceGeneric :: Ident -> Type -> Type -> Type
879 | replaceGeneric name newType =
880 |   mapType
881 |     (\case
882 |        Generic n
883 |          | n == name -> newType
884 |        other -> other)
885 | 
886 | ne :: Text -> Ident
887 | ne s = Ident $ NonEmptyString (T.head s) (T.tail s)
888 | 
889 | symbolToText :: Symbol -> Text
890 | symbolToText (Symbol _ i) = s i
891 | 


--------------------------------------------------------------------------------
/src/Wasm.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE DeriveGeneric #-}
  3 | {-# LANGUAGE OverloadedLists #-}
  4 | {-# LANGUAGE TupleSections #-}
  5 | {-# LANGUAGE QuasiQuotes #-}
  6 | 
  7 | module Wasm
  8 |   ( Expression(..)
  9 |   , Module(..)
 10 |   , WasmType(..)
 11 |   , Declaration(..)
 12 |   , TopLevel(..)
 13 |   , UniqueLocals(..)
 14 |   , printWasm
 15 |   , forestModuleToWasm
 16 |   , assignments
 17 |   , ident
 18 |   ) where
 19 | 
 20 | import qualified Language as F
 21 | 
 22 | import Control.Arrow ((***))
 23 | import Control.Monad
 24 | import Control.Monad.Trans.Class
 25 | import Control.Monad.Trans.State.Lazy
 26 | import Data.Char
 27 | import Data.List (intercalate)
 28 | import qualified Data.List.NonEmpty as NE
 29 | import Data.List.NonEmpty (NonEmpty((:|)))
 30 | import Data.Map (Map)
 31 | import qualified Data.Map as Map
 32 | import Data.Maybe
 33 | import Data.Semigroup ((<>))
 34 | import Data.Set (Set)
 35 | import qualified Data.Set as Set
 36 | import Data.Set.Ordered (OSet)
 37 | import qualified Data.Set.Ordered as OSet
 38 | import Data.Text (Text)
 39 | import qualified Data.Text as Text
 40 | import qualified Generics.Deriving as G
 41 | import Text.RawString.QQ
 42 | 
 43 | import TypeChecker
 44 | import qualified TypeChecker as T
 45 | 
 46 | type BytesAllocated = Int
 47 | 
 48 | data Module =
 49 |   Module [TopLevel]
 50 |          BytesAllocated
 51 |   deriving (Show, Eq)
 52 | 
 53 | data WasmType
 54 |   = I32
 55 |   | F32
 56 |   deriving (Show, Eq, G.Generic)
 57 | 
 58 | data Declaration =
 59 |   Declaration F.Ident
 60 |               [(F.Ident, WasmType)]
 61 |               WasmType
 62 |               Expression
 63 |   deriving (Show, Eq, G.Generic)
 64 | 
 65 | data TopLevel
 66 |   = Func Declaration
 67 |   | Data Int
 68 |          Text
 69 |   deriving (Show, Eq)
 70 | 
 71 | data Expression
 72 |   = Const Int
 73 |   | FloatConst Float
 74 |   | GetLocal F.Ident
 75 |   | SetLocal F.Ident
 76 |              WasmType
 77 |              Expression
 78 |   | TeeLocal F.Ident
 79 |              WasmType
 80 |              Expression
 81 |   | Call F.Ident
 82 |          [Expression]
 83 |   | NamedCall F.Ident
 84 |               [Expression]
 85 |   | If Expression
 86 |        Expression
 87 |        (Maybe Expression)
 88 |   | Block WasmType
 89 |           (NE.NonEmpty Expression)
 90 |   | Sequence (NE.NonEmpty Expression)
 91 |   deriving (Show, Eq)
 92 | 
 93 | newtype Locals =
 94 |   Locals (Set F.Ident)
 95 | 
 96 | newtype UniqueLocals =
 97 |   UniqueLocals (Map F.Ident Int)
 98 | 
 99 | type CompileState = State Module
100 | 
101 | type DeclarationCompileState = StateT UniqueLocals CompileState
102 | 
103 | noLocals :: Locals
104 | noLocals = Locals Set.empty
105 | 
106 | addLocal :: F.Ident -> Locals -> Locals
107 | addLocal i (Locals l) = Locals (Set.insert i l)
108 | 
109 | addLocals :: [F.Ident] -> Locals -> Locals
110 | addLocals is (Locals l) = Locals (Set.union l (Set.fromList is))
111 | 
112 | mergeLocals :: Locals -> Locals -> Locals
113 | mergeLocals (Locals a) (Locals b) = Locals (Set.union a b)
114 | 
115 | showT :: Show a => a -> Text
116 | showT = Text.pack . show
117 | 
118 | -- TODO - malloc could probably be better
119 | prelude :: BytesAllocated -> Text
120 | prelude bytesAllocated =
121 |   let freeBlock =
122 |         ("(global $freeblock (mut i32) (i32.const " <> showT bytesAllocated <>
123 |          "))\n\n")
124 |    in freeBlock <>
125 |       [r|
126 | 
127 | (export "malloc" (func $malloc))
128 | (func $malloc (param $size i32) (result i32)
129 |   (local $address i32)
130 |   (set_local $address (get_global $freeblock))
131 |   (set_global $freeblock (i32.add (get_local $address) (get_local $size)))
132 |   (return (get_local $address))
133 | )
134 | 
135 | (func $string_copy (param $from i32) (param $to i32) (result i32)
136 |   (local $index i32)
137 |   (local $size i32)
138 | 
139 |   (set_local $index (i32.const 1))
140 |   (set_local $size (i32.load8_u (get_local $from)))
141 | 
142 |   (loop $copy
143 |     (i32.store8
144 |       (i32.add (get_local $to) (get_local $index))
145 |       (i32.load8_u (i32.add (get_local $from) (get_local $index)))
146 |     )
147 |     (set_local $index (i32.add (get_local $index) (i32.const 1)))
148 |     (br_if $copy (i32.lt_s (get_local $index) (get_local $size)))
149 |   )
150 | 
151 |   (return (get_local $size))
152 | )
153 | 
154 | (func $string_add (param $a i32) (param $b i32) (result i32)
155 |   (local $sum i32)
156 |   (local $aSize i32)
157 |   (local $newStr i32)
158 |   (return
159 |     (set_local $aSize (i32.load8_u (get_local $a)))
160 |     (set_local $sum
161 |       (i32.sub
162 |         (i32.add
163 |           (get_local $aSize)
164 |           (i32.load8_u (get_local $b))
165 |         )
166 |         (i32.const 1)
167 |       )
168 |     )
169 |     (set_local $newStr (call $malloc (i32.add (get_local $sum) (i32.const 1))))
170 |     (i32.store8 (get_local $newStr) (get_local $sum))
171 |     (call $string_copy (get_local $a) (get_local $newStr))
172 |     (call $string_copy (get_local $b) (i32.sub (i32.add (get_local $newStr) (get_local $aSize)) (i32.const 1)))
173 |     (get_local $newStr)
174 |   )
175 | )
176 | |]
177 | 
178 | indent :: Int -> Text -> Text
179 | indent level str =
180 |   Text.intercalate "\n" $
181 |   fmap (\line -> Text.replicate level " " <> line) (Text.lines str)
182 | 
183 | indent2 :: Text -> Text
184 | indent2 = indent 2
185 | 
186 | forestModuleToWasm :: TypedModule -> Module
187 | forestModuleToWasm (TypedModule topLevel) =
188 |   execState (sequence $ compileDeclaration <$> topLevel) initModule
189 |   where
190 |     initModule = Module [] 0
191 | 
192 | getAddress :: CompileState BytesAllocated
193 | getAddress = gets bytesAllocated
194 |   where
195 |     bytesAllocated (Module _ bytes) = bytes
196 | 
197 | addTopLevel :: [TopLevel] -> CompileState ()
198 | addTopLevel newTopLevel = modify transform
199 |   where
200 |     transform (Module topLevel bytes) = Module (topLevel <> newTopLevel) bytes
201 | 
202 | allocateBytes :: Int -> CompileState ()
203 | allocateBytes i = modify transform
204 |   where
205 |     transform (Module topLevel bytes) = Module topLevel (bytes + i)
206 | 
207 | closureArgs :: OSet ClosureBinding -> [(F.Ident, WasmType)]
208 | closureArgs bindings = mapMaybe closureArg $ OSet.toAscList bindings
209 | 
210 | closureArg :: ClosureBinding -> Maybe (F.Ident, WasmType)
211 | closureArg (T.ClosureBinding _ (T.Lambda _ _)) = Nothing
212 | closureArg (T.ClosureBinding symbol fType) =
213 |   Just (symbolToIdent symbol, forestTypeToWasmType fType)
214 | 
215 | compileDeclaration :: TypedDeclaration -> CompileState ()
216 | compileDeclaration (TypedDeclaration name args _ fType fexpr) = do
217 |   expr' <- evalStateT (compileExpression locals fexpr) (UniqueLocals Map.empty)
218 |   let func =
219 |         Func $
220 |         Declaration
221 |           (symbolToIdent name)
222 |           parameters
223 |           wasmType
224 |           (Block wasmType $ NE.fromList (deconstruction <> [expr']))
225 |   addTopLevel [func]
226 |   where
227 |     parameters = argTypes args
228 |     deconstruction =
229 |       evalState (concat <$> traverse assignments args) (UniqueLocals Map.empty)
230 |     locals =
231 |       Locals
232 |         (Set.fromList $
233 |          (fst <$> parameters) <> (fst <$> concatMap findLocals deconstruction))
234 |     forestTypeToWasmType' fType =
235 |       case fType of
236 |         Lambda _ r -> forestTypeToWasmType' r
237 |         Num -> I32
238 |         Float' -> F32
239 |         _ -> I32
240 |     wasmType = forestTypeToWasmType' fType
241 | 
242 | compileInlineDeclaration ::
243 |      Locals -> TypedDeclaration -> DeclarationCompileState (Maybe Expression)
244 | compileInlineDeclaration (Locals l) (TypedDeclaration name args closureBindings forestType fexpr) = do
245 |   expr' <- compileExpression locals fexpr
246 |   let decl =
247 |         inlineDeclaration expr' deconstruction (forestTypeToWasmType forestType)
248 |   case args of
249 |     [] ->
250 |       return $
251 |       (Just $
252 |        SetLocal (symbolToIdent name) (forestTypeToWasmType forestType) expr')
253 |     _ -> do
254 |       lift $ addTopLevel [decl]
255 |       return $ Nothing
256 |   where
257 |     deconstruction =
258 |       evalState (concat <$> traverse assignments args) (UniqueLocals Map.empty)
259 |     parameters = closureArgs closureBindings <> argTypes args
260 |     locals =
261 |       Locals
262 |         (Set.union
263 |            l
264 |            (Set.fromList
265 |               ((fst <$> parameters) <>
266 |                (fst <$> concatMap findLocals deconstruction))))
267 |     inlineDeclaration expr deconstruction wasmType =
268 |       Func $
269 |       Declaration
270 |         (symbolToIdent name)
271 |         parameters
272 |         (forestTypeToWasmType forestType)
273 |         (Block wasmType $ NE.fromList (deconstruction <> [expr]))
274 | 
275 | forestTypeToWasmType :: T.Type -> WasmType
276 | forestTypeToWasmType fType =
277 |   case fType of
278 |     Num -> I32
279 |     Float' -> F32
280 |     _ -> I32
281 | 
282 | compileExpressions ::
283 |      Locals -> NonEmpty TypedExpression -> DeclarationCompileState [Expression]
284 | compileExpressions locals = foldM compile []
285 |   where
286 |     compile xs te = do
287 |       expr <- compileExpression locals te
288 |       return $ expr : xs
289 | 
290 | compileIdentifer :: Type -> F.Ident -> Set F.Ident -> Expression
291 | compileIdentifer t i l =
292 |   case t of
293 |     T.Applied (T.TL (T.TypeLambda _)) (T.Generic (F.Ident _)) ->
294 |       if (Set.member i l)
295 |         then GetLocal i
296 |         else NamedCall i []
297 |     T.TL (T.TypeLambda _) ->
298 |       if (Set.member i l)
299 |         then GetLocal i
300 |         else NamedCall i []
301 |     _ -> GetLocal i
302 | 
303 | compileInfix ::
304 |      Locals
305 |   -> F.OperatorExpr
306 |   -> TypedExpression
307 |   -> TypedExpression
308 |   -> DeclarationCompileState Expression
309 | compileInfix locals operator a b = do
310 |   aExpr <- compileExpression locals a
311 |   bExpr <- compileExpression locals b
312 |   let name = (F.Ident $ F.NonEmptyString 's' "tring_add")
313 |   return $
314 |     case (operator, T.typeOf b) of
315 |       (F.StringAdd, T.Str) -> NamedCall name [aExpr, bExpr]
316 |       (_, t) -> Call (funcForOperator operator t) [aExpr, bExpr]
317 | 
318 | compileApply ::
319 |      Locals
320 |   -> TypedExpression
321 |   -> TypedExpression
322 |   -> DeclarationCompileState Expression
323 | compileApply locals left right =
324 |   case left of
325 |     T.Apply t (T.Identifier _ name closureBindings) r' -> do
326 |       exprs <- compileExpressions locals [right, r']
327 |       return $
328 |         (Block (forestTypeToWasmType t) $
329 |          NE.fromList
330 |            (bindingsToArgs closureBindings <> exprs <>
331 |             [NamedCall (symbolToIdent name) []]))
332 |     T.Identifier _ name closureBindings -> do
333 |       r <- compileExpression locals right
334 |       return $
335 |         NamedCall (symbolToIdent name) (bindingsToArgs closureBindings <> [r])
336 |     _ -> error $ "do not know what to do with " <> show left
337 |   where
338 |     bindingsToArgs :: OSet T.ClosureBinding -> [Expression]
339 |     bindingsToArgs cbs = mapMaybe bindingToArg $ OSet.toAscList cbs
340 |     bindingToArg :: T.ClosureBinding -> Maybe Expression
341 |     bindingToArg (T.ClosureBinding _ (T.Lambda _ _)) = Nothing
342 |     bindingToArg (T.ClosureBinding s _) = Just $ GetLocal $ symbolToIdent s
343 | 
344 | compileLet ::
345 |      Locals
346 |   -> NonEmpty TypedDeclaration
347 |   -> TypedExpression
348 |   -> DeclarationCompileState Expression
349 | compileLet (Locals l) declarations fexpr = do
350 |   declarationExpressions <- foldM compileDeclaration' [] declarations
351 |   expr' <- compileExpression locals' fexpr
352 |   return $
353 |     (Block (forestTypeToWasmType (T.typeOf fexpr)) $
354 |      NE.fromList (declarationExpressions <> [expr']))
355 |   where
356 |     compileDeclaration' ::
357 |          [Expression]
358 |       -> TypedDeclaration
359 |       -> DeclarationCompileState [Expression]
360 |     compileDeclaration' declarations declaration = do
361 |       mExpr <- compileInlineDeclaration locals' declaration
362 |       return $
363 |         case mExpr of
364 |           Just expr -> declarations <> [expr]
365 |           Nothing -> declarations
366 |     names =
367 |       NE.toList $ (\(TypedDeclaration name _ _ _ _) -> name) <$> declarations
368 |     locals' = Locals $ Set.union l (Set.fromList (symbolToIdent <$> names))
369 | 
370 | compileCase ::
371 |      Locals
372 |   -> WasmType
373 |   -> TypedExpression
374 |   -> NonEmpty (TypedArgument, TypedExpression)
375 |   -> DeclarationCompileState Expression
376 | compileCase locals _ caseFexpr patterns = do
377 |   (resultLocal, caseExpr) <- compileCaseExpression locals caseFexpr
378 |   patternExprs <- patternsToWasm resultLocal patterns
379 |   return $
380 |     Sequence [caseExpr, constructCase (GetLocal resultLocal) patternExprs]
381 |   where
382 |     constructCase ::
383 |          Expression -> NE.NonEmpty (Expression, Expression) -> Expression
384 |     constructCase caseExpr patterns =
385 |       case patterns of
386 |         [x] -> If (Call eq32 [caseExpr, fst x]) (snd x) Nothing
387 |         (x :| xs) ->
388 |           If
389 |             (Call eq32 [caseExpr, fst x])
390 |             (snd x)
391 |             (Just (constructCase caseExpr (NE.fromList xs)))
392 |     patternsToWasm ::
393 |          F.Ident
394 |       -> NE.NonEmpty (T.TypedArgument, T.TypedExpression)
395 |       -> DeclarationCompileState (NonEmpty (Expression, Expression))
396 |     patternsToWasm caseResultIdent patterns =
397 |       let compilePattern ::
398 |                [(Expression, Expression)]
399 |             -> (T.TypedArgument, T.TypedExpression)
400 |             -> DeclarationCompileState [(Expression, Expression)]
401 |           compilePattern exprs (a, b) = do
402 |             (aExpr, locals') <- compileCaseArgument a
403 |             bExpr <- compileExpression (mergeLocals locals locals') b
404 |             return $ exprs <> [(aExpr, bExpr)]
405 |           exprs = foldM compilePattern [] patterns
406 |        in NE.fromList <$> exprs
407 |       where
408 |         compileCaseArgument a =
409 |           case a of
410 |             T.TAIdentifier t s ->
411 |               return
412 |                 ( TeeLocal
413 |                     (symbolToIdent s)
414 |                     (forestTypeToWasmType t)
415 |                     (GetLocal caseResultIdent)
416 |                 , addLocal (symbolToIdent s) noLocals)
417 |             _ -> compileArgument caseFexpr a
418 | 
419 | compileADTConstruction ::
420 |      (Functor t, Foldable t) => Int -> t T.TypedArgument -> Expression
421 | compileADTConstruction tag args =
422 |   Block
423 |     I32
424 |     (NE.fromList
425 |        ([ SetLocal
426 |             (ident "address")
427 |             I32
428 |             (NamedCall (ident "malloc") [Const $ (1 + length args) * 4])
429 |         , Call (ident "i32.store") [GetLocal (ident "address"), Const tag]
430 |         ] <>
431 |         (store <$> zip [1 ..] (argTypes args)) <>
432 |         [GetLocal (ident "address")]))
433 |   where
434 |     store :: (Int, (F.Ident, WasmType)) -> Expression
435 |     store (offset, (i, t)) =
436 |       Call
437 |         (ident (printWasmType t <> ".store"))
438 |         [ Call
439 |             (ident "i32.add")
440 |             [GetLocal (ident "address"), Const (offset * 4)]
441 |         , GetLocal i
442 |         ]
443 | 
444 | compileString :: Text -> DeclarationCompileState Expression
445 | compileString str =
446 |   lift $ do
447 |     address <- getAddress
448 |     addTopLevel [Data address str]
449 |     allocateBytes (Text.length str + 1)
450 |     return $ Const address
451 | 
452 | compileExpression ::
453 |      Locals -> TypedExpression -> DeclarationCompileState Expression
454 | compileExpression locals@(Locals l) fexpr =
455 |   case fexpr of
456 |     T.Identifier t i _ -> return $ compileIdentifer t (symbolToIdent i) l
457 |     T.Number n -> return $ Const n
458 |     T.Float f -> return $ FloatConst f
459 |     T.BetweenParens fexpr -> compileExpression locals fexpr
460 |     T.Infix _ operator a b -> compileInfix locals operator a b
461 |     T.Apply _ left right -> compileApply locals left right
462 |     T.Case t caseFexpr patterns ->
463 |       compileCase locals (forestTypeToWasmType t) caseFexpr patterns
464 |     T.Let declarations fexpr -> compileLet locals declarations fexpr
465 |     T.String' str -> compileString str
466 |     T.ADTConstruction tag args -> return $ compileADTConstruction tag args
467 | 
468 | assignments :: T.TypedArgument -> State UniqueLocals [Expression]
469 | assignments (T.TAIdentifier _ _) = pure []
470 | assignments (T.TADeconstruction (T.BindingSymbol i) _ _ args) =
471 |   concat <$>
472 |   traverse
473 |     (uncurry (compileDeconstructionAssignment (symbolToIdent i)))
474 |     (zip args [1 ..])
475 | assignments (T.TANumberLiteral _) = pure []
476 | 
477 | argTypes :: Foldable t => t T.TypedArgument -> [(F.Ident, WasmType)]
478 | argTypes = concatMap argType
479 | 
480 | argType :: T.TypedArgument -> [(F.Ident, WasmType)]
481 | argType (T.TAIdentifier t i) = [(symbolToIdent i, forestTypeToWasmType t)]
482 | argType (T.TANumberLiteral _) = []
483 | argType (T.TADeconstruction (T.BindingSymbol i) _ _ _) =
484 |   [(symbolToIdent i, I32)]
485 | 
486 | getUniqueLocal :: Monad a => F.Ident -> StateT UniqueLocals a F.Ident
487 | getUniqueLocal i = do
488 |   count <- gets countForIdent
489 |   modify updateCount
490 |   return $ ident (F.s i <> "_" <> showT count)
491 |   where
492 |     updateCount (UniqueLocals map) = UniqueLocals (Map.insertWith (+) i 1 map)
493 |     countForIdent (UniqueLocals map) = fromMaybe 0 (Map.lookup i map)
494 | 
495 | compileDeconstructionAssignment ::
496 |      F.Ident -> T.TypedArgument -> Int -> State UniqueLocals [Expression]
497 | compileDeconstructionAssignment i a n =
498 |   case a of
499 |     T.TAIdentifier t symbol ->
500 |       return
501 |         [ (SetLocal
502 |              (symbolToIdent symbol)
503 |              (forestTypeToWasmType t)
504 |              (Call
505 |                 (ident (printWasmType (forestTypeToWasmType t) <> ".load"))
506 |                 [Call (ident "i32.add") [GetLocal i, Const $ n * 4]]))
507 |         ]
508 |     T.TANumberLiteral _ -> pure []
509 |     T.TADeconstruction (T.BindingSymbol symbol) _ _ args -> do
510 |       let assignment =
511 |             [ SetLocal
512 |                 (symbolToIdent symbol)
513 |                 I32
514 |                 (Call
515 |                    (ident "i32.load")
516 |                    [Call (ident "i32.add") [GetLocal i, Const $ n * 4]])
517 |             ]
518 |       (assignment <>) <$>
519 |         (concat <$>
520 |          traverse
521 |            (uncurry (compileDeconstructionAssignment (symbolToIdent symbol)))
522 |            (zip args [1 ..]))
523 | 
524 | compileCaseExpression ::
525 |      Locals
526 |   -> T.TypedExpression
527 |   -> DeclarationCompileState (F.Ident, Expression)
528 | compileCaseExpression locals fexpr =
529 |   let body =
530 |         case fexpr of
531 |           Identifier (T.Applied _ _) i _ ->
532 |             return $ Call (ident "i32.load") [GetLocal (symbolToIdent i)]
533 |           Identifier (T.TL (T.TypeLambda _)) i _ ->
534 |             return $ Call (ident "i32.load") [GetLocal (symbolToIdent i)]
535 |           _ -> compileExpression locals fexpr
536 |    in do uniqueLocal <- getUniqueLocal (ident "case_result")
537 |          expr <-
538 |            SetLocal uniqueLocal (forestTypeToWasmType (typeOf fexpr)) <$> body
539 |          return (uniqueLocal, expr)
540 | 
541 | -- TODO - make it more clear that this is only about case arguments
542 | compileArgument ::
543 |      T.TypedExpression
544 |   -> TypedArgument
545 |   -> DeclarationCompileState (Expression, Locals)
546 | compileArgument caseFexpr arg =
547 |   case arg of
548 |     T.TAIdentifier _ i ->
549 |       return (GetLocal (symbolToIdent i), addLocal (symbolToIdent i) noLocals)
550 |     T.TANumberLiteral n -> return (Const n, noLocals)
551 |     T.TADeconstruction _ _ tag args ->
552 |       let assignments = mapMaybe makeAssignment (zip args [1 ..])
553 |           makeAssignment :: (T.TypedArgument, Int) -> Maybe Expression
554 |           makeAssignment (arg, index) =
555 |             case arg of
556 |               TAIdentifier fType symbol ->
557 |                 Just
558 |                   (SetLocal
559 |                      (symbolToIdent symbol)
560 |                      (forestTypeToWasmType fType)
561 |                      (Call
562 |                         (ident
563 |                            (printWasmType (forestTypeToWasmType fType) <>
564 |                             ".load"))
565 |                         [Call (ident "i32.add") [caseLocal, Const (index * 4)]]))
566 |               _ -> Nothing
567 |           localName (TAIdentifier _ symbol) = Just (symbolToIdent symbol)
568 |           localName _ = Nothing
569 |           locals = addLocals (mapMaybe localName args) noLocals
570 |        in return (Block I32 (NE.fromList (assignments <> [Const tag])), locals)
571 |   where
572 |     caseLocal =
573 |       case caseFexpr of
574 |         T.Identifier _ name _ -> GetLocal (symbolToIdent name)
575 |         _ -> Const 0
576 | 
577 | eq32 :: F.Ident
578 | eq32 = F.Ident $ F.NonEmptyString 'i' "32.eq"
579 | 
580 | funcForOperator :: F.OperatorExpr -> T.Type -> F.Ident
581 | funcForOperator operator t =
582 |   let wasmType =
583 |         case t of
584 |           Num -> "i32"
585 |           Float' -> "f32"
586 |           _ ->
587 |             error $
588 |             "tried to get a funcForOperator for a non numeric type: " <>
589 |             (Text.unpack $ T.printType t)
590 |       op =
591 |         case (operator, t) of
592 |           (F.Add, _) -> "add"
593 |           (F.Subtract, _) -> "sub"
594 |           (F.Multiply, _) -> "mul"
595 |           (F.Divide, Float') -> "div"
596 |           (F.Divide, _) -> "div_s"
597 |           _ ->
598 |             error $
599 |             "tried to get a funcForOperator for a non numeric type: " <>
600 |             (Text.unpack $ T.printType t)
601 |    in ident (wasmType <> "." <> op)
602 | 
603 | printWasm :: Module -> Text
604 | printWasm (Module expressions bytesAllocated) =
605 |   "(module\n" <> indent2 (prelude bytesAllocated) <> "\n\n" <>
606 |   indent2 (printMemory bytesAllocated) <>
607 |   "\n" <>
608 |   indent2 (Text.intercalate "\n" $ printWasmTopLevel <$> expressions) <>
609 |   "\n)"
610 | 
611 | printMemory :: BytesAllocated -> Text
612 | printMemory bytes =
613 |   case bytes of
614 |     0 -> printMemory 1 -- TODO this is silly, we should omit the prelude instead
615 |     _ ->
616 |       "(memory $memory " <> showT pages <>
617 |       ")\n(export \"memory\" (memory $memory))\n\n"
618 |   where
619 |     pageSize = 2 ** 16
620 |     pages = ceiling $ fromIntegral bytes / pageSize
621 | 
622 | printWasmTopLevel :: TopLevel -> Text
623 | printWasmTopLevel topLevel =
624 |   case topLevel of
625 |     Func (Declaration name args wasmType body) ->
626 |       Text.unlines
627 |         [ "(export \"" <> F.s name <> "\" (func $" <> F.s name <> "))"
628 |         , printDeclaration (Declaration name args wasmType body)
629 |         ]
630 |     Data offset str ->
631 |       "(data (i32.const " <> showT offset <> ") \"" <>
632 |       escape (Text.length str + 1) <>
633 |       str <>
634 |       "\")"
635 |   where
636 |     escape n =
637 |       case n of
638 |         0 -> "\\" <> Text.singleton (chr 0)
639 |         34 -> "\\\""
640 |         _ -> Text.singleton (chr n)
641 | 
642 | printWasmExpr :: Expression -> Text
643 | printWasmExpr expr =
644 |   case expr of
645 |     Sequence exprs ->
646 |       Text.intercalate "\n" $ NE.toList (printWasmExpr <$> exprs)
647 |     Block wasmType exprs ->
648 |       "(block (result " <> printWasmType wasmType <> ")\n" <>
649 |       indent2 (Text.intercalate "\n" $ NE.toList (printWasmExpr <$> exprs)) <>
650 |       "\n)"
651 |     Const n -> "(i32.const " <> showT n <> ")"
652 |     FloatConst n -> "(f32.const " <> showT n <> ")"
653 |     GetLocal name -> "(get_local $" <> F.s name <> ")"
654 |     SetLocal name _ expr' ->
655 |       "(set_local $" <> F.s name <> " " <> printWasmExpr expr' <> ")"
656 |     TeeLocal name _ expr' ->
657 |       "(tee_local $" <> F.s name <> " " <> printWasmExpr expr' <> ")"
658 |     Call name args ->
659 |       "(" <> F.s name <> "\n" <>
660 |       indent2 (Text.intercalate "\n" (printWasmExpr <$> args)) <>
661 |       "\n)"
662 |     NamedCall name args ->
663 |       "(call $" <> F.s name <> "\n" <>
664 |       indent2 (Text.intercalate "\n" (printWasmExpr <$> args)) <>
665 |       "\n)"
666 |     If conditional a b ->
667 |       Text.unlines
668 |         ([ "(if (result i32)"
669 |          , indent2 $ printWasmExpr conditional
670 |          , indent2 $ printWasmExpr a
671 |          ] <>
672 |          [indent2 $ maybe "(i32.const 0)" printWasmExpr b, ")"])
673 | 
674 | printWasmType :: WasmType -> Text
675 | printWasmType wasmType =
676 |   case wasmType of
677 |     I32 -> "i32"
678 |     F32 -> "f32"
679 | 
680 | printDeclaration :: Declaration -> Text
681 | printDeclaration (Declaration name args wasmType body) =
682 |   Text.intercalate
683 |     "\n"
684 |     [ "(func $" <> F.s name <> Text.unwords (printParam <$> args) <> " (result " <>
685 |       printWasmType wasmType <>
686 |       ") " <>
687 |       Text.unwords (printLocal <$> locals body)
688 |     , indent2 $ Text.unlines ["(return", indent2 $ printWasmExpr body, ")"]
689 |     , ")"
690 |     ]
691 |   where
692 |     printParam (name, wasmType) =
693 |       " (param $" <> F.s name <> " " <> printWasmType wasmType <> ")"
694 |     locals :: Expression -> [(Text, WasmType)]
695 |     locals expr' = (\(a, b) -> (F.s a, b)) <$> findLocals expr'
696 | 
697 | findLocals :: Expression -> [(F.Ident, WasmType)]
698 | findLocals expr' =
699 |   case expr' of
700 |     TeeLocal name wasmType expr -> [(name, wasmType)] <> findLocals expr
701 |     SetLocal name wasmType expr -> [(name, wasmType)] <> findLocals expr
702 |     Sequence exprs -> concatMap findLocals $ NE.toList exprs
703 |     Block _ exprs -> concatMap findLocals $ NE.toList exprs
704 |     If expr expr' mexpr ->
705 |       findLocals expr <> findLocals expr' <> maybe [] findLocals mexpr
706 |     Call _ exprs -> concatMap findLocals exprs
707 |     NamedCall _ exprs -> concatMap findLocals exprs
708 |     Const _ -> []
709 |     FloatConst _ -> []
710 |     GetLocal _ -> []
711 | 
712 | printLocal :: (Text, WasmType) -> Text
713 | printLocal (name, wasmType) =
714 |   "(local $" <> name <> " " <> printWasmType wasmType <> ")"
715 | 
716 | ident :: Text -> F.Ident
717 | ident t = F.Ident $ F.NonEmptyString (Text.head t) (Text.tail t)
718 | 
719 | symbolToIdent :: T.Symbol -> F.Ident
720 | symbolToIdent (Symbol n i) =
721 |   if F.s i == "main"
722 |     then ident "main"
723 |     else ident (F.s i <> "_" <> showT n)
724 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | flags: {}
2 | nix:
3 |   enable: true
4 |   shell-file: shell.nix
5 | extra-package-dbs: []
6 | packages:
7 | - .
8 | resolver: lts-14.18
9 | 


--------------------------------------------------------------------------------
/stack.yaml.lock:
--------------------------------------------------------------------------------
 1 | # This file was autogenerated by Stack.
 2 | # You should not edit this file by hand.
 3 | # For more information, please see the documentation at:
 4 | #   https://docs.haskellstack.org/en/stable/lock_files
 5 | 
 6 | packages: []
 7 | snapshots:
 8 | - completed:
 9 |     size: 524789
10 |     url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/18.yaml
11 |     sha256: 646be71223e08234131c6989912e6011e01b9767bc447b6d466a35e14360bdf2
12 |   original: lts-14.18
13 | 


--------------------------------------------------------------------------------
/test/Arbitrary.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedLists #-}
  2 | {-# LANGUAGE FlexibleInstances #-}
  3 | 
  4 | module Arbitrary
  5 |   ( genModule
  6 |   ) where
  7 | 
  8 | import HaskellSyntax
  9 | import Language
 10 | 
 11 | import Control.Monad
 12 | import qualified Data.List.NonEmpty as NE
 13 | import Data.List.NonEmpty (NonEmpty(..))
 14 | import Data.Semigroup
 15 | import Data.Text (Text)
 16 | import qualified Data.Text as T
 17 | import Test.QuickCheck
 18 | import Test.QuickCheck.Arbitrary
 19 | 
 20 | instance Arbitrary Module where
 21 |   arbitrary = genModule
 22 |   shrink = genericShrink
 23 | 
 24 | instance Arbitrary TopLevel where
 25 |   arbitrary = genTopLevel
 26 |   shrink = genericShrink
 27 | 
 28 | instance Arbitrary ADT where
 29 |   arbitrary = genADT
 30 |   shrink = genericShrink
 31 | 
 32 | instance Arbitrary Expression where
 33 |   arbitrary = genExpression
 34 |   shrink = genericShrink
 35 | 
 36 | instance Arbitrary Constructor where
 37 |   arbitrary = genConstructor
 38 |   shrink = genericShrink
 39 | 
 40 | instance Arbitrary ConstructorType where
 41 |   arbitrary = genConstructorType
 42 |   shrink = genericShrink
 43 | 
 44 | instance Arbitrary OperatorExpr where
 45 |   arbitrary = genOperator
 46 |   shrink = genericShrink
 47 | 
 48 | instance Arbitrary Declaration where
 49 |   arbitrary = genDeclaration
 50 |   shrink = genericShrink
 51 | 
 52 | instance Arbitrary Annotation where
 53 |   arbitrary = genAnnotation
 54 |   shrink = genericShrink
 55 | 
 56 | instance Arbitrary AnnotationType where
 57 |   arbitrary = genAnnotationType
 58 |   shrink = genericShrink
 59 | 
 60 | instance Arbitrary Ident where
 61 |   arbitrary = genIdent
 62 |   shrink (Ident s) = Ident <$> filter permittedWord (shrink s)
 63 | 
 64 | instance Arbitrary Text where
 65 |   arbitrary = T.pack <$> arbitrary
 66 |   shrink s = T.pack <$> shrink (T.unpack s)
 67 | 
 68 | permittedWord :: NonEmptyString -> Bool
 69 | permittedWord (NonEmptyString x xs) = T.singleton x <> xs `notElem` reservedWords
 70 | 
 71 | instance Arbitrary NonEmptyString where
 72 |   arbitrary = genNEString
 73 |   shrink (NonEmptyString x xs) =
 74 |     NonEmptyString x <$> (T.pack <$> shrink (T.unpack xs))
 75 | 
 76 | instance Arbitrary (NE.NonEmpty Declaration) where
 77 |   arbitrary = genNonEmpty genDeclaration
 78 |   shrink = shrinkNonEmpty
 79 | 
 80 | instance Arbitrary (NE.NonEmpty (Argument, Expression)) where
 81 |   arbitrary = genNonEmpty genCaseBranch
 82 |   shrink = shrinkNonEmpty
 83 | 
 84 | instance Arbitrary Argument where
 85 |   arbitrary = genArgument
 86 |   shrink = genericShrink
 87 | 
 88 | instance Arbitrary (NE.NonEmpty Ident) where
 89 |   arbitrary = genNonEmpty genIdent
 90 |   shrink = shrinkNonEmpty
 91 | 
 92 | instance Arbitrary (NE.NonEmpty Constructor) where
 93 |   arbitrary = genNonEmpty genConstructor
 94 |   shrink = shrinkNonEmpty
 95 | 
 96 | instance Arbitrary (NE.NonEmpty AnnotationType) where
 97 |   arbitrary = genNonEmpty genAnnotationType
 98 |   shrink = shrinkNonEmpty
 99 | 
100 | genModule :: Gen Module
101 | genModule = Module <$> listOf1 genTopLevel
102 | 
103 | genNonEmpty :: Gen a -> Gen (NE.NonEmpty a)
104 | genNonEmpty gen = NE.fromList <$> listOf1 gen
105 | 
106 | shrinkNonEmpty :: Arbitrary a => NE.NonEmpty a -> [NE.NonEmpty a]
107 | shrinkNonEmpty n =
108 |   let list = NE.toList n
109 |       possibilities = shrink list
110 |       nonEmptyPossibilities = filter (not . null) possibilities
111 |    in map NE.fromList nonEmptyPossibilities
112 | 
113 | genExpression :: Gen Expression
114 | genExpression =
115 |   frequency
116 |     [ (90, genIdentifier)
117 |     , (90, genNumber)
118 |     , (90, genString)
119 |     , (50, BetweenParens <$> genExpression)
120 |     , (10, genInfix)
121 |     , (10, genCall)
122 |     , (1, genLet)
123 |     , (1, genCase)
124 |     ]
125 | 
126 | genChar :: Gen Char
127 | genChar = elements (['a' .. 'z'] ++ ['A' .. 'Z'])
128 | 
129 | genIdent :: Gen Ident
130 | genIdent = Ident <$> suchThat genNEString permittedWord
131 | 
132 | genNEString :: Gen NonEmptyString
133 | genNEString = NonEmptyString <$> genChar <*> (T.pack <$> listOf1 genChar)
134 | 
135 | genIdentifier :: Gen Expression
136 | genIdentifier = Identifier <$> genIdent
137 | 
138 | genNumber :: Gen Expression
139 | genNumber = Number <$> arbitrarySizedNatural
140 | 
141 | genString :: Gen Expression
142 | genString = String' . T.pack <$> listOf genChar
143 | 
144 | genTopLevel :: Gen TopLevel
145 | genTopLevel = oneof [genFunction, genDataType]
146 |   where
147 |     genFunction = Function <$> genDeclaration
148 |     genDataType = DataType <$> genADT
149 | 
150 | genADT :: Gen ADT
151 | genADT = do
152 |   name <- genIdent
153 |   generics <- listOf genIdent
154 |   constructors <- genNonEmpty genConstructor
155 |   return $ ADT name generics constructors
156 | 
157 | genConstructor :: Gen Constructor
158 | genConstructor = do
159 |   name <- genIdent
160 |   types <- genMaybe genConstructorType
161 |   return $ Constructor name types
162 | 
163 | genConstructorType :: Gen ConstructorType
164 | genConstructorType = frequency [(100, concrete), (100, parens), (1, applied)]
165 |   where
166 |     concrete = CTConcrete <$> genIdent
167 |     applied =
168 |       CTApplied <$> (genConstructorType `suchThat` noApply) <*>
169 |       genConstructorType
170 |     parens = CTParenthesized <$> genConstructorType
171 |     noApply ct =
172 |       case ct of
173 |         CTApplied _ _ -> False
174 |         _ -> True
175 | 
176 | genDeclaration :: Gen Declaration
177 | genDeclaration = do
178 |   name <- genIdent
179 |   annotation <- genMaybe genAnnotation
180 |   args <- listOf genArgument
181 |   expr <- genExpression
182 |   return $ Declaration annotation name args expr
183 | 
184 | genAnnotation :: Gen Annotation
185 | genAnnotation = do
186 |   name <- genIdent
187 |   types <- genNonEmpty genAnnotationType
188 |   return $ Annotation name types
189 | 
190 | genAnnotationType :: Gen AnnotationType
191 | genAnnotationType =
192 |   frequency
193 |     [ (100, Concrete <$> genIdent)
194 |     , (1, Parenthesized <$> genNonEmpty genAnnotationType)
195 |     ]
196 | 
197 | genMaybe :: Gen a -> Gen (Maybe a)
198 | genMaybe g = oneof [Just <$> g, Nothing <$ g]
199 | 
200 | genOperator :: Gen OperatorExpr
201 | genOperator = elements [Add, Subtract, Multiply, Divide]
202 | 
203 | genInfix :: Gen Expression
204 | genInfix = do
205 |   operator <- genOperator
206 |   a <- genNumber -- TODO expand this definition
207 |   b <- genExpression
208 |   return $ BetweenParens $ Infix operator a b
209 | 
210 | genCall :: Gen Expression
211 | genCall = do
212 |   a <-
213 |     oneof
214 |       [ genIdentifier
215 |       , genNumber
216 |       , genString
217 |       , genCall
218 |       , BetweenParens <$> genExpression
219 |       ]
220 |   b <-
221 |     oneof
222 |       [ genIdentifier
223 |       , genNumber
224 |       , genString
225 |       , BetweenParens <$> genExpression
226 |       ]
227 |   return $ Apply a b
228 | 
229 | applicationIsExcluded :: Expression -> Bool
230 | applicationIsExcluded e =
231 |   case e of
232 |     Apply _ _ -> False
233 |     _ -> True
234 | 
235 | (>*<) :: Gen a -> Gen b -> Gen (a, b)
236 | x >*< y = liftM2 (,) x y
237 | 
238 | genCase :: Gen Expression
239 | genCase = do
240 |   caseExpr <- genExpression
241 |   cases <- genNonEmpty genCaseBranch
242 |   return $ Case caseExpr cases
243 | 
244 | genArgument :: Gen Argument
245 | genArgument =
246 |   oneof
247 |     [ ANumberLiteral <$> arbitrarySizedNatural
248 |     , AIdentifier <$>
249 |       (Ident <$> genNEString `suchThat` (both permittedWord (not . firstLetterIsCapitalized)))
250 |     ]
251 |   where
252 |     firstLetterIsCapitalized (NonEmptyString x _) =
253 |       T.singleton x == (T.toUpper . T.singleton $ x)
254 |     both a b = \x -> a x && b x
255 | 
256 | genCaseBranch :: Gen (Argument, Expression)
257 | genCaseBranch = genArgument >*< genExpression
258 | 
259 | genLet :: Gen Expression
260 | genLet = do
261 |   declarations <- genNonEmpty genDeclaration
262 |   expr <- genExpression
263 |   return $ Let declarations expr
264 | 


--------------------------------------------------------------------------------
/test/HaskellSyntaxSpec.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE OverloadedLists #-}
  3 | {-# LANGUAGE FlexibleInstances #-}
  4 | 
  5 | module HaskellSyntaxSpec
  6 |   ( haskellSyntaxSpecs
  7 |   ) where
  8 | 
  9 | import Control.Monad
 10 | import Control.Monad.Trans.State.Lazy
 11 | import qualified Data.List.NonEmpty as NE
 12 | import Data.List.NonEmpty
 13 | import Data.Semigroup
 14 | import Data.Text (Text)
 15 | import qualified Data.Map as Map
 16 | import qualified Data.Text as T
 17 | import qualified Data.Text.IO as TIO
 18 | import System.Exit
 19 | import System.IO.Temp
 20 | import System.Process
 21 | import Test.Hspec
 22 | import Test.QuickCheck
 23 | import Text.Megaparsec
 24 | 
 25 | import Arbitrary
 26 | 
 27 | import Compiler
 28 | import HaskellSyntax
 29 | import Language
 30 | 
 31 | parseCode :: Parser a -> Text -> Either ParseError' a
 32 | parseCode parser = parse (evalStateT parser (LineInformation Map.empty Map.empty)) ""
 33 | 
 34 | propParseAndPrint :: Module -> Bool
 35 | propParseAndPrint m =
 36 |   let printedModule = printModule m
 37 |       parsedModule = parseModule printedModule
 38 |    in case parsedModule of
 39 |         Right newModule -> newModule == m
 40 |         Left _ -> False
 41 | 
 42 | haskellSyntaxSpecs :: SpecWith ()
 43 | haskellSyntaxSpecs = parallel $ do
 44 |   describe "Forest haskell syntax" $ do
 45 |     it "parses a module with multiple assignments" $ do
 46 |       code <- readFixture "multiple-assignments"
 47 |       let parseResult = parseModule code
 48 |       let expected =
 49 |             Module
 50 |               [ Function $
 51 |                 Declaration
 52 |                   Nothing
 53 |                   (ne "double")
 54 |                   [AIdentifier $ ne "a"]
 55 |                   (Infix Multiply (Identifier (ne "a")) (Number 2))
 56 |               , Function $
 57 |                 Declaration
 58 |                   Nothing
 59 |                   (ne "half")
 60 |                   [AIdentifier $ ne "a"]
 61 |                   (Infix Divide (Identifier (ne "a")) (Number 2))
 62 |               ]
 63 |       parseResult `shouldBe` Right expected
 64 |     it "parses an assignment with a case statement" $ do
 65 |       code <- readFixture "case-statement"
 66 |       let parseResult = parseModule code
 67 |       let expected =
 68 |             Module
 69 |               [ Function $
 70 |                 Declaration
 71 |                   Nothing
 72 |                   (ne "test")
 73 |                   [AIdentifier $ ne "n"]
 74 |                   (Case
 75 |                      (Identifier (ne "n"))
 76 |                      [ (ANumberLiteral 0, Number 1)
 77 |                      , (ANumberLiteral 1, Number 1)
 78 |                      , ( AIdentifier (ne "n")
 79 |                        , Infix Add (Identifier (ne "n")) (Number 1))
 80 |                      ])
 81 |               ]
 82 |       parseResult `shouldBe` Right expected
 83 |     it
 84 |       "parses an assignment with a case statement followed by another assignment" $ do
 85 |       code <- readFixture "case-statement-and-more"
 86 |       let parseResult = parseModule code
 87 |       let expected =
 88 |             Module
 89 |               [ Function $
 90 |                 Declaration
 91 |                   Nothing
 92 |                   (ne "test")
 93 |                   [AIdentifier $ ne "n"]
 94 |                   (Case
 95 |                      (Identifier (ne "n"))
 96 |                      [ (ANumberLiteral 0, Number 1)
 97 |                      , (ANumberLiteral 1, Number 1)
 98 |                      , (AIdentifier (ne "n"), Identifier (ne "n"))
 99 |                      ])
100 |               , Function $
101 |                 Declaration
102 |                   Nothing
103 |                   (ne "double")
104 |                   [AIdentifier $ ne "x"]
105 |                   (Infix Multiply (Identifier (ne "x")) (Number 2))
106 |               ]
107 |       parseResult `shouldBe` Right expected
108 |     it "parses let expressions" $ do
109 |       code <- readFixture "let"
110 |       let parseResult = parseModule code
111 |       let expected =
112 |             Module
113 |               [ Function $
114 |                 Declaration
115 |                   Nothing
116 |                   (ne "a")
117 |                   []
118 |                   (Let
119 |                      (NE.fromList
120 |                         [ Declaration Nothing (ne "foo") [] (Number 5)
121 |                         , Declaration Nothing (ne "bar") [] (Number 10)
122 |                         ])
123 |                      (Infix Add (Identifier (ne "foo")) (Identifier (ne "bar"))))
124 |               ]
125 |       parseResult `shouldBe` Right expected
126 |     it "parses type applications in annotations" $ do
127 |       let code = "foo :: Int -> Maybe Int"
128 |       let parseResult = parseCode annotation code
129 |       let expected =
130 |             Annotation (ne "foo") $
131 |             Concrete (ne "Int") :|
132 |             [TypeApplication (Concrete (ne "Maybe")) (Concrete (ne "Int"))]
133 |       parseResult `shouldBe` Right expected
134 |     it "parses complex type applications in annotations" $ do
135 |       let code = "foo :: Int -> Maybe (Int -> String)"
136 |       let parseResult = parseCode annotation code
137 |       let expected =
138 |             Annotation (ne "foo") $
139 |             Concrete (ne "Int") :|
140 |             [ TypeApplication
141 |                 (Concrete (ne "Maybe"))
142 |                 (Parenthesized (Concrete (ne "Int") :| [Concrete (ne "String")]))
143 |             ]
144 |       parseResult `shouldBe` Right expected
145 |     it "parses complex type applications in adt constructors" $ do
146 |       let code = "data Foo a\n= Foo (Maybe a)"
147 |       let parseResult = parseCode dataType code
148 |       let expected =
149 |             DataType $
150 |             ADT
151 |               (ne "Foo")
152 |               [ne "a"]
153 |               [ Constructor (ne "Foo") $
154 |                 Just
155 |                   (CTParenthesized
156 |                      (CTApplied (CTConcrete (ne "Maybe")) (CTConcrete (ne "a"))))
157 |               ]
158 |       parseResult `shouldBe` Right expected
159 |     it "parses adt deconstructions in cases " $ do
160 |       code <- readFixture "case-deconstruction"
161 |       let parseResult = parseModule code
162 |       let expected =
163 |             Module
164 |               [ DataType
165 |                   (ADT
166 |                      (ne "Maybe")
167 |                      [ne "a"]
168 |                      (Constructor (ne "Just") (Just (CTConcrete (ne "a"))) :|
169 |                       [Constructor (ne "Nothing") Nothing]))
170 |               , Function
171 |                   (Declaration
172 |                      (Just
173 |                         (Annotation
174 |                            (ne "main")
175 |                            (TypeApplication
176 |                               (Concrete (ne "Maybe"))
177 |                               (Concrete (ne "Int")) :|
178 |                             [Concrete (ne "Int")])))
179 |                      (ne "main")
180 |                      [AIdentifier (ne "m")]
181 |                      (Case
182 |                         (Identifier (ne "m"))
183 |                         (( ADeconstruction (ne "Just") [AIdentifier (ne "n")]
184 |                          , Identifier (ne "n")) :|
185 |                          [(ADeconstruction (ne "Nothing") [], Number 0)])))
186 |               ]
187 |       parseResult `shouldBe` Right expected
188 |     it "prints and reparses arbitrary expressions losslessly" $
189 |       withMaxSuccess 200 (property propParseAndPrint)
190 |     describe "annotation type parsing" $ do
191 |       it "correctly parses applications" $
192 |         let expected =
193 |               (TypeApplication
194 |                  (TypeApplication
195 |                     (Concrete (Ident (NonEmptyString 'E' "ither")))
196 |                     (Concrete (Ident (NonEmptyString 'S' "tring"))))
197 |                  (Concrete (Ident (NonEmptyString 'I' "nt"))))
198 |          in parse (evalStateT pType (LineInformation Map.empty Map.empty)) "" "Either String Int" `shouldBe` Right expected
199 | 
200 | ne :: Text -> Ident
201 | ne s = Ident $ NonEmptyString (T.head s) (T.tail s)
202 | 
203 | readFixture :: Text -> IO Text
204 | readFixture name = TIO.readFile ("test/fixtures/" <> T.unpack name <> ".tree")
205 | 


--------------------------------------------------------------------------------
/test/SampleSpec.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | {-# LANGUAGE OverloadedLists #-}
 3 | {-# LANGUAGE FlexibleInstances #-}
 4 | 
 5 | module SampleSpec
 6 |   ( validSampleSpecs, invalidSampleSpecs
 7 |   ) where
 8 | 
 9 | import Data.Either
10 | import Data.List
11 | import Data.List.NonEmpty (NonEmpty(..))
12 | import qualified Data.List.NonEmpty as NE
13 | import Data.Semigroup ((<>))
14 | import Data.Text (Text)
15 | import qualified Data.Text as T
16 | import qualified Data.Text.IO as TIO
17 | import System.Directory
18 | import System.Exit
19 | import System.IO.Temp
20 | import System.Process
21 | import Test.Hspec
22 | import Text.RawString.QQ
23 | 
24 | import Compiler
25 | import HaskellSyntax
26 | import Language
27 | import TypeChecker
28 | 
29 | validSampleSpecs :: IO (SpecWith ())
30 | validSampleSpecs = do
31 |   files <-
32 |     filter (not . isPrefixOf ".") <$>
33 |     getDirectoryContents "./test/samples/valid"
34 |   specs <- foldl1 (flip (>>)) <$> mapM testFileIsValid files
35 |   return $ parallel $ describe "valid samples" specs
36 |   where
37 |     testFileIsValid :: FilePath -> IO (SpecWith ())
38 |     testFileIsValid path = do
39 |       contents <- TIO.readFile $ "./test/samples/valid/" <> path
40 |       return $
41 |         it (path <> " is valid") $
42 |           case typeCheck contents of
43 |             Success _ -> True
44 |             ParseErr _ -> False
45 |             CompileErr _ -> False
46 | 
47 | invalidSampleSpecs :: IO (SpecWith ())
48 | invalidSampleSpecs = do
49 |   files <-
50 |     filter (not . isPrefixOf ".") <$>
51 |     getDirectoryContents "./test/samples/invalid"
52 |   specs <- foldl1 (flip (>>)) <$> mapM testFileIsValid files
53 |   return $ describe "invalid samples" specs
54 |   where
55 |     testFileIsValid :: FilePath -> IO (SpecWith ())
56 |     testFileIsValid path = do
57 |       contents <- TIO.readFile $ "./test/samples/invalid/" <> path
58 |       return $
59 |         it (path <> " is not valid") $
60 |           case typeCheck contents of
61 |             Success _ -> False
62 |             ParseErr _ -> True
63 |             CompileErr _ -> True
64 | 
65 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedLists #-}
 2 | {-# LANGUAGE FlexibleInstances #-}
 3 | 
 4 | import qualified Data.List.NonEmpty as NE
 5 | import System.Exit
 6 | import System.IO.Temp
 7 | import System.Process
 8 | import Test.Hspec
 9 | import Test.QuickCheck
10 | import Test.QuickCheck.Arbitrary
11 | 
12 | import Compiler
13 | import HaskellSyntax
14 | import Language
15 | 
16 | import HaskellSyntaxSpec
17 | import TypeCheckerSpec
18 | import WasmSpec
19 | import SampleSpec
20 | 
21 | main :: IO ()
22 | main = do
23 |   vSampleSpecs <- validSampleSpecs
24 |   iSampleSpecs <- invalidSampleSpecs
25 |   hspec $ do
26 |     typeCheckerSpecs
27 |     vSampleSpecs
28 |     iSampleSpecs
29 |     wasmSpecs
30 |     haskellSyntaxSpecs
31 | 


--------------------------------------------------------------------------------
/test/TypeCheckerSpec.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE QuasiQuotes #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE OverloadedLists #-}
  4 | {-# LANGUAGE FlexibleInstances #-}
  5 | 
  6 | module TypeCheckerSpec
  7 |   ( typeCheckerSpecs
  8 |   ) where
  9 | 
 10 | import Data.Either
 11 | import Data.List.NonEmpty (NonEmpty(..))
 12 | import qualified Data.List.NonEmpty as NE
 13 | import Data.Text (Text)
 14 | import qualified Data.Text as T
 15 | import System.Exit
 16 | import System.IO.Temp
 17 | import System.Process
 18 | import Test.Hspec
 19 | import Text.RawString.QQ
 20 | 
 21 | import HaskellSyntax
 22 | import Language
 23 | import TypeChecker
 24 | 
 25 | valid :: Text
 26 | valid =
 27 |   [r|
 28 | add :: Int -> Int -> Int
 29 | add a b = a + b
 30 | 
 31 | main :: Int
 32 | main =
 33 |   add 1 1
 34 | |]
 35 | 
 36 | invalid :: Text
 37 | invalid =
 38 |   [r|
 39 | add :: Int -> Int -> Int
 40 | add a b = a + b
 41 | 
 42 | main :: Int
 43 | main =
 44 |   add 1 "test"
 45 | |]
 46 | 
 47 | local :: Text
 48 | local =
 49 |   [r|
 50 | add :: Int -> Int -> Int
 51 | add a b = a + b
 52 | 
 53 | addOne :: Int -> Int
 54 | addOne n =
 55 |   add n 1
 56 | |]
 57 | 
 58 | wrongReturnType :: Text
 59 | wrongReturnType =
 60 |   [r|
 61 | foo :: Int
 62 | foo = "test"
 63 | |]
 64 | 
 65 | badCase :: Text
 66 | badCase =
 67 |   [r|
 68 | main :: Int
 69 | main =
 70 |   case 5 of
 71 |     1 -> "Test"
 72 |     2 -> 2
 73 | |]
 74 | 
 75 | goodCase :: Text
 76 | goodCase =
 77 |   [r|
 78 | main :: Int -> Int
 79 | main i =
 80 |   case i of
 81 |     1 -> 1
 82 |     2 -> 2
 83 |     i -> 5
 84 | |]
 85 | 
 86 | badLet :: Text
 87 | badLet =
 88 |   [r|
 89 | main :: Int
 90 | main =
 91 |   let
 92 |     a :: Int
 93 |     a = 5
 94 | 
 95 |     b :: String
 96 |     b = "test"
 97 |   in
 98 |     a + b
 99 | |]
100 | 
101 | goodLet :: Text
102 | goodLet =
103 |   [r|
104 | main :: Int
105 | main =
106 |   let
107 |     a :: Int
108 |     a = 5
109 | 
110 |     b :: Int
111 |     b = 10
112 |   in
113 |     a + b
114 | |]
115 | 
116 | goodFunctionLet :: Text
117 | goodFunctionLet =
118 |   [r|
119 | main :: Int
120 | main =
121 |   let
122 |     one :: Int
123 |     one = 1
124 | 
125 |     addOne :: Int -> Int
126 |     addOne n = n + one
127 |   in
128 |     addOne 10
129 | |]
130 | 
131 | unorderedDeclarations :: Text
132 | unorderedDeclarations =
133 |   [r|
134 | main :: Int
135 | main = foo
136 | 
137 | foo :: Int
138 | foo = 5
139 | |]
140 | 
141 | adt :: Text
142 | adt =
143 |   [r|
144 | data Maybe a
145 |   = Just a
146 |   | Nothing
147 | 
148 | 
149 | main :: Maybe Int
150 | main = Just 0
151 | 
152 | nada :: Maybe Int
153 | nada = Nothing
154 | 
155 | doubleIfFive :: Int -> Maybe Int
156 | doubleIfFive n =
157 |   case n of
158 |     5 -> Just 10
159 |     n -> Nothing
160 | 
161 | data User
162 |   = User String
163 | 
164 | user :: User
165 | user = User "Nick"
166 | 
167 | withDefault :: a -> Maybe a -> a
168 | withDefault d maybe =
169 |   case maybe of
170 |     Just a -> a
171 |     Nothing -> d
172 | |]
173 | 
174 | disallowGenericCoercion :: Text
175 | disallowGenericCoercion =
176 |   [r|
177 | data List a
178 |   = Cons a (List a)
179 |   | Empty
180 | 
181 | add :: Int -> Int -> Int
182 | add a b = a + b
183 | 
184 | main :: a -> b -> Int
185 | main a b = add a 5
186 | |]
187 | 
188 | sumOfInts :: Text
189 | sumOfInts =
190 |   [r|
191 | data List a
192 |   = Cons a (List a)
193 |   | Empty
194 | 
195 | sum :: List Int -> Int
196 | sum l =
197 |   case l of
198 |     Cons x xs -> x + sum xs
199 |     Empty -> 0
200 | |]
201 | 
202 | recursiveList :: Text
203 | recursiveList =
204 |   [r|
205 | data List
206 |   = Cons Int List
207 |   | Empty
208 | |]
209 | 
210 | messages :: Either (NonEmpty CompileError) () -> [Text]
211 | messages r =
212 |   case r of
213 |     Right () -> []
214 |     Left errors -> NE.toList $ m <$> errors
215 |   where
216 |     m (CompileError _ _ message) = message
217 | 
218 | typeCheckerSpecs :: SpecWith ()
219 | typeCheckerSpecs =
220 |   let checkResult r =
221 |         case r of
222 |           Right m -> () <$ checkModule m
223 |           Left err -> error $ "Failed to parse module: " ++ show err
224 |    in parallel $ describe "Type checker" $ do
225 |         it "checks valid expressions" $
226 |           checkResult (parseModule valid) `shouldBe` Right ()
227 |         it "checks valid expressions that use locals" $
228 |           checkResult (parseModule local) `shouldBe` Right ()
229 |         it "checks invalid expressions" $
230 |           messages (checkResult (parseModule invalid)) `shouldBe`
231 |           [ "Function expected argument of type Int, but instead got argument of type String"
232 |           ]
233 |         it "fails if a function has an incorrect return type" $
234 |           messages (checkResult (parseModule wrongReturnType)) `shouldBe`
235 |           ["Expected foo to return type Int, but instead got type String"]
236 |         it "fails if a case has branches that return different types" $
237 |           messages (checkResult (parseModule badCase)) `shouldBe`
238 |           ["Case expression has multiple return types: String, Int"]
239 |         it "passes with a valid case" $
240 |           checkResult (parseModule goodCase) `shouldBe` Right ()
241 |         it "fails if a let has incorrect types" $
242 |           messages (checkResult (parseModule badLet)) `shouldBe`
243 |           ["No function exists with type Int + String"]
244 |         it "passes with a valid let" $
245 |           checkResult (parseModule goodLet) `shouldBe` Right ()
246 |         it "passes with a valid let that uses functions" $
247 |           checkResult (parseModule goodFunctionLet) `shouldBe` Right ()
248 |         xit "is insensitive to the order of declarations" $
249 |           checkResult (parseModule unorderedDeclarations) `shouldBe` Right ()
250 |         it "typechecks adt constructors" $
251 |           checkResult (parseModule adt) `shouldBe` Right ()
252 |         it "is permissive enough to express recurive sum on lists" $
253 |           checkResult (parseModule sumOfInts) `shouldBe` Right ()
254 |         describe "generics" $ do
255 |           it "disallows coercion of generic types" $
256 |             checkResult (parseModule disallowGenericCoercion) `shouldBe`
257 |             Left
258 |               (CompileError
259 |                  (ExpressionError
260 |                     (Language.Apply
261 |                        (Language.Identifier (Ident (NonEmptyString 'a' "dd")))
262 |                        (Language.Identifier (Ident (NonEmptyString 'a' "")))))
263 |                  Nothing
264 |                  "Function expected argument of type Int, but instead got argument of type a" :|
265 |                [])
266 |         describe "recursive types" $ do
267 |           it "typechecks types that refer to themselves" $
268 |             checkResult (parseModule recursiveList) `shouldBe` Right ()
269 | 


--------------------------------------------------------------------------------
/test/WasmSpec.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE OverloadedLists #-}
  3 | {-# LANGUAGE FlexibleInstances #-}
  4 | 
  5 | module WasmSpec
  6 |   ( wasmSpecs
  7 |   ) where
  8 | 
  9 | import Control.Monad.Trans.State.Lazy
 10 | import Data.Either
 11 | import Data.List.NonEmpty (NonEmpty(..))
 12 | import Data.Map (Map)
 13 | import qualified Data.Map as Map
 14 | import Data.Set.Ordered (OSet)
 15 | import qualified Data.Set.Ordered as OSet
 16 | import Data.Text (Text, unpack)
 17 | import qualified Data.Text as T
 18 | import System.Exit
 19 | import System.IO.Temp
 20 | import System.Process
 21 | import Test.Hspec
 22 | import Test.QuickCheck
 23 | import Text.RawString.QQ
 24 | 
 25 | import Compiler
 26 | import HaskellSyntax
 27 | import Language
 28 | import TypeChecker
 29 | import Wasm
 30 | import qualified Wasm as W
 31 | 
 32 | import Arbitrary
 33 | 
 34 | instance Testable (IO Bool) where
 35 |   property = ioProperty
 36 | 
 37 | propCodeThatTypeChecksShouldCompile :: Language.Module -> IO Bool
 38 | propCodeThatTypeChecksShouldCompile m =
 39 |   case printWasm . forestModuleToWasm <$> checkModule m of
 40 |     Right wat -> do
 41 |       path <- writeSystemTempFile "wat" (unpack wat)
 42 |       exitCode <- system $ "wat2wasm " ++ show path ++ " -o /dev/null"
 43 |       case exitCode of
 44 |         ExitSuccess -> return True
 45 |         ExitFailure _ -> do
 46 |           _ <- system "mkdir -p failures"
 47 |           writeFile "./failures/last.tree" (unpack wat)
 48 |           return False
 49 |     Left _ -> return True
 50 | 
 51 | wasmSpecs :: SpecWith ()
 52 | wasmSpecs =
 53 |   parallel $
 54 |   describe "wasm code generation" $ do
 55 |     it "generates valid wasm for any well typed module" $ do
 56 |       withMaxSuccess
 57 |         1000
 58 |         (property (forAll genModule propCodeThatTypeChecksShouldCompile))
 59 |     it "correctly generates functions that return floats" $
 60 |       let typedModule =
 61 |             TypedModule
 62 |               [ TypedDeclaration
 63 |                   (Symbol 0 $ Ident (NonEmptyString 'g' "etX"))
 64 |                   [ TADeconstruction
 65 |                       (BindingSymbol . Symbol 99 $
 66 |                        Ident (NonEmptyString 'P' "layer"))
 67 |                       (ConstructorSymbol . Symbol 0 $
 68 |                        Ident (NonEmptyString 'P' "layer"))
 69 |                       0
 70 |                       [ TAIdentifier
 71 |                           Float'
 72 |                           (Symbol 1 $ Ident (NonEmptyString 'x' ""))
 73 |                       ]
 74 |                   ]
 75 |                   OSet.empty
 76 |                   (Lambda
 77 |                      (TL (TypeLambda (Ident (NonEmptyString 'P' "layer"))))
 78 |                      Float')
 79 |                   (TypeChecker.Identifier
 80 |                      Float'
 81 |                      (Symbol 1 $ Ident (NonEmptyString 'x' ""))
 82 |                      OSet.empty)
 83 |               ]
 84 |        in forestModuleToWasm typedModule `shouldBe`
 85 |           Wasm.Module
 86 |             [ Func
 87 |                 (Wasm.Declaration
 88 |                    (Ident (NonEmptyString 'g' "etX_0"))
 89 |                    [(Ident (NonEmptyString 'P' "layer_99"), I32)]
 90 |                    F32
 91 |                    (Block
 92 |                       F32
 93 |                       (SetLocal
 94 |                          (Ident (NonEmptyString 'x' "_1"))
 95 |                          F32
 96 |                          (Call
 97 |                             (Ident (NonEmptyString 'f' "32.load"))
 98 |                             [ Call
 99 |                                 (Ident (NonEmptyString 'i' "32.add"))
100 |                                 [ GetLocal
101 |                                     (Ident (NonEmptyString 'P' "layer_99"))
102 |                                 , Const 4
103 |                                 ]
104 |                             ]) :|
105 |                        [GetLocal (Ident (NonEmptyString 'x' "_1"))])))
106 |             ]
107 |             0
108 |     describe "assignment" $ do
109 |       it "generates appropriate instructions for destructuring args" $
110 |         let input =
111 |               TADeconstruction
112 |                 (BindingSymbol . Symbol 3 $ ident "Player")
113 |                 (ConstructorSymbol . Symbol 0 $ ident "Player")
114 |                 0
115 |                 [TAIdentifier Num (Symbol 1 $ ident "x")]
116 |             expectedInstructions =
117 |               [ SetLocal
118 |                   (ident "x_1")
119 |                   I32
120 |                   (Call
121 |                      (ident "i32.load")
122 |                      [ Call
123 |                          (ident "i32.add")
124 |                          [GetLocal (ident "Player_3"), Const 4]
125 |                      ])
126 |               ]
127 |             instructions =
128 |               evalState (assignments input) (UniqueLocals Map.empty)
129 |          in instructions `shouldBe` expectedInstructions
130 |       it "generates appropriate instructions for destructuring nested args" $
131 |         let input =
132 |               TADeconstruction
133 |                 (BindingSymbol . Symbol 99 $ ident "Player")
134 |                 (ConstructorSymbol . Symbol 0 $ ident "Player")
135 |                 0
136 |                 [ TADeconstruction
137 |                     (BindingSymbol . Symbol 99 $ ident "Age")
138 |                     (ConstructorSymbol . Symbol 1 $ ident "Age")
139 |                     0
140 |                     [TAIdentifier Num (Symbol 2 $ ident "age")]
141 |                 ]
142 |             expectedInstructions =
143 |               [ SetLocal
144 |                   (ident "Age_99")
145 |                   I32
146 |                   (Call
147 |                      (ident "i32.load")
148 |                      [ Call
149 |                          (ident "i32.add")
150 |                          [GetLocal (ident "Player_99"), Const 4]
151 |                      ])
152 |               , SetLocal
153 |                   (ident "age_2")
154 |                   I32
155 |                   (Call
156 |                      (ident "i32.load")
157 |                      [ Call
158 |                          (ident "i32.add")
159 |                          [GetLocal (ident "Age_99"), Const 4]
160 |                      ])
161 |               ]
162 |             instructions =
163 |               evalState (assignments input) (UniqueLocals Map.empty)
164 |          in instructions `shouldBe` expectedInstructions
165 |       it "generates unique names for locals" $
166 |         let input =
167 |               TADeconstruction
168 |                 (BindingSymbol . Symbol 99 $ ident "Player")
169 |                 (ConstructorSymbol . Symbol 0 $ ident "Player")
170 |                 0
171 |                 [ TADeconstruction
172 |                     (BindingSymbol . Symbol 98 $ ident "Test")
173 |                     (ConstructorSymbol . Symbol 1 $ ident "Test")
174 |                     0
175 |                     [TAIdentifier Num (Symbol 2 $ ident "a")]
176 |                 , TADeconstruction
177 |                     (BindingSymbol . Symbol 97 $ ident "Test")
178 |                     (ConstructorSymbol . Symbol 1 $ ident "Test")
179 |                     0
180 |                     [TAIdentifier Num (Symbol 4 $ident "a")]
181 |                 ]
182 |             expectedInstructions =
183 |               [ SetLocal
184 |                   (ident "Test_98")
185 |                   I32
186 |                   (Call
187 |                      (ident "i32.load")
188 |                      [ Call
189 |                          (ident "i32.add")
190 |                          [GetLocal (ident "Player_99"), Const 4]
191 |                      ])
192 |               , SetLocal
193 |                   (ident "a_2")
194 |                   I32
195 |                   (Call
196 |                      (ident "i32.load")
197 |                      [ Call
198 |                          (ident "i32.add")
199 |                          [GetLocal (ident "Test_98"), Const 4]
200 |                      ])
201 |               , SetLocal
202 |                   (ident "Test_97")
203 |                   I32
204 |                   (Call
205 |                      (ident "i32.load")
206 |                      [ Call
207 |                          (ident "i32.add")
208 |                          [GetLocal (ident "Player_99"), Const 8]
209 |                      ])
210 |               , SetLocal
211 |                   (ident "a_4")
212 |                   I32
213 |                   (Call
214 |                      (ident "i32.load")
215 |                      [ Call
216 |                          (ident "i32.add")
217 |                          [GetLocal (ident "Test_97"), Const 4]
218 |                      ])
219 |               ]
220 |             instructions =
221 |               evalState (assignments input) (UniqueLocals Map.empty)
222 |          in instructions `shouldBe` expectedInstructions
223 | 


--------------------------------------------------------------------------------
/test/fixtures/case-deconstruction.tree:
--------------------------------------------------------------------------------
 1 | data Maybe a
 2 |   = Just a
 3 |   | Nothing
 4 | 
 5 | main :: Maybe Int -> Int
 6 | main m =
 7 |   case m of
 8 |     Just n -> n
 9 |     Nothing -> 0
10 | 


--------------------------------------------------------------------------------
/test/fixtures/case-statement-and-more.tree:
--------------------------------------------------------------------------------
1 | 
2 | test n =
3 |   case n of
4 |     0 -> 1
5 |     1 -> 1
6 |     n -> n
7 | 
8 | double x = x * 2
9 | 


--------------------------------------------------------------------------------
/test/fixtures/case-statement.tree:
--------------------------------------------------------------------------------
1 | 
2 | test n =
3 |   case n of
4 |     0 -> 1
5 |     1 -> 1
6 |     n -> n + 1
7 | 
8 | 


--------------------------------------------------------------------------------
/test/fixtures/deconstruction.tree:
--------------------------------------------------------------------------------
 1 | 
 2 | data Maybe a
 3 |  = Just a
 4 |  | Nothing
 5 | 
 6 | test :: Maybe Int -> Int
 7 | test m =
 8 |   case m of
 9 |     Just a -> a
10 |     Nothing -> 5
11 | 
12 | main :: Int
13 | main = test (Nothing);
14 | 


--------------------------------------------------------------------------------
/test/fixtures/let.tree:
--------------------------------------------------------------------------------
1 | a =
2 |   let
3 |     foo = 5
4 |     bar = 10
5 |   in
6 |     foo + bar
7 | 


--------------------------------------------------------------------------------
/test/fixtures/multiple-assignments.tree:
--------------------------------------------------------------------------------
1 | double a = a * 2
2 | half a = a / 2
3 | 


--------------------------------------------------------------------------------
/test/integration.rb:
--------------------------------------------------------------------------------
  1 | require 'tempfile'
  2 | 
  3 | def assert_equal(actual, expected, message)
  4 |   raise message unless actual == expected
  5 | end
  6 | 
  7 | def test(name, result)
  8 |   puts "#{name}"
  9 |   wast = `stack exec forest build ./samples/#{name}.tree`
 10 | 
 11 |   Tempfile.open("#{name}.wat") do |f|
 12 |     f.write(wast)
 13 |     f.close
 14 | 
 15 |     output = `./wasm-interp #{f.path}`
 16 | 
 17 |     exitcode = $?.exitstatus
 18 | 
 19 |     assert_equal(
 20 |       exitcode,
 21 |       result,
 22 |       "Expected #{name} to return #{result} but instead got #{exitcode}\n#{output}\n#{wast}"
 23 |     )
 24 |   end
 25 | end
 26 | 
 27 | def testCode(name, code, result)
 28 |   puts "#{name}"
 29 |   wast = nil
 30 | 
 31 |   Tempfile.open("sample.tree") do |f|
 32 |     f.write(code)
 33 |     f.close
 34 | 
 35 |     wast = `stack exec forest build #{f.path}`
 36 |   end
 37 | 
 38 |   Tempfile.open("#{name}.wat") do |f|
 39 |     f.write(wast)
 40 |     f.close
 41 | 
 42 |     output = `./wasm-interp #{f.path}`
 43 | 
 44 |     exitcode = $?.exitstatus
 45 | 
 46 |     assert_equal(
 47 |       exitcode,
 48 |       result,
 49 |       "Expected #{name} to return #{result} but instead got #{exitcode}\n#{output}\n#{wast}"
 50 |     )
 51 |   end
 52 | end
 53 | 
 54 | def run_tests
 55 |   test('fib', 89)
 56 |   test('let', 15)
 57 | 
 58 |   code = <<~FOREST
 59 |     main :: Int
 60 |     main =
 61 |       let
 62 |         add1 :: Int -> Int
 63 |         add1 n = n + 1
 64 | 
 65 |         y :: Int
 66 |         y = 10
 67 |       in
 68 |         y + add1 5
 69 |   FOREST
 70 | 
 71 |   testCode('complex_let', code, 16)
 72 | 
 73 |   code = <<~FOREST
 74 |     main :: Int
 75 |     main =
 76 |       let
 77 |         doubleSum :: Int -> Int -> Int
 78 |         doubleSum a b =
 79 |           let
 80 |             double :: Int -> Int
 81 |             double n = n * 2
 82 |           in
 83 |             (double a) + (double b)
 84 |       in
 85 |         doubleSum 5 10
 86 |   FOREST
 87 | 
 88 |   testCode('nested_let', code, 5 * 2 + 10 * 2)
 89 | 
 90 |   code = <<~FOREST
 91 |     test :: Int -> Int
 92 |     test a =
 93 |       case 5 of
 94 |         5 ->
 95 |           let
 96 |             double :: Int -> Int
 97 |             double n = n * 2
 98 |           in
 99 |             (double 2) + (double 2)
100 |         a -> 10
101 | 
102 |     main :: Int
103 |     main =
104 |       test 5
105 |   FOREST
106 | 
107 |   testCode('case_let', code, 8)
108 | 
109 |   code = <<~FOREST
110 |     data Maybe a
111 |       = Just a
112 |       | Nothing
113 | 
114 |     test :: Maybe Int -> Int
115 |     test m =
116 |       case m of
117 |         Just a -> a
118 |         Nothing -> 5
119 | 
120 |     main :: Int
121 |     main = test (Nothing)
122 |   FOREST
123 | 
124 |   testCode('deconstruction_nothing', code, 5)
125 | 
126 |   code = <<~FOREST
127 |     data Maybe a
128 |       = Just a
129 |       | Nothing
130 | 
131 |     test :: Maybe Int -> Int
132 |     test m =
133 |       case m of
134 |         Just a -> a
135 |         Nothing -> 5
136 | 
137 |     main :: Int
138 |     main = test (Just 10)
139 |   FOREST
140 | 
141 |   testCode('case_declaration_just', code, 10)
142 | 
143 |   code = <<~FOREST
144 |     data List
145 |       = Cons Int List
146 |       | Empty
147 | 
148 |     sum :: List -> Int
149 |     sum l =
150 |       case l of
151 |         Cons x xs -> x + sum xs
152 |         Empty -> 0
153 | 
154 |     main :: Int
155 |     main = sum (Cons 5 Empty)
156 |   FOREST
157 | 
158 |   testCode('sum_int_fold', code, 5)
159 | 
160 |   code = <<~FOREST
161 |     data List a
162 |       = Cons a (List a)
163 |       | Empty
164 | 
165 |     sum :: List Int -> Int
166 |     sum l =
167 |       case l of
168 |         Cons x xs -> x + sum xs
169 |         Empty -> 0
170 | 
171 |     main :: Int
172 |     main = sum (Cons 5 (Cons 10 Empty))
173 |   FOREST
174 | 
175 |   testCode('generic_list_sum_fold', code, 15)
176 | 
177 |   code = <<~FOREST
178 |     data Player
179 |       = Player Int Int
180 | 
181 |     getX :: Player -> Int
182 |     getX (Player x y) = x
183 | 
184 |     main :: Int
185 |     main = getX (Player 30 20)
186 |   FOREST
187 | 
188 |   testCode('adt_deconstruction_function', code, 30)
189 | 
190 |   code = <<~FOREST
191 |     main :: Float
192 |     main = 5.0 / 2.0 * 4.0
193 |   FOREST
194 | 
195 |   testCode('float_infix_ops', code, 10)
196 | 
197 |   code = <<~FOREST
198 |     data Player
199 |       = Player Float Float
200 | 
201 |     getX :: Player -> Float
202 |     getX (Player x y) = x
203 | 
204 |     main :: Float
205 |     main = getX (Player 30.0 20.0)
206 |   FOREST
207 | 
208 |   testCode('adt_deconstruction_float', code, 30)
209 | 
210 |   code = <<~FOREST
211 |     data Vector2
212 |       = Vector2 Float Float
213 | 
214 |     data Player
215 |       = Player Vector2
216 | 
217 |     getX :: Player -> Float
218 |     getX (Player (Vector2 x y)) = x
219 | 
220 |     main :: Float
221 |     main = getX (Player (Vector2 30.0 20.0))
222 |   FOREST
223 | 
224 |   testCode('nested_deconstruction', code, 30)
225 | 
226 |   code = <<~FOREST
227 |     main :: Int
228 |     main =
229 |       let
230 |         a :: Int
231 |         a = 5
232 | 
233 |         calc :: Int -> Int
234 |         calc n = n + a
235 |       in
236 |         calc 7
237 |   FOREST
238 | 
239 |   testCode('closure', code, 12)
240 | 
241 |   puts 'Integration tests ran successfully!'
242 | end
243 | 
244 | run_tests
245 | 


--------------------------------------------------------------------------------
/test/samples/invalid/incomplete_definition.tree:
--------------------------------------------------------------------------------
1 | 
2 | a :: Int
3 | a =
4 | 


--------------------------------------------------------------------------------
/test/samples/invalid/mistyped_argument_deconstruction.tree:
--------------------------------------------------------------------------------
1 | data Player
2 |   = Player String Int
3 | 
4 | main :: Player -> Int
5 | main (Player x y) =
6 |   x
7 | 


--------------------------------------------------------------------------------
/test/samples/valid/argument_deconstruction.tree:
--------------------------------------------------------------------------------
 1 | data Player
 2 |   = Player Int Int
 3 | 
 4 | x :: Player -> Int
 5 | x (Player px py) =
 6 |   px
 7 | 
 8 | main :: Int
 9 | main = x (Player 50 10)
10 | 


--------------------------------------------------------------------------------
/test/samples/valid/float.tree:
--------------------------------------------------------------------------------
1 | 
2 | main :: Float
3 | main = 0.5
4 | 
5 | 


--------------------------------------------------------------------------------
/test/samples/valid/list.tree:
--------------------------------------------------------------------------------
 1 | add :: Int -> Int -> Int
 2 | add a b = a + b
 3 | 
 4 | data List a
 5 |   = Cons a (List a)
 6 |   | Empty
 7 | 
 8 | fib :: List Int
 9 | fib = Cons 1 (Cons 1 (Cons 2 (Cons 3 (Cons 5 (Cons 8 Empty)))))
10 | 
11 | map :: (a -> b) -> List a -> List b
12 | map f list =
13 |   case list of
14 |     Cons x xs -> Cons (f x) (map f xs)
15 |     Empty -> Empty
16 | 
17 | test :: List Int
18 | test = map (add 5) (Cons 1 Empty)
19 | 
20 | doubledFib :: List Int
21 | doubledFib =
22 |   let
23 |     double :: Int -> Int
24 |     double n = n * 2
25 |   in
26 |     map double fib
27 | 
28 | foldl :: (a -> a -> a) -> a -> List a -> a
29 | foldl f acc list =
30 |   case list of
31 |     Cons x xs -> foldl f (f acc x) xs
32 |     Empty -> acc
33 | 
34 | sum :: List Int -> Int
35 | sum = foldl add 0
36 | 
37 | data NonEmptyList a
38 |   = NonEmptyList a (List a)
39 | 
40 | main :: NonEmptyList String
41 | main = NonEmptyList "foo" (Cons "bar" Empty)
42 | 
43 | data Maybe a
44 |   = Just a
45 |   | Nothing
46 | 
47 | fromList :: List a -> Maybe (NonEmptyList a)
48 | fromList l =
49 |   case l of
50 |     Cons x xs -> Just (NonEmptyList x xs)
51 |     Empty -> Nothing
52 | 
53 | 


--------------------------------------------------------------------------------
/test/samples/valid/nested_deconstruction.tree:
--------------------------------------------------------------------------------
 1 | data Vector2
 2 |   = Vector2 Float Float
 3 | 
 4 | data Player
 5 |   = Player Vector2 Vector2
 6 | 
 7 | getX :: Player -> Float
 8 | getX (Player (Vector2 x y) (Vector2 vx vy)) =
 9 |   x
10 | 
11 | main :: Float
12 | main =
13 |   getX (Player (Vector2 30.0 20.0) (Vector2 0.0 0.0))
14 | 
15 | 


--------------------------------------------------------------------------------
/test/samples/valid/result.tree:
--------------------------------------------------------------------------------
 1 | data Result error value
 2 |   = Err error
 3 |   | Ok value
 4 | 
 5 | data Maybe a
 6 |   = Just a
 7 |   | Nothing
 8 | 
 9 | map :: (a -> b) -> Result e a -> Result e b
10 | map f result =
11 |     case result of
12 |       Ok  v -> Ok (f v)
13 |       Err e -> Err e
14 | 
15 | andThen :: Result e a -> (a -> Result e b) -> Result e b
16 | andThen result callback =
17 |     case result of
18 |       Ok value -> callback value
19 |       Err msg -> Err msg
20 | 
21 | formatError :: (e -> fe) -> Result e a -> Result fe a
22 | formatError f result =
23 |     case result of
24 |       Ok  v -> Ok v
25 |       Err e -> Err (f e)
26 | 
27 | toMaybe :: Result e a -> Maybe a
28 | toMaybe result =
29 |     case result of
30 |       Ok  v -> Just v
31 |       Err err -> Nothing
32 | 
33 | fromMaybe :: e -> Maybe a -> Result e a
34 | fromMaybe err maybe =
35 |     case maybe of
36 |       Just v  -> Ok v
37 |       Nothing -> Err err
38 | 


--------------------------------------------------------------------------------
/test/samples/valid/simple_int_defintion.tree:
--------------------------------------------------------------------------------
1 | a :: Int
2 | a = 1
3 | 


--------------------------------------------------------------------------------
/test/samples/valid/simple_string_definition.tree:
--------------------------------------------------------------------------------
1 | a :: String
2 | a = "test"
3 | 
4 | 


--------------------------------------------------------------------------------
/wasm-interp:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env node
 2 | const childProcess = require('child_process');
 3 | const process = require('process');
 4 | const file = process.argv[2];
 5 | 
 6 | let wasm = require('fs').readFileSync(file);
 7 | 
 8 | const wasmMagic = Buffer.from([0x00, 0x61, 0x73, 0x6d]);
 9 | 
10 | if (wasm.slice(0,4).compare(wasmMagic) !== 0) {
11 |   childProcess.execSync(`wat2wasm ${file} -o /tmp/output.wasm`);
12 |   wasm = require('fs').readFileSync('/tmp/output.wasm');
13 | }
14 | 
15 | WebAssembly.instantiate(wasm).then(m => {
16 |   const result = m.instance.exports.main();
17 | 
18 |   if (process.argv.includes("--debug")) {
19 |     console.log('Result of main():', result);
20 |     console.log('Memory layout after run (first 32 i32s):');
21 |     console.log(
22 |       Array.from(
23 |         new Uint32Array(m.instance.exports.memory.buffer)
24 |       ).slice(0, 32).join(' ')
25 |     );
26 |   }
27 | 
28 |   process.exit(result);
29 | });
30 | 


--------------------------------------------------------------------------------
/wasm-server:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env node
 2 | const http = require('http');
 3 | const fs = require('fs');
 4 | const path = require('path');
 5 | 
 6 | const proxy = http.createServer((req, res) => {
 7 |   console.log(req.url);
 8 |   const p = path.join('.', req.url);
 9 | 
10 |   try {
11 |     if (p.endsWith('.wasm')) {
12 |       res.setHeader("Content-Type", "application/wasm")
13 |     }
14 |     if (p.endsWith('.js')) {
15 |       res.setHeader("Content-Type", "application/javascript")
16 |     }
17 |     res.write(fs.readFileSync(p));
18 |   } catch (e) {
19 |     res.write(e.toString());
20 |   }
21 |   res.end();
22 | });
23 | 
24 | console.log('Listening on localhost:1337');
25 | proxy.listen(1337, '127.0.0.1');
26 | 


--------------------------------------------------------------------------------