├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── compiler └── Main.hs ├── examples ├── Main.hs ├── ex1.out ├── ex1.src ├── ex2.out ├── ex2.src ├── ex3.out └── ex3.src ├── sized-hkts.cabal ├── src ├── Check │ ├── Datatype.hs │ ├── Entailment.hs │ ├── Function.hs │ ├── Kind.hs │ ├── TCState.hs │ ├── TCState │ │ └── FilterTypes.hs │ └── Type.hs ├── Codegen.hs ├── Codegen │ └── C.hs ├── Compile.hs ├── Error │ └── TypeError.hs ├── IR.hs ├── Parser.hs ├── Size.hs ├── Size │ └── Builtins.hs ├── Syntax.hs └── Unify │ ├── KMeta.hs │ ├── Kind.hs │ ├── TMeta.hs │ └── Type.hs └── test ├── Main.hs └── Test └── Parser.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for sized-hkts 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Isaac Elliott 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Isaac Elliott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `sized-hkts` 2 | 3 | A compiler that implements statically-sized higher-kinded types ala Rust. 4 | 5 | See the companion article [here](https://blog.ielliott.io/sized-hkts). 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: git@github.com:LightAndLight/sage.git 6 | 7 | source-repository-package 8 | type: git 9 | location: git@github.com:LightAndLight/diagnostica.git 10 | 11 | source-repository-package 12 | type: git 13 | location: git@github.com:LightAndLight/diagnostica-sage.git -------------------------------------------------------------------------------- /compiler/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Text as Text (pack) 4 | import qualified Data.Text.IO as Text (readFile) 5 | import qualified Data.Text.Lazy.IO as Lazy 6 | import System.Environment (getArgs) 7 | import System.Exit (exitFailure, exitSuccess) 8 | 9 | import Codegen.C (prettyCDecls) 10 | import Compile (parseAndCompile) 11 | 12 | main :: IO () 13 | main = do 14 | file:_ <- getArgs 15 | contents <- Text.readFile file 16 | case parseAndCompile (Text.pack file) contents of 17 | Left err -> do 18 | Lazy.putStrLn err 19 | exitFailure 20 | Right res -> do 21 | print $ prettyCDecls res 22 | exitSuccess 23 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (when) 4 | import Data.Foldable (for_) 5 | import qualified Data.Text as Text (pack) 6 | import qualified Data.Text.IO as Text (readFile) 7 | import qualified Data.Text.Lazy.IO as Lazy (writeFile) 8 | import qualified System.Directory as Directory 9 | import System.FilePath ((<.>)) 10 | import qualified System.FilePath as FilePath 11 | import qualified Text.PrettyPrint.Leijen.Text as Pretty 12 | 13 | import qualified Codegen.C as C 14 | import qualified Compile 15 | 16 | main :: IO () 17 | main = 18 | let 19 | examplesDir = "examples" 20 | in 21 | Directory.withCurrentDirectory examplesDir $ do 22 | files <- Directory.listDirectory "." 23 | for_ files $ \file -> 24 | case FilePath.takeExtension file of 25 | ".out" -> Directory.removeFile file 26 | ".src" -> do 27 | contents <- Text.readFile file 28 | let 29 | output = 30 | case Compile.parseAndCompile (Text.pack file) contents of 31 | Left err -> err 32 | Right res -> Pretty.displayT $ Pretty.renderPretty 1.0 100 (C.prettyCDecls res) 33 | Lazy.writeFile (FilePath.dropExtension file <.> "out") output 34 | _ -> pure () 35 | -------------------------------------------------------------------------------- /examples/ex1.out: -------------------------------------------------------------------------------- 1 | #include "stdlib.h" 2 | #include "stdint.h" 3 | #include "stdbool.h" 4 | #include "alloca.h" 5 | 6 | typedef struct List_TInt32_t List_TInt32_t; 7 | 8 | struct List_TInt32_t { 9 | uint8_t tag; 10 | union { 11 | struct { } Nil; 12 | struct { int32_t _0; List_TInt32_t * _1; } Cons; 13 | } data; 14 | }; 15 | 16 | List_TInt32_t make_Nil_TInt32() { 17 | List_TInt32_t __0 = {0, {.Nil = {}}}; 18 | return __0; 19 | } 20 | 21 | List_TInt32_t make_Cons_TInt32(int32_t __1, List_TInt32_t * __2) { 22 | List_TInt32_t __3 = {1, {.Cons = {__1, __2}}}; 23 | return __3; 24 | } 25 | 26 | List_TInt32_t mapList_TInt32_TInt32(int32_t(*f)(int32_t), List_TInt32_t xs) { 27 | List_TInt32_t __6 = xs; 28 | List_TInt32_t __7; 29 | if (__6.tag == 0) { 30 | __7 = make_Nil_TInt32(); 31 | }; 32 | if (__6.tag == 1) { 33 | List_TInt32_t * __8 = (List_TInt32_t *)malloc(13); 34 | *__8 = mapList_TInt32_TInt32(f, *__6.data.Cons._1); 35 | __7 = make_Cons_TInt32(f(__6.data.Cons._0), __8); 36 | }; 37 | return __7; 38 | } 39 | 40 | int32_t plusTen(int32_t x) { 41 | return x + 10; 42 | } 43 | 44 | int32_t main() { 45 | List_TInt32_t a = make_Nil_TInt32(); 46 | List_TInt32_t * __4 = (List_TInt32_t *)malloc(13); 47 | *__4 = a; 48 | List_TInt32_t b = make_Cons_TInt32(0, __4); 49 | List_TInt32_t * __5 = (List_TInt32_t *)malloc(13); 50 | *__5 = b; 51 | List_TInt32_t c = make_Cons_TInt32(1, __5); 52 | List_TInt32_t __9 = mapList_TInt32_TInt32(plusTen, c); 53 | int32_t __10; 54 | if (__9.tag == 0) { 55 | __10 = 0; 56 | }; 57 | if (__9.tag == 1) { 58 | __10 = __9.data.Cons._0; 59 | }; 60 | return __10; 61 | } -------------------------------------------------------------------------------- /examples/ex1.src: -------------------------------------------------------------------------------- 1 | enum List a { Nil(), Cons(a, ptr (List a)) } 2 | 3 | fn mapList(f: fun(a) b, xs: List a) -> List b { 4 | match xs { 5 | Nil() => Nil(), 6 | Cons(x, rest) => Cons(f(x), new[mapList(f, *rest)]) 7 | } 8 | } 9 | 10 | fn plusTen(x: int32) -> int32 { 11 | x + 10 12 | } 13 | 14 | fn main() -> int32 { 15 | let 16 | a = Nil(); 17 | b = Cons(0, new[a]); 18 | c = Cons(1, new[b]) 19 | in 20 | match mapList(plusTen, c) { 21 | Nil() => 0, 22 | Cons(x, xs) => x 23 | } 24 | } -------------------------------------------------------------------------------- /examples/ex2.out: -------------------------------------------------------------------------------- 1 | #include "stdlib.h" 2 | #include "stdint.h" 3 | #include "stdbool.h" 4 | #include "alloca.h" 5 | 6 | typedef struct Maybe_TInt32_t Maybe_TInt32_t; 7 | 8 | struct Maybe_TInt32_t { 9 | uint8_t tag; 10 | union { 11 | struct { } Nothing; 12 | struct { int32_t _0; } Just; 13 | } data; 14 | }; 15 | 16 | typedef struct ListF_Maybe_TInt32_t ListF_Maybe_TInt32_t; 17 | 18 | struct ListF_Maybe_TInt32_t { 19 | uint8_t tag; 20 | union { 21 | struct { } Nil; 22 | struct { Maybe_TInt32_t _0; ListF_Maybe_TInt32_t * _1; } Cons; 23 | } data; 24 | }; 25 | 26 | ListF_Maybe_TInt32_t make_Nil_Maybe_TInt32() { 27 | ListF_Maybe_TInt32_t __0 = {0, {.Nil = {}}}; 28 | return __0; 29 | } 30 | 31 | ListF_Maybe_TInt32_t make_Cons_Maybe_TInt32(Maybe_TInt32_t __1, ListF_Maybe_TInt32_t * __2) { 32 | ListF_Maybe_TInt32_t __3 = {1, {.Cons = {__1, __2}}}; 33 | return __3; 34 | } 35 | 36 | Maybe_TInt32_t make_Nothing_TInt32() { 37 | Maybe_TInt32_t __4 = {0, {.Nothing = {}}}; 38 | return __4; 39 | } 40 | 41 | Maybe_TInt32_t make_Just_TInt32(int32_t __6) { 42 | Maybe_TInt32_t __7 = {1, {.Just = {__6}}}; 43 | return __7; 44 | } 45 | 46 | typedef struct Identity_TInt32_t Identity_TInt32_t; 47 | 48 | struct Identity_TInt32_t { 49 | int32_t _0; 50 | }; 51 | 52 | typedef struct ListF_Identity_TInt32_t ListF_Identity_TInt32_t; 53 | 54 | struct ListF_Identity_TInt32_t { 55 | uint8_t tag; 56 | union { 57 | struct { } Nil; 58 | struct { Identity_TInt32_t _0; ListF_Identity_TInt32_t * _1; } Cons; 59 | } data; 60 | }; 61 | 62 | typedef struct Maybe_TAppTAppListFIdentityTInt32_t Maybe_TAppTAppListFIdentityTInt32_t; 63 | 64 | struct Maybe_TAppTAppListFIdentityTInt32_t { 65 | uint8_t tag; 66 | union { 67 | struct { } Nothing; 68 | struct { ListF_Identity_TInt32_t _0; } Just; 69 | } data; 70 | }; 71 | 72 | Maybe_TAppTAppListFIdentityTInt32_t make_Just_TAppTAppListFIdentityTInt32(ListF_Identity_TInt32_t __11) { 73 | Maybe_TAppTAppListFIdentityTInt32_t __12 = {1, {.Just = {__11}}}; 74 | return __12; 75 | } 76 | 77 | ListF_Identity_TInt32_t make_Nil_Identity_TInt32() { 78 | ListF_Identity_TInt32_t __13 = {0, {.Nil = {}}}; 79 | return __13; 80 | } 81 | 82 | Maybe_TAppTAppListFIdentityTInt32_t make_Nothing_TAppTAppListFIdentityTInt32() { 83 | Maybe_TAppTAppListFIdentityTInt32_t __16 = {0, {.Nothing = {}}}; 84 | return __16; 85 | } 86 | 87 | ListF_Identity_TInt32_t make_Cons_Identity_TInt32(Identity_TInt32_t __19, ListF_Identity_TInt32_t * __20) { 88 | ListF_Identity_TInt32_t __21 = {1, {.Cons = {__19, __20}}}; 89 | return __21; 90 | } 91 | 92 | Identity_TInt32_t make_Identity_TInt32(int32_t __22) { 93 | Identity_TInt32_t __23 = {__22}; 94 | return __23; 95 | } 96 | 97 | Maybe_TAppTAppListFIdentityTInt32_t validate_TInt32(ListF_Maybe_TInt32_t xs) { 98 | ListF_Maybe_TInt32_t __9 = xs; 99 | Maybe_TAppTAppListFIdentityTInt32_t __10; 100 | if (__9.tag == 0) { 101 | __10 = make_Just_TAppTAppListFIdentityTInt32(make_Nil_Identity_TInt32()); 102 | }; 103 | if (__9.tag == 1) { 104 | Maybe_TInt32_t __14 = __9.data.Cons._0; 105 | Maybe_TAppTAppListFIdentityTInt32_t __15; 106 | if (__14.tag == 0) { 107 | __15 = make_Nothing_TAppTAppListFIdentityTInt32(); 108 | }; 109 | if (__14.tag == 1) { 110 | Maybe_TAppTAppListFIdentityTInt32_t __17 = validate_TInt32(*__9.data.Cons._1); 111 | Maybe_TAppTAppListFIdentityTInt32_t __18; 112 | if (__17.tag == 0) { 113 | __18 = make_Nothing_TAppTAppListFIdentityTInt32(); 114 | }; 115 | if (__17.tag == 1) { 116 | ListF_Identity_TInt32_t * __24 = (ListF_Identity_TInt32_t *)malloc(13); 117 | *__24 = __17.data.Just._0; 118 | __18 = make_Just_TAppTAppListFIdentityTInt32(make_Cons_Identity_TInt32(make_Identity_TInt32(__14.data.Just._0), __24)); 119 | }; 120 | __15 = __18; 121 | }; 122 | __10 = __15; 123 | }; 124 | return __10; 125 | } 126 | 127 | int32_t main() { 128 | ListF_Maybe_TInt32_t a = make_Nil_Maybe_TInt32(); 129 | ListF_Maybe_TInt32_t * __5 = (ListF_Maybe_TInt32_t *)malloc(14); 130 | *__5 = a; 131 | ListF_Maybe_TInt32_t b = make_Cons_Maybe_TInt32(make_Nothing_TInt32(), __5); 132 | ListF_Maybe_TInt32_t * __8 = (ListF_Maybe_TInt32_t *)malloc(14); 133 | *__8 = b; 134 | ListF_Maybe_TInt32_t c = make_Cons_Maybe_TInt32(make_Just_TInt32(1), __8); 135 | Maybe_TAppTAppListFIdentityTInt32_t __25 = validate_TInt32(c); 136 | int32_t __26; 137 | if (__25.tag == 0) { 138 | __26 = 11; 139 | }; 140 | if (__25.tag == 1) { 141 | ListF_Identity_TInt32_t __27 = __25.data.Just._0; 142 | int32_t __28; 143 | if (__27.tag == 0) { 144 | __28 = 22; 145 | }; 146 | if (__27.tag == 1) { 147 | __28 = __27.data.Cons._0._0; 148 | }; 149 | __26 = __28; 150 | }; 151 | return __26; 152 | } -------------------------------------------------------------------------------- /examples/ex2.src: -------------------------------------------------------------------------------- 1 | enum ListF f a { Nil(), Cons(f a, ptr (ListF f a)) } 2 | enum Maybe a { Nothing(), Just(a) } 3 | struct Identity a = Identity(a) 4 | 5 | fn validate(xs: ListF Maybe a) -> Maybe (ListF Identity a) { 6 | match xs { 7 | Nil() => Just(Nil()), 8 | Cons(mx, rest) => match mx { 9 | Nothing() => Nothing(), 10 | Just(x) => match validate(*rest) { 11 | Nothing() => Nothing(), 12 | Just(nextRest) => Just(Cons(Identity(x), new[nextRest])) 13 | } 14 | } 15 | } 16 | } 17 | 18 | fn main() -> int32 { 19 | let 20 | a = Nil(); 21 | b = Cons(Nothing(), new[a]); 22 | c = Cons(Just(1), new[b]) 23 | in 24 | match validate(c) { 25 | Nothing() => 11, 26 | Just(xs) => match xs { 27 | Nil() => 22, 28 | Cons(x, rest) => x.0 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /examples/ex3.out: -------------------------------------------------------------------------------- 1 | #include "stdlib.h" 2 | #include "stdint.h" 3 | #include "stdbool.h" 4 | #include "alloca.h" 5 | 6 | typedef struct Maybe_TInt32_t Maybe_TInt32_t; 7 | 8 | struct Maybe_TInt32_t { 9 | uint8_t tag; 10 | union { 11 | struct { } Nothing; 12 | struct { int32_t _0; } Just; 13 | } data; 14 | }; 15 | 16 | typedef struct ListF_Maybe_TInt32_t ListF_Maybe_TInt32_t; 17 | 18 | struct ListF_Maybe_TInt32_t { 19 | uint8_t tag; 20 | union { 21 | struct { } Nil; 22 | struct { Maybe_TInt32_t _0; ListF_Maybe_TInt32_t * _1; } Cons; 23 | } data; 24 | }; 25 | 26 | ListF_Maybe_TInt32_t make_Nil_Maybe_TInt32() { 27 | ListF_Maybe_TInt32_t __0 = {0, {.Nil = {}}}; 28 | return __0; 29 | } 30 | 31 | ListF_Maybe_TInt32_t make_Cons_Maybe_TInt32(Maybe_TInt32_t __1, ListF_Maybe_TInt32_t * __2) { 32 | ListF_Maybe_TInt32_t __3 = {1, {.Cons = {__1, __2}}}; 33 | return __3; 34 | } 35 | 36 | Maybe_TInt32_t make_Just_TInt32(int32_t __4) { 37 | Maybe_TInt32_t __5 = {1, {.Just = {__4}}}; 38 | return __5; 39 | } 40 | 41 | typedef struct Identity_TInt32_t Identity_TInt32_t; 42 | 43 | struct Identity_TInt32_t { 44 | int32_t _0; 45 | }; 46 | 47 | typedef struct ListF_Identity_TInt32_t ListF_Identity_TInt32_t; 48 | 49 | struct ListF_Identity_TInt32_t { 50 | uint8_t tag; 51 | union { 52 | struct { } Nil; 53 | struct { Identity_TInt32_t _0; ListF_Identity_TInt32_t * _1; } Cons; 54 | } data; 55 | }; 56 | 57 | typedef struct Maybe_TAppTAppListFIdentityTInt32_t Maybe_TAppTAppListFIdentityTInt32_t; 58 | 59 | struct Maybe_TAppTAppListFIdentityTInt32_t { 60 | uint8_t tag; 61 | union { 62 | struct { } Nothing; 63 | struct { ListF_Identity_TInt32_t _0; } Just; 64 | } data; 65 | }; 66 | 67 | Maybe_TAppTAppListFIdentityTInt32_t make_Just_TAppTAppListFIdentityTInt32(ListF_Identity_TInt32_t __10) { 68 | Maybe_TAppTAppListFIdentityTInt32_t __11 = {1, {.Just = {__10}}}; 69 | return __11; 70 | } 71 | 72 | ListF_Identity_TInt32_t make_Nil_Identity_TInt32() { 73 | ListF_Identity_TInt32_t __12 = {0, {.Nil = {}}}; 74 | return __12; 75 | } 76 | 77 | Maybe_TAppTAppListFIdentityTInt32_t make_Nothing_TAppTAppListFIdentityTInt32() { 78 | Maybe_TAppTAppListFIdentityTInt32_t __15 = {0, {.Nothing = {}}}; 79 | return __15; 80 | } 81 | 82 | ListF_Identity_TInt32_t make_Cons_Identity_TInt32(Identity_TInt32_t __18, ListF_Identity_TInt32_t * __19) { 83 | ListF_Identity_TInt32_t __20 = {1, {.Cons = {__18, __19}}}; 84 | return __20; 85 | } 86 | 87 | Identity_TInt32_t make_Identity_TInt32(int32_t __21) { 88 | Identity_TInt32_t __22 = {__21}; 89 | return __22; 90 | } 91 | 92 | Maybe_TAppTAppListFIdentityTInt32_t validate_TInt32(ListF_Maybe_TInt32_t xs) { 93 | ListF_Maybe_TInt32_t __8 = xs; 94 | Maybe_TAppTAppListFIdentityTInt32_t __9; 95 | if (__8.tag == 0) { 96 | __9 = make_Just_TAppTAppListFIdentityTInt32(make_Nil_Identity_TInt32()); 97 | }; 98 | if (__8.tag == 1) { 99 | Maybe_TInt32_t __13 = __8.data.Cons._0; 100 | Maybe_TAppTAppListFIdentityTInt32_t __14; 101 | if (__13.tag == 0) { 102 | __14 = make_Nothing_TAppTAppListFIdentityTInt32(); 103 | }; 104 | if (__13.tag == 1) { 105 | Maybe_TAppTAppListFIdentityTInt32_t __16 = validate_TInt32(*__8.data.Cons._1); 106 | Maybe_TAppTAppListFIdentityTInt32_t __17; 107 | if (__16.tag == 0) { 108 | __17 = make_Nothing_TAppTAppListFIdentityTInt32(); 109 | }; 110 | if (__16.tag == 1) { 111 | ListF_Identity_TInt32_t * __23 = (ListF_Identity_TInt32_t *)malloc(13); 112 | *__23 = __16.data.Just._0; 113 | __17 = make_Just_TAppTAppListFIdentityTInt32(make_Cons_Identity_TInt32(make_Identity_TInt32(__13.data.Just._0), __23)); 114 | }; 115 | __14 = __17; 116 | }; 117 | __9 = __14; 118 | }; 119 | return __9; 120 | } 121 | 122 | int32_t main() { 123 | ListF_Maybe_TInt32_t a = make_Nil_Maybe_TInt32(); 124 | ListF_Maybe_TInt32_t * __6 = (ListF_Maybe_TInt32_t *)malloc(14); 125 | *__6 = a; 126 | ListF_Maybe_TInt32_t b = make_Cons_Maybe_TInt32(make_Just_TInt32(2), __6); 127 | ListF_Maybe_TInt32_t * __7 = (ListF_Maybe_TInt32_t *)malloc(14); 128 | *__7 = b; 129 | ListF_Maybe_TInt32_t c = make_Cons_Maybe_TInt32(make_Just_TInt32(1), __7); 130 | Maybe_TAppTAppListFIdentityTInt32_t __24 = validate_TInt32(c); 131 | int32_t __25; 132 | if (__24.tag == 0) { 133 | __25 = 11; 134 | }; 135 | if (__24.tag == 1) { 136 | ListF_Identity_TInt32_t __26 = __24.data.Just._0; 137 | int32_t __27; 138 | if (__26.tag == 0) { 139 | __27 = 22; 140 | }; 141 | if (__26.tag == 1) { 142 | __27 = __26.data.Cons._0._0; 143 | }; 144 | __25 = __27; 145 | }; 146 | return __25; 147 | } -------------------------------------------------------------------------------- /examples/ex3.src: -------------------------------------------------------------------------------- 1 | enum ListF f a { Nil(), Cons(f a, ptr (ListF f a)) } 2 | enum Maybe a { Nothing(), Just(a) } 3 | struct Identity a = Identity(a) 4 | 5 | fn validate(xs: ListF Maybe a) -> Maybe (ListF Identity a) { 6 | match xs { 7 | Nil() => Just(Nil()), 8 | Cons(mx, rest) => match mx { 9 | Nothing() => Nothing(), 10 | Just(x) => match validate(*rest) { 11 | Nothing() => Nothing(), 12 | Just(nextRest) => Just(Cons(Identity(x), new[nextRest])) 13 | } 14 | } 15 | } 16 | } 17 | 18 | fn main() -> int32 { 19 | let 20 | a = Nil(); 21 | b = Cons(Just(2), new[a]); 22 | c = Cons(Just(1), new[b]) 23 | in 24 | match validate(c) { 25 | Nothing() => 11, 26 | Just(xs) => match xs { 27 | Nil() => 22, 28 | Cons(x, rest) => x.0 29 | } 30 | } 31 | } -------------------------------------------------------------------------------- /sized-hkts.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'sized-hkts.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: sized-hkts 7 | version: 0.1.0.0 8 | synopsis: Higher-kindeded polymorphism with statically computable sizes 9 | -- description: 10 | -- bug-reports: 11 | license: BSD-3-Clause 12 | license-file: LICENSE 13 | author: Isaac Elliott 14 | maintainer: isaace71295@gmail.com 15 | -- copyright: 16 | category: Language 17 | extra-source-files: CHANGELOG.md 18 | 19 | library 20 | exposed-modules: Check.Datatype 21 | , Check.Entailment 22 | , Check.Function 23 | , Check.Kind 24 | , Check.TCState 25 | , Check.TCState.FilterTypes 26 | , Check.Type 27 | , Codegen 28 | , Codegen.C 29 | , Compile 30 | , Error.TypeError 31 | , IR 32 | , Parser 33 | , Size 34 | , Size.Builtins 35 | , Syntax 36 | , Unify.KMeta 37 | , Unify.Kind 38 | , Unify.TMeta 39 | , Unify.Type 40 | build-depends: base >=4.12.0.0 && <5 41 | , wl-pprint-text 42 | , bifunctors 43 | , bound 44 | , charset 45 | , containers >=0.6 46 | , deepseq 47 | , deriving-compat 48 | , diagnostica 49 | , diagnostica-sage 50 | , lens 51 | , mtl 52 | , primitive 53 | , sage 54 | , text 55 | , transformers 56 | , validation 57 | , vector 58 | hs-source-dirs: src 59 | default-language: Haskell2010 60 | ghc-options: -Wall -Werror 61 | 62 | executable compiler 63 | main-is: Main.hs 64 | build-depends: base >=4.12.0.0 && <5 65 | , sized-hkts 66 | , text >=1.2 67 | hs-source-dirs: compiler 68 | default-language: Haskell2010 69 | 70 | executable examples 71 | main-is: Main.hs 72 | build-depends: base >=4.12.0.0 && <5 73 | , sized-hkts 74 | , directory >=1.3 75 | , filepath >=1.4 76 | , text >=1.2 77 | , wl-pprint-text 78 | hs-source-dirs: examples 79 | default-language: Haskell2010 80 | 81 | test-suite sized-hkts-test 82 | default-language: Haskell2010 83 | type: exitcode-stdio-1.0 84 | hs-source-dirs: test 85 | main-is: Main.hs 86 | other-modules: Test.Parser 87 | build-depends: base >=4.12.0.0 && <5 88 | , sized-hkts 89 | , bound 90 | , charset 91 | , containers >= 0.6 92 | , hspec 93 | , lens 94 | , mtl 95 | , sage 96 | , text 97 | , transformers 98 | -------------------------------------------------------------------------------- /src/Check/Datatype.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language OverloadedLists, OverloadedStrings #-} 4 | {-# language PatternSynonyms #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language QuantifiedConstraints #-} 7 | module Check.Datatype 8 | ( checkADT 9 | , HasDatatypeFields(..) 10 | , getFieldType 11 | , HasDatatypeCtors(..) 12 | , getConstructor 13 | ) 14 | where 15 | 16 | import Bound (abstract) 17 | import Bound.Var (Var(..), unvar) 18 | import Control.Lens.Lens (Lens') 19 | import Control.Lens.Getter (use, uses) 20 | import Control.Monad (guard) 21 | import Control.Monad.Except (MonadError, throwError) 22 | import Control.Monad.State.Strict (MonadState) 23 | import Control.Monad.Writer (runWriter, tell) 24 | import Data.Foldable (foldlM, traverse_) 25 | import Data.Map (Map) 26 | import qualified Data.Map as Map 27 | import Data.Monoid (Any(..)) 28 | import Data.Set (Set) 29 | import qualified Data.Set as Set 30 | import Data.Text (Text) 31 | import Data.Validation (Validation(..), validation) 32 | import Data.Vector (Vector) 33 | import qualified Data.Vector as Vector 34 | import Data.Void (Void, absurd) 35 | 36 | import Check.Entailment 37 | ( HasGlobalTheory, HasSizeMetas 38 | , SMeta, Theory(..) 39 | , freshSMeta, findSMeta 40 | , globalTheory 41 | , solve 42 | ) 43 | import Check.Kind (checkKind) 44 | import Check.TCState.FilterTypes (FilterTypes) 45 | import Error.TypeError (TypeError(..)) 46 | import IR (Constraint(..), KMeta, Kind(..), substKMeta) 47 | import qualified IR 48 | import Size (Size(..), plusSize, maxSize, sizeConstraintFor) 49 | import Syntax (Index(..), indexSpan, getIndex, Span(..), Type(..), TMeta, pattern TypeM) 50 | import qualified Syntax 51 | import Unify.KMeta (HasKindMetas, freshKMeta, solveKMetas) 52 | import Unify.Kind (unifyKind) 53 | import Unify.TMeta (HasTypeMetas) 54 | 55 | class HasDatatypeFields s where 56 | datatypeFields :: Lens' s (Map Text IR.Fields) 57 | 58 | class HasDatatypeCtors s where 59 | datatypeCtors :: Lens' s (Map Text IR.Constructor) 60 | 61 | getConstructor :: 62 | ( MonadState s m, HasDatatypeCtors s 63 | , MonadError TypeError m 64 | ) => 65 | Span -> 66 | Text -> 67 | m IR.Constructor 68 | getConstructor sp ctorName = do 69 | m_ctor <- uses datatypeCtors $ Map.lookup ctorName 70 | case m_ctor of 71 | Nothing -> throwError $ CtorNotInScope sp 72 | Just ctor -> pure ctor 73 | 74 | getFieldType :: 75 | ( MonadState s m, HasDatatypeFields s 76 | , MonadError TypeError m 77 | ) => 78 | Span -> 79 | Text -> 80 | IR.Projection -> 81 | m (Maybe (Type (Var Index Void))) 82 | getFieldType sp tyName prj = do 83 | m_fs <- uses datatypeFields $ Map.lookup tyName 84 | case m_fs of 85 | Nothing -> throwError $ TNotInScope sp 86 | Just fs -> 87 | pure $ case prj of 88 | IR.Numeric ix -> 89 | case fs of 90 | IR.Unnamed fs' -> Just $ fs' Vector.! fromIntegral ix 91 | _ -> Nothing 92 | IR.Field n -> 93 | case fs of 94 | IR.Named fs' -> Map.lookup n fs' 95 | _ -> Nothing 96 | 97 | makeSizeTerm :: 98 | forall s m. 99 | ( MonadState (s (Var Index Void)) m 100 | , FilterTypes s 101 | , HasTypeMetas s 102 | , forall x. HasKindMetas (s x) 103 | , forall x. HasSizeMetas (s x) 104 | , forall x. HasGlobalTheory (s x) 105 | , MonadError TypeError m 106 | ) => 107 | Map Text Kind -> 108 | Vector Text -> 109 | Vector Kind -> 110 | Map (Constraint (Var Index Void)) SMeta -> 111 | Vector (Type (Var Index Void)) -> 112 | m (Set SMeta, Size (Either SMeta Void)) 113 | makeSizeTerm kindScope paramNames paramKinds assumedConstraints argTypes = do 114 | global <- use globalTheory 115 | let 116 | theory :: Theory (Either TMeta (Var Index Void)) 117 | theory = 118 | Theory 119 | { _thGlobal = global 120 | , _thLocal = Map.mapKeys (fmap Right) assumedConstraints 121 | } 122 | foldlM 123 | (\(usedSizeMetas, sz) a -> do 124 | sz' <- typeSizeTerm theory a 125 | pure (usedSizeMetas <> foldMap (either Set.singleton absurd) sz', plusSize sz sz') 126 | ) 127 | (mempty, Word 0) 128 | argTypes 129 | where 130 | typeSizeTerm :: 131 | Theory (Either TMeta (Var Index Void)) -> 132 | Type (Var Index Void) -> 133 | m (Size (Either SMeta Void)) 134 | typeSizeTerm theory t = do 135 | placeholder <- freshSMeta 136 | (_assumes, subs) <- 137 | solve 138 | kindScope 139 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 140 | (unvar (Right . (paramNames Vector.!) . getIndex) absurd) 141 | (unvar ((paramKinds Vector.!) . getIndex) absurd) 142 | theory 143 | [(placeholder, CSized $ Right <$> t)] 144 | pure $ findSMeta subs placeholder 145 | 146 | -- | Given some assumptions and an instance head, construct an axiom type 147 | makeSizeConstraint :: 148 | Vector Kind -> 149 | Vector (Constraint (Var Index Void)) -> 150 | Type (Var Index Void) -> 151 | Constraint Void 152 | makeSizeConstraint paramKinds as = 153 | validation (error . ("makeSizeConstraint: un-abstracted bound variable: " <>) . show) id . 154 | traverse (unvar (Failure . Set.singleton . getIndex) absurd) . 155 | go mempty (Vector.toList as) 156 | where 157 | indices :: Vector Int 158 | indices = [0..length paramKinds-1] 159 | 160 | -- attempt to abstract over the provided index not present in the set. 161 | -- if no abstraction was done, returns a Nothing. 162 | abstractVar :: 163 | Int -> 164 | Constraint (Var Index Void) -> 165 | Maybe (Constraint (Var () (Var Index Void))) 166 | abstractVar n c = 167 | let 168 | (res, abstracted) = 169 | runWriter $ do 170 | traverse 171 | (unvar 172 | (\n' -> if n == getIndex n' then B () <$ tell (Any True) else pure . F $ B n') 173 | absurd 174 | ) 175 | c 176 | in 177 | if getAny abstracted 178 | then Just res 179 | else Nothing 180 | 181 | abstractVars :: 182 | Set Int -> 183 | Constraint (Var Index Void) -> 184 | Constraint (Var Index Void) 185 | abstractVars ns c = 186 | let 187 | toAbstractOver = Vector.filter (`Set.notMember` ns) indices 188 | in 189 | foldr 190 | (\n rest -> do 191 | case abstractVar n rest of 192 | Nothing -> 193 | rest 194 | Just rest' -> 195 | CForall Nothing (paramKinds Vector.! n) rest' 196 | ) 197 | c 198 | toAbstractOver 199 | 200 | -- the aim of this function is to insert foralls as 'deeply' as possible 201 | -- e.g. `forall a. C a => forall b. C b => C (f a b)` instead of `forall a b. C a => C b => C (f a b)` 202 | go :: 203 | Set Int -> -- free variables that we've seen so far 204 | [Constraint (Var Index Void)] -> 205 | Type (Var Index Void) -> 206 | Constraint (Var Index Void) 207 | go !freeVars assumes hd = 208 | case assumes of 209 | [] -> 210 | abstractVars freeVars $ 211 | CSized hd 212 | a:rest -> 213 | let 214 | hd' = 215 | CImplies a $ 216 | go (freeVars <> foldMap (unvar (Set.singleton . getIndex) absurd) a) rest hd 217 | in 218 | abstractVars freeVars hd' 219 | 220 | -- | Check that an ADT is well formed, and return its 221 | -- * constructor declarations 222 | -- * kind 223 | -- * axiom type 224 | -- * sizeterm 225 | checkADT :: 226 | forall s m. 227 | ( MonadState (s (Var Index Void)) m 228 | , FilterTypes s 229 | , HasTypeMetas s 230 | , forall x. HasKindMetas (s x) 231 | , forall x. HasSizeMetas (s x) 232 | , forall x. HasGlobalTheory (s x) 233 | , MonadError TypeError m 234 | ) => 235 | Map Text Kind -> 236 | Text -> -- name 237 | Vector Text -> -- type parameters 238 | Syntax.Ctors (Var Index Void) -> -- constructors 239 | m (IR.Datatype, Kind, Constraint Void, Size Void) 240 | checkADT kScope datatypeName paramNames ctors = do 241 | datatypeKind <- KVar <$> freshKMeta 242 | paramMetas <- Vector.replicateM (Vector.length paramNames) freshKMeta 243 | 244 | let kindScope = Map.insert datatypeName datatypeKind kScope 245 | adtKinds kindScope paramMetas ctors 246 | 247 | ks <- traverse (solveKMetas . KVar) paramMetas 248 | let datatypeKind' = foldr KArr KType ks 249 | unifyKind {- TODO -} Unknown datatypeKind' datatypeKind 250 | datatypeKind'' <- 251 | substKMeta (const KType) <$> 252 | solveKMetas datatypeKind' 253 | 254 | sizeMetas <- Vector.replicateM (Vector.length paramNames) freshSMeta 255 | paramKinds <- traverse (fmap (substKMeta $ const KType) . solveKMetas . KVar) paramMetas 256 | let 257 | assumedConstraintsFwd :: Map (Constraint (Var Index Void)) SMeta 258 | assumedConstraintsBwd :: Map SMeta (Constraint (Var Index Void)) 259 | (assumedConstraintsFwd, assumedConstraintsBwd) = 260 | Vector.ifoldl' 261 | (\(accFwd, accBwd) ix s -> 262 | let 263 | k = paramKinds Vector.! ix 264 | c = unvar (\() -> B $ Index {- TODO -} Unknown ix) F <$> sizeConstraintFor k 265 | in 266 | ( Map.insert c s accFwd 267 | , Map.insert s c accBwd 268 | ) 269 | ) 270 | (mempty, mempty) 271 | sizeMetas 272 | 273 | (usedSizeMetas, sz) <- 274 | adtSizeTerm 275 | kindScope 276 | paramKinds 277 | assumedConstraintsFwd 278 | 0 279 | mempty 280 | (Word 0) 281 | ctors 282 | 283 | let 284 | usedConstraints :: Vector (Constraint (Var Index Void)) 285 | usedConstraints = 286 | Vector.map (assumedConstraintsBwd Map.!) $ 287 | Vector.filter (`Set.member` usedSizeMetas) sizeMetas 288 | 289 | let 290 | m_sz' = 291 | traverse 292 | (either (const Nothing) Just) 293 | (foldr 294 | (\s -> Lam . abstract (either (guard . (s ==)) (const Nothing))) 295 | sz 296 | usedSizeMetas 297 | ) 298 | case m_sz' of 299 | Nothing -> error "failed to abstract over all SMetas" 300 | Just sz' -> 301 | let 302 | namedParamKinds = Vector.zip paramNames paramKinds 303 | datatype = 304 | case Syntax.ctorsToList ctors of 305 | [] -> 306 | IR.Empty datatypeName namedParamKinds 307 | [(_, ctys)] -> 308 | IR.Struct datatypeName namedParamKinds ((,) Nothing <$> ctys) 309 | cs -> 310 | IR.Enum datatypeName namedParamKinds ((fmap.fmap) ((,) Nothing) <$> Vector.fromList cs) 311 | in 312 | pure 313 | ( datatype 314 | , IR.substKMeta (const KType) datatypeKind'' 315 | , makeSizeConstraint paramKinds usedConstraints fullyApplied 316 | , sz' 317 | ) 318 | where 319 | fullyApplied :: Type (Var Index Void) 320 | fullyApplied = 321 | Vector.foldl 322 | (\acc ix -> TApp {- TODO -} Unknown acc (TVar . B $ Index {- TODO -} Unknown ix)) 323 | (TName {- TODO -} Unknown datatypeName) 324 | [0..length paramNames - 1] 325 | 326 | adtKinds :: 327 | Map Text Kind -> 328 | Vector KMeta -> 329 | Syntax.Ctors (Var Index Void) -> -- constructors 330 | m () 331 | adtKinds kindScope paramMetas c = 332 | case c of 333 | Syntax.End -> pure () 334 | Syntax.Ctor _ctorName ctorArgs ctorRest -> do 335 | let paramKinds = KVar <$> paramMetas 336 | traverse_ 337 | (\ty -> 338 | checkKind 339 | kindScope 340 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 341 | (unvar ((paramKinds Vector.!) . getIndex) absurd) 342 | (TypeM $ Right <$> ty) 343 | KType 344 | ) 345 | ctorArgs 346 | adtKinds kindScope paramMetas ctorRest 347 | 348 | adtSizeTerm :: 349 | Map Text Kind -> 350 | Vector Kind -> 351 | Map (Constraint (Var Index Void)) SMeta -> 352 | Int -> 353 | Set SMeta -> 354 | Size (Either SMeta Void) -> 355 | Syntax.Ctors (Var Index Void) -> -- constructors 356 | m (Set SMeta, Size (Either SMeta Void)) 357 | adtSizeTerm kindScope paramKinds assumedConstraints !ctorCount !usedConstraints sz c = 358 | case c of 359 | Syntax.End -> 360 | pure $! 361 | if ctorCount > 1 362 | then (usedConstraints, plusSize (Word 1) sz) -- 1 byte tag 363 | else (usedConstraints, sz) 364 | Syntax.Ctor _ctorName ctorArgs ctorRest -> do 365 | traverse_ 366 | (\ty -> 367 | checkKind 368 | kindScope 369 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 370 | (unvar ((paramKinds Vector.!) . getIndex) absurd) 371 | (TypeM $ Right <$> ty) 372 | KType 373 | ) 374 | ctorArgs 375 | 376 | (usedConstraints', sz') <- makeSizeTerm kindScope paramNames paramKinds assumedConstraints ctorArgs 377 | adtSizeTerm 378 | kindScope 379 | paramKinds 380 | assumedConstraints 381 | (ctorCount+1) 382 | (usedConstraints <> usedConstraints') 383 | (maxSize sz sz') 384 | ctorRest 385 | -------------------------------------------------------------------------------- /src/Check/Entailment.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language FlexibleInstances, MultiParamTypeClasses #-} 4 | {-# language PatternSynonyms #-} 5 | {-# language RankNTypes #-} 6 | {-# language TemplateHaskell #-} 7 | {-# language TupleSections #-} 8 | {-# language QuantifiedConstraints #-} 9 | {-# options_ghc -fno-warn-unused-top-binds #-} 10 | module Check.Entailment 11 | ( solve 12 | , entails 13 | , simplify 14 | , SMeta(..), composeSSubs 15 | , Theory(..), theoryToList, insertLocal, mapTy 16 | , HasGlobalTheory(..) 17 | , HasSizeMetas(..) 18 | , freshSMeta 19 | , findSMeta 20 | ) 21 | where 22 | 23 | import Bound (abstract) 24 | import Bound.Var (Var(..), unvar) 25 | import Control.Applicative (empty) 26 | import Control.Lens.Getter (view, use) 27 | import Control.Lens.Lens (Lens', lens) 28 | import Control.Lens.Setter ((.~), (.=)) 29 | import Control.Lens.TH (makeLenses) 30 | import Control.Monad (guard) 31 | import Control.Monad.Except (MonadError, runExcept, throwError) 32 | import Control.Monad.State.Strict (MonadState, runStateT, get, put) 33 | import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) 34 | import Data.Bifunctor (first) 35 | import Data.Foldable (asum, foldl') 36 | import Data.Function ((&)) 37 | import Data.Map (Map) 38 | import qualified Data.Map as Map 39 | import Data.Maybe (fromMaybe) 40 | import Data.Text (Text) 41 | import Data.Void (Void, absurd) 42 | 43 | import Check.TCState.FilterTypes (FilterTypes, filterTypes, mapTypes) 44 | import Error.TypeError (TypeError(..), renderTyName) 45 | import IR (Constraint(..), Kind) 46 | import Size((.@), Size(..), pattern Var) 47 | import Syntax (TMeta(..), TMeta, pattern TypeM, Span(Unknown)) 48 | import Unify.KMeta (HasKindMetas(..)) 49 | import Unify.TMeta (HasTypeMetas(..), freshTMeta, solveMetas_Constraint) 50 | import Unify.Type (unifyType) 51 | 52 | newtype SMeta = SMeta Int 53 | deriving (Eq, Ord, Show) 54 | 55 | data Theory ty 56 | = Theory 57 | { _thGlobal :: Map (Constraint Void) (Size Void) 58 | , _thLocal :: Map (Constraint ty) SMeta 59 | } deriving Show 60 | makeLenses ''Theory 61 | 62 | theoryToList :: Theory ty -> [(Size (Either SMeta sz), Constraint ty)] 63 | theoryToList (Theory gbl lcl) = 64 | Map.foldrWithKey 65 | (\c m -> (:) (Var $ Left m, c)) 66 | (Map.foldrWithKey (\c s -> (:) (absurd <$> s, absurd <$> c)) [] gbl) 67 | lcl 68 | 69 | class HasGlobalTheory s where 70 | globalTheory :: Lens' s (Map (Constraint Void) (Size Void)) 71 | 72 | instance HasGlobalTheory (Theory ty) where 73 | globalTheory = thGlobal 74 | 75 | insertLocal :: Ord ty => Constraint ty -> SMeta -> Theory ty -> Theory ty 76 | insertLocal k v (Theory gbl lcl) = Theory gbl $! Map.insert k v lcl 77 | 78 | mapTy :: Ord ty' => (ty -> ty') -> Theory ty -> Theory ty' 79 | mapTy f (Theory gbl lcl) = Theory gbl (Map.mapKeys (fmap f) lcl) 80 | 81 | applySSubs :: 82 | Map SMeta (Size (Either SMeta sz)) -> 83 | Size (Either SMeta sz) -> 84 | Size (Either SMeta sz) 85 | applySSubs subs s = 86 | s >>= either (\m -> fromMaybe (Var $ Left m) $ Map.lookup m subs) (Var . Right) 87 | 88 | findSMeta :: 89 | Map SMeta (Size (Either SMeta sz)) -> 90 | SMeta -> 91 | Size (Either SMeta sz) 92 | findSMeta s m = 93 | case Map.lookup m s of 94 | Nothing -> Var $ Left m 95 | Just term -> term >>= either (findSMeta s) (Var . Right) 96 | 97 | composeSSubs :: 98 | Map SMeta (Size (Either SMeta sz)) -> 99 | Map SMeta (Size (Either SMeta sz)) -> 100 | Map SMeta (Size (Either SMeta sz)) 101 | composeSSubs a b = 102 | fmap (applySSubs a) b <> a 103 | 104 | class HasSizeMetas s where 105 | nextSMeta :: Lens' s SMeta 106 | 107 | freshSMeta :: (MonadState s m, HasSizeMetas s) => m SMeta 108 | freshSMeta = do 109 | SMeta t <- use nextSMeta 110 | nextSMeta .= SMeta (t+1) 111 | pure $ SMeta t 112 | 113 | withoutMetas :: (ty -> ty') -> Constraint (Either TMeta ty) -> Maybe (Constraint ty') 114 | withoutMetas f = traverse (either (const Nothing) (Just . f)) 115 | 116 | solve :: 117 | ( MonadState (s ty) m 118 | , FilterTypes s, HasTypeMetas s 119 | , forall x. HasKindMetas (s x), forall x. HasSizeMetas (s x) 120 | , MonadError TypeError m 121 | , Ord ty 122 | ) => 123 | Map Text Kind -> 124 | Lens' ty Span -> 125 | (ty -> Either Int Text) -> 126 | (ty -> Kind) -> 127 | Theory (Either TMeta ty) -> 128 | [(SMeta, Constraint (Either TMeta ty))] -> 129 | m 130 | ( [(SMeta, Constraint (Either TMeta ty))] 131 | , Map SMeta (Size (Either SMeta Void)) 132 | ) 133 | solve _ _ _ _ _ [] = pure ([], mempty) 134 | solve kindScope spans tyNames kinds theory (c:cs) = do 135 | m_res <- runMaybeT $ simplify kindScope spans tyNames kinds theory c 136 | case m_res of 137 | Nothing -> do 138 | c' <- solveMetas_Constraint (snd c) 139 | case withoutMetas (Right . renderTyName . tyNames) c' of 140 | Nothing -> do 141 | (cs', sols') <- solve kindScope spans tyNames kinds theory cs 142 | pure ((fst c, c') : cs', sols') 143 | Just c'' -> throwError $ CouldNotDeduce c'' 144 | Just (cs', sols) -> do 145 | (cs'', sols') <- solve kindScope spans tyNames kinds theory (cs' <> cs) 146 | pure (cs'', composeSSubs sols' sols) 147 | 148 | entails :: 149 | ( MonadState (s ty) m, HasKindMetas (s ty), HasTypeMetas s, HasSizeMetas (s ty) 150 | , Eq ty 151 | ) => 152 | Map Text Kind -> 153 | Lens' ty Span -> 154 | (ty -> Either Int Text) -> 155 | (ty -> Kind) -> 156 | (Size (Either SMeta sz), Constraint (Either TMeta ty)) -> 157 | (SMeta, Constraint (Either TMeta ty)) -> 158 | MaybeT m 159 | ( [(SMeta, Constraint (Either TMeta ty))] 160 | , Map SMeta (Size (Either SMeta sz)) 161 | ) 162 | entails kindScope spans tyNames kinds (antSize, ant) (consVar, cons) = 163 | case ant of 164 | -- antSize : forall (x : k). _ 165 | CForall _ k a -> do 166 | meta <- freshTMeta Unknown k 167 | entails kindScope spans tyNames kinds (antSize, unvar (\() -> Left meta) id <$> a) (consVar, cons) 168 | -- antSize : _ -> _ 169 | CImplies a b -> do 170 | bvar <- freshSMeta 171 | (bAssumes, ssubs) <- entails kindScope spans tyNames kinds (Var $ Left bvar, b) (consVar, cons) 172 | avar <- freshSMeta 173 | pure 174 | ( (avar, a) : bAssumes 175 | , composeSSubs (Map.singleton bvar $ antSize .@ Var (Left avar)) ssubs 176 | ) 177 | -- antSize : Word64 178 | CSized t -> 179 | case cons of 180 | CSized t' -> do 181 | st <- get 182 | let res = runExcept $ runStateT (unifyType kindScope spans tyNames kinds (TypeM t') (TypeM t)) st 183 | case res of 184 | Left{} -> do 185 | empty 186 | Right ((), st') -> do 187 | put st' 188 | pure ([], Map.singleton consVar antSize) 189 | _ -> error "consequent not simple enough" 190 | 191 | simplify :: 192 | ( MonadState (s ty) m 193 | , FilterTypes s, HasTypeMetas s 194 | , forall x. HasKindMetas (s x), forall x. HasSizeMetas (s x) 195 | , MonadError TypeError m 196 | , Ord ty 197 | ) => 198 | Map Text Kind -> 199 | Lens' ty Span -> 200 | (ty -> Either Int Text) -> 201 | (ty -> Kind) -> 202 | Theory (Either TMeta ty) -> 203 | (SMeta, Constraint (Either TMeta ty)) -> 204 | m 205 | ( [(SMeta, Constraint (Either TMeta ty))] 206 | , Map SMeta (Size (Either SMeta sz)) 207 | ) 208 | simplify kindScope spans tyNames kinds !theory (consVar, cons) = 209 | case cons of 210 | CForall m_n k a -> do 211 | ameta <- freshSMeta 212 | es <- get 213 | ((aAssumes, asubs), es') <- 214 | flip runStateT (mapTypes F es) $ do 215 | (aAssumes, asubs) <- 216 | simplify 217 | kindScope 218 | (lens 219 | {- TODO: what about the span for the bound variable? This is bad lens otherwise -} 220 | (unvar (\() -> Unknown) (view spans)) 221 | (unvar (\() _ -> B ()) (\t sp -> F $ t & spans .~ sp)) 222 | ) 223 | (unvar (\() -> maybe (Left 0) Right m_n) (first (+1) . tyNames)) 224 | (unvar (\() -> k) kinds) 225 | (mapTy (fmap F) theory) 226 | (ameta, sequence <$> a) 227 | -- solve metas now, because any solutions that involve skolem variables 228 | -- will be filtered out by `filterTypes` 229 | aAssumes' <- (traverse.traverse) solveMetas_Constraint aAssumes 230 | pure (aAssumes', asubs) 231 | put $ filterTypes (unvar (\() -> Nothing) Just) es' 232 | pure 233 | ( (fmap.fmap) (CForall m_n k . fmap sequence) aAssumes 234 | , Map.singleton consVar (fromMaybe (error "ameta not solved") $ Map.lookup ameta asubs) 235 | ) 236 | CImplies a b -> do 237 | ameta <- freshSMeta 238 | bmeta <- freshSMeta 239 | (bAssumes, bsubs) <- simplify kindScope spans tyNames kinds (insertLocal a ameta theory) (bmeta, b) 240 | bAssumes' <- traverse (\assume -> (, assume) <$> freshSMeta) bAssumes 241 | pure 242 | ( (\(v, (_, c)) -> (v, CImplies a c)) <$> bAssumes' 243 | , Map.singleton consVar $ 244 | Lam 245 | (abstract (either (guard . (ameta ==)) (const Nothing)) $ 246 | applySSubs 247 | (foldl' 248 | (\acc (new, (old, _)) -> 249 | Map.insert old ((Var $ Left new) .@ (Var $ Left ameta)) acc 250 | ) 251 | mempty 252 | bAssumes' 253 | ) 254 | (fromMaybe (error "bmeta not solved") $ Map.lookup bmeta bsubs) 255 | ) 256 | ) 257 | CSized{} -> do 258 | m_res <- 259 | runMaybeT . asum $ 260 | (\(antVar, ant) -> entails kindScope spans tyNames kinds (antVar, ant) (consVar, cons)) <$> 261 | theoryToList theory 262 | case m_res of 263 | Nothing -> do 264 | cons' <- solveMetas_Constraint cons 265 | throwError $ CouldNotDeduce ((fmap.fmap) (renderTyName . tyNames) cons') 266 | Just (assumes, sub) -> pure (assumes, sub) 267 | -------------------------------------------------------------------------------- /src/Check/Function.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language QuantifiedConstraints #-} 4 | module Check.Function 5 | (checkFunction) 6 | where 7 | 8 | import Bound.Var (unvar) 9 | import Control.Lens.Getter (use) 10 | import Control.Lens.Indexed (ifoldlM) 11 | import Control.Lens.Setter ((.~)) 12 | import Control.Monad.Except (MonadError) 13 | import Control.Monad.State.Strict (evalStateT) 14 | import Data.Bifunctor (first) 15 | import Data.Foldable (foldrM, traverse_) 16 | import Data.Function ((&)) 17 | import Data.Map (Map) 18 | import qualified Data.Map as Map 19 | import qualified Data.Set as Set 20 | import Data.Text (Text) 21 | import qualified Data.Vector as Vector 22 | import Data.Void (Void, absurd) 23 | 24 | import Check.Entailment (Theory(..), freshSMeta, globalTheory, solve) 25 | import Check.Datatype (datatypeCtors, datatypeFields) 26 | import Check.Kind (checkKind) 27 | import Check.TCState (emptyTCState) 28 | import Check.Type (CheckResult(..), checkExpr, requiredConstraints, zonkExprTypes) 29 | import Error.TypeError (TypeError(..)) 30 | import Syntax (pattern TypeM, unTypeM) 31 | import qualified Syntax 32 | import IR (Kind(..), TypeScheme) 33 | import qualified IR 34 | import Size (Size, sizeConstraintFor) 35 | import Unify.KMeta (freshKMeta, solveKMetas) 36 | import Unify.TMeta (solveMetas_Constraint, solveTMetas_Expr) 37 | 38 | checkFunction :: 39 | MonadError TypeError m => 40 | Map (IR.Constraint Void) (Size Void) -> 41 | Map Text IR.Fields -> 42 | Map Text IR.Constructor -> 43 | Map Text Kind -> 44 | Map Text (TypeScheme Void) -> 45 | Syntax.Function -> 46 | m IR.Function 47 | checkFunction glbl fields ctors kindScope tyScope (Syntax.Function name tyArgs args retTy body) = do 48 | let 49 | initial = 50 | emptyTCState & 51 | globalTheory .~ glbl & 52 | datatypeFields .~ fields & 53 | datatypeCtors .~ ctors 54 | (tyArgs', constraints', body') <- 55 | flip evalStateT initial $ do 56 | tyArgKinds <- traverse (fmap KVar . const freshKMeta) tyArgs 57 | let args' = TypeM . fmap Right . snd <$> args 58 | let retTy' = TypeM $ Right <$> retTy 59 | checkKind 60 | kindScope 61 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 62 | (unvar ((tyArgKinds Vector.!) . Syntax.getIndex) absurd) 63 | retTy' 64 | KType 65 | traverse_ 66 | (\t -> 67 | checkKind 68 | kindScope 69 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 70 | (unvar ((tyArgKinds Vector.!) . Syntax.getIndex) absurd) 71 | t 72 | KType 73 | ) 74 | args' 75 | exprResult <- 76 | checkExpr 77 | kindScope 78 | (Map.insert 79 | name 80 | (IR.TypeScheme IR.OFunction 81 | (Vector.zip tyArgs tyArgKinds) 82 | mempty 83 | (first Just <$> args) 84 | retTy 85 | ) 86 | tyScope 87 | ) 88 | mempty 89 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 90 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 91 | (unvar ((tyArgs Vector.!) . Syntax.getIndex) absurd) 92 | (unvar (fst . (args Vector.!) . Syntax.getIndex) absurd) 93 | (unvar ((tyArgKinds Vector.!) . Syntax.getIndex) absurd) 94 | (unvar 95 | (\ix sp -> 96 | (args' Vector.! Syntax.getIndex ix) & 97 | Syntax.typemSpans (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) .~ 98 | sp 99 | ) 100 | absurd 101 | ) 102 | body 103 | retTy' 104 | tyArgKinds' <- traverse (fmap (IR.substKMeta (const KType)) . solveKMetas) tyArgKinds 105 | constraints <- do 106 | reqs <- use requiredConstraints 107 | global <- use globalTheory 108 | local <- 109 | -- locally, we assume that each type variable is sized 110 | ifoldlM 111 | (\ix acc k -> do 112 | m <- freshSMeta 113 | pure $ 114 | Map.insert 115 | (Right . first (const $ Syntax.Index {- TODO -} Syntax.Unknown ix) <$> sizeConstraintFor k) 116 | m 117 | acc 118 | ) 119 | mempty 120 | tyArgKinds' 121 | reqsAndRet <- 122 | foldrM 123 | (\c rest -> do 124 | m <- freshSMeta 125 | pure $ (m, c) : rest 126 | ) 127 | [] 128 | (reqs <> Set.singleton (IR.CSized $ unTypeM retTy')) 129 | (constraints', simplifications) <- 130 | solve 131 | kindScope 132 | (Syntax.varSpan Syntax.indexSpan Syntax.voidSpan) 133 | (unvar (Right . (tyArgs Vector.!) . Syntax.getIndex) absurd) 134 | (unvar ((tyArgKinds' Vector.!) . Syntax.getIndex) absurd) 135 | (Theory { _thGlobal = global, _thLocal = local }) 136 | reqsAndRet 137 | pure . Vector.fromList $ 138 | constraints' <> 139 | Map.foldrWithKey -- include all the local axioms that weren't simplified 140 | (\c m rest -> if Map.member m simplifications then rest else (m, c) : rest) 141 | [] 142 | local 143 | constraints' <- 144 | (traverse.traverse) (either (error . ("checkFunction: unsolved meta " <>) . show) pure) =<< 145 | traverse (solveMetas_Constraint . snd) constraints 146 | body' <- zonkExprTypes =<< solveTMetas_Expr (crExpr exprResult) 147 | pure (Vector.zip tyArgs tyArgKinds', constraints', body') 148 | pure $ IR.Function name tyArgs' constraints' args retTy body' 149 | -------------------------------------------------------------------------------- /src/Check/Kind.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language RankNTypes #-} 4 | module Check.Kind 5 | ( checkKind 6 | , inferKind 7 | ) 8 | where 9 | 10 | import Control.Lens.Getter ((^.)) 11 | import Control.Lens.Lens (Lens') 12 | import Control.Monad.Except (MonadError, throwError) 13 | import Control.Monad.State.Strict (MonadState) 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Text (Text) 17 | 18 | import Error.TypeError (TypeError(..)) 19 | import IR (Kind(..)) 20 | import Syntax (Span, TypeM, pattern TypeM, unTypeM, typemSpan) 21 | import qualified Syntax 22 | import Unify.KMeta (HasKindMetas, freshKMeta) 23 | import Unify.Kind (unifyKind) 24 | import Unify.TMeta (HasTypeMetas, getTMetaKind) 25 | 26 | checkKind :: 27 | ( MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty) 28 | , MonadError TypeError m 29 | ) => 30 | Map Text Kind -> 31 | Lens' ty Span -> 32 | (ty -> Kind) -> 33 | TypeM ty -> 34 | Kind -> 35 | m () 36 | checkKind kindScope spans kinds ty k = do 37 | k' <- inferKind kindScope kinds ty 38 | let sp = ty ^. typemSpan spans 39 | unifyKind sp k k' 40 | 41 | inferKind :: 42 | ( MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty) 43 | , MonadError TypeError m 44 | ) => 45 | Map Text Kind -> 46 | (ty -> Kind) -> 47 | TypeM ty -> 48 | m Kind 49 | inferKind kindScope kinds ty = 50 | case unTypeM ty of 51 | Syntax.TVar (Left m) -> do 52 | mk <- getTMetaKind m 53 | case mk of 54 | Nothing -> error $ "Missing " <> show mk 55 | Just k -> pure k 56 | Syntax.TVar (Right a) -> pure $ kinds a 57 | Syntax.TApp sp a b -> do 58 | aK <- inferKind kindScope kinds (TypeM a) 59 | bK <- inferKind kindScope kinds (TypeM b) 60 | meta <- freshKMeta 61 | let expected = KArr bK (KVar meta) 62 | unifyKind sp expected aK 63 | pure $ KVar meta 64 | Syntax.TInt32{} -> pure KType 65 | Syntax.TBool{} -> pure KType 66 | Syntax.TPtr{} -> pure $ KArr KType KType 67 | Syntax.TFun{} -> pure $ KArr KType KType 68 | Syntax.TName sp n -> 69 | case Map.lookup n kindScope of 70 | Nothing -> throwError $ TNotInScope sp 71 | Just k -> pure k 72 | 73 | -------------------------------------------------------------------------------- /src/Check/TCState.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language FunctionalDependencies, MultiParamTypeClasses, TypeFamilies #-} 5 | {-# language PatternSynonyms #-} 6 | {-# language TemplateHaskell #-} 7 | module Check.TCState 8 | ( TCState 9 | , emptyTCState 10 | , tcsKindMeta 11 | , tcsKindSolutions 12 | , tcsTypeMeta 13 | , tcsTypeMetaKinds 14 | , tcsTypeSolutions 15 | , tcsConstraints 16 | , tcsGlobalTheory 17 | ) 18 | where 19 | 20 | import Control.Lens.Getter ((^.)) 21 | import Control.Lens.TH (makeLenses) 22 | import Data.Foldable (foldl') 23 | import Data.Map (Map) 24 | import qualified Data.Map as Map 25 | import Data.Set (Set) 26 | import qualified Data.Set as Set 27 | import Data.Text (Text) 28 | import Data.Void (Void) 29 | 30 | import Check.Datatype (HasDatatypeCtors(..), HasDatatypeFields(..)) 31 | import Check.Entailment (HasGlobalTheory(..), HasSizeMetas(..), SMeta(..)) 32 | import Check.TCState.FilterTypes (FilterTypes(..)) 33 | import Check.Type (HasConstraints(..)) 34 | import IR (Constraint, KMeta(..), Kind(..)) 35 | import qualified IR 36 | import Size (Size) 37 | import Syntax (TMeta(..), TypeM) 38 | import Unify.KMeta (HasKindMetas(..)) 39 | import Unify.TMeta (HasTypeMetas(..)) 40 | 41 | data TCState ty 42 | = TCState 43 | { _tcsKindMeta :: KMeta 44 | , _tcsKindSolutions :: Map KMeta Kind 45 | , _tcsTypeMeta :: Int 46 | , _tcsTypeMetaKinds :: Map TMeta Kind 47 | , _tcsTypeSolutions :: Map TMeta (TypeM ty) 48 | , _tcsConstraints :: Set (Constraint (Either TMeta ty)) 49 | , _tcsSizeMeta :: SMeta 50 | , _tcsGlobalTheory :: Map (Constraint Void) (Size Void) 51 | , _tcsDatatypeFields :: Map Text IR.Fields 52 | , _tcsDatatypeCtors :: Map Text IR.Constructor 53 | } 54 | makeLenses ''TCState 55 | 56 | emptyTCState :: Ord ty => TCState ty 57 | emptyTCState = 58 | TCState 59 | { _tcsKindMeta = KMeta 0 60 | , _tcsKindSolutions = mempty 61 | , _tcsTypeMeta = 0 62 | , _tcsTypeMetaKinds = mempty 63 | , _tcsTypeSolutions = mempty 64 | , _tcsConstraints = mempty 65 | , _tcsGlobalTheory = mempty 66 | , _tcsSizeMeta = SMeta 0 67 | , _tcsDatatypeFields = mempty 68 | , _tcsDatatypeCtors = mempty 69 | } 70 | 71 | instance HasGlobalTheory (TCState ty) where 72 | globalTheory = tcsGlobalTheory 73 | 74 | instance HasSizeMetas (TCState ty) where 75 | nextSMeta = tcsSizeMeta 76 | 77 | instance HasConstraints TCState where 78 | requiredConstraints = tcsConstraints 79 | 80 | instance HasTypeMetas TCState where 81 | nextTMeta = tcsTypeMeta 82 | tmetaKinds = tcsTypeMetaKinds 83 | tmetaSolutions = tcsTypeSolutions 84 | 85 | instance HasKindMetas (TCState ty) where 86 | nextKMeta = tcsKindMeta 87 | kmetaSolutions = tcsKindSolutions 88 | 89 | instance FilterTypes TCState where 90 | filterTypes f tcs = 91 | let 92 | (tmetas, sols') = 93 | Map.foldrWithKey 94 | (\k a (ms, ss) -> 95 | case traverse f a of 96 | Nothing -> (k:ms, ss) 97 | Just a' -> (ms, Map.insert k a' ss) 98 | ) 99 | ([], mempty) 100 | (tcs ^. tcsTypeSolutions) 101 | kinds' = foldl' (flip Map.delete) (tcs ^. tcsTypeMetaKinds) tmetas 102 | constraints' = 103 | foldr 104 | (\c -> 105 | case traverse (either (Just . Left) (fmap Right . f)) c of 106 | Nothing -> id 107 | Just c' -> Set.insert c' 108 | ) 109 | mempty 110 | (tcs ^. tcsConstraints) 111 | in 112 | tcs 113 | { _tcsTypeMetaKinds = kinds' 114 | , _tcsTypeSolutions = sols' 115 | , _tcsConstraints = constraints' 116 | } 117 | 118 | instance HasDatatypeFields (TCState ty) where 119 | datatypeFields = tcsDatatypeFields 120 | 121 | instance HasDatatypeCtors (TCState ty) where 122 | datatypeCtors = tcsDatatypeCtors 123 | -------------------------------------------------------------------------------- /src/Check/TCState/FilterTypes.hs: -------------------------------------------------------------------------------- 1 | module Check.TCState.FilterTypes (FilterTypes(..), mapTypes) where 2 | 3 | class FilterTypes s where 4 | filterTypes :: Ord ty' => (ty -> Maybe ty') -> s ty -> s ty' 5 | 6 | mapTypes :: (FilterTypes s, Ord ty') => (ty -> ty') -> s ty -> s ty' 7 | mapTypes f = filterTypes (Just . f) 8 | 9 | -------------------------------------------------------------------------------- /src/Check/Type.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language DeriveFunctor #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language PatternSynonyms #-} 5 | {-# language QuantifiedConstraints #-} 6 | {-# language RankNTypes #-} 7 | {-# language TemplateHaskell #-} 8 | {-# language ViewPatterns #-} 9 | module Check.Type 10 | ( CheckResult(..), InferResult(..) 11 | , checkExpr, inferExpr 12 | , HasConstraints(..) 13 | , applyTSubs_Constraint 14 | , zonkExprTypes 15 | ) 16 | where 17 | 18 | import Bound.Var (unvar) 19 | import Control.Lens.Getter ((^.), view) 20 | import Control.Lens.Lens (Lens') 21 | import Control.Lens.Setter ((<>=) ) 22 | import Control.Monad.Except (MonadError, throwError) 23 | import Control.Monad.State.Strict (MonadState) 24 | import Data.Bitraversable (bitraverse) 25 | import Data.Foldable (foldlM, foldl', traverse_) 26 | import Data.Int (Int32) 27 | import Data.Map (Map) 28 | import qualified Data.Map as Map 29 | import Data.Set (Set) 30 | import qualified Data.Set as Set 31 | import Data.Text (Text) 32 | import Data.Vector (Vector) 33 | import qualified Data.Vector as Vector 34 | import Data.Void (Void, absurd) 35 | 36 | import Check.Datatype (HasDatatypeFields, HasDatatypeCtors, getConstructor, getFieldType) 37 | import Error.TypeError (TypeError(..)) 38 | import Syntax (Span(Unknown), TMeta, TypeM, pattern TypeM, unTypeM, getIndex) 39 | import qualified Syntax 40 | import IR (Kind(..), TypeScheme) 41 | import qualified IR 42 | import Unify.KMeta (HasKindMetas) 43 | import Unify.TMeta (HasTypeMetas, freshTMeta, solveTMetas_Type) 44 | import Unify.Type (unifyType) 45 | 46 | class HasConstraints s where 47 | requiredConstraints :: Lens' (s ty) (Set (IR.Constraint (Either TMeta ty))) 48 | 49 | applyTSubs_Constraint :: 50 | Map TMeta (TypeM ty) -> 51 | IR.Constraint (Either TMeta ty) -> 52 | IR.Constraint (Either TMeta ty) 53 | applyTSubs_Constraint subs = 54 | IR.bindConstraint (either (\m -> maybe (pure $ Left m) unTypeM $ Map.lookup m subs) (pure . Right)) 55 | 56 | 57 | data InferResult ty tm 58 | = InferResult 59 | { irExpr :: IR.Expr (Either TMeta ty) tm 60 | , irType :: TypeM ty 61 | } 62 | 63 | instantiateScheme :: 64 | (MonadState (s ty) m, HasTypeMetas s, Ord ty) => 65 | TypeScheme Void -> 66 | m 67 | ( IR.Origin 68 | , Vector TMeta 69 | , Set (IR.Constraint (Either TMeta ty)) 70 | , TypeM ty 71 | ) 72 | instantiateScheme (IR.TypeScheme origin tyArgs constraints args retTy) = do 73 | tyArgMetas <- traverse (\(_, k) -> freshTMeta {- TODO -} Unknown k) tyArgs 74 | let placeMetas = unvar (Left . (tyArgMetas Vector.!) . getIndex) absurd 75 | pure 76 | ( origin 77 | , tyArgMetas 78 | , foldl' 79 | (\acc c -> Set.insert (placeMetas <$> c) acc) 80 | mempty 81 | constraints 82 | , TypeM $ 83 | Syntax.TApp {- TODO -} Unknown 84 | (Syntax.TFun {- TODO -} Unknown $ fmap placeMetas . snd <$> args) 85 | (placeMetas <$> retTy) 86 | ) 87 | 88 | inferPattern :: 89 | ( MonadState (s ty) m 90 | , HasTypeMetas s, HasKindMetas (s ty), HasConstraints s 91 | , forall x. HasDatatypeFields (s x), forall x. HasDatatypeCtors (s x) 92 | , MonadError TypeError m 93 | , Ord ty 94 | ) => 95 | Span -> 96 | Text -> 97 | Vector Text -> 98 | m (Vector (Span -> TypeM ty), TypeM ty) 99 | inferPattern sp ctorName argNames = do 100 | ctor <- getConstructor sp ctorName 101 | case IR.ctorSort ctor of 102 | IR.StructCtor -> throwError $ MatchingOnStruct sp 103 | IR.EnumCtor{} -> do 104 | let 105 | expectedLength = length $ IR.ctorArgs ctor 106 | actualLength = length argNames 107 | case expectedLength == actualLength of 108 | False -> throwError $ CtorArityMismatch sp expectedLength actualLength 109 | True -> do 110 | tyArgs <- traverse (\(_, k) -> freshTMeta {- TODO -} Unknown k) $ IR.ctorTyArgs ctor 111 | let inst = fmap $ unvar (Left . (tyArgs Vector.!) . getIndex) absurd 112 | pure 113 | ( (\f -> TypeM . inst . f) . snd <$> IR.ctorArgs ctor 114 | , TypeM . inst $ IR.ctorRetTy ctor sp 115 | ) 116 | 117 | inferExpr :: 118 | ( MonadState (s ty) m 119 | , HasTypeMetas s, HasKindMetas (s ty), HasConstraints s 120 | , forall x. HasDatatypeFields (s x), forall x. HasDatatypeCtors (s x) 121 | , MonadError TypeError m 122 | , Ord ty 123 | ) => 124 | Map Text Kind -> 125 | Map Text (TypeScheme Void) -> 126 | Map Text (TypeM ty) -> 127 | Lens' ty Span -> 128 | Lens' tm Span -> 129 | (ty -> Text) -> 130 | (tm -> Text) -> 131 | (ty -> Kind) -> 132 | (tm -> Span -> TypeM ty) -> 133 | Syntax.Expr tm -> 134 | m (InferResult ty tm) 135 | inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types expr = 136 | case expr of 137 | Syntax.Var a -> 138 | pure $ 139 | InferResult 140 | { irExpr = IR.Var a 141 | , irType = types a (view tmSpans a) 142 | } 143 | 144 | Syntax.Name sp name -> do 145 | case Map.lookup name letScope of 146 | Nothing -> 147 | case Map.lookup name tyScope of 148 | Nothing -> throwError $ NotInScope sp 149 | Just scheme -> do 150 | (origin, metas, constraints, bodyTy) <- instantiateScheme scheme 151 | requiredConstraints <>= constraints 152 | case origin of 153 | IR.OFunction -> 154 | pure $ 155 | InferResult 156 | { irExpr = IR.Inst name $ Syntax.TVar . Left <$> metas 157 | , irType = bodyTy 158 | } 159 | IR.OConstructor -> 160 | pure $ 161 | InferResult 162 | { irExpr = IR.Ctor name $ Syntax.TVar . Left <$> metas 163 | , irType = bodyTy 164 | } 165 | IR.ODatatype -> error "got ODatatype" 166 | Just ty -> 167 | pure $ 168 | InferResult 169 | { irExpr = IR.Name name 170 | , irType = ty 171 | } 172 | 173 | Syntax.Number sp n -> do 174 | if 0 <= n && n <= fromIntegral (maxBound::Int32) 175 | then 176 | pure $ 177 | InferResult 178 | { irExpr = IR.Int32 (fromIntegral n) 179 | , irType = TypeM $ Syntax.TInt32 sp 180 | } 181 | else throwError $ OutOfBoundsInt32 sp 182 | 183 | Syntax.Add sp a b -> do 184 | aResult <- 185 | checkExpr 186 | kindScope 187 | tyScope 188 | letScope 189 | tySpans 190 | tmSpans 191 | tyNames 192 | tmNames 193 | kinds 194 | types 195 | a 196 | (TypeM $ Syntax.TInt32 $ a ^. Syntax.exprSpan tmSpans) 197 | bResult <- 198 | checkExpr 199 | kindScope 200 | tyScope 201 | letScope 202 | tySpans 203 | tmSpans 204 | tyNames 205 | tmNames 206 | kinds 207 | types 208 | b 209 | (TypeM $ Syntax.TInt32 $ b ^. Syntax.exprSpan tmSpans) 210 | pure $ 211 | InferResult 212 | { irExpr = IR.Add (crExpr aResult) (crExpr bResult) 213 | , irType = TypeM $ Syntax.TInt32 sp 214 | } 215 | 216 | Syntax.Let _ bindings body -> do 217 | (letScope', bindings') <- 218 | foldlM 219 | (\(acc, bs) (n, b) -> do 220 | bResult <- inferExpr kindScope tyScope acc tySpans tmSpans tyNames tmNames kinds types b 221 | requiredConstraints <>= Set.singleton (IR.CSized . unTypeM $ irType bResult) 222 | pure 223 | ( Map.insert n (irType bResult) acc 224 | , Vector.snoc bs ((n, irExpr bResult), unTypeM $ irType bResult) 225 | ) 226 | ) 227 | (mempty, mempty) 228 | bindings 229 | bodyResult <- inferExpr kindScope tyScope letScope' tySpans tmSpans tyNames tmNames kinds types body 230 | pure $ 231 | InferResult 232 | { irExpr = IR.Let bindings' $ irExpr bodyResult 233 | , irType = irType bodyResult 234 | } 235 | 236 | Syntax.Call sp fun args -> do 237 | funResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types fun 238 | (args', argTys) <- 239 | foldlM 240 | (\(as, atys) arg -> do 241 | argResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types arg 242 | pure 243 | ( Vector.snoc as $ irExpr argResult 244 | , Vector.snoc atys . unTypeM $ irType argResult 245 | ) 246 | ) 247 | (mempty, mempty) 248 | args 249 | argTyMetas <- Vector.replicateM (Vector.length argTys) (Syntax.TVar . Left <$> freshTMeta sp KType) 250 | retTy <- Syntax.TVar . Left <$> freshTMeta sp KType 251 | unifyType 252 | kindScope 253 | tySpans 254 | (Right . tyNames) 255 | kinds 256 | (TypeM $ Syntax.TApp sp (Syntax.TFun sp argTyMetas) retTy) 257 | (irType funResult) 258 | traverse_ 259 | (\(argTyMeta, argTy) -> 260 | unifyType 261 | kindScope 262 | tySpans 263 | (Right . tyNames) 264 | kinds 265 | (TypeM argTyMeta) 266 | (TypeM argTy) 267 | ) 268 | (Vector.zip argTyMetas argTys) 269 | pure $ 270 | InferResult 271 | { irExpr = IR.Call (irExpr funResult) args' retTy 272 | , irType = TypeM retTy 273 | } 274 | 275 | Syntax.BTrue sp -> 276 | pure $ 277 | InferResult 278 | { irExpr = IR.BTrue 279 | , irType = TypeM $ Syntax.TBool sp 280 | } 281 | 282 | Syntax.BFalse sp -> 283 | pure $ 284 | InferResult 285 | { irExpr = IR.BFalse 286 | , irType = TypeM $ Syntax.TBool sp 287 | } 288 | 289 | Syntax.New sp a -> do 290 | aResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types a 291 | requiredConstraints <>= Set.singleton (IR.CSized . unTypeM $ irType aResult) 292 | pure $ 293 | InferResult 294 | { irExpr = IR.New (irExpr aResult) (unTypeM $ irType aResult) 295 | , irType = TypeM $ Syntax.TApp sp (Syntax.TPtr sp) (unTypeM $ irType aResult) 296 | } 297 | 298 | Syntax.Deref sp a -> do 299 | aResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types a 300 | meta <- freshTMeta sp KType 301 | unifyType 302 | kindScope 303 | tySpans 304 | (Right . tyNames) 305 | kinds 306 | (TypeM $ Syntax.TApp sp (Syntax.TPtr sp) $ Syntax.TVar $ Left meta) 307 | (irType aResult) 308 | pure $ 309 | InferResult 310 | { irExpr = IR.Deref $ irExpr aResult 311 | , irType = TypeM $ Syntax.TVar (Left meta) 312 | } 313 | 314 | Syntax.Project sp a field -> do 315 | aResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types a 316 | aTy <- solveTMetas_Type id . unTypeM $ irType aResult 317 | let (t, ts) = Syntax.unApply aTy 318 | case t of 319 | Syntax.TName sp' n -> do 320 | let field' = IR.parseProjection field 321 | m_fieldType <- getFieldType sp' n field' 322 | case m_fieldType of 323 | Nothing -> throwError $ Doesn'tHaveField sp (tyNames <$> TypeM aTy) field 324 | Just fieldType -> 325 | let 326 | fieldType' = fieldType >>= unvar ((ts !!) . getIndex) absurd 327 | in 328 | pure $ 329 | InferResult 330 | { irExpr = IR.Project (irExpr aResult) field' 331 | , irType = TypeM fieldType' 332 | } 333 | _ -> throwError $ Can'tInfer sp 334 | 335 | Syntax.Match sp a cases -> do 336 | aResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types a 337 | resTy <- Syntax.TVar . Left <$> freshTMeta sp KType 338 | caseExprs <- 339 | traverse 340 | (\(Syntax.Case sp' ctorName ctorArgs body) -> do 341 | (ctorArgTypes, patternType) <- inferPattern sp' ctorName ctorArgs 342 | unifyType 343 | kindScope 344 | tySpans 345 | (Right . tyNames) 346 | kinds 347 | (irType aResult) 348 | patternType 349 | bodyResult <- 350 | inferExpr 351 | kindScope 352 | tyScope 353 | letScope 354 | tySpans 355 | (Syntax.varSpan Syntax.indexSpan tmSpans) 356 | tyNames 357 | (unvar ((ctorArgs Vector.!) . Syntax.getIndex) tmNames) 358 | kinds 359 | (unvar ((ctorArgTypes Vector.!) . Syntax.getIndex) types) 360 | body 361 | unifyType 362 | kindScope 363 | tySpans 364 | (Right . tyNames) 365 | kinds 366 | (TypeM resTy) 367 | (irType bodyResult) 368 | pure $ IR.Case ctorName ctorArgs (irExpr bodyResult) 369 | ) 370 | cases 371 | pure $ 372 | InferResult 373 | { irExpr = IR.Match (irExpr aResult) (unTypeM $ irType aResult) caseExprs resTy 374 | , irType = TypeM resTy 375 | } 376 | 377 | data CheckResult ty tm 378 | = CheckResult 379 | { crExpr :: IR.Expr (Either TMeta ty) tm 380 | } 381 | 382 | checkExpr :: 383 | ( MonadState (s ty) m 384 | , HasTypeMetas s, HasKindMetas (s ty), HasConstraints s 385 | , forall x. HasDatatypeFields (s x), forall x. HasDatatypeCtors (s x) 386 | , MonadError TypeError m 387 | , Ord ty 388 | ) => 389 | Map Text Kind -> 390 | Map Text (TypeScheme Void) -> 391 | Map Text (TypeM ty) -> 392 | Lens' ty Span -> 393 | Lens' tm Span -> 394 | (ty -> Text) -> 395 | (tm -> Text) -> 396 | (ty -> Kind) -> 397 | (tm -> Span -> TypeM ty) -> 398 | Syntax.Expr tm -> 399 | TypeM ty -> 400 | m (CheckResult ty tm) 401 | checkExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types expr ty = do 402 | exprResult <- inferExpr kindScope tyScope letScope tySpans tmSpans tyNames tmNames kinds types expr 403 | unifyType kindScope tySpans (Right . tyNames) kinds ty (irType exprResult) 404 | pure $ 405 | CheckResult 406 | { crExpr = irExpr exprResult 407 | } 408 | 409 | zonkCaseTypes :: 410 | Monad m => 411 | IR.Case (Either TMeta ty) tm -> 412 | m (IR.Case ty tm) 413 | zonkCaseTypes (IR.Case n as e) = IR.Case n as <$> zonkExprTypes e 414 | 415 | zonkExprTypes :: 416 | Monad m => 417 | IR.Expr (Either TMeta ty) tm -> 418 | m (IR.Expr ty tm) 419 | zonkExprTypes e = 420 | case e of 421 | IR.Var a -> pure $ IR.Var a 422 | IR.Name n -> pure $ IR.Name n 423 | IR.Let bs rest -> 424 | IR.Let <$> 425 | traverse 426 | (bitraverse 427 | (traverse zonkExprTypes) 428 | (traverse (either (error . ("zonking found: " <>) . show) pure)) 429 | ) 430 | bs <*> 431 | zonkExprTypes rest 432 | IR.Inst n args -> 433 | IR.Inst n <$> 434 | (traverse.traverse) 435 | (either (error . ("zonking found: " <>) . show) pure) 436 | args 437 | IR.Ctor n ts -> 438 | IR.Ctor n <$> 439 | (traverse.traverse) 440 | (either (error . ("zonking found: " <>) . show) pure) 441 | ts 442 | IR.Call f args t -> 443 | IR.Call <$> 444 | zonkExprTypes f <*> 445 | traverse zonkExprTypes args <*> 446 | traverse (either (error . ("zonking found: " <>) . show) pure) t 447 | IR.Int32 n -> pure $ IR.Int32 n 448 | IR.Add a b -> IR.Add <$> zonkExprTypes a <*> zonkExprTypes b 449 | IR.BTrue -> pure $ IR.BTrue 450 | IR.BFalse -> pure $ IR.BFalse 451 | IR.New a t -> 452 | IR.New <$> 453 | zonkExprTypes a <*> 454 | traverse 455 | (either (error . ("zonking found: " <>) . show) pure) 456 | t 457 | IR.Deref a -> IR.Deref <$> zonkExprTypes a 458 | IR.Project a b -> (\a' -> IR.Project a' b) <$> zonkExprTypes a 459 | IR.Match a inTy bs resTy -> 460 | IR.Match <$> 461 | zonkExprTypes a <*> 462 | traverse (either (error . ("zonking found: " <>) . show) pure) inTy <*> 463 | traverse zonkCaseTypes bs <*> 464 | traverse (either (error . ("zonking found: " <>) . show) pure) resTy 465 | -------------------------------------------------------------------------------- /src/Codegen.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language OverloadedLists, OverloadedStrings #-} 4 | {-# language ScopedTypeVariables #-} 5 | {-# language TemplateHaskell #-} 6 | {-# language TypeApplications #-} 7 | {-# language ViewPatterns #-} 8 | module Codegen 9 | ( Code 10 | , Key(..) 11 | , emptyCode 12 | , codeKinds 13 | , codeDatatypeCtors 14 | , codeDeclarations 15 | , codeGlobalTheory 16 | , genFunction 17 | , genExpr 18 | , genDecls 19 | ) 20 | where 21 | 22 | import Bound.Var (unvar) 23 | import Control.Lens.Getter (use, uses) 24 | import Control.Lens.Setter ((.=), (%=), (<>=)) 25 | import Control.Lens.TH (makeLenses) 26 | import Control.Monad.State.Strict (MonadState, evalStateT) 27 | import Control.Monad.Writer.Strict (WriterT, runWriterT, tell) 28 | import Data.Foldable (fold, traverse_) 29 | import qualified Data.List as List 30 | import Data.Map (Map) 31 | import qualified Data.Map as Map 32 | import Data.Text (Text) 33 | import qualified Data.Maybe as Maybe 34 | import qualified Data.Text as Text 35 | import Data.Vector (Vector) 36 | import qualified Data.Vector as Vector 37 | import Data.Void (Void, absurd) 38 | import Data.Word (Word64) 39 | 40 | import Check.Entailment (Theory(..), findSMeta, freshSMeta, solve) 41 | import Check.TCState (emptyTCState) 42 | import Codegen.C (CDecl, CExpr, CStatement, CType) 43 | import qualified Codegen.C as C 44 | import qualified IR 45 | import Size (Size) 46 | import qualified Size 47 | import qualified Syntax 48 | 49 | data Key = Key IR.Origin Text (Vector (Syntax.Type Void)) 50 | deriving (Eq, Ord, Show) 51 | 52 | data Code 53 | = Code 54 | { _codeKinds :: Map Text IR.Kind 55 | , _codeDeclarations :: Map (IR.Origin, Text) IR.Declaration 56 | , _codeGlobalTheory :: Map (IR.Constraint Void) (Size Void) 57 | , _codeDatatypeCtors :: Map Text IR.Constructor 58 | , _codeCompiledNames :: Map Key Text 59 | , _codeCompiled :: [CDecl] 60 | , _codeSupply :: Int 61 | } 62 | makeLenses ''Code 63 | 64 | emptyCode :: Code 65 | emptyCode = 66 | Code 67 | { _codeKinds = mempty 68 | , _codeDeclarations = mempty 69 | , _codeGlobalTheory = mempty 70 | , _codeDatatypeCtors = mempty 71 | , _codeCompiledNames = mempty 72 | , _codeCompiled = mempty 73 | , _codeSupply = 0 74 | } 75 | 76 | freshName :: MonadState Code m => m Text 77 | freshName = do 78 | n <- use codeSupply 79 | codeSupply .= (n+1) 80 | pure . Text.pack $ "__" <> show n 81 | 82 | typeSuffix :: Vector (Syntax.Type Void) -> Text 83 | typeSuffix ts = 84 | if Vector.null ts 85 | then mempty 86 | else 87 | ("_" <>) . fold . List.intersperse "_" $ foldr ((:) . doTy) [] ts 88 | where 89 | doTy ty = 90 | case ty of 91 | Syntax.TVar a -> absurd a 92 | Syntax.TApp _ t1 t2 -> "TApp" <> doTy t1 <> doTy t2 93 | Syntax.TInt32{} -> "TInt32" 94 | Syntax.TBool{} -> "TBool" 95 | Syntax.TPtr{} -> "TPtr" 96 | Syntax.TFun _ args -> "TFun" <> foldMap doTy args 97 | Syntax.TName _ a -> a 98 | 99 | genType :: MonadState Code m => Syntax.Type Void -> m CType 100 | genType ty = 101 | let 102 | (t, Vector.fromList -> ts) = Syntax.unApply ty 103 | in 104 | case t of 105 | Syntax.TVar a -> absurd a 106 | Syntax.TFun _ args | [ret] <- ts -> 107 | C.FunPtr <$> 108 | genType ret <*> 109 | traverse genType args 110 | Syntax.TPtr _ | [ret] <- ts -> 111 | C.Ptr <$> genType ret 112 | Syntax.TInt32{} -> pure C.Int32 113 | Syntax.TBool{} -> pure C.Bool 114 | Syntax.TName _ name -> do 115 | -- let key = (IR.ODatatype, name, ts) 116 | let key = Key IR.ODatatype name ts 117 | m_code <- uses codeCompiledNames $ Map.lookup key 118 | name' <- 119 | case m_code of 120 | Nothing -> do 121 | let realName = name <> typeSuffix ts <> "_t" 122 | m_decl <- uses codeDeclarations $ Map.lookup (IR.ODatatype, name) 123 | codeCompiledNames %= Map.insert key realName 124 | code <- 125 | case m_decl of 126 | Nothing -> error $ "genType: " <> show name <> " not found" 127 | Just decl -> 128 | case decl of 129 | IR.DData adt -> genDatatype adt ts 130 | IR.DFunc{} -> error $ "genType: got Func" 131 | IR.DCtor{} -> error $ "genInst: got Ctor" 132 | codeCompiled <>= code 133 | pure realName 134 | Just realName -> pure realName 135 | pure $ C.Name name' 136 | _ -> error $ "genType: bad type " <> show ty 137 | 138 | 139 | genDatatype :: 140 | (MonadState Code m) => 141 | IR.Datatype -> 142 | Vector (Syntax.Type Void) -> 143 | m [CDecl] 144 | genDatatype adt ts = 145 | case adt of 146 | IR.Empty adtName tyArgs -> 147 | let 148 | !True = correctSize adtName (length tyArgs) 149 | fullName = adtName <> typeSuffix ts <> "_t" 150 | in 151 | pure [C.Typedef (C.Void Nothing) fullName] 152 | IR.Struct adtName tyArgs fields -> do 153 | let 154 | !True = correctSize adtName (length tyArgs) 155 | fullName = adtName <> typeSuffix ts <> "_t" 156 | 157 | fields_inst = (fmap.fmap) inst fields 158 | namedFields = nameFields fields_inst 159 | 160 | (\fs' -> 161 | [ C.Typedef (C.Name $ "struct " <> fullName) fullName 162 | , C.Struct fullName fs' 163 | ] 164 | ) <$> 165 | traverse (\(n, t) -> (,) <$> genType t <*> pure n) namedFields 166 | IR.Enum adtName tyArgs ctors -> do 167 | let 168 | !True = correctSize adtName (length tyArgs) 169 | fullName = adtName <> typeSuffix ts <> "_t" 170 | 171 | ctors_inst = (fmap.fmap.fmap.fmap) inst ctors 172 | unionMembers <- 173 | traverse 174 | (\(cname, cty) -> 175 | (,) . C.TStruct <$> 176 | traverse (\(n, t) -> (,) <$> genType t <*> pure n) (nameFields cty) <*> 177 | pure cname 178 | ) 179 | ctors_inst 180 | pure 181 | [ C.Typedef (C.Name $ "struct " <> fullName) fullName 182 | , C.Struct 183 | fullName 184 | [ (C.UInt8, "tag") 185 | , (C.Union unionMembers, "data") 186 | ] 187 | ] 188 | where 189 | nameFields fs = 190 | let 191 | numberedFieldNames = Text.pack . ('_' :) . show <$> [0..length fs-1] 192 | in 193 | Vector.zipWith (\n (m_n, t) -> (Maybe.fromMaybe n m_n, t)) numberedFieldNames fs 194 | 195 | inst = (>>= unvar ((ts Vector.!) . Syntax.getIndex) absurd) 196 | 197 | correctSize name tyArgsLen = 198 | case compare (Vector.length ts) tyArgsLen of 199 | LT -> 200 | error $ 201 | "genDatatype: not enough type arguments for " <> 202 | show name <> 203 | " (expected " <> show tyArgsLen <> ")" 204 | GT -> 205 | error $ 206 | "genDatatype: too many type arguments for " <> 207 | show name <> 208 | " (expected " <> show tyArgsLen <> ")" 209 | EQ -> True 210 | 211 | genInst :: 212 | (MonadState Code m) => 213 | Text -> 214 | Vector (Syntax.Type Void) -> 215 | m CExpr 216 | genInst name ts = do 217 | -- let key = (IR.OFunction, name, ts) 218 | let key = Key IR.OFunction name ts 219 | m_code <- uses codeCompiledNames $ Map.lookup key 220 | name' <- 221 | case m_code of 222 | Nothing -> do 223 | let realName = name <> typeSuffix ts 224 | codeCompiledNames %= Map.insert key realName 225 | code <- do 226 | m_decl <- uses codeDeclarations $ Map.lookup (IR.OFunction, name) 227 | case m_decl of 228 | Nothing -> error $ "genInst: " <> show name <> " not found" 229 | Just decl -> 230 | case decl of 231 | IR.DFunc func -> genFunction func ts 232 | IR.DData{} -> error $ "genInst: got Data" 233 | IR.DCtor{} -> error $ "genInst: got Ctor" 234 | codeCompiled <>= [code] 235 | pure realName 236 | Just realName -> pure realName 237 | pure $ C.Var name' 238 | 239 | genCtor :: 240 | (MonadState Code m) => 241 | Text -> 242 | Vector (Syntax.Type Void) -> 243 | m CExpr 244 | genCtor name ts = do 245 | -- let key = (IR.OConstructor, name, ts) 246 | let key = Key IR.OConstructor name ts 247 | m_code <- uses codeCompiledNames $ Map.lookup key 248 | name' <- 249 | case m_code of 250 | Nothing -> do 251 | let realName = "make_" <> name <> typeSuffix ts 252 | codeCompiledNames %= Map.insert key realName 253 | code <- do 254 | m_decl <- uses codeDeclarations $ Map.lookup (IR.OConstructor, name) 255 | case m_decl of 256 | Nothing -> error $ "genCtor: " <> show name <> " not found" 257 | Just decl -> 258 | case decl of 259 | IR.DFunc{} -> error $ "genCtor: got Func" 260 | IR.DCtor ctor -> genConstructor ctor ts 261 | IR.DData{} -> error $ "genCtor: got Data" 262 | codeCompiled <>= [code] 263 | pure realName 264 | Just realName -> pure realName 265 | pure $ C.Var name' 266 | 267 | sizeOfType :: 268 | Map Text IR.Kind -> 269 | Map (IR.Constraint Void) (Size Void) -> 270 | Syntax.Type Void -> 271 | Word64 272 | sizeOfType kindScope global t = 273 | case result of 274 | Left err -> error $ "sizeOfType: got " <> show err 275 | Right n -> n 276 | where 277 | result = 278 | flip evalStateT emptyTCState $ do 279 | m <- freshSMeta 280 | (_, solutions) <- 281 | solve 282 | kindScope 283 | Syntax.voidSpan 284 | absurd 285 | absurd 286 | (Theory { _thGlobal = global, _thLocal = mempty }) 287 | [(m, IR.CSized $ Right <$> t)] 288 | case findSMeta solutions m of 289 | Size.Word n -> pure n 290 | sz -> error $ "sizeOfType: got " <> show sz 291 | 292 | genExpr :: 293 | forall m tm. 294 | (MonadState Code m) => 295 | (tm -> CExpr) -> 296 | IR.Expr Void tm -> 297 | WriterT [CStatement] m CExpr 298 | genExpr vars expr = do 299 | case expr of 300 | IR.Var a -> pure $ vars a 301 | IR.Name n -> pure $ C.Var n 302 | IR.Let es b -> do 303 | genBindings es 304 | genExpr vars b 305 | where 306 | genBindings :: 307 | Vector ((Text, IR.Expr Void tm), Syntax.Type Void) -> 308 | WriterT [CStatement] m () 309 | genBindings = 310 | traverse_ 311 | (\((bname, bval), bty) -> do 312 | bval' <- genExpr vars bval 313 | bty' <- genType bty 314 | tell [C.Declare bty' bname $ Just bval'] 315 | ) 316 | IR.Inst n ts -> genInst n ts 317 | IR.Ctor n ts -> genCtor n ts 318 | IR.Call a bs _ -> do 319 | a' <- genExpr vars a 320 | bs' <- traverse (genExpr vars) bs 321 | pure $ C.Call a' bs' 322 | IR.Int32 n -> pure . C.Number $ fromIntegral n 323 | IR.Add a b -> C.Plus <$> genExpr vars a <*> genExpr vars b 324 | IR.BTrue -> pure C.BTrue 325 | IR.BFalse -> pure C.BFalse 326 | IR.New a t -> do 327 | kindScope <- use codeKinds 328 | global <- use codeGlobalTheory 329 | let !size = sizeOfType kindScope global t 330 | 331 | a' <- genExpr vars a 332 | pt <- C.Ptr <$> genType t 333 | n1 <- freshName 334 | tell 335 | [ C.Declare pt n1 . Just . C.Cast pt $ 336 | C.Malloc (C.Number $ fromIntegral size) 337 | , C.Assign (C.Deref $ C.Var n1) a' 338 | ] 339 | pure $ C.Var n1 340 | IR.Deref a -> C.Deref <$> genExpr vars a 341 | IR.Project a b -> do 342 | a' <- genExpr vars a 343 | case b of 344 | IR.Numeric ix -> 345 | pure $ C.Project a' (Text.pack $ '_' : show @Word64 ix) 346 | IR.Field n -> 347 | pure $ C.Project a' n 348 | IR.Match a inTy bs resTy -> do 349 | a' <- genExpr vars a 350 | 351 | varName <- freshName 352 | inTy' <- genType inTy 353 | tell [C.Declare inTy' varName $ Just a'] 354 | 355 | resName <- freshName 356 | resTy' <- genType resTy 357 | tell [C.Declare resTy' resName Nothing] 358 | traverse_ 359 | (\(IR.Case ctorName _ caseExpr) -> do 360 | m_ctor <- uses codeDatatypeCtors $ Map.lookup ctorName 361 | case m_ctor of 362 | Nothing -> error $ "genExpr: missing ctor " <> show ctorName 363 | Just ctor -> 364 | case IR.ctorSort ctor of 365 | IR.EnumCtor tag -> do 366 | (caseExpr', caseExprSts) <- 367 | runWriterT $ 368 | genExpr 369 | (unvar 370 | (\ix -> 371 | C.Project 372 | (C.Project (C.Project (C.Var varName) "data") ctorName) 373 | (Text.pack $ "_" <> show @Int (Syntax.getIndex ix)) 374 | ) 375 | vars 376 | ) 377 | caseExpr 378 | tell 379 | [ C.If 380 | (C.Eq (C.Project (C.Var varName) "tag") (C.Number $ fromIntegral tag)) 381 | (caseExprSts <> 382 | [C.Assign (C.Var resName) caseExpr'] 383 | ) 384 | ] 385 | IR.StructCtor -> error "genExpr: matching on struct" 386 | ) 387 | bs 388 | pure $ C.Var resName 389 | 390 | genConstructor :: 391 | (MonadState Code m) => 392 | IR.Constructor -> 393 | Vector (Syntax.Type Void) -> 394 | m CDecl 395 | genConstructor (IR.Constructor name ctorSort tyArgs args retTy) tyArgs' = 396 | let 397 | tyArgsLen = length tyArgs 398 | in 399 | case compare (Vector.length tyArgs') tyArgsLen of 400 | LT -> 401 | error $ 402 | "genConstructor: not enough type arguments for " <> 403 | show name <> 404 | " (expected " <> show tyArgsLen <> ")" 405 | GT -> 406 | error $ 407 | "genConstructor: too many type arguments for " <> 408 | show name <> 409 | " (expected " <> show tyArgsLen <> ")" 410 | EQ -> do 411 | let 412 | inst = unvar ((tyArgs' Vector.!) . Syntax.getIndex) absurd 413 | args_inst = (fmap.fmap) (\f -> f Syntax.Unknown >>= inst) args 414 | retTy_inst = retTy Syntax.Unknown >>= inst 415 | 416 | retTy_instGen <- genType retTy_inst 417 | args_inst' <- 418 | traverse 419 | (\(m_n, t) -> (,) <$> genType t <*> maybe freshName pure m_n) 420 | args_inst 421 | destName <- freshName 422 | pure $ 423 | C.Function 424 | retTy_instGen 425 | ("make_" <> name <> typeSuffix tyArgs') 426 | args_inst' 427 | [ case ctorSort of 428 | IR.StructCtor -> 429 | C.Declare retTy_instGen destName . Just . C.Init $ C.Var . snd <$> args_inst' 430 | IR.EnumCtor tag -> 431 | C.Declare retTy_instGen destName . Just $ 432 | C.Init 433 | [ C.Number $ fromIntegral tag 434 | , C.InitNamed [(name, C.Init $ C.Var . snd <$> args_inst')] 435 | ] 436 | , C.Return $ C.Var destName 437 | ] 438 | 439 | genFunction :: 440 | (MonadState Code m) => 441 | IR.Function -> 442 | Vector (Syntax.Type Void) -> 443 | m CDecl 444 | genFunction (IR.Function name tyArgs _constraints args retTy body) tyArgs' = 445 | let 446 | tyArgsLen = length tyArgs 447 | in 448 | case compare (Vector.length tyArgs') tyArgsLen of 449 | LT -> 450 | error $ 451 | "genFunction: not enough type arguments for " <> 452 | show name <> 453 | " (expected " <> show tyArgsLen <> ")" 454 | GT -> 455 | error $ 456 | "genFunction: too many type arguments for " <> 457 | show name <> 458 | " (expected " <> show tyArgsLen <> ")" 459 | EQ -> do 460 | let 461 | inst = unvar ((tyArgs' Vector.!) . Syntax.getIndex) absurd 462 | -- constraints_inst = IR.bindConstraint inst <$> _constraints 463 | args_inst = (fmap.fmap) (>>= inst) args 464 | retTy_inst = retTy >>= inst 465 | body_inst = IR.bindType_Expr inst body 466 | (body', sts) <- 467 | runWriterT $ 468 | genExpr (unvar (C.Var . (fmap fst args Vector.!) . Syntax.getIndex) absurd) body_inst 469 | (\retTy' args' -> 470 | C.Function retTy' 471 | (name <> typeSuffix tyArgs') 472 | args' 473 | (sts <> [C.Return body']) 474 | ) <$> 475 | genType retTy_inst <*> 476 | traverse (\(n, t) -> (,) <$> genType t <*> pure n) args_inst 477 | 478 | genDecls :: MonadState Code m => m [CDecl] 479 | genDecls = use codeCompiled 480 | -------------------------------------------------------------------------------- /src/Codegen/C.hs: -------------------------------------------------------------------------------- 1 | {-# language GeneralizedNewtypeDeriving #-} 2 | {-# language OverloadedStrings #-} 3 | module Codegen.C 4 | ( Ann(..) 5 | , C(..) 6 | , CDecl(..) 7 | , CStatement(..) 8 | , CType(..) 9 | , CExpr(..) 10 | , preamble 11 | , render 12 | , prettyCDecls 13 | , prettyCStatement 14 | , prettyCType 15 | , prettyCExpr 16 | ) 17 | where 18 | 19 | import Data.Foldable (fold) 20 | import qualified Data.List as List 21 | import Data.Text (Text) 22 | import qualified Data.Text.Lazy as Lazy 23 | import Data.Vector (Vector) 24 | import qualified Data.Vector as Vector 25 | import Data.Word (Word64) 26 | import GHC.Exts (fromString) 27 | import Text.PrettyPrint.Leijen.Text (Doc) 28 | import qualified Text.PrettyPrint.Leijen.Text as Pretty 29 | 30 | newtype Ann = Ann Text 31 | deriving (Eq, Show) 32 | 33 | data CType 34 | = Ptr CType 35 | | FunPtr CType (Vector CType) 36 | | Void (Maybe Ann) 37 | | Int32 38 | | UInt8 39 | | Bool 40 | | Name Text 41 | | TStruct (Vector (CType, Text)) 42 | | Union (Vector (CType, Text)) 43 | deriving (Eq, Show) 44 | 45 | data CExpr 46 | = BTrue 47 | | BFalse 48 | | Alloca CExpr 49 | | Malloc CExpr 50 | | Number Integer 51 | | Var Text 52 | | Call CExpr (Vector CExpr) 53 | | Deref CExpr 54 | | Index CExpr Word64 55 | | Cast CType CExpr 56 | | Plus CExpr CExpr 57 | | Init (Vector CExpr) 58 | | InitNamed (Vector (Text, CExpr)) 59 | | Project CExpr Text 60 | | Eq CExpr CExpr 61 | deriving (Eq, Show) 62 | 63 | data CStatement 64 | = Return CExpr 65 | | Declare CType Text (Maybe CExpr) 66 | | Assign CExpr CExpr 67 | | If CExpr [CStatement] 68 | deriving (Eq, Show) 69 | 70 | data CDecl 71 | = Include Text 72 | | Typedef CType Text 73 | | Struct Text (Vector (CType, Text)) 74 | | Function CType Text (Vector (CType, Text)) [CStatement] 75 | deriving (Eq, Show) 76 | 77 | newtype C = C [CDecl] 78 | deriving (Eq, Show, Semigroup, Monoid) 79 | 80 | intersperseMap :: (Foldable f, Monoid m) => m -> (a -> m) -> f a -> m 81 | intersperseMap sep f = fold . List.intersperse sep . foldr ((:) . f) [] 82 | 83 | render :: Doc -> Text 84 | render = Lazy.toStrict . Pretty.displayT . Pretty.renderPretty 1.0 100 85 | 86 | prettyCExpr :: CExpr -> Doc 87 | prettyCExpr e = 88 | case e of 89 | BTrue -> "true" 90 | BFalse -> "false" 91 | Alloca a -> "alloca" <> Pretty.parens (prettyCExpr a) 92 | Malloc a -> "malloc" <> Pretty.parens (prettyCExpr a) 93 | Number a -> fromString $ show a 94 | Var a -> Pretty.textStrict a 95 | Call a bs -> 96 | (case a of 97 | Cast{} -> Pretty.parens 98 | Deref{} -> Pretty.parens 99 | Plus{} -> Pretty.parens 100 | _ -> id 101 | ) (prettyCExpr a) <> 102 | Pretty.parens (intersperseMap ", " prettyCExpr bs) 103 | Deref a -> 104 | "*" <> 105 | (case a of 106 | Plus{} -> Pretty.parens 107 | _ -> id) 108 | (prettyCExpr a) 109 | Index a n -> 110 | (case a of 111 | Cast{} -> Pretty.parens 112 | Plus{} -> Pretty.parens 113 | _ -> id) 114 | (prettyCExpr a) <> 115 | Pretty.brackets (fromString $ show n) 116 | Cast t a -> 117 | Pretty.parens (prettyCType t) <> 118 | (case a of 119 | Cast{} -> Pretty.parens 120 | Deref{} -> Pretty.parens 121 | Plus{} -> Pretty.parens 122 | _ -> id 123 | ) (prettyCExpr a) 124 | Plus a b -> 125 | prettyCExpr a <> 126 | " + " <> 127 | prettyCExpr b 128 | Init as -> Pretty.braces $ intersperseMap ", " prettyCExpr as 129 | InitNamed as -> 130 | Pretty.braces $ 131 | intersperseMap 132 | ", " 133 | (\(a, b) -> "." <> Pretty.textStrict a <> " = " <> prettyCExpr b) 134 | as 135 | Project a b -> 136 | (case a of 137 | Cast{} -> Pretty.parens 138 | Plus{} -> Pretty.parens 139 | _ -> id 140 | ) 141 | (prettyCExpr a) <> 142 | "." <> Pretty.textStrict b 143 | Eq a b -> 144 | prettyCExpr a <> 145 | " == " <> 146 | prettyCExpr b 147 | 148 | prettyCType :: CType -> Doc 149 | prettyCType t = 150 | case t of 151 | Ptr a -> prettyCType a <> " *" 152 | FunPtr ret args -> 153 | prettyCType ret <> 154 | Pretty.parens "*" <> 155 | Pretty.parens (intersperseMap ", " prettyCType args) 156 | Void m_ann -> 157 | "void" <> 158 | foldMap (\(Ann a) -> " /* " <> Pretty.textStrict a <> " */") m_ann 159 | Int32 -> "int32_t" 160 | UInt8 -> "uint8_t" 161 | Bool -> "bool" 162 | Name n -> Pretty.textStrict n 163 | TStruct fs -> 164 | "struct " <> 165 | Pretty.braces 166 | (" " <> 167 | foldMap 168 | (\(ft, fn) -> prettyNamedCType fn ft <> "; ") 169 | fs 170 | ) 171 | Union vs -> 172 | "union " <> 173 | Pretty.lbrace Pretty.<$> 174 | Pretty.indent 4 175 | (Pretty.vsep . Vector.toList $ 176 | fmap 177 | (\(vt, vn) -> prettyNamedCType vn vt <> ";") 178 | vs 179 | ) Pretty.<$> 180 | Pretty.rbrace 181 | 182 | prettyNamedCType :: Text -> CType -> Doc 183 | prettyNamedCType n t = 184 | case t of 185 | FunPtr ret args -> 186 | prettyCType ret <> 187 | Pretty.parens ("*" <> Pretty.textStrict n) <> 188 | Pretty.parens (intersperseMap ", " prettyCType args) 189 | _ -> Pretty.hsep [prettyCType t, Pretty.textStrict n] 190 | 191 | prettyCStatement :: CStatement -> Doc 192 | prettyCStatement s = 193 | case s of 194 | Return e -> "return " <> prettyCExpr e 195 | Declare t n e -> 196 | prettyNamedCType n t <> 197 | foldMap ((" = " <>) . prettyCExpr) e 198 | Assign l r -> prettyCExpr l <> " = " <> prettyCExpr r 199 | If cond ss -> 200 | "if " <> Pretty.parens (prettyCExpr cond) <> " " <> 201 | Pretty.lbrace Pretty.<$> 202 | Pretty.indent 4 203 | (Pretty.vsep $ 204 | fmap (\s' -> prettyCStatement s' <> ";") ss 205 | ) Pretty.<$> 206 | Pretty.rbrace 207 | 208 | prettyCDecl :: CDecl -> Doc 209 | prettyCDecl d = 210 | case d of 211 | Include n -> "#include " <> Pretty.textStrict n 212 | Function ty n args body -> 213 | prettyCType ty <> " " <> Pretty.textStrict n <> 214 | Pretty.parens 215 | (intersperseMap 216 | ", " 217 | (\(argTy, argName) -> 218 | prettyNamedCType argName argTy 219 | ) 220 | args 221 | ) <> 222 | " " <> 223 | Pretty.lbrace Pretty.<$> 224 | Pretty.indent 4 225 | (Pretty.vsep $ 226 | fmap (\s -> prettyCStatement s <> ";") body 227 | ) Pretty.<$> 228 | Pretty.rbrace 229 | Typedef t n -> 230 | "typedef " <> prettyCType t <> " " <> Pretty.textStrict n 231 | Struct n fs -> 232 | "struct " <> Pretty.textStrict n <> " " <> 233 | Pretty.lbrace Pretty.<$> 234 | Pretty.indent 4 235 | (Pretty.vsep . Vector.toList $ 236 | fmap 237 | (\(ft, fn) -> prettyNamedCType fn ft <> ";") 238 | fs 239 | ) Pretty.<$> 240 | Pretty.rbrace 241 | 242 | prettyCDecls :: [CDecl] -> Doc 243 | prettyCDecls = 244 | intersperseMap 245 | Pretty.line 246 | (\d -> 247 | (case d of 248 | Typedef{} -> Pretty.line 249 | Function{} -> Pretty.line 250 | Struct{} -> Pretty.line 251 | _ -> mempty 252 | ) <> 253 | prettyCDecl d <> 254 | (case d of 255 | Typedef{} -> ";" 256 | Struct{} -> ";" 257 | Function{} -> "" 258 | _ -> mempty 259 | ) 260 | ) 261 | 262 | preamble :: [CDecl] 263 | preamble = 264 | [ Include "\"stdlib.h\"" 265 | , Include "\"stdint.h\"" 266 | , Include "\"stdbool.h\"" 267 | , Include "\"alloca.h\"" 268 | ] 269 | -------------------------------------------------------------------------------- /src/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language LambdaCase #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language QuantifiedConstraints #-} 5 | {-# language ScopedTypeVariables #-} 6 | module Compile 7 | ( CompileError(..) 8 | , SyntaxError(..) 9 | , parse 10 | , compile 11 | , parseAndCompile 12 | ) 13 | where 14 | 15 | import Bound.Var (Var) 16 | import Control.Lens.Getter (use, view) 17 | import Control.Lens.Setter ((%=), (.~), (<>=)) 18 | import Control.Monad.Except (MonadError, throwError) 19 | import Control.Monad.State.Strict (MonadState, evalStateT, runStateT) 20 | import Data.Foldable (foldl') 21 | import Data.Function ((&)) 22 | import Data.Map (Map) 23 | import qualified Data.Map as Map 24 | import Data.Text (Text) 25 | import qualified Data.Text.Lazy as Lazy 26 | import Data.Text.Lazy.Builder (Builder) 27 | import qualified Data.Text.Lazy.Builder as Builder 28 | import Data.Void (Void) 29 | import Text.Diagnostic (Diagnostic(..), Position(..), Report, render, defaultConfig, emit) 30 | import Text.Diagnostic.Sage (parseError) 31 | import Text.Sage (spanStart, spanLength) 32 | 33 | import Check.Datatype (HasDatatypeCtors, HasDatatypeFields, checkADT, datatypeCtors, datatypeFields) 34 | import Check.Entailment (HasSizeMetas, HasGlobalTheory, globalTheory) 35 | import Check.Function (checkFunction) 36 | import Check.TCState (emptyTCState) 37 | import Check.TCState.FilterTypes (FilterTypes) 38 | import Codegen (codeKinds, codeDatatypeCtors, codeDeclarations, codeGlobalTheory) 39 | import qualified Codegen 40 | import qualified Codegen.C as C 41 | import Error.TypeError (TypeError(..)) 42 | import qualified IR 43 | import qualified Parser 44 | import qualified Size.Builtins as Size 45 | import Syntax (Index, Span(..)) 46 | import qualified Syntax 47 | import Unify.KMeta (HasKindMetas) 48 | import Unify.TMeta (HasTypeMetas) 49 | 50 | data SyntaxError 51 | = ParseError Parser.ParseError 52 | 53 | renderSyntaxError :: Text -> Text -> SyntaxError -> Lazy.Text 54 | renderSyntaxError fileName input (ParseError err) = 55 | render defaultConfig fileName input (parseError err) 56 | 57 | emitSpan :: Span -> Builder -> Report 58 | emitSpan sp msg = 59 | case sp of 60 | Unknown -> 61 | emit 62 | (Offset 0) 63 | Caret 64 | (msg <> " (location unknown)") 65 | Known sp' -> 66 | emit 67 | (Offset $ spanStart sp') 68 | (Span $ spanLength sp') 69 | msg 70 | 71 | prettyTypeM :: (a -> Text) -> Syntax.TypeM a -> Text 72 | prettyTypeM f = Syntax.prettyType (either Syntax.prettyTMeta f) . Syntax.unTypeM 73 | 74 | typeError :: TypeError -> Report 75 | typeError err = 76 | case err of 77 | MissingKMeta k -> error $ "internal error: missing kind meta " <> show k 78 | MissingTMeta t -> error $ "internal error: missing type meta " <> show t 79 | OutOfBoundsInt32 sp -> 80 | emitSpan sp "out of bounds for 32-bit int" 81 | TypeMismatch sp expected actual -> 82 | emitSpan sp $ 83 | "expected type '" <> 84 | Builder.fromText (prettyTypeM id expected) <> 85 | "', got '" <> 86 | Builder.fromText (prettyTypeM id actual) <> 87 | "'" 88 | KindMismatch sp expected actual -> 89 | emitSpan sp $ 90 | "expected kind '" <> 91 | Builder.fromText (IR.prettyKind expected) <> 92 | "', got '" <> 93 | Builder.fromText (IR.prettyKind actual) <> 94 | "'" 95 | TypeOccurs sp v t -> 96 | emitSpan sp $ 97 | "cannot equate types '" <> 98 | Builder.fromText (Syntax.prettyTMeta v) <> 99 | "', and '" <> 100 | Builder.fromText (prettyTypeM id t) <> 101 | "'" 102 | KindOccurs sp v k -> 103 | emitSpan sp $ 104 | "cannot equate kinds '" <> 105 | Builder.fromText (IR.prettyKMeta v) <> 106 | "', and '" <> 107 | Builder.fromText (IR.prettyKind k) <> 108 | "'" 109 | Can'tInfer sp -> emitSpan sp "can't infer type" 110 | NotInScope sp -> emitSpan sp "variable not in scope" 111 | TNotInScope sp -> emitSpan sp "type not in scope" 112 | CouldNotDeduce c -> 113 | emitSpan {- TODO -}Unknown $ 114 | "could not deduce " <> 115 | Builder.fromText (IR.prettyConstraint (Right . either Syntax.prettyTMeta id) c) 116 | Doesn'tHaveField sp t f -> 117 | emitSpan sp $ 118 | "type '" <> 119 | Builder.fromText (prettyTypeM id t) <> 120 | "' has no field \"" <> 121 | Builder.fromText f <> 122 | "\"" 123 | CtorNotInScope sp -> 124 | emitSpan sp "constructor not in scope" 125 | CtorArityMismatch sp expected actual -> 126 | emitSpan sp $ 127 | "expected " <> 128 | Builder.fromString (show expected) <> 129 | " arguments, got " <> 130 | Builder.fromString (show actual) 131 | MatchingOnStruct sp -> 132 | emitSpan sp "can't pattern match on struct" 133 | 134 | data CompileError 135 | = TypeError TypeError 136 | | MissingMainFunction 137 | deriving (Eq, Show) 138 | 139 | compileError :: CompileError -> Report 140 | compileError err = 141 | case err of 142 | TypeError e -> typeError e 143 | MissingMainFunction -> emitSpan Unknown "missing main function" 144 | 145 | renderCompileError :: Text -> Text -> CompileError -> Lazy.Text 146 | renderCompileError fileName input = render defaultConfig fileName input . compileError 147 | 148 | parseAndCompile :: 149 | MonadError Lazy.Text m => 150 | Text -> -- file name 151 | Text -> -- input 152 | m [C.CDecl] 153 | parseAndCompile fileName input = 154 | case parse input of 155 | Left err -> throwError $ renderSyntaxError fileName input err 156 | Right decls -> 157 | case compile decls of 158 | Left err -> throwError $ renderCompileError fileName input err 159 | Right res -> pure res 160 | 161 | parse :: 162 | MonadError SyntaxError m => 163 | Text -> 164 | m [Syntax.Declaration] 165 | parse input = 166 | case Parser.parse (Parser.declarations <* Parser.eof) input of 167 | Left err -> throwError $ ParseError err 168 | Right decls -> pure decls 169 | 170 | compile :: 171 | MonadError CompileError m => 172 | [Syntax.Declaration] -> 173 | m [C.CDecl] 174 | compile decls = do 175 | ((kindScope, _, decls'), tcState) <- 176 | either (throwError . TypeError) pure . 177 | flip runStateT (emptyTCState & globalTheory .~ Map.fromList Size.builtins) $ 178 | checkDecls mempty mempty decls 179 | let 180 | declsMap = 181 | foldl' 182 | (\acc f -> Map.insert (IR.declOrigin f, IR.declName f) f acc) 183 | mempty 184 | decls' 185 | initialCode = 186 | Codegen.emptyCode & 187 | codeKinds .~ kindScope & 188 | codeDeclarations .~ declsMap & 189 | codeGlobalTheory .~ view globalTheory tcState & 190 | codeDatatypeCtors .~ view datatypeCtors tcState 191 | code <- 192 | flip evalStateT initialCode $ 193 | case Map.lookup (IR.OFunction, "main") declsMap of 194 | Just (IR.DFunc mainFunc) -> do 195 | mainFunc' <- Codegen.genFunction mainFunc mempty 196 | ds <- Codegen.genDecls 197 | pure $ C.preamble <> ds <> [mainFunc'] 198 | _ -> throwError MissingMainFunction 199 | pure code 200 | where 201 | checkDecls :: 202 | ( MonadState (s (Var Index Void)) m 203 | , FilterTypes s 204 | , HasTypeMetas s 205 | , forall x. HasDatatypeCtors (s x) 206 | , forall x. HasDatatypeFields (s x) 207 | , forall x. HasKindMetas (s x) 208 | , forall x. HasSizeMetas (s x) 209 | , forall x. HasGlobalTheory (s x) 210 | , MonadError TypeError m 211 | ) => 212 | Map Text IR.Kind -> 213 | Map Text (IR.TypeScheme Void) -> 214 | [Syntax.Declaration] -> 215 | m 216 | ( Map Text IR.Kind 217 | , Map Text (IR.TypeScheme Void) 218 | , [IR.Declaration] 219 | ) 220 | checkDecls kindScope tyScope ds = 221 | case ds of 222 | [] -> pure (kindScope, tyScope, []) 223 | d:rest -> 224 | case d of 225 | Syntax.DData (Syntax.ADT name params ctors) -> do 226 | (adt, kind, axiom, size) <- checkADT kindScope name params ctors 227 | let ctorsDecls = IR.datatypeConstructors adt 228 | datatypeCtors <>= foldl' (\acc c -> Map.insert (IR.ctorName c) c acc) mempty ctorsDecls 229 | globalTheory %= Map.insert axiom size 230 | maybe 231 | (pure ()) 232 | (\fs -> datatypeFields %= Map.insert name fs) 233 | (IR.makeDatatypeFields adt) 234 | (kindScope', tyScope', rest') <- 235 | checkDecls 236 | (Map.insert name kind kindScope) 237 | (foldl' 238 | (\acc ctor -> 239 | Map.insert 240 | (IR.ctorName ctor) 241 | (IR.constructorToTypeScheme ctor) 242 | acc 243 | ) 244 | tyScope 245 | ctorsDecls 246 | ) 247 | rest 248 | pure 249 | ( kindScope' 250 | , tyScope' 251 | , IR.DData adt : foldr ((:) . IR.DCtor) rest' ctorsDecls 252 | ) 253 | Syntax.DFunc func -> do 254 | global <- use globalTheory 255 | fields <- use datatypeFields 256 | ctors <- use datatypeCtors 257 | func' <- checkFunction global fields ctors kindScope tyScope func 258 | (kindScope', tyScope', rest') <- 259 | checkDecls 260 | kindScope 261 | (Map.insert 262 | (IR.funcName func') 263 | (IR.functionToTypeScheme func') 264 | tyScope 265 | ) 266 | rest 267 | pure (kindScope', tyScope', IR.DFunc func' : rest') 268 | -------------------------------------------------------------------------------- /src/Error/TypeError.hs: -------------------------------------------------------------------------------- 1 | module Error.TypeError where 2 | 3 | import Data.Text (Text) 4 | import qualified Data.Text as Text 5 | 6 | import IR (Constraint, KMeta, Kind) 7 | import Syntax (Span, TMeta, TypeM) 8 | 9 | data TypeError 10 | = MissingKMeta KMeta 11 | | MissingTMeta TMeta 12 | | OutOfBoundsInt32 !Span 13 | | TypeMismatch !Span (TypeM Text) (TypeM Text) 14 | | KindMismatch !Span Kind Kind 15 | | TypeOccurs !Span TMeta (TypeM Text) 16 | | KindOccurs !Span KMeta Kind 17 | | Can'tInfer !Span 18 | | NotInScope !Span 19 | | TNotInScope !Span 20 | | CouldNotDeduce {- TODO: !Span -} (Constraint (Either TMeta Text)) 21 | | Doesn'tHaveField !Span (TypeM Text) Text 22 | | CtorNotInScope !Span 23 | | CtorArityMismatch !Span Int Int 24 | | MatchingOnStruct !Span 25 | deriving (Eq, Show) 26 | 27 | renderTyName :: Either Int Text -> Text 28 | renderTyName = either (Text.pack . ("#" <>) . show) id 29 | 30 | typeMismatch :: (ty -> Either Int Text) -> Span -> TypeM ty -> TypeM ty -> TypeError 31 | typeMismatch tyNames sp expected actual = 32 | TypeMismatch sp (renderTyName . tyNames <$> expected) (renderTyName . tyNames <$> actual) 33 | -------------------------------------------------------------------------------- /src/IR.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language OverloadedLists, OverloadedStrings #-} 4 | {-# language StandaloneDeriving #-} 5 | {-# language TemplateHaskell #-} 6 | {-# language TypeApplications #-} 7 | module IR where 8 | 9 | import Bound.Var (Var(..), unvar) 10 | import Control.Lens.Setter ((.~), over, mapped) 11 | import Control.Lens.Tuple (_1) 12 | import Data.Bifunctor (bimap, first) 13 | import Data.Deriving (deriveEq1, deriveShow1, deriveEq2, deriveShow2) 14 | import Data.Function ((&)) 15 | import Data.Functor.Classes (Eq1(..), Show1(..), Eq2(..), Show2(..), eq1, showsPrec1) 16 | import Data.Map (Map) 17 | import qualified Data.Map as Map 18 | import qualified Data.Maybe as Maybe 19 | import Data.Text (Text) 20 | import qualified Data.Text as Text 21 | import Data.Vector (Vector) 22 | import qualified Data.Vector as Vector 23 | import Data.Void (Void) 24 | import Data.Word (Word8, Word64) 25 | import Data.Int (Int32) 26 | import qualified Data.Text.Read as Text (decimal) 27 | 28 | import Syntax (Index(..), Span(..), Type(..), prettyType, typeSpans, varSpan, indexSpan, voidSpan) 29 | 30 | data Projection 31 | = Numeric Word64 32 | | Field Text 33 | deriving (Eq, Show) 34 | 35 | parseProjection :: Text -> Projection 36 | parseProjection a = 37 | case Text.decimal a of 38 | Right (n, "") -> Numeric n 39 | _ -> Field a 40 | 41 | data Case ty tm 42 | = Case 43 | { caseCtor :: Text 44 | , caseArgs :: Vector Text 45 | , caseExpr :: Expr ty (Var Index tm) 46 | } deriving (Functor, Foldable, Traversable) 47 | 48 | data Expr ty tm 49 | = Var tm 50 | | Name Text 51 | 52 | | Let (Vector ((Text, Expr ty tm), Type ty)) (Expr ty tm) 53 | | Inst Text (Vector (Type ty)) 54 | | Ctor Text (Vector (Type ty)) 55 | | Call (Expr ty tm) (Vector (Expr ty tm)) (Type ty) 56 | 57 | | Int32 Int32 58 | | Add (Expr ty tm) (Expr ty tm) 59 | 60 | | BTrue 61 | | BFalse 62 | 63 | | New (Expr ty tm) (Type ty) 64 | | Deref (Expr ty tm) 65 | 66 | | Project (Expr ty tm) Projection 67 | | Match (Expr ty tm) (Type ty) (Vector (Case ty tm)) (Type ty) 68 | deriving (Functor, Foldable, Traversable) 69 | deriveEq2 ''Case 70 | deriveShow2 ''Case 71 | instance (Eq ty) => Eq1 (Case ty) where; liftEq = liftEq2 (==) 72 | instance (Show ty) => Show1 (Case ty) where; liftShowsPrec = liftShowsPrec2 showsPrec showList 73 | instance (Eq ty, Eq tm) => Eq (Case ty tm) where; (==) = eq1 74 | instance (Show ty, Show tm) => Show (Case ty tm) where; showsPrec = showsPrec1 75 | 76 | deriveEq2 ''Expr 77 | deriveShow2 ''Expr 78 | instance (Eq ty) => Eq1 (Expr ty) where; liftEq = liftEq2 (==) 79 | instance (Show ty) => Show1 (Expr ty) where; liftShowsPrec = liftShowsPrec2 showsPrec showList 80 | instance (Eq ty, Eq tm) => Eq (Expr ty tm) where; (==) = eq1 81 | instance (Show ty, Show tm) => Show (Expr ty tm) where; showsPrec = showsPrec1 82 | 83 | bindType_Case :: (ty -> Type ty') -> Case ty tm -> Case ty' tm 84 | bindType_Case f (Case name args e) = 85 | Case name args (bindType_Expr f e) 86 | 87 | bindType_Expr :: (ty -> Type ty') -> Expr ty tm -> Expr ty' tm 88 | bindType_Expr f e = 89 | case e of 90 | Var a -> Var a 91 | Name a -> Name a 92 | Let es b -> 93 | Let 94 | (fmap (bimap (fmap (bindType_Expr f)) (>>= f)) es) 95 | (bindType_Expr f b) 96 | Inst n ts -> Inst n ((>>= f) <$> ts) 97 | Ctor n ts -> Ctor n ((>>= f) <$> ts) 98 | Call a bs t -> 99 | Call (bindType_Expr f a) (bindType_Expr f <$> bs) (t >>= f) 100 | Int32 ws -> Int32 ws 101 | Add a b -> Add (bindType_Expr f a) (bindType_Expr f b) 102 | BTrue -> BTrue 103 | BFalse -> BFalse 104 | New a t -> New (bindType_Expr f a) (t >>= f) 105 | Deref a -> Deref $ bindType_Expr f a 106 | Project a b -> Project (bindType_Expr f a) b 107 | Match a inTy bs resTy -> 108 | Match (bindType_Expr f a) (inTy >>= f) (bindType_Case f <$> bs) (resTy >>= f) 109 | 110 | newtype KMeta = KMeta Int 111 | deriving (Eq, Ord, Show) 112 | 113 | prettyKMeta :: KMeta -> Text 114 | prettyKMeta (KMeta n) = Text.pack $ '?' : show n 115 | 116 | data Kind = KType | KArr Kind Kind | KVar KMeta 117 | deriving (Eq, Ord, Show) 118 | 119 | prettyKind :: Kind -> Text 120 | prettyKind k = 121 | case k of 122 | KType -> "Type" 123 | KArr a b -> 124 | (case a of 125 | KType -> ("(" <>) . (<> ")") 126 | _ -> id 127 | ) (prettyKind a) <> 128 | " -> " <> 129 | prettyKind b 130 | KVar v -> prettyKMeta v 131 | 132 | foldKMeta :: Monoid m => (KMeta -> m) -> Kind -> m 133 | foldKMeta f k = 134 | case k of 135 | KType -> mempty 136 | KArr a b -> foldKMeta f a <> foldKMeta f b 137 | KVar a -> f a 138 | 139 | substKMeta :: (KMeta -> Kind) -> Kind -> Kind 140 | substKMeta f k = 141 | case k of 142 | KType -> KType 143 | KArr a b -> KArr (substKMeta f a) (substKMeta f b) 144 | KVar a -> f a 145 | 146 | data Constraint a 147 | = CSized (Type a) 148 | | CForall (Maybe Text) Kind (Constraint (Var () a)) 149 | | CImplies (Constraint a) (Constraint a) 150 | deriving (Functor, Foldable, Traversable) 151 | deriveEq1 ''Constraint 152 | deriveShow1 ''Constraint 153 | instance Eq a => Eq (Constraint a) where; (==) = eq1 154 | deriving instance Ord a => Ord (Constraint a) 155 | instance Show a => Show (Constraint a) where; showsPrec = showsPrec1 156 | 157 | prettyConstraint :: (a -> Either Int Text) -> Constraint a -> Text 158 | prettyConstraint var c = 159 | case c of 160 | CSized t -> 161 | "Sized " <> 162 | (case t of 163 | TApp{} -> ("(" <>) . (<> ")") 164 | _ -> id 165 | ) (prettyType (either (Text.pack . ('#' :) . show) id . var) t) 166 | CForall mName k rest -> 167 | "forall (" <> 168 | Maybe.fromMaybe "_" mName <> 169 | " : " <> 170 | prettyKind k <> 171 | ")." <> 172 | prettyConstraint 173 | (unvar (\() -> maybe (Left 0) Right mName) (first (+1) . var)) 174 | rest 175 | CImplies a b -> 176 | (case a of 177 | CForall{} -> ("(" <>) . (<> ")") 178 | CImplies{} -> ("(" <>) . (<> ")") 179 | _ -> id 180 | ) 181 | (prettyConstraint var a) <> 182 | " => " <> 183 | prettyConstraint var b 184 | 185 | bindConstraint :: (a -> Type b) -> Constraint a -> Constraint b 186 | bindConstraint f c = 187 | case c of 188 | CSized t -> CSized (t >>= f) 189 | CImplies a b -> CImplies (f `bindConstraint` a) (f `bindConstraint` b) 190 | CForall n k a -> CForall n k (unvar (pure . B) (fmap F . f) `bindConstraint` a) 191 | 192 | data Function 193 | = Function 194 | { funcName :: Text 195 | , funcTyArgs :: Vector (Text, Kind) 196 | , funcConstraints :: Vector (Constraint (Var Index Void)) -- indices from funcTyArgs 197 | , funcArgs :: Vector (Text, Type (Var Index Void)) -- indices from funcTyArgs 198 | , funcRetTy :: Type (Var Index Void) -- indices from funcTyArgs 199 | , funcBody :: 200 | Expr 201 | (Var Index Void) -- indices from funcTyArgs 202 | (Var Index Void) -- indices from funcArgs 203 | } deriving (Eq, Show) 204 | 205 | data CtorSort 206 | = StructCtor 207 | | EnumCtor Word8 208 | deriving (Eq, Show) 209 | 210 | data Constructor 211 | = Constructor 212 | { ctorName :: Text 213 | , ctorSort :: CtorSort 214 | , ctorTyArgs :: Vector (Text, Kind) 215 | , ctorArgs :: Vector (Maybe Text, Span -> Type (Var Index Void)) 216 | , ctorRetTy :: Span -> Type (Var Index Void) 217 | } 218 | 219 | data Datatype 220 | = Empty 221 | { datatypeName :: Text 222 | , datatypeTyArgs :: Vector (Text, Kind) 223 | } 224 | | Struct 225 | { datatypeName :: Text 226 | , datatypeTyArgs :: Vector (Text, Kind) 227 | , structFields :: Vector (Maybe Text, Type (Var Index Void)) 228 | } 229 | | Enum 230 | { datatypeName :: Text 231 | , datatypeTyArgs :: Vector (Text, Kind) 232 | , enumCtors :: Vector (Text, Vector (Maybe Text, Type (Var Index Void))) 233 | } deriving (Eq, Show) 234 | 235 | data Fields 236 | = Unnamed (Vector (Type (Var Index Void))) 237 | | Named (Map Text (Type (Var Index Void))) 238 | deriving Show 239 | 240 | makeDatatypeFields :: Datatype -> Maybe Fields 241 | makeDatatypeFields adt = 242 | case adt of 243 | Empty{} -> Just $ Unnamed mempty 244 | Struct _ _ fs -> Just . either (Unnamed . Vector.fromList) Named $ namedOrUnnamed fs 245 | Enum{} -> Nothing 246 | where 247 | namedOrUnnamed :: Vector (Maybe Text, a) -> Either [a] (Map Text a) 248 | namedOrUnnamed = 249 | Maybe.fromJust . 250 | foldr 251 | (\(m_n, t) rest -> 252 | case rest of 253 | Nothing -> 254 | Just $ 255 | maybe 256 | (Left [t]) 257 | (\n -> Right $ Map.singleton n t) 258 | m_n 259 | Just (Left unnamed) -> 260 | case m_n of 261 | Just{} -> error $ "makeDatatypeFields: mix of named an unnamed fields in " <> show adt 262 | Nothing -> Just . Left $ t : unnamed 263 | Just (Right named) -> 264 | case m_n of 265 | Nothing -> error $ "makeDatatypeFields: mix of named an unnamed fields in " <> show adt 266 | Just n -> Just . Right $ Map.insert n t named 267 | ) 268 | Nothing 269 | 270 | data Origin 271 | = ODatatype 272 | | OConstructor 273 | | OFunction 274 | deriving (Eq, Ord, Show) 275 | 276 | data TypeScheme ty 277 | = TypeScheme 278 | { schemeOrigin :: Origin 279 | , schemeTyArgs :: Vector (Text, Kind) 280 | , schemeConstraints :: Vector (Constraint (Var Index ty)) -- indices from schemeTyArgs 281 | , schemeArgs :: Vector (Maybe Text, Type (Var Index ty)) -- indices from schemeTyArgs 282 | , schemeRetTy :: Type (Var Index ty) -- indices from schemeTyArgs 283 | } 284 | deriveEq1 ''TypeScheme 285 | deriveShow1 ''TypeScheme 286 | instance Eq ty => Eq (TypeScheme ty) where; (==) = eq1 287 | instance Show ty => Show (TypeScheme ty) where; showsPrec = showsPrec1 288 | 289 | functionToTypeScheme :: Function -> TypeScheme Void 290 | functionToTypeScheme (Function _ tyArgs constrs args ret _) = 291 | TypeScheme OFunction tyArgs constrs (over (mapped._1) Just args) ret 292 | 293 | datatypeConstructors :: Datatype -> Vector Constructor 294 | datatypeConstructors adt = 295 | case adt of 296 | Empty{} -> mempty 297 | Struct name params fields -> 298 | [ Constructor 299 | { ctorName = name 300 | , ctorSort = StructCtor 301 | , ctorTyArgs = params 302 | , ctorArgs = fmap (\t sp -> t & typeSpans (varSpan indexSpan voidSpan) .~ sp) <$> fields 303 | , ctorRetTy = 304 | \sp -> 305 | foldl @[] 306 | (\a b -> TApp sp a (TVar . B $ Index Unknown b)) 307 | (TName sp name) 308 | [0..length params-1] 309 | } 310 | ] 311 | Enum name params ctors -> 312 | let 313 | retTy sp = 314 | foldl @[] 315 | (\a b -> TApp sp a (TVar . B $ Index sp b)) 316 | (TName sp name) 317 | [0..length params-1] 318 | in 319 | (\(tag, (cn, fields)) -> 320 | Constructor 321 | { ctorName = cn 322 | , ctorSort = EnumCtor tag 323 | , ctorTyArgs = params 324 | , ctorArgs = fmap (\t sp -> t & typeSpans (varSpan indexSpan voidSpan) .~ sp) <$> fields 325 | , ctorRetTy = retTy 326 | } 327 | ) <$> 328 | Vector.zip [0..] ctors 329 | 330 | constructorToTypeScheme :: Constructor -> TypeScheme Void 331 | constructorToTypeScheme (Constructor _ _ tyArgs args retTy) = 332 | TypeScheme 333 | { schemeOrigin = OConstructor 334 | , schemeTyArgs = tyArgs 335 | , schemeConstraints = [] 336 | , schemeArgs = fmap ($ Unknown) <$> args {- TODO: make these depend on instantiation span? -} 337 | , schemeRetTy = retTy {- TODO -} Unknown 338 | } 339 | 340 | data Declaration 341 | = DData Datatype 342 | | DCtor Constructor 343 | | DFunc Function 344 | 345 | declOrigin :: Declaration -> Origin 346 | declOrigin d = 347 | case d of 348 | DFunc{} -> OFunction 349 | DCtor{} -> OConstructor 350 | DData{} -> ODatatype 351 | 352 | declName :: Declaration -> Text 353 | declName d = 354 | case d of 355 | DFunc f -> funcName f 356 | DCtor c -> ctorName c 357 | DData a -> datatypeName a 358 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language OverloadedStrings #-} 3 | {-# language ScopedTypeVariables #-} 4 | module Parser 5 | ( Parser, Parser.ParseError(..), Parser.parse, Parser.eof 6 | , datatype 7 | , declaration 8 | , declarations 9 | , expr 10 | , function 11 | , type_ 12 | ) 13 | where 14 | 15 | import Bound (Var(..)) 16 | import Control.Applicative ((<|>), many) 17 | import Data.Functor (void) 18 | import qualified Data.Set as Set 19 | import Data.Text (Text) 20 | import qualified Data.Vector as Vector 21 | import Text.Sage (Parser, ()) 22 | import qualified Text.Sage as Parser 23 | 24 | import Syntax 25 | ( Index(..), Span(..) 26 | , ADT(..), Ctors(..) 27 | , Declaration(..) 28 | , Function(..) 29 | , Case(..) 30 | , Expr(..) 31 | , Type(..) 32 | ) 33 | 34 | spaces :: Parser s () 35 | spaces = 36 | void . many $ 37 | Parser.satisfy (Parser.Predicate (== ' ') (Set.singleton $ Parser.Named "space")) 38 | 39 | newlines :: Parser s () 40 | newlines = 41 | void . many $ 42 | Parser.satisfy 43 | (Parser.Predicate 44 | (\case; '\n' -> True; ' ' -> True; _ -> False) 45 | (Set.singleton $ Parser.Named "newline") 46 | ) 47 | 48 | parens :: Parser s a -> Parser s a 49 | parens = Parser.between (Parser.char '(') (Parser.char ')') 50 | 51 | braces :: Parser s a -> Parser s a 52 | braces = Parser.between (Parser.char '{') (Parser.char '}') 53 | 54 | angles :: Parser s a -> Parser s a 55 | angles = Parser.between (Parser.char '<') (Parser.char '>') 56 | 57 | ident :: Parser s Text 58 | ident = Parser.takeWhile1 (Parser.pLower <> Parser.pUpper) "identifier" 59 | 60 | expr :: forall s a. (Parser.Span -> Text -> Maybe a) -> Parser s (Expr a) 61 | expr abstract = 62 | match <|> 63 | let_ <|> 64 | simple 65 | where 66 | let_ = 67 | (\(sp, (bs, e)) -> Let (Known sp) (Vector.fromList bs) e) <$> 68 | Parser.spanned 69 | ((,) <$ Parser.symbol "let" <* newlines <*> 70 | Parser.sepBy 71 | ((,) <$> 72 | ident <* Parser.between spaces spaces (Parser.char '=') <*> 73 | expr abstract 74 | ) 75 | (Parser.char ';' <* newlines) <* 76 | Parser.between newlines newlines (Parser.symbol "in") <*> 77 | expr abstract 78 | ) 79 | 80 | simple = add 81 | 82 | add = 83 | fmap snd $ 84 | foldl 85 | (\(spl, l) (spr, r) -> let sp = spl <> spr in (sp, Add (Known sp) l r)) <$> 86 | Parser.spanned deref <* spaces <*> 87 | many (Parser.char '+' *> spaces *> Parser.spanned deref <* spaces) 88 | 89 | deref = 90 | (\(sp, e) -> Deref (Known sp) e) <$> Parser.spanned (Parser.char '*' *> deref) <|> 91 | projectOrCall 92 | 93 | field = 94 | Parser.takeWhile1 Parser.pDigit <|> 95 | Parser.takeWhile1 Parser.pLower 96 | 97 | commasep p = Parser.sepBy p (Parser.char ',' *> spaces) 98 | 99 | args = 100 | parens (Vector.fromList <$> commasep (expr abstract)) 101 | 102 | projectOrCall = 103 | (\(sp, (z, as)) -> 104 | foldl (\acc -> either (Project (Known sp) acc) (Call (Known sp) acc)) z as 105 | ) <$> 106 | (Parser.spanned $ 107 | (,) <$> 108 | atom <*> 109 | many 110 | (Left <$ Parser.char '.' <*> field <|> 111 | Right <$> args 112 | ) 113 | ) 114 | 115 | bool :: Parser s (Expr a) 116 | bool = 117 | (\(sp, _) -> BTrue $ Known sp) <$> Parser.spanned (Parser.symbol "true") <|> 118 | (\(sp, _) -> BFalse $ Known sp) <$> Parser.spanned (Parser.symbol "false") 119 | 120 | new = 121 | (\(sp, e) -> New (Known sp) e) <$> 122 | Parser.spanned 123 | (Parser.symbol "new" *> Parser.char '[' *> 124 | expr abstract <* Parser.char ']' 125 | ) 126 | 127 | number = 128 | (\(sp, x) -> Number (Known sp) x) <$> 129 | (Parser.spanned $ 130 | (negate <$ Parser.char '-' <|> pure id) <*> 131 | Parser.decimal 132 | ) 133 | 134 | atom = 135 | bool <|> 136 | new <|> 137 | number <|> 138 | (\(sp, i) -> maybe (Name (Known sp) i) Var $ abstract sp i) <$> Parser.spanned ident <|> 139 | parens (expr abstract) 140 | 141 | case_ = do 142 | (sp, (c, as)) <- 143 | Parser.spanned $ 144 | (,) <$> ident <*> parens (Vector.fromList <$> commasep ident) 145 | _ <- spaces *> Parser.symbol "=>" *> spaces 146 | e <- expr (\s n -> B . Index (Known s) <$> Vector.findIndex (n ==) as <|> F <$> abstract s n) 147 | pure $ Case (Known sp) c as e 148 | 149 | match = 150 | (\(sp, (e, bs)) -> Match (Known sp) e bs) <$> 151 | (Parser.spanned $ 152 | (,) <$ Parser.symbol "match" <* spaces <*> 153 | simple <* spaces <*> 154 | Parser.between 155 | (Parser.char '{' *> newlines) 156 | (newlines *> Parser.char '}') 157 | (Vector.fromList <$> Parser.sepBy case_ (Parser.char ',' <* newlines)) 158 | ) 159 | 160 | type_ :: forall s a. (Parser.Span -> Text -> Maybe a) -> Parser s (Type a) 161 | type_ abstract = snd <$> self 162 | where 163 | self = app 164 | 165 | atom :: Parser s (Type a) 166 | atom = 167 | (\(sp, _) -> TInt32 $ Known sp) <$> Parser.spanned (Parser.symbol "int32") <* spaces <|> 168 | (\(sp, _) -> TBool $ Known sp) <$> Parser.spanned (Parser.symbol "bool") <* spaces <|> 169 | (\(sp, _) -> TPtr $ Known sp) <$> Parser.spanned (Parser.symbol "ptr") <* spaces <|> 170 | (\(sp, ts) -> TFun (Known sp) $ Vector.fromList ts) <$> 171 | Parser.spanned 172 | (Parser.symbol "fun" *> 173 | parens (Parser.sepBy (type_ abstract) (Parser.char ',' <* spaces)) 174 | ) <* spaces <|> 175 | parens (type_ abstract) <* spaces <|> 176 | (\(sp, i) -> maybe (TName (Known sp) i) TVar $ abstract sp i) <$> Parser.spanned ident <* spaces 177 | 178 | app = 179 | foldl 180 | (\(spl, l) (spr, r) -> let sp = spl <> spr in (sp, TApp (Known sp) l r)) <$> 181 | Parser.spanned atom <*> 182 | many (Parser.spanned atom) 183 | 184 | datatype :: Parser s ADT 185 | datatype = 186 | struct <|> 187 | enum 188 | where 189 | struct = do 190 | Parser.symbol "struct" <* Parser.char ' ' <* spaces 191 | tName <- ident <* spaces 192 | tArgs <- Vector.fromList <$> many (ident <* spaces) 193 | _ <- Parser.char '=' <* spaces 194 | c <- 195 | (\n as -> Ctor n (Vector.fromList as) End) <$> 196 | ident <*> 197 | parens 198 | (Parser.sepBy 199 | (type_ $ \sp v -> B . Index (Known sp) <$> Vector.elemIndex v tArgs) 200 | (Parser.char ',' <* spaces) 201 | ) 202 | pure $ ADT tName tArgs c 203 | enum = do 204 | Parser.symbol "enum" <* Parser.char ' ' <* spaces 205 | tName <- ident <* spaces 206 | tArgs <- Vector.fromList <$> many (ident <* spaces) 207 | cs <- 208 | braces $ 209 | foldr (\(n, as) -> Ctor n (Vector.fromList as)) End <$ spaces <*> 210 | Parser.sepBy 211 | ((,) <$> 212 | ident <*> 213 | parens 214 | (Parser.sepBy 215 | (type_ $ \sp v -> B . Index (Known sp) <$> Vector.elemIndex v tArgs) 216 | (Parser.char ',' <* spaces) 217 | ) <* 218 | spaces 219 | ) 220 | (Parser.char ',' <* spaces) 221 | pure $ ADT tName tArgs cs 222 | 223 | function :: Parser s Function 224 | function = do 225 | Parser.symbol "fn" <* Parser.char ' ' <* spaces 226 | name <- ident 227 | tArgs <- 228 | angles 229 | (Vector.fromList <$> 230 | Parser.sepBy ident (Parser.char ',' *> spaces) 231 | ) <|> 232 | pure mempty 233 | let abstractTy sp v = B . Index (Known sp) <$> Vector.elemIndex v tArgs 234 | args <- 235 | parens $ 236 | Vector.fromList <$> 237 | Parser.sepBy 238 | ((,) <$> ident <* spaces <* Parser.char ':' <* spaces <*> type_ abstractTy) 239 | (Parser.char ',' *> spaces) 240 | _ <- spaces <* Parser.symbol "->" <* spaces 241 | retTy <- type_ abstractTy 242 | let abstractTm sp v = B . Index (Known sp) <$> Vector.elemIndex v (fst <$> args) 243 | body <- braces $ newlines *> expr abstractTm <* newlines 244 | pure $ Function name tArgs args retTy body 245 | 246 | declaration :: Parser s Declaration 247 | declaration = 248 | DData <$> datatype <|> 249 | DFunc <$> function 250 | 251 | declarations :: Parser s [Declaration] 252 | declarations = newlines *> many (declaration <* newlines) 253 | -------------------------------------------------------------------------------- /src/Size.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language TemplateHaskell #-} 4 | module Size 5 | ( Size(..), pattern Var, (.@), plusSize, maxSize 6 | , sizeConstraintFor 7 | ) 8 | where 9 | 10 | import Bound ((>>>=), Scope, instantiate1) 11 | import Bound.Var (Var(..)) 12 | import Control.Monad (ap) 13 | import Data.Deriving (deriveEq1, deriveShow1) 14 | import Data.Functor.Classes (eq1, showsPrec1) 15 | import Data.Word (Word64) 16 | 17 | import IR (Kind(..)) 18 | import qualified IR 19 | import qualified Syntax 20 | 21 | data Size a 22 | = Lam (Scope () Size a) 23 | | App a [Size a] 24 | | Plus (Size a) (Size a) 25 | | Max (Size a) (Size a) 26 | | Word Word64 27 | deriving (Functor, Foldable, Traversable) 28 | deriveEq1 ''Size 29 | deriveShow1 ''Size 30 | instance Eq a => Eq (Size a) where; (==) = eq1 31 | instance Show a => Show (Size a) where; showsPrec = showsPrec1 32 | instance Applicative Size where; pure a = App a []; (<*>) = ap 33 | instance Monad Size where -- probably not lawful, but it's helpful to have everything be 'beta-normal' 34 | Lam a >>= f = Lam (a >>>= f) 35 | App a bs >>= f = foldl (.@) (f a) ((>>= f) <$> bs) 36 | Plus a b >>= f = 37 | let 38 | a' = a >>= f 39 | b' = b >>= f 40 | in 41 | case (a', b') of 42 | (Word m, Word n) -> Word $! m + n 43 | _ -> Plus a' b' 44 | Max a b >>= f = 45 | let 46 | a' = a >>= f 47 | b' = b >>= f 48 | in 49 | case (a', b') of 50 | (Word m, Word n) -> Word $! max m n 51 | _ -> Plus a' b' 52 | Word n >>= _ = Word n 53 | 54 | pattern Var :: a -> Size a 55 | pattern Var a = App a [] 56 | 57 | infixl 5 .@ 58 | (.@) :: Size a -> Size a -> Size a 59 | (.@) (Lam f) x = instantiate1 x f 60 | (.@) (App a bs) x = App a (bs ++ [x]) 61 | (.@) Word{} _ = error "applying to Word" 62 | (.@) Plus{} _ = error "applying to Plus" 63 | (.@) Max{} _ = error "applying to Max" 64 | 65 | plusSize :: Size a -> Size a -> Size a 66 | plusSize (Word 0) b = b 67 | plusSize a (Word 0) = a 68 | plusSize (Word a) (Word b) = Word (a + b) 69 | plusSize a b = Plus a b 70 | 71 | maxSize :: Size a -> Size a -> Size a 72 | maxSize (Word 0) b = b 73 | maxSize a (Word 0) = a 74 | maxSize (Word a) (Word b) = Word (max a b) 75 | maxSize a b = Max a b 76 | 77 | -- | Computes a size constraint for a type of a particular kind 78 | -- 79 | -- Examples: 80 | -- 81 | -- `Type` maps to `Sized #0` 82 | -- `Type -> Type` maps to `forall t0. Sized t0 => Sized (#0 t0)` 83 | -- `(Type -> Type) -> Type -> Type` maps to `forall t0. (forall t1. Sized t1 => Sized (t0 t1)) => forall t3. Sized t3 => Sized #0` 84 | sizeConstraintFor :: 85 | Kind -> 86 | IR.Constraint (Var () ty) 87 | sizeConstraintFor = go [] (B ()) 88 | where 89 | go :: 90 | [x] -> 91 | x -> 92 | Kind -> 93 | IR.Constraint x 94 | go quants x k = 95 | case k of 96 | KType -> 97 | IR.CSized $ 98 | foldl 99 | (\acc v -> Syntax.TApp Syntax.Unknown acc $ Syntax.TVar v) 100 | (Syntax.TVar x) 101 | quants 102 | KArr a b -> 103 | IR.CForall Nothing a $ 104 | IR.CImplies (sizeConstraintFor a) $ 105 | go (fmap F quants ++ [B ()]) (F x) b 106 | KVar m -> error $ show m <> " in sizeConstraintFor" 107 | -------------------------------------------------------------------------------- /src/Size/Builtins.hs: -------------------------------------------------------------------------------- 1 | module Size.Builtins 2 | ( builtins 3 | , ptrSize 4 | , boolSize 5 | , int32Size 6 | ) 7 | where 8 | 9 | import Bound.Var (Var(..)) 10 | import Data.Void (Void) 11 | 12 | import IR (Constraint(..), Kind(..)) 13 | import Size (Size) 14 | import qualified Size 15 | import Syntax (Type(..), Span(Unknown)) 16 | 17 | builtins :: [(Constraint Void, Size Void)] 18 | builtins = 19 | ptrSize : 20 | boolSize : 21 | int32Size : 22 | [] 23 | 24 | ptrSize :: (Constraint Void, Size Void) 25 | ptrSize = 26 | ( CForall Nothing KType $ 27 | CSized $ TApp Unknown (TPtr Unknown) (TVar $ B ()) 28 | , Size.Word 8 29 | ) 30 | 31 | boolSize :: (Constraint Void, Size Void) 32 | boolSize = 33 | ( CSized $ TBool Unknown 34 | , Size.Word 1 35 | ) 36 | 37 | int32Size :: (Constraint Void, Size Void) 38 | int32Size = 39 | ( CSized $ TInt32 Unknown 40 | , Size.Word 4 41 | ) 42 | -------------------------------------------------------------------------------- /src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# language OverloadedStrings #-} 3 | {-# language PatternSynonyms #-} 4 | {-# language RankNTypes #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language StandaloneDeriving #-} 7 | {-# language TemplateHaskell #-} 8 | module Syntax where 9 | 10 | import Bound.TH (makeBound) 11 | import Bound.Var (Var(..), unvar) 12 | import Control.Lens.Getter ((^.)) 13 | import Control.Lens.Lens (Lens', lens) 14 | import Control.Lens.Setter ((.~)) 15 | import Control.Lens.Traversal (Traversal') 16 | import Control.Monad (ap) 17 | import Control.Monad.Except (ExceptT(..), runExceptT) 18 | import Data.Deriving (deriveEq1, deriveShow1) 19 | import Data.Foldable (fold) 20 | import Data.Function ((&)) 21 | import Data.Functor.Classes (Eq1(..), eq1, showsPrec1) 22 | import qualified Data.List as List 23 | import Data.Text (Text) 24 | import qualified Data.Text as Text 25 | import Data.Vector (Vector) 26 | import Data.Void (Void, absurd) 27 | import qualified Text.Sage as Sage 28 | 29 | data Span = Unknown | Known Sage.Span 30 | deriving (Eq, Ord, Show) 31 | 32 | instance Semigroup Span where 33 | Unknown <> a = a 34 | a <> Unknown = a 35 | Known a <> Known b = Known (a <> b) 36 | 37 | data Type a 38 | = TVar a 39 | | TApp !Span (Type a) (Type a) 40 | | TInt32 !Span 41 | | TBool !Span 42 | | TPtr !Span 43 | | TFun !Span (Vector (Type a)) 44 | | TName !Span Text 45 | deriving (Functor, Foldable, Traversable) 46 | makeBound ''Type 47 | -- deriveEq1 ''Type 48 | -- instance Eq a => Eq (Type a) where; (==) = eq1 49 | -- deriving instance Ord a => Ord (Type a) 50 | deriveShow1 ''Type 51 | instance Eq1 Type where 52 | liftEq f (TVar a) (TVar a') = f a a' 53 | liftEq f (TApp _ a b) (TApp _ a' b') = liftEq f a a' && liftEq f b b' 54 | liftEq _ (TInt32 _) (TInt32 _) = True 55 | liftEq _ (TBool _) (TBool _) = True 56 | liftEq _ (TPtr _) (TPtr _) = True 57 | liftEq f (TFun _ ts) (TFun _ ts') = liftEq (liftEq f) ts ts' 58 | liftEq _ (TName _ a) (TName _ a') = a == a' 59 | liftEq _ _ _ = False 60 | instance Eq a => Eq (Type a) where (==) = eq1 61 | instance Ord a => Ord (Type a) where 62 | compare (TVar a) (TVar a') = compare a a' 63 | compare TVar{} _ = LT 64 | compare _ TVar{} = GT 65 | 66 | compare (TApp _ a b) (TApp _ a' b') = 67 | case compare a a' of 68 | EQ -> compare b b' 69 | c -> c 70 | compare TApp{} _ = LT 71 | compare _ TApp{} = GT 72 | 73 | compare (TInt32 _) (TInt32 _) = EQ 74 | compare TInt32{} _ = LT 75 | compare _ TInt32{} = GT 76 | 77 | compare (TBool _) (TBool _) = EQ 78 | compare TBool{} _ = LT 79 | compare _ TBool{} = GT 80 | 81 | compare (TPtr _) (TPtr _) = EQ 82 | compare TPtr{} _ = LT 83 | compare _ TPtr{} = GT 84 | 85 | compare (TFun _ a) (TFun _ a') = compare a a' 86 | compare TFun{} _ = LT 87 | compare _ TFun{} = GT 88 | 89 | compare (TName _ a) (TName _ a') = compare a a' 90 | -- compare TName{} _ = LT 91 | -- compare _ TName{} = GT 92 | instance Show a => Show (Type a) where; showsPrec = showsPrec1 93 | 94 | typeSpans :: forall a. Traversal' a Span -> Traversal' (Type a) Span 95 | typeSpans as f t = 96 | case t of 97 | TVar a -> TVar <$> as f a 98 | TApp sp a b -> TApp <$> f sp <*> typeSpans as f a <*> typeSpans as f b 99 | TInt32 sp -> TInt32 <$> f sp 100 | TBool sp -> TBool <$> f sp 101 | TPtr sp -> TPtr <$> f sp 102 | TFun sp a -> TFun <$> f sp <*> (traverse.typeSpans as) f a 103 | TName sp a -> (\sp' -> TName sp' a) <$> f sp 104 | 105 | typeSpan :: forall a. Lens' a Span -> Lens' (Type a) Span 106 | typeSpan as = lens get set 107 | where 108 | get :: Type a -> Span 109 | get t = 110 | case t of 111 | TVar a -> a ^. as 112 | TApp sp _ _ -> sp 113 | TInt32 sp -> sp 114 | TBool sp -> sp 115 | TPtr sp -> sp 116 | TFun sp _ -> sp 117 | TName sp _ -> sp 118 | 119 | set :: Type a -> Span -> Type a 120 | set t sp' = 121 | case t of 122 | TVar a -> TVar (a & as .~ sp') 123 | TApp _ a b -> TApp sp' a b 124 | TInt32 _ -> TInt32 sp' 125 | TBool _ -> TBool sp' 126 | TPtr _ -> TPtr sp' 127 | TFun _ a -> TFun sp' a 128 | TName _ a -> TName sp' a 129 | 130 | unApply :: Type a -> (Type a, [Type a]) 131 | unApply = go [] 132 | where 133 | go ts t = 134 | case t of 135 | TApp _ a b -> go (b:ts) a 136 | _ -> (t, ts) 137 | 138 | data TMeta = TMeta !Span {-# UNPACK #-} !Int 139 | deriving Show 140 | instance Eq TMeta where; TMeta _ v == TMeta _ v' = v == v' 141 | instance Ord TMeta where; TMeta _ v `compare` TMeta _ v' = v `compare` v' 142 | 143 | prettyTMeta :: TMeta -> Text 144 | prettyTMeta (TMeta _ n) = Text.pack $ '?' : show n 145 | 146 | tmetaSpan :: TMeta -> Span 147 | tmetaSpan (TMeta s _) = s 148 | 149 | type TypeM = ExceptT TMeta Type 150 | 151 | eitherTMetaSpan :: forall a. Lens' a Span -> Lens' (Either TMeta a) Span 152 | eitherTMetaSpan as = lens get set 153 | where 154 | get :: Either TMeta a -> Span 155 | get t = 156 | case t of 157 | Left (TMeta sp _) -> sp 158 | Right a -> a ^. as 159 | 160 | set :: Either TMeta a -> Span -> Either TMeta a 161 | set t sp' = 162 | case t of 163 | Left (TMeta _ v) -> Left (TMeta sp' v) 164 | Right a -> Right (a & as .~ sp') 165 | 166 | typemSpan :: forall a. Lens' a Span -> Lens' (TypeM a) Span 167 | typemSpan as = lens get set 168 | where 169 | get :: TypeM a -> Span 170 | get t = unTypeM t ^. typeSpan (eitherTMetaSpan as) 171 | 172 | set :: TypeM a -> Span -> TypeM a 173 | set t sp' = TypeM $ unTypeM t & typeSpan (eitherTMetaSpan as) .~ sp' 174 | 175 | eitherTMetaSpans :: forall a. Traversal' a Span -> Traversal' (Either TMeta a) Span 176 | eitherTMetaSpans as f e = 177 | case e of 178 | Left (TMeta sp v) -> (\sp' -> Left $ TMeta sp' v) <$> f sp 179 | Right a -> Right <$> as f a 180 | 181 | typemSpans :: Traversal' a Span -> Traversal' (TypeM a) Span 182 | typemSpans as f = fmap TypeM . typeSpans (eitherTMetaSpans as) f . unTypeM 183 | 184 | pattern TypeM :: Type (Either TMeta ty) -> TypeM ty 185 | pattern TypeM a = ExceptT a 186 | 187 | unTypeM :: TypeM ty -> Type (Either TMeta ty) 188 | unTypeM = runExceptT 189 | 190 | 191 | parens :: Text -> Text 192 | parens a = "(" <> a <> ")" 193 | 194 | prettyType :: (a -> Text) -> Type a -> Text 195 | prettyType var ty = 196 | case ty of 197 | TVar a -> var a 198 | TApp _ a b -> 199 | prettyType var a <> 200 | " " <> 201 | (case b of 202 | TApp{} -> parens 203 | _ -> id 204 | ) (prettyType var b) 205 | TInt32 _ -> "int32" 206 | TBool _ -> "bool" 207 | TPtr _ -> "ptr" 208 | TFun _ args -> 209 | "fun(" <> 210 | fold 211 | (List.intersperse ", " $ 212 | foldr ((:) . prettyType var) [] args 213 | ) <> 214 | ")" 215 | TName _ n -> n 216 | 217 | data Ctors a 218 | = End 219 | | Ctor { ctorName :: Text, ctorArgs :: Vector (Type a), ctorRest :: Ctors a } 220 | deriving (Functor, Foldable, Traversable) 221 | -- deriveEq1 ''Ctors 222 | -- instance Eq a => Eq (Ctors a) where; (==) = eq1 223 | deriving instance Eq a => Eq (Ctors a) 224 | deriveShow1 ''Ctors 225 | instance Show a => Show (Ctors a) where; showsPrec = showsPrec1 226 | 227 | ctorsToList :: Ctors a -> [(Text, Vector (Type a))] 228 | ctorsToList cs = 229 | case cs of 230 | End -> [] 231 | Ctor a b c -> (a, b) : ctorsToList c 232 | 233 | data Index 234 | = Index !Span {-# UNPACK #-} !Int 235 | deriving Show 236 | 237 | voidSpan :: Lens' Void Span 238 | voidSpan = lens absurd absurd 239 | 240 | indexSpan :: Lens' Index Span 241 | indexSpan = lens get set 242 | where 243 | get (Index sp _) = sp 244 | set (Index _ i) sp' = Index sp' i 245 | 246 | varSpan :: Lens' a Span -> Lens' b Span -> Lens' (Var a b) Span 247 | varSpan as bs = lens get set 248 | where 249 | get = unvar (^. as) (^. bs) 250 | set = unvar (\a new -> B $ a & as .~ new) (\b new -> F $ b & bs .~ new) 251 | 252 | instance Eq Index where; Index _ i == Index _ i' = i == i' 253 | instance Ord Index where; Index _ i `compare` Index _ i' = i `compare` i' 254 | 255 | getIndex :: Index -> Int 256 | getIndex (Index _ i) = i 257 | 258 | data ADT 259 | = ADT 260 | { adtName :: Text 261 | , adtArgs :: Vector Text 262 | , adtCtors :: Ctors (Var Index Void) 263 | } deriving (Eq, Show) 264 | 265 | data Case a 266 | = Case 267 | { caseCtorSpan :: !Span 268 | , caseCtor :: Text 269 | , caseArgs :: Vector Text 270 | , caseExpr :: Expr (Var Index a) 271 | } deriving (Functor, Foldable, Traversable) 272 | 273 | data Expr a 274 | = Var a 275 | | Name !Span Text 276 | 277 | | Let !Span (Vector (Text, Expr a)) (Expr a) 278 | | Call !Span (Expr a) (Vector (Expr a)) 279 | 280 | | Number !Span Integer 281 | | Add !Span (Expr a) (Expr a) 282 | 283 | | BTrue !Span 284 | | BFalse !Span 285 | 286 | | New !Span (Expr a) 287 | | Deref !Span (Expr a) 288 | 289 | | Project !Span (Expr a) Text 290 | | Match !Span (Expr a) (Vector (Case a)) 291 | deriving (Functor, Foldable, Traversable) 292 | deriveEq1 ''Case 293 | deriveShow1 ''Case 294 | instance Eq a => Eq (Case a) where; (==) = eq1 295 | instance Show a => Show (Case a) where; showsPrec = showsPrec1 296 | 297 | deriveEq1 ''Expr 298 | deriveShow1 ''Expr 299 | instance Eq a => Eq (Expr a) where; (==) = eq1 300 | instance Show a => Show (Expr a) where; showsPrec = showsPrec1 301 | 302 | exprSpan :: forall a. Lens' a Span -> Lens' (Expr a) Span 303 | exprSpan l = lens get set 304 | where 305 | get :: Expr a -> Span 306 | get e = 307 | case e of 308 | Var a -> a ^. l 309 | Name sp _ -> sp 310 | Let sp _ _ -> sp 311 | Call sp _ _ -> sp 312 | Number sp _ -> sp 313 | Add sp _ _ -> sp 314 | BTrue sp -> sp 315 | BFalse sp -> sp 316 | New sp _ -> sp 317 | Deref sp _ -> sp 318 | Project sp _ _ -> sp 319 | Match sp _ _ -> sp 320 | 321 | set :: Expr a -> Span -> Expr a 322 | set e sp' = 323 | case e of 324 | Var a -> Var (a & l .~ sp') 325 | Name _ a -> Name sp' a 326 | Let _ a b -> Let sp' a b 327 | Call _ a b -> Call sp' a b 328 | Number _ a -> Number sp' a 329 | Add _ a b -> Add sp' a b 330 | BTrue _ -> BTrue sp' 331 | BFalse _ -> BFalse sp' 332 | New _ a -> New sp' a 333 | Deref _ a -> Deref sp' a 334 | Project _ a b -> Project sp' a b 335 | Match _ a b -> Match sp' a b 336 | 337 | bindExpr_Case :: (a -> Expr b) -> Case a -> Case b 338 | bindExpr_Case f (Case sp name args e) = Case sp name args (e >>= unvar (Var . B) (fmap F . f)) 339 | 340 | instance Applicative Expr where; pure = Var; (<*>) = ap 341 | instance Monad Expr where 342 | expr >>= f = 343 | case expr of 344 | Var a -> f a 345 | Name sp n -> Name sp n 346 | Let sp es b -> Let sp ((\(n, e) -> (n, e >>= f)) <$> es) (b >>= f) 347 | Call sp a args -> Call sp (a >>= f) ((>>= f) <$> args) 348 | Number sp n -> Number sp n 349 | Add sp a b -> Add sp (a >>= f) (b >>= f) 350 | BTrue sp -> BTrue sp 351 | BFalse sp -> BFalse sp 352 | New sp v -> New sp (v >>= f) 353 | Deref sp p -> Deref sp (p >>= f) 354 | Project sp a field -> Project sp (a >>= f) field 355 | Match sp e cs -> Match sp (e >>= f) (bindExpr_Case f <$> cs) 356 | 357 | data Function 358 | = Function 359 | { funcName :: Text 360 | , funcTyArgs :: Vector Text 361 | , funcArgs :: Vector (Text, Type (Var Index Void)) -- indices from funcTyArgs 362 | , funcRetTy :: Type (Var Index Void) -- indices from funcTyArgs 363 | , funcBody :: Expr (Var Index Void) -- indices from funcArgs 364 | } deriving (Eq, Show) 365 | 366 | data Declaration 367 | = DData ADT 368 | | DFunc Function 369 | deriving Show 370 | -------------------------------------------------------------------------------- /src/Unify/KMeta.hs: -------------------------------------------------------------------------------- 1 | module Unify.KMeta 2 | ( HasKindMetas(..) 3 | , freshKMeta 4 | , getKMeta 5 | , solveKMetasMaybe 6 | , solveKMetas 7 | ) 8 | where 9 | 10 | import Control.Applicative (empty) 11 | import Control.Lens.Getter (use) 12 | import Control.Lens.Lens (Lens') 13 | import Control.Lens.Setter ((.=)) 14 | import Control.Monad.State.Strict (MonadState) 15 | import Control.Monad.Trans.Class (lift) 16 | import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) 17 | import Data.Map (Map) 18 | import qualified Data.Map as Map 19 | 20 | import IR (KMeta(..), Kind(..)) 21 | 22 | class HasKindMetas s where 23 | nextKMeta :: Lens' s KMeta 24 | kmetaSolutions :: Lens' s (Map KMeta Kind) 25 | 26 | freshKMeta :: (MonadState s m, HasKindMetas s) => m KMeta 27 | freshKMeta = do 28 | KMeta k <- use nextKMeta 29 | nextKMeta .= KMeta (k+1) 30 | pure $ KMeta k 31 | 32 | getKMeta :: 33 | (MonadState s m, HasKindMetas s) => 34 | KMeta -> 35 | m (Maybe Kind) 36 | getKMeta v = do 37 | sols <- use kmetaSolutions 38 | pure $ Map.lookup v sols 39 | 40 | solveKMetasMaybe :: 41 | (MonadState s m, HasKindMetas s) => 42 | IR.Kind -> 43 | m (Maybe IR.Kind) 44 | solveKMetasMaybe = runMaybeT . go 45 | where 46 | go :: 47 | (MonadState s m, HasKindMetas s) => 48 | IR.Kind -> 49 | MaybeT m IR.Kind 50 | go k = 51 | case k of 52 | IR.KVar m -> 53 | maybe empty go =<< 54 | lift (getKMeta m) 55 | IR.KArr a b -> 56 | IR.KArr <$> go a <*> go b 57 | IR.KType -> pure IR.KType 58 | 59 | solveKMetas :: 60 | (MonadState s m, HasKindMetas s) => 61 | IR.Kind -> 62 | m IR.Kind 63 | solveKMetas = go 64 | where 65 | go :: 66 | (MonadState s m, HasKindMetas s) => 67 | IR.Kind -> 68 | m IR.Kind 69 | go k = 70 | case k of 71 | IR.KVar m -> 72 | maybe (pure $ IR.KVar m) go =<< 73 | getKMeta m 74 | IR.KArr a b -> 75 | IR.KArr <$> go a <*> go b 76 | IR.KType -> pure IR.KType 77 | -------------------------------------------------------------------------------- /src/Unify/Kind.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | module Unify.Kind (unifyKind) where 3 | 4 | import Control.Lens.Setter ((%=)) 5 | import Control.Monad.Except (MonadError, throwError) 6 | import Control.Monad.State.Strict (MonadState) 7 | import qualified Data.Map as Map 8 | import Data.Monoid (Any(..)) 9 | 10 | import Error.TypeError (TypeError(..)) 11 | import IR (Kind(..), foldKMeta) 12 | import Syntax (Span) 13 | import Unify.KMeta (HasKindMetas, getKMeta, kmetaSolutions) 14 | 15 | unifyKind :: 16 | ( MonadState s m, HasKindMetas s 17 | , MonadError TypeError m 18 | ) => 19 | Span -> 20 | Kind -> 21 | Kind -> 22 | m () 23 | unifyKind sp expected actual = 24 | case expected of 25 | KVar v | KVar v' <- actual, v == v' -> pure () 26 | KVar v -> solveLeft v actual 27 | KArr a b -> 28 | case actual of 29 | KVar v -> solveRight expected v 30 | KArr a' b' -> do 31 | unifyKind sp a a' 32 | unifyKind sp b b' 33 | _ -> throwError $ KindMismatch sp expected actual 34 | KType -> 35 | case actual of 36 | KVar v -> solveRight expected v 37 | KType -> pure () 38 | _ -> throwError $ KindMismatch sp expected actual 39 | where 40 | solveLeft v k = do 41 | m_k' <- getKMeta v 42 | case m_k' of 43 | Nothing -> 44 | if getAny $ foldKMeta (Any . (v ==)) k 45 | then throwError $ KindOccurs sp v k 46 | else kmetaSolutions %= Map.insert v k 47 | Just k' -> unifyKind sp k' k 48 | solveRight k v = do 49 | m_k' <- getKMeta v 50 | case m_k' of 51 | Nothing -> 52 | if getAny $ foldKMeta (Any . (v ==)) k 53 | then throwError $ KindOccurs sp v k 54 | else kmetaSolutions %= Map.insert v k 55 | Just k' -> unifyKind sp k k' 56 | -------------------------------------------------------------------------------- /src/Unify/TMeta.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | module Unify.TMeta 3 | ( HasTypeMetas(..) 4 | , freshTMeta 5 | , getTMeta 6 | , getTMetaKind 7 | , solveMetas_Constraint 8 | , solveTMetas_Expr 9 | , solveTMetas_Type 10 | ) 11 | where 12 | 13 | import Bound.Var (Var(..)) 14 | import Control.Lens.Getter (use) 15 | import Control.Lens.Lens (Lens') 16 | import Control.Lens.Setter ((.=), (%=)) 17 | import Control.Monad.State.Strict (MonadState) 18 | import Data.Bitraversable (bitraverse) 19 | import Data.Map (Map) 20 | import qualified Data.Map as Map 21 | 22 | import IR (Kind(..)) 23 | import qualified IR 24 | import Syntax (Span, TMeta(..), TypeM, unTypeM, Type(..)) 25 | import Unify.KMeta (HasKindMetas, solveKMetas) 26 | 27 | class HasTypeMetas s where 28 | nextTMeta :: Lens' (s ty) Int 29 | tmetaKinds :: Lens' (s ty) (Map TMeta Kind) 30 | tmetaSolutions :: Lens' (s ty) (Map TMeta (TypeM ty)) 31 | 32 | getTMeta :: 33 | (MonadState (s ty) m, HasTypeMetas s) => 34 | TMeta -> 35 | m (Maybe (TypeM ty)) 36 | getTMeta v = do 37 | sols <- use tmetaSolutions 38 | pure $ Map.lookup v sols 39 | 40 | getTMetaKind :: (MonadState (s ty) m, HasTypeMetas s) => TMeta -> m (Maybe Kind) 41 | getTMetaKind v = do 42 | ks <- use tmetaKinds 43 | pure $ Map.lookup v ks 44 | 45 | freshTMeta :: (MonadState (s ty) m, HasTypeMetas s) => Span -> Kind -> m TMeta 46 | freshTMeta sp k = do 47 | t <- use nextTMeta 48 | nextTMeta .= t+1 49 | tmetaKinds %= Map.insert (TMeta sp t) k 50 | pure $ TMeta sp t 51 | 52 | solveTMetas_Type :: 53 | (MonadState (s ty) m, HasTypeMetas s) => 54 | (ty -> a) -> 55 | Type (Either TMeta a) -> 56 | m (Type (Either TMeta a)) 57 | solveTMetas_Type d = go d 58 | where 59 | go :: 60 | (MonadState (s ty) m, HasTypeMetas s) => 61 | (ty -> a) -> 62 | Type (Either TMeta a) -> 63 | m (Type (Either TMeta a)) 64 | go depth t = 65 | case t of 66 | TVar a -> 67 | case a of 68 | Left m -> 69 | getTMeta m >>= 70 | maybe 71 | (pure $ TVar $ Left m) 72 | (go depth . unTypeM . fmap depth) 73 | Right x -> pure $ TVar $ Right x 74 | TApp sp a b -> TApp sp <$> go depth a <*> go depth b 75 | TInt32 sp -> pure $ TInt32 sp 76 | TBool sp -> pure $ TBool sp 77 | TPtr sp -> pure $ TPtr sp 78 | TFun sp ts -> TFun sp <$> traverse (go depth) ts 79 | TName sp n -> pure $ TName sp n 80 | 81 | solveMetas_Constraint :: 82 | (MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty)) => 83 | IR.Constraint (Either TMeta ty) -> 84 | m (IR.Constraint (Either TMeta ty)) 85 | solveMetas_Constraint = go id 86 | where 87 | go :: 88 | (MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty)) => 89 | (ty -> a) -> 90 | IR.Constraint (Either TMeta a) -> 91 | m (IR.Constraint (Either TMeta a)) 92 | go depth c = 93 | case c of 94 | IR.CSized t -> 95 | IR.CSized <$> solveTMetas_Type depth t 96 | IR.CForall n k rest -> 97 | IR.CForall n <$> 98 | solveKMetas k <*> 99 | (fmap sequence <$> go (F . depth) (sequence <$> rest)) 100 | IR.CImplies a b -> 101 | IR.CImplies <$> 102 | go depth a <*> 103 | go depth b 104 | 105 | solveTMetas_Expr :: 106 | (MonadState (s ty) m, HasTypeMetas s) => 107 | IR.Expr (Either TMeta ty) tm -> 108 | m (IR.Expr (Either TMeta ty) tm) 109 | solveTMetas_Expr = go 110 | where 111 | goCase :: 112 | (MonadState (s ty) m, HasTypeMetas s) => 113 | IR.Case (Either TMeta ty) tm -> 114 | m (IR.Case (Either TMeta ty) tm) 115 | goCase (IR.Case name args e) = 116 | IR.Case name args <$> go e 117 | 118 | go :: 119 | (MonadState (s ty) m, HasTypeMetas s) => 120 | IR.Expr (Either TMeta ty) tm -> 121 | m (IR.Expr (Either TMeta ty) tm) 122 | go e = 123 | case e of 124 | IR.Var a -> pure $ IR.Var a 125 | IR.Name n -> pure $ IR.Name n 126 | IR.Let bs rest -> 127 | IR.Let <$> 128 | traverse (bitraverse (traverse go) (solveTMetas_Type id)) bs <*> 129 | go rest 130 | IR.Inst n args -> 131 | IR.Inst n <$> 132 | traverse 133 | (solveTMetas_Type id) 134 | args 135 | IR.Ctor n ts -> 136 | IR.Ctor n <$> 137 | traverse 138 | (solveTMetas_Type id) 139 | ts 140 | IR.Call f args t -> 141 | IR.Call <$> 142 | go f <*> 143 | traverse go args <*> 144 | solveTMetas_Type id t 145 | IR.Int32 n -> pure $ IR.Int32 n 146 | IR.Add a b -> IR.Add <$> go a <*> go b 147 | IR.BTrue -> pure $ IR.BTrue 148 | IR.BFalse -> pure $ IR.BFalse 149 | IR.New a t -> IR.New <$> go a <*> solveTMetas_Type id t 150 | IR.Deref a -> IR.Deref <$> go a 151 | IR.Project a b -> (\a' -> IR.Project a' b) <$> go a 152 | IR.Match a inTy b resTy -> 153 | IR.Match <$> 154 | go a <*> 155 | solveTMetas_Type id inTy <*> 156 | traverse goCase b <*> 157 | solveTMetas_Type id resTy 158 | -------------------------------------------------------------------------------- /src/Unify/Type.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language RankNTypes #-} 4 | module Unify.Type (unifyType) where 5 | 6 | import Control.Applicative (empty) 7 | import Control.Lens.Getter ((^.)) 8 | import Control.Lens.Lens (Lens') 9 | import Control.Lens.Setter ((%=)) 10 | import Control.Monad.Except (MonadError, throwError) 11 | import Control.Monad.State.Strict (MonadState) 12 | import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) 13 | import Data.Foldable (traverse_) 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Text (Text) 17 | import qualified Data.Vector as Vector 18 | 19 | import Check.Kind (inferKind) 20 | import Error.TypeError (TypeError(..), typeMismatch, renderTyName) 21 | import Syntax (Span, TypeM, pattern TypeM, unTypeM, tmetaSpan, typemSpan) 22 | import qualified Syntax 23 | import IR (Kind(..)) 24 | import Unify.KMeta (HasKindMetas) 25 | import Unify.Kind (unifyKind) 26 | import Unify.TMeta (HasTypeMetas, getTMeta, tmetaSolutions, solveTMetas_Type) 27 | 28 | unifyType :: 29 | ( MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty) 30 | , MonadError TypeError m 31 | , Eq ty 32 | ) => 33 | Map Text Kind -> 34 | Lens' ty Span -> 35 | (ty -> Either Int Text) -> 36 | (ty -> Kind) -> 37 | TypeM ty -> 38 | TypeM ty -> 39 | m () 40 | unifyType kindScope spans tyNames kinds expected actual = do 41 | eKind <- inferKind kindScope kinds expected 42 | aKind <- inferKind kindScope kinds actual 43 | unifyKind (actual ^. typemSpan spans) eKind aKind 44 | res <- runMaybeT $ tryUnifyType kindScope spans tyNames kinds expected actual 45 | case res of 46 | Nothing -> do 47 | expected' <- TypeM <$> solveTMetas_Type id (unTypeM expected) 48 | actual' <- TypeM <$> solveTMetas_Type id (unTypeM actual) 49 | throwError $ typeMismatch tyNames (actual' ^. typemSpan spans) expected' actual' 50 | Just () -> pure () 51 | 52 | tryUnifyType :: 53 | ( MonadState (s ty) m, HasTypeMetas s, HasKindMetas (s ty) 54 | , MonadError TypeError m 55 | , Eq ty 56 | ) => 57 | Map Text Kind -> 58 | Lens' ty Span -> 59 | (ty -> Either Int Text) -> 60 | (ty -> Kind) -> 61 | TypeM ty -> 62 | TypeM ty -> 63 | MaybeT m () 64 | tryUnifyType kindScope spans tyNames kinds expected actual = do 65 | case unTypeM expected of 66 | Syntax.TVar (Left m) -> solveLeft m actual 67 | Syntax.TVar (Right a) -> 68 | case unTypeM actual of 69 | Syntax.TVar (Left m) -> solveRight expected m 70 | Syntax.TVar (Right b) | a == b -> pure () 71 | _ -> empty 72 | Syntax.TApp _ a b -> 73 | case unTypeM actual of 74 | Syntax.TVar (Left m) -> solveRight expected m 75 | Syntax.TApp _ a' b' -> do 76 | tryUnifyType kindScope spans tyNames kinds (TypeM a) (TypeM a') 77 | tryUnifyType kindScope spans tyNames kinds (TypeM b) (TypeM b') 78 | _ -> empty 79 | Syntax.TInt32{} -> 80 | case unTypeM actual of 81 | Syntax.TVar (Left m) -> solveRight expected m 82 | Syntax.TInt32{} -> pure () 83 | _ -> empty 84 | Syntax.TBool{} -> 85 | case unTypeM actual of 86 | Syntax.TVar (Left m) -> solveRight expected m 87 | Syntax.TBool{} -> pure () 88 | _ -> empty 89 | Syntax.TPtr{} -> 90 | case unTypeM actual of 91 | Syntax.TVar (Left m) -> solveRight expected m 92 | Syntax.TPtr{} -> pure () 93 | _ -> empty 94 | Syntax.TFun _ args -> 95 | case unTypeM actual of 96 | Syntax.TVar (Left m) -> solveRight expected m 97 | Syntax.TFun _ args' | Vector.length args == Vector.length args' -> 98 | traverse_ 99 | (\(a, b) -> tryUnifyType kindScope spans tyNames kinds (TypeM a) (TypeM b)) 100 | (Vector.zip args args') 101 | _ -> empty 102 | Syntax.TName _ n -> 103 | case unTypeM actual of 104 | Syntax.TVar (Left m) -> solveRight expected m 105 | Syntax.TName _ n' | n == n' -> pure () 106 | _ -> empty 107 | where 108 | solveLeft m actual' = do 109 | m_t <- getTMeta m 110 | case m_t of 111 | Just t -> tryUnifyType kindScope spans tyNames kinds t actual' 112 | Nothing -> 113 | case unTypeM actual' of 114 | Syntax.TVar (Left m') | m == m' -> pure () 115 | _ -> 116 | if any (either (== m) (const False)) (unTypeM actual') 117 | then throwError $ TypeOccurs (actual' ^. typemSpan spans) m (renderTyName . tyNames <$> actual') 118 | else tmetaSolutions %= Map.insert m actual' 119 | solveRight expected' m = do 120 | m_t <- getTMeta m 121 | case m_t of 122 | Just t -> tryUnifyType kindScope spans tyNames kinds expected' t 123 | Nothing -> 124 | case unTypeM expected' of 125 | Syntax.TVar (Left m') | m == m' -> pure () 126 | _ -> 127 | if any (either (== m) (const False)) (unTypeM expected') 128 | then throwError $ TypeOccurs (tmetaSpan m) m (renderTyName . tyNames <$> expected') 129 | else tmetaSolutions %= Map.insert m expected' 130 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedLists, OverloadedStrings #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language TypeApplications #-} 4 | module Main where 5 | 6 | import Bound.Scope (toScope) 7 | import Bound.Var (Var(..)) 8 | import Control.Lens.Setter ((.~)) 9 | import Control.Monad.Except (runExceptT) 10 | import Control.Monad.State.Strict (evalState, evalStateT) 11 | import Control.Monad.Trans.Maybe (runMaybeT) 12 | import Data.Function ((&)) 13 | import qualified Data.Map as Map 14 | import Data.Maybe (fromMaybe) 15 | import qualified Data.Text.IO as Text 16 | import Data.Void (Void, absurd) 17 | import Test.Hspec 18 | 19 | import Check.Datatype (checkADT) 20 | import Check.Entailment 21 | ( SMeta(..), Theory(..) 22 | , composeSSubs 23 | , globalTheory 24 | , freshSMeta, simplify, solve 25 | ) 26 | import Check.Function (checkFunction) 27 | import Check.TCState (emptyTCState) 28 | import qualified Codegen.C as C 29 | import qualified Compile 30 | import Error.TypeError (TypeError(..)) 31 | import Size ((.@), Size, sizeConstraintFor) 32 | import qualified Size (Size(..), pattern Var) 33 | import qualified Size.Builtins as Size (builtins) 34 | import IR (Constraint(..), Kind(..)) 35 | import qualified IR 36 | import Syntax (Index(..), Type(..), pattern TypeM, TMeta(..), Span(Unknown)) 37 | import qualified Syntax 38 | 39 | import Test.Parser (parserTests) 40 | 41 | main :: IO () 42 | main = 43 | hspec $ do 44 | parserTests 45 | describe "sizeConstraintFor" $ do 46 | it "*" $ 47 | sizeConstraintFor @Void KType `shouldBe` CSized (TVar $ B ()) 48 | it "* -> *" $ 49 | sizeConstraintFor @Void (KArr KType KType) `shouldBe` 50 | CForall Nothing KType 51 | (CImplies 52 | (CSized (TVar $ B ())) 53 | (CSized $ 54 | TApp Unknown 55 | (TVar $ F $ B ()) 56 | (TVar $ B ()) 57 | ) 58 | ) 59 | it "* -> * -> *" $ 60 | sizeConstraintFor @Void (KArr KType $ KArr KType KType) `shouldBe` 61 | CForall Nothing KType 62 | (CImplies 63 | (CSized $ TVar $ B ()) 64 | (CForall Nothing KType . CImplies (CSized $ TVar $ B ()) $ 65 | CSized $ 66 | TApp Unknown 67 | (TApp Unknown 68 | (TVar $ F $ F $ B ()) 69 | (TVar $ F $ B ()) 70 | ) 71 | (TVar $ B ()) 72 | ) 73 | ) 74 | it "* -> (* -> *) -> *" $ 75 | sizeConstraintFor @Void (KArr KType $ KArr (KArr KType KType) KType) `shouldBe` 76 | -- forall x : Type 77 | CForall Nothing KType 78 | -- Sized x => 79 | (CImplies (CSized $ TVar $ B ()) $ 80 | -- forall y : Type -> Type. 81 | CForall Nothing (KArr KType KType) . 82 | -- (forall z : Type. Sized z => Sized (y z)) => 83 | CImplies 84 | (CForall Nothing KType $ 85 | CImplies 86 | (CSized $ TVar $ B ()) 87 | (CSized $ TApp Unknown (TVar $ F $ B ()) (TVar $ B ())) 88 | ) $ 89 | -- Sized (#0 x y) 90 | CSized $ 91 | TApp Unknown 92 | (TApp Unknown 93 | (TVar $ F $ F $ B ()) 94 | (TVar $ F $ B ()) 95 | ) 96 | (TVar $ B ()) 97 | ) 98 | describe "entailment" $ do 99 | it "simplify { (4, Sized I32) } (d0 : Sized I32) ==> [d0 := 4]" $ do 100 | let 101 | theory :: Theory (Either TMeta Void) 102 | theory = 103 | Theory 104 | { _thGlobal = 105 | [ (CSized $ TInt32 Unknown, Size.Word 4) 106 | ] 107 | , _thLocal = mempty 108 | } 109 | e_res = flip evalState emptyTCState . runExceptT $ do 110 | m <- freshSMeta 111 | (,) m <$> simplify mempty Syntax.voidSpan absurd absurd theory (m, CSized $ TInt32 Unknown) 112 | case e_res of 113 | Left{} -> expectationFailure "expected success, got error" 114 | Right (d0, res) -> res `shouldBe` ([], [(d0, Size.Word 4 :: Size (Either SMeta Void))]) 115 | 116 | it "solve $ simplify { (4, Sized I32), (\\x -> x + x, forall a. Sized a => Sized (Pair a)) } (d0 : Sized (Pair I32)) ==> [d0 := 8]" $ do 117 | let 118 | kindScope = 119 | [ ("Pair", KArr KType $ KArr KType KType) 120 | ] 121 | 122 | theory :: Theory (Either TMeta Void) 123 | theory = 124 | Theory 125 | { _thGlobal = 126 | [ (CSized $ TInt32 Unknown, Size.Word 4) 127 | , ( CForall (Just "a") KType $ 128 | CImplies 129 | (CSized $ TVar $ B ()) 130 | (CSized $ TApp Unknown (TName Unknown "Pair") (TVar $ B ())) 131 | , Size.Lam . toScope $ Size.Plus (Size.Var $ B ()) (Size.Var $ B ()) 132 | ) 133 | ] 134 | , _thLocal = mempty 135 | } 136 | e_res = flip evalState (emptyTCState) . runExceptT $ do 137 | m <- freshSMeta 138 | (assumes, sols) <- 139 | fmap (fromMaybe ([], mempty)) . runMaybeT $ 140 | simplify 141 | kindScope 142 | Syntax.voidSpan 143 | absurd 144 | absurd 145 | theory 146 | (m, CSized $ TApp Unknown (TName Unknown "Pair") (TInt32 Unknown)) 147 | (assumes', sols') <- solve kindScope Syntax.voidSpan absurd absurd theory assumes 148 | pure (m, (assumes', composeSSubs sols' sols)) 149 | case e_res of 150 | Left err -> expectationFailure $ "expected success, got error: " <> show err 151 | Right (d0, (assumes, sols)) -> 152 | Map.lookup d0 sols `shouldBe` Just (Size.Word 8 :: Size (Either SMeta Void)) 153 | 154 | it "solve $ simplify { (\\x -> x + x, forall a. Sized a => Sized (Pair a)) } (d0 : Sized (Pair I32)) ==> cannot deduce Sized I32" $ do 155 | let 156 | kindScope = 157 | [ ("Pair", KArr KType $ KArr KType KType) 158 | ] 159 | 160 | theory :: Theory (Either TMeta Void) 161 | theory = 162 | Theory 163 | { _thGlobal = 164 | [ ( CForall (Just "a") KType $ 165 | CImplies 166 | (CSized $ TVar $ B ()) 167 | (CSized $ TApp Unknown (TName Unknown "Pair") (TVar $ B ())) 168 | , Size.Lam . toScope $ Size.Plus (Size.Var $ B ()) (Size.Var $ B ()) 169 | ) 170 | ] 171 | , _thLocal = mempty 172 | } 173 | e_res = flip evalState (emptyTCState) . runExceptT $ do 174 | m <- freshSMeta 175 | (assumes, sols) <- 176 | fmap (fromMaybe ([], mempty)) . runMaybeT $ 177 | simplify 178 | kindScope 179 | Syntax.voidSpan 180 | absurd 181 | absurd 182 | theory 183 | (m, CSized $ TApp Unknown (TName Unknown "Pair") (TInt32 Unknown)) 184 | (assumes', sols') <- solve kindScope Syntax.voidSpan absurd absurd theory assumes 185 | pure (m, (assumes', composeSSubs sols' sols)) 186 | case e_res of 187 | Left err -> err `shouldBe` CouldNotDeduce (CSized $ TInt32 Unknown) 188 | Right{} -> expectationFailure "expected failure, got success" 189 | 190 | it "solve $ simplify { (\\x -> x + x, forall x. Sized x => Sized (Pair x)) } (d0 : forall a. Sized (Pair a) => Sized a) ==> cannot deduce Sized a" $ do 191 | let 192 | theory :: Theory (Either TMeta Void) 193 | theory = 194 | Theory 195 | { _thGlobal = 196 | [ ( CForall (Just "x") KType $ 197 | CImplies 198 | (CSized $ TVar $ B ()) 199 | (CSized $ TApp Unknown (TName Unknown "Pair") (TVar $ B ())) 200 | , Size.Lam . toScope $ Size.Plus (Size.Var $ B ()) (Size.Var $ B ()) 201 | ) 202 | ] 203 | , _thLocal = mempty 204 | } 205 | e_res = flip evalState (emptyTCState) . runExceptT $ do 206 | m <- freshSMeta 207 | (assumes, sols) <- 208 | fmap (fromMaybe ([], mempty)) . runMaybeT $ 209 | simplify mempty Syntax.voidSpan absurd absurd theory 210 | ( m 211 | , CForall (Just "a") KType $ 212 | CImplies 213 | (CSized $ TApp Unknown (TName Unknown "Pair") (TVar $ B ())) 214 | (CSized $ TVar $ B ()) 215 | ) 216 | (assumes', sols') <- solve @_ @Void mempty Syntax.voidSpan absurd absurd theory assumes 217 | pure (m, (assumes', composeSSubs sols' sols)) 218 | case e_res of 219 | Left err -> err `shouldBe` CouldNotDeduce (CSized $ TVar $ Right "a") 220 | Right res -> expectationFailure $ "expected error, got success: " <> show res 221 | 222 | describe "typechecking" $ do 223 | it "id(x : A) -> A" $ do 224 | let 225 | input = 226 | Syntax.Function 227 | { Syntax.funcName = "id" 228 | , Syntax.funcTyArgs = ["A"] 229 | , Syntax.funcArgs = [("x", TVar . B $ Index Unknown 0)] 230 | , Syntax.funcRetTy = TVar . B $ Index Unknown 0 231 | , Syntax.funcBody = Syntax.Var . B $ Index Unknown 0 232 | } 233 | output = 234 | IR.Function 235 | { IR.funcName = "id" 236 | , IR.funcTyArgs = [("A", KType)] 237 | , IR.funcConstraints = [CSized $ TVar . B $ Index Unknown 0] 238 | , IR.funcArgs = [("x", TVar . B $ Index Unknown 0)] 239 | , IR.funcRetTy = TVar . B $ Index Unknown 0 240 | , IR.funcBody = IR.Var . B $ Index Unknown 0 241 | } 242 | evalStateT (checkFunction mempty mempty mempty mempty mempty input) (emptyTCState @Void) `shouldBe` 243 | Right output 244 | it "five() -> int32" $ do 245 | let 246 | input = 247 | Syntax.Function 248 | { Syntax.funcName = "five" 249 | , Syntax.funcTyArgs = [] 250 | , Syntax.funcArgs = [] 251 | , Syntax.funcRetTy = TInt32 Unknown 252 | , Syntax.funcBody = Syntax.Number Unknown 5 253 | } 254 | output = 255 | IR.Function 256 | { IR.funcName = "five" 257 | , IR.funcTyArgs = [] 258 | , IR.funcConstraints = [] 259 | , IR.funcArgs = [] 260 | , IR.funcRetTy = TInt32 Unknown 261 | , IR.funcBody = IR.Int32 5 262 | } 263 | evalStateT 264 | (checkFunction (Map.fromList Size.builtins) mempty mempty mempty mempty input) 265 | (emptyTCState @Void) `shouldBe` 266 | Right output 267 | it "check `struct Pair(A, B)`" $ do 268 | let 269 | result = 270 | flip evalStateT (emptyTCState) $ 271 | checkADT 272 | mempty 273 | "Pair" 274 | ["A", "B"] 275 | (Syntax.Ctor 276 | "Pair" 277 | [Syntax.TVar . B $ Index Unknown 0, Syntax.TVar . B $ Index Unknown 1] 278 | Syntax.End 279 | ) 280 | 281 | result `shouldBe` 282 | Right 283 | ( IR.Struct 284 | { IR.datatypeName = "Pair" 285 | , IR.datatypeTyArgs = [("A", KType), ("B", KType)] 286 | , IR.structFields = [(Nothing, TVar . B $ Index Unknown 0), (Nothing, TVar . B $ Index Unknown 1)] 287 | } 288 | , KArr KType $ KArr KType KType 289 | , CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ 290 | CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ 291 | CSized $ foldl @[] (TApp Unknown) (TName Unknown "Pair") [TVar . F $ B (), TVar $ B ()] 292 | , Size.Lam $ toScope $ 293 | Size.Lam $ toScope $ 294 | Size.Plus (Size.Var $ F $ B ()) (Size.Var $ B ()) 295 | ) 296 | it "check `struct Pair(F, F)`" $ do 297 | let 298 | result = 299 | flip evalStateT emptyTCState $ 300 | checkADT 301 | mempty 302 | "Pair" 303 | ["F", "A", "B"] 304 | (Syntax.Ctor 305 | "Pair" 306 | [ Syntax.TApp Unknown (Syntax.TVar . B $ Index Unknown 0) (Syntax.TVar . B $ Index Unknown 1) 307 | , Syntax.TApp Unknown (Syntax.TVar . B $ Index Unknown 0) (Syntax.TVar . B $ Index Unknown 2) 308 | ] 309 | Syntax.End 310 | ) 311 | fConstraint = 312 | CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ -- a 313 | CSized $ foldl @[] (TApp Unknown) (TVar . F $ B ()) [TVar $ B ()] 314 | 315 | case result of 316 | Left err -> expectationFailure $ "Expected success, got failure: " <> show err 317 | Right (ctors, kind, constraint, size) -> do 318 | ctors `shouldBe` 319 | IR.Struct 320 | { IR.datatypeName = "Pair" 321 | , IR.datatypeTyArgs = 322 | [ ("F", KArr KType KType) 323 | , ("A", KType) 324 | , ("B", KType) 325 | ] 326 | , IR.structFields = 327 | [ (Nothing, TApp Unknown (TVar . B $ Index Unknown 0) (TVar . B $ Index Unknown 1)) 328 | , (Nothing, TApp Unknown (TVar . B $ Index Unknown 0) (TVar . B $ Index Unknown 2)) 329 | ] 330 | } 331 | kind `shouldBe` KArr (KArr KType KType) (KArr KType $ KArr KType KType) 332 | constraint `shouldBe` 333 | CForall Nothing (KArr KType KType) (CImplies fConstraint $ -- f 334 | CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ -- a 335 | CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ -- b 336 | CSized $ 337 | foldl @[] 338 | (TApp Unknown) 339 | (TName Unknown "Pair") 340 | [TVar . F . F $ B (), TVar . F $ B (), TVar $ B ()]) 341 | size `shouldBe` 342 | Size.Lam (toScope $ 343 | Size.Lam $ toScope $ 344 | Size.Lam $ toScope $ 345 | Size.Plus 346 | (Size.Var (F $ F $ B ()) .@ Size.Var (F $ B ())) 347 | (Size.Var (F $ F $ B ()) .@ Size.Var (B ()))) 348 | it "check `struct Sum{ Left(A), Right(B) }`" $ do 349 | let 350 | result = 351 | flip evalStateT emptyTCState $ 352 | checkADT 353 | mempty 354 | "Sum" 355 | ["A", "B"] 356 | (Syntax.Ctor "Left" [Syntax.TVar . B $ Index Unknown 0] $ 357 | Syntax.Ctor "Right" [Syntax.TVar . B $ Index Unknown 1] $ 358 | Syntax.End) 359 | 360 | result `shouldBe` 361 | Right 362 | ( IR.Enum 363 | { IR.datatypeName = "Sum" 364 | , IR.datatypeTyArgs = [("A", KType), ("B", KType)] 365 | , IR.enumCtors = 366 | [ ("Left", [ (Nothing, TVar . B $ Index Unknown 0) ]) 367 | , ("Right", [ (Nothing, TVar . B $ Index Unknown 1) ]) 368 | ] 369 | } 370 | , KArr KType $ KArr KType KType 371 | -- forall t0. Sized t0 => forall t1. Sized t1 => Sized (Sum t0 t1) 372 | , CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ 373 | CForall Nothing KType . CImplies (CSized . TVar $ B ()) $ 374 | CSized $ foldl @[] (TApp Unknown) (TName Unknown "Sum") [TVar . F $ B (), TVar $ B ()] 375 | , Size.Lam $ toScope $ 376 | Size.Lam $ toScope $ 377 | Size.Plus (Size.Word 1) $ 378 | Size.Max (Size.Var $ F $ B ()) (Size.Var $ B ()) 379 | ) 380 | it "check `struct Box(Ptr)`" $ do 381 | let 382 | result = 383 | flip evalStateT (emptyTCState & globalTheory .~ Map.fromList Size.builtins) $ 384 | checkADT 385 | mempty 386 | "Box" 387 | ["A"] 388 | (Syntax.Ctor "Box" [Syntax.TApp Unknown (Syntax.TPtr Unknown) . Syntax.TVar . B $ Index Unknown 0] $ 389 | Syntax.End) 390 | 391 | result `shouldBe` 392 | Right 393 | ( IR.Struct 394 | { IR.datatypeName = "Box" 395 | , IR.datatypeTyArgs = [("A", KType)] 396 | , IR.structFields = 397 | [ (Nothing, TApp Unknown (TPtr Unknown) (TVar . B $ Index Unknown 0)) 398 | ] 399 | } 400 | , KArr KType KType 401 | -- forall t0. Sized (Box t0) 402 | , CForall Nothing KType . 403 | CSized $ foldl @[] (TApp Unknown) (TName Unknown "Box") [TVar $ B ()] 404 | , Size.Word 8 405 | ) 406 | describe "compile" $ do 407 | it "1" $ do 408 | let 409 | input = 410 | [ Syntax.DFunc $ 411 | Syntax.Function 412 | { Syntax.funcName = "main" 413 | , Syntax.funcTyArgs = [] 414 | , Syntax.funcArgs = [] 415 | , Syntax.funcRetTy = TInt32 Unknown 416 | , Syntax.funcBody = Syntax.Number Unknown 0 417 | } 418 | ] 419 | output = 420 | C.preamble <> 421 | [ C.Function C.Int32 "main" [] 422 | [ C.Return $ C.Number 0 423 | ] 424 | ] 425 | case Compile.compile input of 426 | Left err -> expectationFailure $ "Expected success, got " <> show err 427 | Right code -> 428 | code `shouldBe` output 429 | it "2" $ do 430 | let 431 | input = 432 | [ Syntax.DFunc $ 433 | Syntax.Function 434 | { Syntax.funcName = "id" 435 | , Syntax.funcTyArgs = ["A"] 436 | , Syntax.funcArgs = [("x", TVar . B $ Index Unknown 0)] 437 | , Syntax.funcRetTy = TVar . B $ Index Unknown 0 438 | , Syntax.funcBody = Syntax.Var . B $ Index Unknown 0 439 | } 440 | , Syntax.DFunc $ 441 | Syntax.Function 442 | { Syntax.funcName = "main" 443 | , Syntax.funcTyArgs = [] 444 | , Syntax.funcArgs = [] 445 | , Syntax.funcRetTy = TInt32 Unknown 446 | , Syntax.funcBody = 447 | Syntax.Call Unknown (Syntax.Name Unknown "id") [Syntax.Number Unknown 0] 448 | } 449 | ] 450 | output = 451 | C.preamble <> 452 | [ C.Function C.Int32 "id_TInt32" [(C.Int32, "x")] 453 | [ C.Return $ C.Var "x" 454 | ] 455 | , C.Function C.Int32 "main" [] 456 | [ C.Return $ C.Call (C.Var "id_TInt32") [C.Number 0] 457 | ] 458 | ] 459 | case Compile.compile input of 460 | Left err -> 461 | expectationFailure $ 462 | "Expected success, got " <> show err 463 | Right code -> 464 | code `shouldBe` output 465 | it "3" $ do 466 | let 467 | input = 468 | [ Syntax.DFunc $ 469 | Syntax.Function 470 | { Syntax.funcName = "main" 471 | , Syntax.funcTyArgs = [] 472 | , Syntax.funcArgs = [] 473 | , Syntax.funcRetTy = TInt32 Unknown 474 | , Syntax.funcBody = 475 | Syntax.Let 476 | Unknown 477 | [("x", Syntax.New Unknown $ Syntax.Number Unknown 26)] 478 | (Syntax.Deref Unknown $ Syntax.Name Unknown "x") 479 | } 480 | ] 481 | output = 482 | C.preamble <> 483 | [ C.Function C.Int32 "main" [] 484 | [ C.Declare (C.Ptr C.Int32) "__0" . Just $ 485 | C.Cast (C.Ptr C.Int32) (C.Malloc $ C.Number 4) 486 | , C.Assign (C.Deref $ C.Var "__0") (C.Number 26) 487 | , C.Declare (C.Ptr C.Int32) "x" (Just $ C.Var "__0") 488 | , C.Return . C.Deref $ C.Var "x" 489 | ] 490 | ] 491 | case Compile.compile input of 492 | Left err -> 493 | expectationFailure $ 494 | "Expected success, got " <> show err 495 | Right code -> do 496 | code `shouldBe` output 497 | it "4" $ do 498 | let 499 | input = 500 | [ Syntax.DData $ 501 | Syntax.ADT 502 | { Syntax.adtName = "Pair" 503 | , Syntax.adtArgs = ["A", "B"] 504 | , Syntax.adtCtors = 505 | Syntax.Ctor "Pair" [TVar . B $ Index Unknown 0, TVar . B $ Index Unknown 1] $ 506 | Syntax.End 507 | } 508 | , Syntax.DFunc $ 509 | Syntax.Function 510 | { Syntax.funcName = "main" 511 | , Syntax.funcTyArgs = [] 512 | , Syntax.funcArgs = [] 513 | , Syntax.funcRetTy = TInt32 Unknown 514 | , Syntax.funcBody = 515 | Syntax.Let 516 | Unknown 517 | [ ( "x" 518 | , Syntax.Call Unknown 519 | (Syntax.Name Unknown "Pair") 520 | [Syntax.BTrue Unknown, Syntax.BFalse Unknown] 521 | ) 522 | ] 523 | (Syntax.Number Unknown 99) 524 | } 525 | ] 526 | pairBoolBoolAnn = Just $ C.Ann "Pair bool bool" 527 | output = 528 | C.preamble <> 529 | [ C.Typedef (C.Name $ "struct Pair_TBool_TBool_t") "Pair_TBool_TBool_t" 530 | , C.Struct "Pair_TBool_TBool_t" [(C.Bool, "_0"), (C.Bool, "_1")] 531 | , C.Function 532 | (C.Name "Pair_TBool_TBool_t") 533 | "make_Pair_TBool_TBool" 534 | [ (C.Bool, "__0") 535 | , (C.Bool, "__1") 536 | ] 537 | [ C.Declare 538 | (C.Name "Pair_TBool_TBool_t") 539 | "__2" 540 | (Just $ C.Init [(C.Var "__0"), (C.Var "__1")]) 541 | , C.Return $ C.Var "__2" 542 | ] 543 | , C.Function C.Int32 "main" [] 544 | [ C.Declare (C.Name "Pair_TBool_TBool_t") "x" . Just $ 545 | C.Call 546 | (C.Var "make_Pair_TBool_TBool") 547 | [C.BTrue, C.BFalse] 548 | , C.Return $ C.Number 99 549 | ] 550 | ] 551 | case Compile.compile input of 552 | Left err -> 553 | expectationFailure $ 554 | "Expected success, got " <> show err 555 | Right code -> do 556 | code `shouldBe` output 557 | it "5" $ do 558 | let 559 | input = 560 | [ Syntax.DData $ 561 | Syntax.ADT 562 | { Syntax.adtName = "Pair" 563 | , Syntax.adtArgs = ["A", "B"] 564 | , Syntax.adtCtors = 565 | Syntax.Ctor "Pair" [TVar . B $ Index Unknown 0, TVar . B $ Index Unknown 1] $ 566 | Syntax.End 567 | } 568 | , Syntax.DFunc $ 569 | Syntax.Function 570 | { Syntax.funcName = "main" 571 | , Syntax.funcTyArgs = [] 572 | , Syntax.funcArgs = [] 573 | , Syntax.funcRetTy = TInt32 Unknown 574 | , Syntax.funcBody = 575 | Syntax.Let 576 | Unknown 577 | [ ( "x" 578 | , Syntax.Call Unknown 579 | (Syntax.Name Unknown "Pair") 580 | [Syntax.Number Unknown 22, Syntax.Number Unknown 33] 581 | ) 582 | ] 583 | (Syntax.Project Unknown (Syntax.Name Unknown "x") "0") 584 | } 585 | ] 586 | output = 587 | C.preamble <> 588 | [ C.Typedef (C.Name $ "struct Pair_TInt32_TInt32_t") "Pair_TInt32_TInt32_t" 589 | , C.Struct "Pair_TInt32_TInt32_t" [(C.Int32, "_0"), (C.Int32, "_1")] 590 | , C.Function 591 | (C.Name "Pair_TInt32_TInt32_t") 592 | "make_Pair_TInt32_TInt32" 593 | [ (C.Int32, "__0") 594 | , (C.Int32, "__1") 595 | ] 596 | [ C.Declare 597 | (C.Name "Pair_TInt32_TInt32_t") 598 | "__2" 599 | (Just $ C.Init [(C.Var "__0"), (C.Var "__1")]) 600 | , C.Return $ C.Var "__2" 601 | ] 602 | , C.Function C.Int32 "main" [] 603 | [ C.Declare (C.Name "Pair_TInt32_TInt32_t") "x" . Just $ 604 | C.Call 605 | (C.Var "make_Pair_TInt32_TInt32") 606 | [C.Number 22, C.Number 33] 607 | , C.Return $ C.Project (C.Var "x") "_0" 608 | ] 609 | ] 610 | case Compile.compile input of 611 | Left err -> 612 | expectationFailure $ 613 | "Expected success, got " <> show err 614 | Right code -> do 615 | code `shouldBe` output 616 | it "6" $ do 617 | let 618 | input = 619 | [ Syntax.DData $ 620 | Syntax.ADT 621 | { Syntax.adtName = "List" 622 | , Syntax.adtArgs = ["A"] 623 | , Syntax.adtCtors = 624 | Syntax.Ctor "Nil" [] $ 625 | Syntax.Ctor "Cons" 626 | [ TVar . B $ Index Unknown 0 627 | , TApp Unknown (TPtr Unknown) $ TApp Unknown (TName Unknown "List") (TVar . B $ Index Unknown 0) 628 | ] $ 629 | Syntax.End 630 | } 631 | , Syntax.DFunc $ 632 | Syntax.Function 633 | { Syntax.funcName = "main" 634 | , Syntax.funcTyArgs = [] 635 | , Syntax.funcArgs = [] 636 | , Syntax.funcRetTy = TInt32 Unknown 637 | , Syntax.funcBody = 638 | Syntax.Let 639 | Unknown 640 | [("x", Syntax.Call Unknown (Syntax.Name Unknown "Nil") [])] 641 | (Syntax.Number Unknown 0) 642 | } 643 | ] 644 | output = 645 | C.preamble <> 646 | [ C.Typedef (C.Name "struct List_TInt32_t") "List_TInt32_t" 647 | , C.Struct "List_TInt32_t" 648 | [ (C.UInt8, "tag") 649 | , ( C.Union 650 | [ (C.TStruct [],"Nil") 651 | , (C.TStruct [(C.Int32,"_0"), (C.Ptr (C.Name "List_TInt32_t"),"_1")],"Cons") 652 | ] 653 | , "data" 654 | ) 655 | ] 656 | , C.Function (C.Name "List_TInt32_t") "make_Nil_TInt32" [] 657 | [ C.Declare (C.Name "List_TInt32_t") "__0" . Just $ 658 | C.Init [C.Number 0, C.InitNamed [("Nil", C.Init [])]] 659 | , C.Return (C.Var "__0") 660 | ] 661 | , C.Function C.Int32 "main" [] 662 | [ C.Declare (C.Name "List_TInt32_t") "x" . Just $ 663 | C.Call (C.Var "make_Nil_TInt32") [] 664 | , C.Return $ C.Number 0 665 | ] 666 | ] 667 | case Compile.compile input of 668 | Left err -> 669 | expectationFailure $ 670 | "Expected success, got " <> show err 671 | Right code -> do 672 | code `shouldBe` output 673 | it "7" $ do 674 | let 675 | input = 676 | [ Syntax.DData $ 677 | Syntax.ADT 678 | { Syntax.adtName = "List" 679 | , Syntax.adtArgs = ["A"] 680 | , Syntax.adtCtors = 681 | Syntax.Ctor "Nil" [] $ 682 | Syntax.Ctor "Cons" 683 | [ TVar . B $ Index Unknown 0 684 | , TApp Unknown (TPtr Unknown) $ TApp Unknown (TName Unknown "List") (TVar . B $ Index Unknown 0) 685 | ] $ 686 | Syntax.End 687 | } 688 | , Syntax.DFunc $ 689 | Syntax.Function 690 | { Syntax.funcName = "main" 691 | , Syntax.funcTyArgs = [] 692 | , Syntax.funcArgs = [] 693 | , Syntax.funcRetTy = TInt32 Unknown 694 | , Syntax.funcBody = 695 | let 696 | e = 697 | Syntax.Call Unknown 698 | (Syntax.Name Unknown "Cons") 699 | [ Syntax.Number Unknown 1 700 | , Syntax.New Unknown $ Syntax.Call Unknown (Syntax.Name Unknown "Nil") [] 701 | ] 702 | in 703 | Syntax.Match Unknown e 704 | [ Syntax.Case Unknown "Nil" [] $ Syntax.Number Unknown 0 705 | , Syntax.Case Unknown "Cons" ["a", "b"] $ 706 | Syntax.Var (B $ Index Unknown 0) 707 | ] 708 | } 709 | ] 710 | output = 711 | C.preamble <> 712 | [ C.Typedef (C.Name "struct List_TInt32_t") "List_TInt32_t" 713 | , C.Struct "List_TInt32_t" 714 | [ (C.UInt8, "tag") 715 | , ( C.Union 716 | [ (C.TStruct [],"Nil") 717 | , (C.TStruct [(C.Int32,"_0"), (C.Ptr (C.Name "List_TInt32_t"),"_1")],"Cons") 718 | ] 719 | , "data" 720 | ) 721 | ] 722 | , C.Function 723 | (C.Name "List_TInt32_t") 724 | "make_Cons_TInt32" 725 | [(C.Int32, "__0"), (C.Ptr $ C.Name "List_TInt32_t", "__1")] 726 | [ C.Declare (C.Name "List_TInt32_t") "__2" . Just $ 727 | C.Init [C.Number 1, C.InitNamed [("Cons", C.Init [C.Var "__0", C.Var "__1"])]] 728 | , C.Return (C.Var "__2") 729 | ] 730 | , C.Function (C.Name "List_TInt32_t") "make_Nil_TInt32" [] 731 | [ C.Declare (C.Name "List_TInt32_t") "__3" . Just $ 732 | C.Init [C.Number 0, C.InitNamed [("Nil", C.Init [])]] 733 | , C.Return (C.Var "__3") 734 | ] 735 | , C.Function C.Int32 "main" [] 736 | [ C.Declare (C.Ptr $ C.Name "List_TInt32_t") "__4" . Just $ 737 | C.Cast (C.Ptr $ C.Name "List_TInt32_t") (C.Malloc $ C.Number 13) 738 | , C.Assign (C.Deref (C.Var "__4")) $ C.Call (C.Var "make_Nil_TInt32") [] 739 | 740 | , C.Declare (C.Name "List_TInt32_t") "__5" . Just $ 741 | C.Call (C.Var "make_Cons_TInt32") [C.Number 1, C.Var "__4"] 742 | 743 | , C.Declare C.Int32 "__6" Nothing 744 | 745 | , C.If (C.Eq (C.Project (C.Var "__5") "tag") (C.Number 0)) 746 | [ C.Assign (C.Var "__6") (C.Number 0) 747 | ] 748 | 749 | , C.If (C.Eq (C.Project (C.Var "__5") "tag") (C.Number 1)) 750 | [ C.Assign (C.Var "__6") (C.Project (C.Project (C.Project (C.Var "__5") "data") "Cons") "_0") 751 | ] 752 | 753 | , C.Return $ C.Var "__6" 754 | ] 755 | ] 756 | case Compile.compile input of 757 | Left err -> 758 | expectationFailure $ 759 | "Expected success, got " <> show err 760 | Right code -> do 761 | code `shouldBe` output 762 | it "8" $ do 763 | let 764 | input = 765 | [ Syntax.DData $ 766 | Syntax.ADT 767 | { Syntax.adtName = "List" 768 | , Syntax.adtArgs = ["A"] 769 | , Syntax.adtCtors = 770 | Syntax.Ctor "Nil" [] $ 771 | Syntax.Ctor "Cons" 772 | [ TVar . B $ Index Unknown 0 773 | , TApp Unknown (TPtr Unknown) $ TApp Unknown (TName Unknown "List") (TVar . B $ Index Unknown 0) 774 | ] $ 775 | Syntax.End 776 | } 777 | , Syntax.DFunc $ 778 | Syntax.Function 779 | { Syntax.funcName = "main" 780 | , Syntax.funcTyArgs = [] 781 | , Syntax.funcArgs = [] 782 | , Syntax.funcRetTy = TInt32 Unknown 783 | , Syntax.funcBody = 784 | let 785 | e = 786 | Syntax.Call Unknown 787 | (Syntax.Name Unknown "Cons") 788 | [ Syntax.BTrue Unknown 789 | , Syntax.New Unknown $ Syntax.Call Unknown (Syntax.Name Unknown "Nil") [] 790 | ] 791 | in 792 | Syntax.Match Unknown e 793 | [ Syntax.Case Unknown "Nil" [] $ Syntax.Number Unknown 0 794 | , Syntax.Case Unknown "Cons" ["a", "b"] $ 795 | Syntax.Var (B $ Index Unknown 0) 796 | ] 797 | } 798 | ] 799 | case Compile.compile input of 800 | Left err -> 801 | err `shouldBe` 802 | Compile.TypeError (TypeMismatch Unknown (TypeM $ TInt32 Unknown) (TypeM $ TBool Unknown)) 803 | Right code -> expectationFailure $ "expected error, got " <> show code 804 | it "9" $ do 805 | let 806 | input = 807 | [ Syntax.DData $ 808 | Syntax.ADT 809 | { Syntax.adtName = "Either" 810 | , Syntax.adtArgs = ["A", "B"] 811 | , Syntax.adtCtors = 812 | Syntax.Ctor "Left" [TVar . B $ Index Unknown 0] $ 813 | Syntax.Ctor "Right" [TVar . B $ Index Unknown 1] $ 814 | Syntax.End 815 | } 816 | , Syntax.DData $ 817 | Syntax.ADT 818 | { Syntax.adtName = "List" 819 | , Syntax.adtArgs = ["A"] 820 | , Syntax.adtCtors = 821 | Syntax.Ctor "Nil" [] $ 822 | Syntax.Ctor "Cons" 823 | [ TVar . B $ Index Unknown 0 824 | , TApp Unknown (TPtr Unknown) $ TApp Unknown (TName Unknown "List") (TVar . B $ Index Unknown 0) 825 | ] $ 826 | Syntax.End 827 | } 828 | , Syntax.DFunc $ 829 | Syntax.Function 830 | { Syntax.funcName = "main" 831 | , Syntax.funcTyArgs = [] 832 | , Syntax.funcArgs = [] 833 | , Syntax.funcRetTy = TInt32 Unknown 834 | , Syntax.funcBody = 835 | let 836 | e = 837 | -- Cons(1, new[Nil()]) 838 | Syntax.Call Unknown 839 | (Syntax.Name Unknown "Cons") 840 | [ Syntax.Number Unknown 1 841 | , Syntax.New Unknown $ Syntax.Call Unknown (Syntax.Name Unknown "Nil") [] 842 | ] 843 | in 844 | -- match Cons(1, new[Nil()]) { 845 | -- Left(a) => a 846 | -- Cons(a, b) => a 847 | -- } 848 | Syntax.Match Unknown e 849 | [ Syntax.Case Unknown "Left" ["a"] $ 850 | Syntax.Var (B $ Index Unknown 0) 851 | , Syntax.Case Unknown "Cons" ["a", "b"] $ 852 | Syntax.Var (B $ Index Unknown 0) 853 | ] 854 | } 855 | ] 856 | case Compile.compile input of 857 | Left err -> 858 | err `shouldBe` 859 | Compile.TypeError 860 | (TypeMismatch 861 | Unknown 862 | (TypeM $ 863 | TApp Unknown (TName Unknown "List") (TInt32 Unknown) 864 | ) 865 | (TypeM $ 866 | foldl @[] (TApp Unknown) 867 | (TName Unknown "Either") 868 | [ TVar . Left $ TMeta Unknown 7 869 | , TVar . Left $ TMeta Unknown 8 870 | ] 871 | ) 872 | ) 873 | Right code -> expectationFailure $ "expected error, got " <> show code 874 | it "10" $ do 875 | let 876 | input = 877 | [ Syntax.DData $ 878 | Syntax.ADT 879 | { Syntax.adtName = "Identity" 880 | , Syntax.adtArgs = ["A"] 881 | , Syntax.adtCtors = 882 | Syntax.Ctor "Identity" [TVar . B $ Index Unknown 0] $ 883 | Syntax.End 884 | } 885 | , Syntax.DData $ 886 | Syntax.ADT 887 | { Syntax.adtName = "List" 888 | , Syntax.adtArgs = ["F", "A"] 889 | , Syntax.adtCtors = 890 | Syntax.Ctor "Nil" [] $ 891 | Syntax.Ctor "Cons" 892 | [ TApp Unknown (TVar . B $ Index Unknown 0) (TVar . B $ Index Unknown 1) 893 | , TApp Unknown (TPtr Unknown) $ 894 | foldl @[] (TApp Unknown) 895 | (TName Unknown "List") 896 | [TVar . B $ Index Unknown 0, TVar . B $ Index Unknown 1] 897 | ] 898 | Syntax.End 899 | } 900 | , Syntax.DFunc $ 901 | Syntax.Function 902 | { Syntax.funcName = "main" 903 | , Syntax.funcTyArgs = [] 904 | , Syntax.funcArgs = [] 905 | , Syntax.funcRetTy = TInt32 Unknown 906 | , Syntax.funcBody = 907 | let 908 | e = 909 | Syntax.Call Unknown 910 | (Syntax.Name Unknown "Cons") 911 | [ Syntax.Call Unknown (Syntax.Name Unknown "Identity") [Syntax.Number Unknown 1] 912 | , Syntax.New Unknown $ Syntax.Call Unknown (Syntax.Name Unknown "Nil") [] 913 | ] 914 | in 915 | Syntax.Match Unknown e 916 | [ Syntax.Case Unknown "Nil" [] $ Syntax.Number Unknown 0 917 | , Syntax.Case Unknown "Cons" ["a", "b"] $ 918 | Syntax.Project Unknown (Syntax.Var (B $ Index Unknown 0)) "0" 919 | ] 920 | } 921 | ] 922 | case Compile.compile input of 923 | Left err -> expectationFailure $ "expected success, got " <> show err 924 | Right code -> do 925 | let 926 | output = 927 | C.preamble <> 928 | [ C.Typedef (C.Name "struct Identity_TInt32_t") "Identity_TInt32_t" 929 | , C.Struct "Identity_TInt32_t" [(C.Int32,"_0")] 930 | 931 | , C.Typedef (C.Name "struct List_Identity_TInt32_t") "List_Identity_TInt32_t" 932 | , C.Struct "List_Identity_TInt32_t" 933 | [ (C.UInt8, "tag") 934 | , ( C.Union 935 | [ (C.TStruct [],"Nil") 936 | , ( C.TStruct 937 | [ (C.Name "Identity_TInt32_t","_0") 938 | , (C.Ptr (C.Name "List_Identity_TInt32_t"),"_1") 939 | ] 940 | ,"Cons" 941 | ) 942 | ] 943 | , "data" 944 | ) 945 | ] 946 | 947 | , C.Function 948 | (C.Name "List_Identity_TInt32_t") 949 | "make_Cons_Identity_TInt32" 950 | [(C.Name "Identity_TInt32_t", "__0"), (C.Ptr $ C.Name "List_Identity_TInt32_t", "__1")] 951 | [ C.Declare (C.Name "List_Identity_TInt32_t") "__2" . Just $ 952 | C.Init [C.Number 1, C.InitNamed [("Cons", C.Init [C.Var "__0", C.Var "__1"])]] 953 | , C.Return (C.Var "__2") 954 | ] 955 | 956 | , C.Function (C.Name "Identity_TInt32_t") "make_Identity_TInt32" [(C.Int32, "__3")] 957 | [ C.Declare (C.Name "Identity_TInt32_t") "__4" . Just $ C.Init [C.Var "__3"] 958 | , C.Return (C.Var "__4") 959 | ] 960 | 961 | , C.Function (C.Name "List_Identity_TInt32_t") "make_Nil_Identity_TInt32" [] 962 | [ C.Declare (C.Name "List_Identity_TInt32_t") "__5" . Just $ 963 | C.Init [C.Number 0, C.InitNamed [("Nil", C.Init [])]] 964 | , C.Return (C.Var "__5") 965 | ] 966 | 967 | , C.Function C.Int32 "main" [] 968 | [ C.Declare (C.Ptr $ C.Name "List_Identity_TInt32_t") "__6" . Just $ 969 | C.Cast (C.Ptr $ C.Name "List_Identity_TInt32_t") (C.Malloc $ C.Number 13) 970 | , C.Assign (C.Deref (C.Var "__6")) $ C.Call (C.Var "make_Nil_Identity_TInt32") [] 971 | 972 | , C.Declare (C.Name "List_Identity_TInt32_t") "__7" . Just $ 973 | C.Call (C.Var "make_Cons_Identity_TInt32") 974 | [C.Call (C.Var "make_Identity_TInt32") [C.Number 1], C.Var "__6"] 975 | 976 | , C.Declare C.Int32 "__8" Nothing 977 | 978 | , C.If (C.Eq (C.Project (C.Var "__7") "tag") (C.Number 0)) 979 | [ C.Assign (C.Var "__8") (C.Number 0) 980 | ] 981 | 982 | , C.If (C.Eq (C.Project (C.Var "__7") "tag") (C.Number 1)) 983 | [ C.Assign (C.Var "__8") $ 984 | C.Project (C.Project (C.Project (C.Project (C.Var "__7") "data") "Cons") "_0") "_0" 985 | ] 986 | 987 | , C.Return $ C.Var "__8" 988 | ] 989 | ] 990 | code `shouldBe` output 991 | -------------------------------------------------------------------------------- /test/Test/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language OverloadedLists #-} 3 | module Test.Parser (parserTests) where 4 | 5 | import Bound (Var(..)) 6 | import Data.Void (Void) 7 | import Test.Hspec 8 | import Text.Sage (Span(..)) 9 | 10 | import Syntax (ADT(..), Case(..), Ctors(..), Expr(..), Function(..), Index(..), Span(..), Type(..)) 11 | import Parser (parse, eof, datatype, expr, function, type_) 12 | 13 | parserTests :: Spec 14 | parserTests = 15 | describe "parser" $ do 16 | describe "expr" $ do 17 | it "x" $ do 18 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "x" `shouldBe` 19 | Right (Name (Known $ Span 0 1) "x") 20 | it "true" $ do 21 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "true" `shouldBe` 22 | Right (BTrue (Known $ Span 0 4)) 23 | it "false" $ do 24 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "false" `shouldBe` 25 | Right (BFalse (Known $ Span 0 5)) 26 | it "1234" $ do 27 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "1234" `shouldBe` 28 | Right (Number (Known $ Span 0 4) 1234) 29 | it "-1234" $ do 30 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "-12345" `shouldBe` 31 | Right (Number (Known $ Span 0 6) (-12345)) 32 | it "1 + 2 + 3" $ do 33 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "1 + 2 + 3" `shouldBe` 34 | Right 35 | (Add 36 | (Known $ Span 0 9) 37 | (Add 38 | (Known $ Span 0 5) 39 | (Number (Known $ Span 0 1) 1) 40 | (Number (Known $ Span 4 1) 2) 41 | ) 42 | (Number (Known $ Span 8 1) 3) 43 | ) 44 | it "hello" $ do 45 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "hello" `shouldBe` 46 | Right (Name (Known $ Span 0 5) "hello") 47 | it "f()" $ do 48 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "f()" `shouldBe` 49 | Right (Call (Known $ Span 0 3) (Name (Known $ Span 0 1) "f") []) 50 | it "f(a, b)" $ do 51 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "f(a, b)" `shouldBe` 52 | Right 53 | (Call 54 | (Known $ Span 0 7) 55 | (Name (Known $ Span 0 1) "f") 56 | [Name (Known $ Span 2 1) "a", Name (Known $ Span 5 1) "b"] 57 | ) 58 | it "x.y" $ do 59 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "x.y" `shouldBe` 60 | Right (Project (Known $ Span 0 3) (Name (Known $ Span 0 1) "x") "y") 61 | it "x.0" $ do 62 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "x.0" `shouldBe` 63 | Right (Project (Known $ Span 0 3) (Name (Known $ Span 0 1) "x") "0") 64 | it "*x" $ do 65 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "*x" `shouldBe` 66 | Right (Deref (Known $ Span 0 2) (Name (Known $ Span 1 1) "x")) 67 | it "**x" $ do 68 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "**x" `shouldBe` 69 | Right (Deref (Known $ Span 0 3) $ Deref (Known $ Span 1 2) $ Name (Known $ Span 2 1) "x") 70 | it "new[0]" $ do 71 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "new[0]" `shouldBe` 72 | Right (New (Known $ Span 0 6) (Number (Known $ Span 4 1) 0)) 73 | it "*new[0]" $ do 74 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "*new[0]" `shouldBe` 75 | Right (Deref (Known $ Span 0 7) $ New (Known $ Span 1 6) (Number (Known $ Span 5 1) 0)) 76 | it "match x { Left(e) => e(1), Right(a) => 1 }" $ do 77 | parse (expr (\_ _ -> Nothing :: Maybe Void) <* eof) "match x { Left(e) => e(1), Right(a) => 1 }" `shouldBe` 78 | Right 79 | (Match (Known $ Span 0 42) 80 | (Name (Known $ Span 6 1) "x") 81 | [ Case (Known $ Span 10 7) "Left" ["e"] $ 82 | Call (Known $ Span 21 4) (Var . B $ Index (Known $ Span 21 1) 0) [Number (Known $ Span 23 1) 1] 83 | , Case (Known $ Span 27 8) "Right" ["a"] $ 84 | Number (Known $ Span 39 1) 1 85 | ] 86 | ) 87 | describe "type" $ do 88 | it "x" $ do 89 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "x" `shouldBe` 90 | Right (TName (Known $ Span 0 1) "x") 91 | it "x y z" $ do 92 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "x y z" `shouldBe` 93 | Right 94 | (TApp 95 | (Known $ Span 0 5) 96 | (TApp 97 | (Known $ Span 0 3) 98 | (TName (Known $ Span 0 1) "x") 99 | (TName (Known $ Span 2 1) "y")) 100 | (TName (Known $ Span 4 1) "z") 101 | ) 102 | it "int32" $ do 103 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "int32" `shouldBe` 104 | Right (TInt32 (Known $ Span 0 5)) 105 | it "bool" $ do 106 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "bool" `shouldBe` 107 | Right (TBool (Known $ Span 0 4)) 108 | it "ptr a" $ do 109 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "ptr a" `shouldBe` 110 | Right (TApp (Known $ Span 0 5) (TPtr (Known $ Span 0 3)) (TName (Known $ Span 4 1) "a")) 111 | it "fun(a, bool)" $ do 112 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "fun(a, bool)" `shouldBe` 113 | Right (TFun (Known $ Span 0 12) [TName (Known $ Span 4 1) "a", TBool (Known $ Span 7 4)]) 114 | it "fun(a, bool) int32" $ do 115 | parse (type_ (\_ _ -> Nothing :: Maybe Void) <* eof) "fun(a, bool) int32" `shouldBe` 116 | Right 117 | (TApp (Known $ Span 0 18) 118 | (TFun (Known $ Span 0 12) [TName (Known $ Span 4 1) "a", TBool (Known $ Span 7 4)]) 119 | (TInt32 (Known $ Span 13 5)) 120 | ) 121 | describe "datatype" $ do 122 | it "struct Pair a b = Pair(a, b)" $ do 123 | parse (datatype <* eof) "struct Pair a b = Pair(a, b)" `shouldBe` 124 | Right 125 | (ADT "Pair" ["a", "b"] $ 126 | Ctor "Pair" [TVar . B $ Index (Known $ Span 23 1) 0, TVar . B $ Index (Known $ Span 26 1) 1] End 127 | ) 128 | it "enum Either a b { Left(a), Right(b) }" $ do 129 | parse (datatype <* eof) "enum Either a b { Left(a), Right(b) }" `shouldBe` 130 | Right 131 | (ADT "Either" ["a", "b"] $ 132 | Ctor "Left" [TVar . B $ Index (Known $ Span 23 1) 0] $ 133 | Ctor "Right" [TVar . B $ Index (Known $ Span 33 1) 1] $ 134 | End 135 | ) 136 | describe "function" $ do 137 | it "fn const(x: a, y: b) -> a {\n x\n}" $ do 138 | parse (function <* eof) "fn const(x: a, y: b) -> a {\n x\n}" `shouldBe` 139 | Right 140 | (Function 141 | "const" 142 | ["a", "b"] 143 | [ ("x", TVar . B $ Index (Known $ Span 17 1) 0) 144 | , ("y", TVar . B $ Index (Known $ Span 23 1) 1) 145 | ] 146 | (TVar . B $ Index (Known $ Span 29 1) 0) 147 | (Var . B $ Index (Known $ Span 35 1) 0) 148 | ) 149 | --------------------------------------------------------------------------------