├── .ghci ├── .gitignore ├── Ideas.markdown ├── README.md ├── neblen.cabal ├── resources ├── notes │ ├── Data-Types-And-Kinds.md │ ├── Evaluation.md │ └── Type-Checker-and-Inference.md └── vim │ └── neblen.vim ├── src ├── Main.hs ├── Neblen.hs └── Neblen │ ├── Compiler.hs │ ├── Data.hs │ ├── DataTypes.hs │ ├── Eval.hs │ ├── Parser.hs │ ├── TypeChecker.hs │ └── Utils.hs ├── stack.yaml ├── test-program.neblen └── tests ├── Neblen ├── Compiler │ └── Tests.hs ├── Eval │ └── Tests.hs ├── Parser │ └── Tests.hs └── TypeChecker │ └── Tests.hs └── TestSuite.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :l src/Neblen.hs 3 | :set prompt ">> " 4 | :set -Wall 5 | :set -fno-warn-unused-binds 6 | :set -fno-warn-unused-do-bind 7 | :set -fno-warn-unused-imports 8 | :set -fno-warn-type-defaults 9 | :set -XOverloadedStrings 10 | :set -XTypeSynonymInstances 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work/ 18 | .DS_Store 19 | codex.tags 20 | -------------------------------------------------------------------------------- /Ideas.markdown: -------------------------------------------------------------------------------- 1 | 2 | # Error messages 3 | 4 | Understandable parser error messages. Need to carry around state while parsing? See Elm blog post and link to HN comment. 5 | 6 | # Data types 7 | 8 | Algebraic data types, per Haskell. 9 | 10 | ``` 11 | type Name = String 12 | data Maybe a = Just a | Nothing 13 | data Either a b = Left a | Right b 14 | data List a = NilList | (a :. List a) 15 | data Tree a = Branch (Tree a) (Tree a) 16 | | Leaf a 17 | 18 | Maybe : * -> * 19 | (data-type (Maybe a) 20 | (Just a) 21 | Nothing) 22 | 23 | Either : * -> * -> * 24 | (data-type (Either a b) 25 | (Left a) 26 | (Right b)) 27 | 28 | List : * -> * 29 | (data-type (List a) 30 | NilList 31 | (SomeList a (List a))) 32 | 33 | List : * -> * 34 | (data-type (List a) 35 | NilList 36 | (:. a (List a))) 37 | 38 | Tree : * -> * 39 | (data-type (Tree a) 40 | (Branch (Tree a) (Tree a)) 41 | (Leaf a)) 42 | ``` 43 | 44 | 45 | What about named records? Meh, ignore for now. 46 | 47 | ``` 48 | data Person = { name :: String, age :: Int } 49 | 50 | data Either a b = Left { left :: a } 51 | | Right { right :: a } 52 | 53 | data List a = NilList 54 | | SomeList { getHead :: a, getRest :: List a } 55 | deriving Show 56 | ``` 57 | 58 | ## References 59 | 60 | 61 | # Type annotations 62 | 63 | ``` 64 | (: x Int) 65 | (def x 1) 66 | => 1 67 | 68 | (def y : String "Hello world") 69 | => "Hello world" 70 | 71 | ((fn [z] (+ z x)) 10) 72 | => 11 73 | 74 | (: incr (-> Int Int)) 75 | (def incr (fn [x] (+ x 1))) 76 | 77 | (incr 10) 78 | => 11 79 | 80 | (def decr (fn [x] (- x 1))) 81 | => TYPE ERROR. x is any, but expected to be Int. 82 | ``` 83 | 84 | ## References 85 | 86 | https://wiki.haskell.org/Type 87 | 88 | https://en.wikibooks.org/wiki/Haskell/More_on_datatypes 89 | 90 | http://elm-lang.org/docs/records 91 | 92 | http://docs.racket-lang.org/reference/define-struct.html 93 | 94 | # Ideas 95 | 96 | - Statically-typed lisp. 97 | - Interperted? 98 | - LLVM? 99 | - Compiled to JS? 100 | - See these compilers for inspiration: 101 | - [ClojureScript](https://github.com/clojure/clojurescript/blob/master/src/main/clojure/cljs/compiler.cljc) 102 | 103 | 104 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A programming language, a typed Lisp, a fun time. 2 | 3 | ``` 4 | Neblen> (let [incr (+ 1)] (incr (incr 10))) 5 | 12 : Int 6 | 7 | Neblen> (let [twice (fn [f x] (f (f x)))] ((twice (+ 1)) 10)) 8 | 12 : Int 9 | 10 | Neblen> :t (fn [x] x) 11 | (fn [x] x) : (-> a a) 12 | 13 | Neblen> :t ((fn [x] x) (fn [y] (y true))) 14 | ((fn [x] x) (fn [y] (y true))) : (-> (-> Bool a) a) 15 | ``` 16 | 17 | # Development 18 | 19 | First, [download and install `stack`](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). 20 | 21 | ``` 22 | cd ~/code/neblen 23 | 24 | # Get GHC 25 | stack install 26 | 27 | stack build 28 | ``` 29 | 30 | To run the Neblen REPL: 31 | 32 | ``` 33 | stack ghci neblen:exe:neblen 34 | >> main 35 | ``` 36 | 37 | # Tests 38 | 39 | ``` 40 | stack test 41 | 42 | # Install doctest 43 | stack install doctest 44 | 45 | stack exec doctest -- -isrc -Wall -fno-warn-type-defaults -fno-warn-unused-do-bind src/ 46 | ``` 47 | 48 | # References 49 | 50 | [Write You a Haskell by Stephen Diehl](http://dev.stephendiehl.com/fun) 51 | 52 | [Types and Programming Languages by Benjamin C. Pierce](https://mitpress.mit.edu/books/types-and-programming-languages) 53 | 54 | [Anatomy of Programming Languages by William R. Cook](http://www.cs.utexas.edu/~wcook/anatomy/anatomy.htm) 55 | 56 | [The Typed Racket Guide](http://docs.racket-lang.org/ts-guide/) 57 | 58 | [Typing Haskell in Haskell](http://web.cecs.pdx.edu/~mpj/thih/TypingHaskellInHaskell.html) 59 | -------------------------------------------------------------------------------- /neblen.cabal: -------------------------------------------------------------------------------- 1 | name: neblen 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >= 1.10 5 | 6 | executable neblen 7 | default-language: Haskell2010 8 | hs-source-dirs: src src/Neblen 9 | main-is: Main.hs 10 | other-modules: Neblen.Compiler 11 | Neblen.Data 12 | Neblen.DataTypes 13 | Neblen.Eval 14 | Neblen.Parser 15 | Neblen.TypeChecker 16 | Neblen.Utils 17 | 18 | build-depends: base == 4.* 19 | , array >= 0.5.0.0 20 | , containers >= 0.5.0.0 21 | , deepseq >= 1.3.0.0 22 | , haskeline >= 0.7.1.2 23 | , parsec >= 3.1.9 24 | , process >= 1.2.0.0 25 | , transformers >= 0.4.2.0 26 | -- , transformers >= 0.3 27 | -- Test deps below are listed here just for development, so 28 | -- that ghc-mod picks it up. 29 | , HUnit 30 | , QuickCheck >= 2.0 31 | , test-framework >= 0.8 && < 0.9 32 | , test-framework-hunit >= 0.3.0 33 | , test-framework-quickcheck2 >= 0.3.0 34 | -- , doctest >= 0.9.13 && <= 0.10.1 35 | 36 | ghc-options: -threaded 37 | -Wall 38 | -fno-warn-unused-binds 39 | -fno-warn-unused-do-bind 40 | -fno-warn-unused-imports 41 | -fno-warn-type-defaults 42 | 43 | test-suite neblen-tests 44 | default-language: Haskell2010 45 | type: exitcode-stdio-1.0 46 | 47 | hs-source-dirs: src src/Neblen tests 48 | main-is: TestSuite.hs 49 | other-modules: Neblen.Data 50 | Neblen.Eval 51 | Neblen.Eval.Tests 52 | Neblen.Parser 53 | Neblen.TypeChecker 54 | Neblen.TypeChecker.Tests 55 | Neblen.Utils 56 | 57 | build-depends: base == 4.* 58 | , HUnit >= 1.2 && < 1.3 59 | , QuickCheck >= 2.0 60 | , containers >= 0.5.0.0 61 | , directory >= 1.1 62 | , filepath >= 1.3 63 | , parsec >= 3.1.9 64 | , template-haskell >= 2.8 65 | , test-framework >= 0.8 && < 0.9 66 | , test-framework-hunit >= 0.3.0 67 | , test-framework-quickcheck2 >= 0.3.0 68 | , transformers >= 0.4.2.0 69 | -- , doctest >= 0.9.13 && <= 0.10.1 70 | ghc-options: -threaded 71 | -Wall 72 | -fno-warn-unused-binds 73 | -fno-warn-unused-do-bind 74 | -fno-warn-unused-imports 75 | -fno-warn-type-defaults 76 | 77 | -------------------------------------------------------------------------------- /resources/notes/Data-Types-And-Kinds.md: -------------------------------------------------------------------------------- 1 | # Data Types and Kinds 2 | 3 | Neblen supports data types similar to Haskell data types. Here's the `Maybe` data type: 4 | 5 | ``` 6 | (data-type Maybe (a) 7 | Nothing 8 | (Just a)) 9 | ``` 10 | 11 | To check that usage of type constructors are valid, we use a concept called 12 | "kinds". See [Typing Haskell in Haskell](https://web.cecs.pdx.edu/~mpj/thih/) 13 | and [https://wiki.haskell.org/Kind](https://wiki.haskell.org/Kind). 14 | For example, `Maybe a` is a type constructor of one argument, `a`. While 15 | `ExceptT e m a` is a type constructor with three arguments. 16 | 17 | ```haskell 18 | data Kind = Star 19 | | KFun Kind Kind 20 | ``` 21 | 22 | For showing, we use `*` for `Star`. Some examples of type constructors and 23 | their kinds: 24 | 25 | ```haskell 26 | Int :: * 27 | Maybe :: * -> * 28 | Maybe Int :: * 29 | (->) :: * -> * -> * 30 | a -> a :: * 31 | ExceptT :: * -> (* -> *) -> * -> * 32 | ``` 33 | 34 | ## Finding Kinds 35 | 36 | In the actual Neblen implementation of kinds, we need kind variables as a 37 | place-holder as we solve its kind: 38 | 39 | ```haskell 40 | data Kind = Star 41 | | KFun Kind Kind 42 | | KUnknown Int 43 | | KUnknownInit 44 | ``` 45 | 46 | Data type declarations are represented with `DeclareType`, which contains a list 47 | of type constructors, or `DeclareCtor`s: 48 | 49 | ```haskell 50 | -- | Data type declaration. 51 | data DeclareType = DeclareType Name [TName] [DeclareCtor] Kind 52 | 53 | -- | Data type constructor declaration. 54 | data DeclareCtor = DeclareCtor Name [Type] 55 | 56 | -- Maybe data type 57 | DeclareType "Maybe" ["a"] 58 | [DeclareCtor "Nothing" [], 59 | DeclareCtor "Just" [TVarK "a" KUnknownInit]] 60 | KUnknownInit 61 | ``` 62 | 63 | When the program is first parsed, every data type and type constructor has an 64 | unknown kind, `KUnknownInit`. The `replaceKUnknownInitsDeclareType` function 65 | replaces these uninitialized kinds with, `KUnknown Int`, whose kinds we still 66 | don't know, but at least have unique identifiers: 67 | 68 | ```haskell 69 | DeclareType "Maybe" ["a"] 70 | [DeclareCtor "Nothing" [], 71 | DeclareCtor "Just" [TVarK "a" (KUnknown 0)]] 72 | (KUnknown 1) 73 | ``` 74 | 75 | The goal is now to find the kind of each type variable in the type. In doing so, 76 | we would be able to build the kind of the data type itself, and also the type 77 | constructors. 78 | 79 | After solving for the `Maybe` declaration above (using `evalDataTypeKind`), we 80 | should have: 81 | 82 | ```haskell 83 | DeclareType "Maybe" ["a"] 84 | [DeclareCtor "Nothing" [], 85 | DeclareCtor "Just" [TVarK "a" (KUnknown 0)]] 86 | (KFun Star Star) 87 | 88 | -- With a kind mapping: 89 | fromList [("a", Star)] 90 | ``` 91 | 92 | Note that the `Just` constructor has a `TVarK "a" (KUnknown 0)`. We know that 93 | `a` must be of kind `*` (the mapping says so). `TVarK "a" (KUnknown 0)` is 94 | saying that we don't know what kind *will* be supplied for `a`. If the user 95 | gives us a kind `*`, then all is well. But if it's say `* -> *`, this would be 96 | an error. 97 | 98 | ### General Strategy 99 | 100 | The goal is to find the kind of each type in every type constructor. This is 101 | similar to an interpreter or type checker—there are terms (type variables like 102 | `a` in `(Just a)`), and we go down into each term and try to figure out its 103 | kind, building a mapping of type variables to kinds, and also a substitution 104 | mapping of kind variables to kinds. 105 | 106 | Look at `evalKindOfType` to see how this is done. 107 | 108 | The interesting case is `TApp t1 t2`, because once you evaluate the kind of `t1` 109 | and `t2`, you then create a third kind `k3` which is returned by the 110 | application. All of this gets remembered in the substitution, like this: 111 | 112 | ``` 113 | Environment (KEnv): 114 | t1 : k1 115 | t2 : k2 116 | 117 | Substitutions of kind variables (KSubst): 118 | k1 : k2 -> k3 119 | ``` 120 | 121 | Let's follow the example for `ExceptT`: 122 | 123 | 124 | ```haskell 125 | data Either e a = Left e | Right a 126 | 127 | data ExceptT e m a = ExceptT m (Either e a) 128 | 129 | exceptT = DeclareType "ExceptT" ["e","m","a"] 130 | [DeclareCtor "ExceptT" 131 | [TApp (TVarK "m" (KUnknown 0)) 132 | (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 133 | (TVarK "a" (KUnknown 3)))]] 134 | (KUnknown 4) 135 | ``` 136 | 137 | What is passed into `evalKindOfType` is the term `TApp (TVarK "m" (KUnknown 0)) 138 | …` with two maps, `KEnv`, which is the mapping of type vars to kinds, and 139 | `KSubst`, which specifies kind variables substitutions: 140 | 141 | ``` 142 | KEnv: 143 | EMPTY 144 | 145 | KSubst: 146 | EMPTY 147 | ``` 148 | 149 | The first non-`TApp` term is reached: 150 | 151 | ```haskell 152 | (TVarK "m" (KUnknown 0)) 153 | ``` 154 | 155 | The term `m` is simply added: 156 | 157 | ``` 158 | KEnv: 159 | m : k0 160 | 161 | KSubst: 162 | EMPTY 163 | ``` 164 | 165 | The next term reached is: 166 | 167 | ```haskell 168 | (TConst "Either" (KUnknown 1)) 169 | ``` 170 | 171 | We first make sure we know what `Either` is. If we don't, error. Otherwise, assume we don't know it's kind, and let's return the kind variable it has, `k1`. 172 | 173 | Next: 174 | 175 | ```haskell 176 | (TVarK "e" (KUnknown 2)) 177 | ``` 178 | 179 | And the env is modified: 180 | 181 | ``` 182 | KEnv: 183 | m : k0 184 | e : k2 185 | 186 | KSubst: 187 | EMPTY 188 | ``` 189 | 190 | Now we're at the first `TApp`, of the last two terms above: 191 | 192 | ```haskell 193 | (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 194 | ``` 195 | 196 | Here, we make a new kind variable `k10`, and learn something about `k1`: 197 | 198 | ``` 199 | KEnv: 200 | m : k0 201 | e : k2 202 | 203 | KSubst: 204 | k1 : k2 -> k10 205 | ``` 206 | 207 | Next: 208 | 209 | ```haskell 210 | (TVarK "a" (KUnknown 3)) 211 | ``` 212 | 213 | ``` 214 | KEnv: 215 | m : k0 216 | e : k2 217 | a : k3 218 | 219 | KSubst: 220 | k1 : k2 -> k10 221 | ``` 222 | 223 | Next is the next outer `TApp`, combining all the terms above: 224 | 225 | ```haskell 226 | ------ (0) 227 | -- (1) 228 | (TApp (TApp (TConst "Either" (KUnknown 1)) 229 | (TVarK "e" (KUnknown 2))) 230 | (TVarK "a" (KUnknown 3))) 231 | ``` 232 | 233 | Remember that the inner `TApp` (marked as `(0)`), we create a return kind `k10`. That is the kind of the `(0)` term. The outer `TApp`, then, has a new return kind `k11`. Our enviornment is: 234 | 235 | ``` 236 | KEnv: 237 | m : k0 238 | e : k2 239 | a : k3 240 | 241 | KSubst: 242 | k1 : k2 -> k10 243 | k10 : k3 -> k11 244 | ``` 245 | 246 | Notice how we can substitute `k10`. We do just that, and get: 247 | 248 | ``` 249 | KEnv: 250 | m : k0 251 | e : k2 252 | a : k3 253 | 254 | KSubst: 255 | k1 : k2 -> k3 -> k11 256 | k10 : k3 -> k11 257 | ``` 258 | 259 | This goes on for every term, until we build a finalize `KSubst` and `KEnv`. 260 | 261 | # References 262 | 263 | [Typing Haskell in Haskell](https://web.cecs.pdx.edu/~mpj/thih/) 264 | 265 | PureScript implementation: 266 | - [Kind unification](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/TypeChecker/Kinds.hs#L58) 267 | - [Kinds](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Kinds.hs#L33) 268 | 269 | # Brain dump 270 | 271 | ```haskell 272 | -- Data types 273 | -- 274 | -- Data types can only be declared at the top level. 275 | -- 276 | -- =============== 277 | -- Parsing 278 | -- =============== 279 | -- 280 | -- First, we need to parse the data type declaration into something that we 281 | -- can work with. When you declare a data type, you're declaring: 282 | -- 283 | -- - Its name (e.g. Maybe) 284 | -- - What its constructors are 285 | -- - For each constructor, what types it accepts, and what its kinds are 286 | 287 | 288 | -- Some examples: 289 | -- 290 | -- (data-type Person 291 | -- (Person String Int)) 292 | -- 293 | person :: DeclareType 294 | person = DeclareType "Person" [] [DeclareCtor "Person" [TString,TInt]] (KUnknown 0) 295 | -- 296 | -- Maybe: 297 | -- (data-type Maybe (a) 298 | -- Nothing 299 | -- (Just a)) 300 | -- 301 | -- Parser "dumbly" parses this data type declaration. Note that the kinds of 302 | -- each type is currently unknown: 303 | -- 304 | dtMaybe :: DeclareType 305 | dtMaybe = DeclareType "Maybe" ["a"] [DeclareCtor "Nothing" [], 306 | DeclareCtor "Just" [TVarK "a" (KUnknown 0)]] 307 | (KUnknown 1) 308 | -- Either: 309 | -- (data-type Either (a b) 310 | -- (Left a) 311 | -- (Right b)) 312 | -- 313 | dtEither :: DeclareType 314 | dtEither = DeclareType "Either" ["a","b"] [DeclareCtor "Left" [TVarK "a" (KUnknown 0)], 315 | DeclareCtor "Right" [TVarK "b" (KUnknown 1)]] 316 | (KUnknown 2) 317 | 318 | -- (data-type ExceptT (e m a) 319 | -- (ExceptT (m (Either e a)))) 320 | -- 321 | dtExceptT :: DeclareType 322 | dtExceptT = DeclareType "ExceptT" ["e","m","a"] 323 | [DeclareCtor "ExceptT" 324 | [TApp (TVarK "m" (KUnknown 0)) 325 | (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 326 | (TVarK "a" (KUnknown 3)))]] 327 | (KUnknown 4) 328 | 329 | -- (data-type Pair (a b) 330 | -- (Pair a b)) 331 | -- 332 | dtPair :: DeclareType 333 | dtPair = DeclareType "Pair" ["a","b"] 334 | [DeclareCtor "Pair" [TVarK "a" (KUnknown 1),TVarK "b" (KUnknown 2)]] 335 | (KUnknown 3) 336 | 337 | dtPair2 :: DeclareType 338 | dtPair2 = DeclareType "Pair" ["a","b"] 339 | [DeclareCtor "Pair" [TVarK "a" Star,TVarK "b" Star]] 340 | (KFun Star (KFun Star Star)) 341 | 342 | 343 | -- | Primitive function type. 344 | funT :: Type 345 | funT = (TConst "->" (KFun Star (KFun Star Star))) 346 | 347 | -- (data-type State (s a) 348 | -- (State (-> s (Pair s a)))) 349 | -- 350 | dtState :: DeclareType 351 | dtState = DeclareType "State" ["s","a"] 352 | [DeclareCtor "State" 353 | [TApp (TApp (TConst "->" (KUnknown 0)) 354 | (TVarK "s" (KUnknown 1))) 355 | (TApp (TApp (TConst "Pair" (KUnknown 2)) (TVarK "s" (KUnknown 3))) 356 | (TVarK "a" (KUnknown 4)))]] 357 | (KUnknown 5) 358 | dtState2 :: DeclareType 359 | dtState2 = DeclareType "State" ["s","a"] 360 | [DeclareCtor "State" 361 | [TApp (TApp funT 362 | (TVarK "s" Star)) 363 | (TApp (TApp (TConst "Pair" (KFun Star (KFun Star Star))) (TVarK "s" Star)) 364 | (TVarK "a" Star))]] 365 | (KFun (KFun Star Star) Star) 366 | 367 | -- Recursive data type: 368 | data Tree a = Leaf a 369 | | Branch (Tree a) (Tree a) 370 | 371 | dtTree :: DeclareType 372 | dtTree = DeclareType "Tree" ["a"] 373 | [DeclareCtor "Leaf" [TVarK "a" (KUnknown 0)], 374 | DeclareCtor "Branch" [TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)), 375 | TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0))]] 376 | (KUnknown 1) 377 | 378 | -- Foo :: (* -> * -> *) -> * -> * -> * 379 | -- 380 | data Dallas a b c d e = Dallas (a (b c) d e) 381 | -- 382 | dtFoo :: DeclareType 383 | dtFoo = DeclareType "Foo" ["a","b","c","d"] 384 | [DeclareCtor "Foo" 385 | [TApp (TApp (TApp (TVarK "a" (KUnknown 0)) 386 | (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 387 | (TVarK "d" (KUnknown 3))) 388 | (TVarK "e" (KUnknown 4))]] 389 | (KUnknown 5) 390 | 391 | foo = Dallas 392 | 393 | --------------------------- 394 | -- Let's manually do some evaluation. 395 | --------------------------- 396 | -- 397 | --------------------------- 398 | -- Except 399 | --------------------------- 400 | -- 401 | -- data ExceptT e m a = m (Either e a) 402 | -- 403 | -- dtExceptT :: DeclareType 404 | -- dtExceptT = DeclareType "ExceptT" ["e","m","a"] 405 | -- [DeclareCtor "ExceptT" 406 | -- [TApp (TVarK "m" (KUnknown 0)) 407 | -- (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 408 | -- (TVarK "a" (KUnknown 3)))]] 409 | -- (KUnknown 4) 410 | -- 411 | -- Starts with inner-most lhs: 412 | -- 413 | -- ===== (TVarK "m" (KUnknown 0)) 414 | -- 415 | -- KConstEnv: 416 | -- Either : * -> * -> * 417 | -- ExceptT : 4 418 | -- 419 | -- KEnv: 420 | -- m : 0 421 | -- 422 | -- KSubst: 423 | -- n/a 424 | -- 425 | -- ===== (TConst "Either" (KUnknown 1)) 426 | -- 427 | -- KConstEnv: 428 | -- Either : * -> * -> * 429 | -- ExceptT : 4 430 | -- 431 | -- KEnv: 432 | -- m : 0 433 | -- 434 | -- KSubst: 435 | -- 436 | -- ===== (TVarK "e" (KUnknown 2)) 437 | -- 438 | -- KConstEnv: 439 | -- Either : * -> * -> * 440 | -- ExceptT : 4 441 | -- 442 | -- KEnv: 443 | -- m : 0 444 | -- e : 2 445 | -- 446 | -- KSubst: 447 | -- 448 | -- ===== (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 449 | -- 450 | -- We know to apply, so 1 must accept 2, and return a new kind var 100. 451 | -- 452 | -- KConstEnv: 453 | -- Either : * -> * -> * 454 | -- ExceptT : 4 455 | -- 456 | -- KEnv: 457 | -- m : 0 458 | -- e : 2 459 | -- 460 | -- KSubst: 461 | -- 1 : 2 -> 100 462 | -- 463 | -- ===== (TVarK "a" (KUnknown 3)) 464 | -- 465 | -- KConstEnv: 466 | -- Either : * -> * -> * 467 | -- ExceptT : 4 468 | -- 469 | -- KEnv: 470 | -- m : 0 471 | -- e : 2 472 | -- a : 3 473 | -- 474 | -- KSubst: 475 | -- 1 : 2 -> 100 476 | -- 477 | -- ===== (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 478 | -- (TVarK "a" (KUnknown 3))) 479 | -- 480 | -- KConstEnv: 481 | -- Either : * -> * -> * 482 | -- ExceptT : 4 483 | -- 484 | -- KEnv: 485 | -- m : 0 486 | -- e : 2 487 | -- a : 3 488 | -- 489 | -- KSubst: 490 | -- 1 : 2 -> 100 491 | -- 100: 3 -> 200 492 | -- apply ==> 493 | -- 1 : 2 -> 3 -> 200 494 | -- 100: 3 -> 200 495 | -- 496 | -- ===== TApp (TVarK "m" (KUnknown 0)) 497 | -- ===== (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 498 | -- ===== (TVarK "a" (KUnknown 3))) 499 | -- 500 | -- KConstEnv: 501 | -- Either : * -> * -> * 502 | -- ExceptT : 4 503 | -- 504 | -- KEnv: 505 | -- m : 0 506 | -- e : 2 507 | -- a : 3 508 | -- 509 | -- KSubst: 510 | -- 1 : 2 -> 3 -> 200 511 | -- 100: 3 -> 200 512 | -- 0 : 200 -> 300 513 | -- 514 | -- Replace all unknowns with stars: 515 | -- 516 | -- KEnv: 517 | -- m : * -> * 518 | -- e : * 519 | -- a : * 520 | -- 521 | -- KSubst: 522 | -- 1 : * -> * -> * 523 | -- 100: * -> * 524 | -- 0 : * -> * 525 | -- 526 | -- And get: 527 | -- 528 | -- ExceptT e m a -> * 529 | -- ExceptT * -> (((* -> *) -> *) -> *) 530 | -- 531 | --------------------------- 532 | -- Dallas 533 | --------------------------- 534 | -- 535 | -- Start from: 536 | -- 537 | -- data Dallas a b c d e = Dallas (a (b c) d e) 538 | -- 539 | -- In Neblen: 540 | -- 541 | -- (data-type Dallas (a b c d e) 542 | -- (Dallas (a (b c) d e))) 543 | -- 544 | -- Parse this, and give each TVarK a unique integer: 545 | -- 546 | -- dtFoo :: DeclareType 547 | -- dtFoo = DeclareType "Foo" ["a","b","c","d"] 548 | -- [DeclareCtor "Foo" 549 | -- [TApp (TApp (TApp (TVarK "a" (KUnknown 0)) 550 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 551 | -- (TVarK "d" (KUnknown 3))) 552 | -- (TVarK "e" (KUnknown 4))]] 553 | -- (KUnknown 5) 554 | -- 555 | -- Start with inner-most LHS type: 556 | -- 557 | -- (TVarK "a" (KUnknown 0)) 558 | -- 559 | -- Known data types mapping: 560 | -- Dallas : 5 561 | -- 562 | -- TVarK to kind mapping: 563 | -- a : 0 564 | -- b : 1 565 | -- c : 2 566 | -- d : 3 567 | -- e : 4 568 | -- 569 | -- Move to the RHS: 570 | -- 571 | -- (TVarK "b" (KUnknown 1)) 572 | -- 573 | -- a : 0 574 | -- b : 1 575 | -- c : 2 576 | -- d : 3 577 | -- e : 4 578 | -- 579 | -- (TVarK "c" (KUnknown 2)) 580 | -- 581 | -- a : 0 582 | -- b : 1 583 | -- c : 2 584 | -- d : 3 585 | -- e : 4 586 | -- 587 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2))) 588 | -- 589 | -- Now we're back to the inner-most TApp. Here, we unify and discover new info 590 | -- about b's k1, namely that it must be 2 -> 100, where 100 is a fresh kind var. 591 | -- 592 | -- Eager apply: 593 | -- Note that we don't need to apply the kinds into the type vars yet. 'b' can 594 | -- stay as 'b : 1' until the end. I think all we need to carry forward are the 595 | -- kind mappings (e.g. 1 : 2 -> 100), composing them together at every step. 596 | -- a : 0 597 | -- b : 2 -> 100 598 | -- c : 2 599 | -- d : 3 600 | -- e : 4 601 | -- 1 : 2 -> 100 602 | -- 603 | -- (TApp (TVarK "a" (KUnknown 0)) 604 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 605 | -- 606 | -- Same as before, get a fresh k200. Kind of expression is k200, but we 607 | -- discovered new info about a's k0: 608 | -- 609 | -- Eager apply: 610 | -- a : 100 -> 200 611 | -- b : 2 -> 100 612 | -- c : 2 613 | -- d : 3 614 | -- e : 4 615 | -- 1 : 2 -> 100 616 | -- 0 : 100 -> 200 617 | -- 618 | -- (TApp (TApp (TVarK "a" (KUnknown 0)) 619 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 620 | -- (TVarK "d" (KUnknown 3))) 621 | -- 622 | -- Kind of expression is k300. 623 | -- 624 | -- Eager apply: 625 | -- a : 100 -> (3 -> 300) 626 | -- b : 2 -> 100 627 | -- c : 2 628 | -- d : 3 629 | -- e : 4 630 | -- 1 : 2 -> 100 631 | -- 0 : 100 -> (3 -> 300) 632 | -- 200: 3 -> 300 633 | -- 634 | -- TApp (TApp (TApp (TVarK "a" (KUnknown 0)) 635 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 636 | -- (TVarK "d" (KUnknown 3))) 637 | -- (TVarK "e" (KUnknown 4)) 638 | -- 639 | -- Kind of expression is k400. 640 | -- 641 | -- Eager apply: 642 | -- a : 100 -> (3 -> (4 -> 400)) 643 | -- b : 2 -> 100 644 | -- c : 2 645 | -- d : 3 646 | -- e : 4 647 | -- 1 : 2 -> 100 648 | -- 0 : 100 -> (3 -> (4 -> 400)) 649 | -- 200: 3 -> (4 -> 400) 650 | -- 300: 4 -> 400 651 | -- 652 | -- Then, apply substitutions on k vars and t vars. Or, should we have been 653 | -- applying them as we went along, similar to how type checking works? I wonder 654 | -- if data types being recursive makes it easier to do one way over the other. 655 | -- 656 | -- Eager apply (subsitutions already applied!): 657 | -- a : 100 -> (3 -> (4 -> 400)) 658 | -- b : 2 -> 100 659 | -- c : 2 660 | -- d : 3 661 | -- e : 4 662 | -- 1 : 2 -> 100 663 | -- 0 : 100 -> (3 -> (4 -> 400)) 664 | -- 200: 3 -> (4 -> 400) 665 | -- 300: 4 -> 400 666 | -- 667 | -- To get: 668 | -- 669 | -- a : 100 -> (3 -> (4 -> 400)) 670 | -- b : 2 -> 100 671 | -- c : 2 672 | -- d : 3 673 | -- e : 4 674 | -- 675 | -- Then, replace all unknowns with stars. 676 | -- 677 | -- a : * -> (* -> (* -> *)) 678 | -- b : * -> * 679 | -- c : * 680 | -- d : * 681 | -- e : * 682 | -- 683 | -- And get: 684 | -- 685 | -- Dallas : (* -> (* -> (* -> *))) -> (* -> *) -> * -> * -> * -> * 686 | 687 | --------------------------- 688 | -- Manual evaluation of recursive types 689 | --------------------------- 690 | -- 691 | -- data Tree a = Leaf a | Branch (Tree a) (Tree a) 692 | -- 693 | -- DeclareType "Tree" ["a"] 694 | -- [DeclareCtor "Leaf" [TVarK "a" (KUnknown 0)], 695 | -- DeclareCtor "Branch" [TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)), 696 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0))]] 697 | -- (KUnknown 2) 698 | -- 699 | -- Starting from most-inner LHS of the first element: 700 | -- 701 | -- TVarK "a" (KUnknown 0) 702 | -- 703 | -- Data type mapping: 704 | -- Tree : 1 705 | -- 706 | -- TVarK to kind mapping: 707 | -- a : 0 708 | -- 709 | -- Done with this one. We can't convert 0 to * yet. Must go to the other ctors. 710 | -- 711 | -- DeclareCtor "Branch" [TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)), 712 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0))]] 713 | -- 714 | -- (TConst "Tree" (KUnknown 1)) 715 | -- 716 | -- Look up "Tree", we note that it is being declared. So we just say: 717 | -- 718 | -- a : 0 719 | -- 720 | -- (TVarK "a" (KUnknown 0)) 721 | -- 722 | -- a : 0 723 | -- 724 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)) 725 | -- 726 | -- a : 0 727 | -- 1 : 0 -> 100 728 | -- 729 | -- Go the second argument of ctor: 730 | -- 731 | -- (TConst "Tree" (KUnknown 1)) 732 | -- 733 | -- a : 0 734 | -- 1 : 0 -> 100 735 | -- 736 | -- (TVarK "a" (KUnknown 0)) 737 | -- 738 | -- a : 0 739 | -- 1 : 0 -> 100 740 | -- 741 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)) 742 | -- 743 | -- a : 0 744 | -- 1 : 0 -> 100 745 | -- 746 | -- We are done: 747 | -- 748 | -- a : 0 749 | -- 750 | -- Replace with *: 751 | -- 752 | -- a : * 753 | -- 754 | -- And as for Tree, we just iterate through its declared variables (just 'a' for 755 | -- this): 756 | -- 757 | -- Tree : * -> * 758 | -- 759 | -- And return: 760 | -- 761 | -- 762 | -- dtTree :: DeclareType 763 | -- dtTree = DeclareType "Tree" ["a"] 764 | -- [DeclareCtor "Leaf" [TVarK "a" Star], 765 | -- DeclareCtor "Branch" [TApp (TConst "Tree" (KFun Star Star)) (TVarK "a" Star), 766 | -- TApp (TConst "Tree" (KFun Star Star)) (TVarK "a" Star)]] 767 | -- (KFun Star Star) 768 | 769 | 770 | -- 771 | dtMaybe2 :: DeclareType 772 | dtMaybe2 = DeclareType "Maybe" ["a"] [DeclareCtor "Nothing" [], 773 | DeclareCtor "Just" [TVarK "a" Star]] 774 | (KFun Star Star) 775 | dtEither2 :: DeclareType 776 | dtEither2 = DeclareType "Either" ["a","b"] [DeclareCtor "Left" [TVarK "a" Star], 777 | DeclareCtor "Right" [TVarK "b" Star]] 778 | (KFun (KFun Star Star) Star) 779 | dtExceptT2 :: DeclareType 780 | dtExceptT2 = DeclareType "ExceptT" ["e","m","a"] 781 | [DeclareCtor "ExceptT" 782 | [TApp (TVarK "m" (KFun Star Star)) 783 | (TApp (TApp (TConst "Either" (KFun Star (KFun Star Star))) (TVarK "e" Star)) 784 | (TVarK "a" Star))]] 785 | (KFun Star (KFun (KFun Star Star) (KFun Star Star))) 786 | 787 | dtPerson2 :: DeclareType 788 | dtPerson2 = DeclareType "Person" [] [DeclareCtor "Person" [TString,TInt]] Star 789 | 790 | 791 | -- More examples: 792 | data Foo a = Foo (Maybe a) 793 | data Bar a b = Bar (a b) 794 | data Far a b = Far (a b) b 795 | data Complex a b c d e = Complex (b a) (a (c d e)) 796 | 797 | foo1 :: Foo Int 798 | foo1 = Foo (Just (0 :: Int)) 799 | 800 | foo2 :: Foo a 801 | foo2 = Foo Nothing 802 | 803 | bar1 :: Bar Maybe Int 804 | bar1 = Bar (Just (0 :: Int)) 805 | 806 | far1 :: Far Maybe Int 807 | far1 = Far (Just (0 :: Int)) 1 808 | 809 | -- Complex :: b a -> a (c d e) -> Complex a b c d e 810 | -- 811 | -- b = ? 812 | -- a = Maybe 813 | -- c = Either d Int 814 | -- d is free 815 | -- e = Int 816 | -- 817 | -- Kind of `Complex` is: 818 | -- 819 | -- a :: * -> * 820 | -- b :: (* -> *) -> * 821 | -- c :: * -> * -> * 822 | -- d :: * 823 | -- e :: * 824 | -- 825 | -- Clownpiece: So something like Fix f = Fold {unFold :: f (Fix f)} would work for b. 826 | -- 827 | -- complex1 :: Complex Maybe ? (Either d Int) d Int 828 | -- complex1 = Complex _ (Just (Right (0 :: Int))) 829 | 830 | -- data Fix f = Fold { unFold :: f (Fix f) } 831 | ``` 832 | -------------------------------------------------------------------------------- /resources/notes/Evaluation.md: -------------------------------------------------------------------------------- 1 | # Evaluation 2 | 3 | At it's core, Neblen is just the lambda calculus. This makes evaluation fairly 4 | simple. 5 | 6 | The evaluator is in `Eval.hs`, via the main function `eval'`: 7 | 8 | ```haskell 9 | eval' :: EvalEnv -> Exp -> Exp 10 | ``` 11 | 12 | This function takes an evaluation environment (mapping of variables to its 13 | expression value), an expression, and returns the reduced expression. There are 14 | hard-coded primitive functions, like binary and numeric operations, and also 15 | `print`. 16 | -------------------------------------------------------------------------------- /resources/notes/Type-Checker-and-Inference.md: -------------------------------------------------------------------------------- 1 | # Type Checker and Inference 2 | 3 | The `TypeChecker.hs` has an in-depth explanation of the type checker and 4 | inferencer. 5 | -------------------------------------------------------------------------------- /resources/vim/neblen.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Neblen 3 | " Maintainer: Elben Shira 4 | " URL: http://github.com/elben/neblen/resources/vim 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | syn keyword neblenTodo contained TODO FIXME XXX NOTE 11 | syn match neblenComment ";.*$" contains=neblenTodo 12 | syn keyword neblenPrimitiveKeywords fn def let 13 | syn match neblenClosures "\v[\(\)\[\]]" 14 | 15 | let b:current_syntax = "neblen" 16 | 17 | hi def link neblenTodo Todo 18 | hi def link neblenComment Comment 19 | hi def link neblenPrimitiveKeywords Keyword 20 | hi def link neblenClosures Delimiter 21 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Neblen.Data 4 | import Neblen.Eval 5 | import Neblen.Utils 6 | import System.Console.Haskeline 7 | import System.Process 8 | import Data.List 9 | 10 | execJS :: JSProgram -> IO String 11 | execJS = readProcess "node" ["-p"] 12 | 13 | main :: IO () 14 | main = runInputT defaultSettings loop 15 | where 16 | loop = do 17 | minput <- getInputLine "Neblen> " 18 | case minput of 19 | Nothing -> outputStrLn "Exiting..." 20 | Just input -> do 21 | let typeCheck = ":t " `isPrefixOf` input 22 | let input' = if typeCheck then input \\ ":t " else input 23 | -- TODO only checkType if :t? 24 | let answer = parseAndEval input' 25 | case answer of 26 | Left e -> outputStrLn e 27 | Right (e, t) -> 28 | if typeCheck 29 | then outputStrLn (input' ++ " : " ++ show t) 30 | else outputStrLn (toLisp e ++ " : " ++ show t) 31 | loop 32 | -------------------------------------------------------------------------------- /src/Neblen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Neblen (module X) where 4 | 5 | import Neblen.Data as X 6 | import Neblen.Compiler as X 7 | import Neblen.Parser as X 8 | import Neblen.TypeChecker as X 9 | import Neblen.Eval as X 10 | import Neblen.DataTypes as X 11 | -------------------------------------------------------------------------------- /src/Neblen/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Neblen.Compiler where 4 | 5 | import Neblen.Data 6 | import Neblen.Parser 7 | import qualified Data.Map.Strict as M 8 | import qualified Data.List as L 9 | 10 | -- $setup 11 | -- >>> :set -XOverloadedStrings 12 | -- >>> import Neblen.Compiler 13 | -- 14 | 15 | type Env = M.Map String Value 16 | 17 | emptyEnv :: Env 18 | emptyEnv = M.empty 19 | 20 | -- | Emit Value. 21 | -- 22 | -- >>> emitValue (IntV (-30)) 23 | -- "-30" 24 | -- 25 | -- >>> emitValue (StringV "Hello") 26 | -- "\"Hello\"" 27 | -- 28 | emitValue :: Value -> JSProgram 29 | emitValue (IntV i) = show i 30 | emitValue (BoolV True) = "true" 31 | emitValue (BoolV False) = "false" 32 | emitValue (StringV s) = "\"" ++ s ++ "\"" 33 | 34 | -- https://mathiasbynens.be/notes/javascript-identifiers 35 | -- toJsVar :: String -> JSProgram 36 | -- toJsVar 37 | 38 | -- | Emit variable identifier. 39 | -- 40 | -- >>> xformVar "+++" 41 | -- "_nbln_plusplusplus" 42 | -- 43 | -- >>> xformVar "hello" 44 | -- "_nbln_hello" 45 | -- 46 | -- >>> xformVar "hello-world" 47 | -- "_nbln_hellominusworld" 48 | -- 49 | -- TODO: need to make sure vars CAN'T smash other vars with the same name 50 | -- but different scope. I think since we use javascript 'var' this is solved? 51 | xformVar :: Name -> JSProgram 52 | xformVar v = "_nbln_" ++ v' 53 | where v' = L.intercalate "" (fmap (\c -> M.findWithDefault [c] c symbolToJsId) v) 54 | 55 | -- | Emit definition binding. 56 | -- 57 | -- >>> emitDef emptyEnv (Var "x") (UnaryApp (Var "incr") (Lit (IntV 10))) 58 | -- "var _nbln_x = _nbln_incr(10);\n" 59 | -- 60 | -- >>> emitDef emptyEnv (Var "x") (Var "y") 61 | -- "var _nbln_x = _nbln_y;\n" 62 | -- 63 | emitDef :: Env -> Exp -> Exp -> JSProgram 64 | emitDef env (Var v) expr = "var " ++ xformVar v ++ " = " ++ emitExp env expr ++ ";\n" 65 | emitDef _ _ _ = error "Definition has invalid variable name." 66 | 67 | 68 | -- | Emit nullary function. 69 | -- 70 | -- >>> emitNullaryFun emptyEnv (UnaryApp (Var "incr") (Var "x")) 71 | -- "(function () { return _nbln_incr(_nbln_x); })" 72 | -- 73 | emitNullaryFun :: Env -> Exp -> JSProgram 74 | emitNullaryFun env expr = "(function () { return " ++ emitExp env expr ++ "; })" 75 | 76 | -- | Emit unary function. 77 | -- 78 | -- >>> emitFun emptyEnv (Var "x") (UnaryApp (Var "incr") (Var "x")) 79 | -- "(function (_nbln_x) { return _nbln_incr(_nbln_x); })" 80 | -- 81 | emitFun :: Env -> Exp -> Exp -> JSProgram 82 | emitFun env (Var v) expr = "(function (" ++ xformVar v ++ ") { return " ++ emitExp env expr ++ "; })" 83 | emitFun _ _ _ = error "Invalid function definition." 84 | 85 | -- | Emit let binding. 86 | -- 87 | -- Env -> Variable name -> Variable value -> Body expression 88 | -- 89 | -- Implemented as function call so that the variable is scoped only in the body. 90 | -- 91 | -- >>> emitLet emptyEnv (Var "x") (Lit (IntV 55)) (Var "x") 92 | -- "(function (_nbln_x) { return _nbln_x; })(55)" 93 | -- 94 | -- >>> emitLet emptyEnv (Var "incr") (Fun (Var "x") (Var "x")) (UnaryApp (Var "incr") (Lit (IntV 10))) 95 | -- "(function (_nbln_incr) { return _nbln_incr(10); })((function (_nbln_x) { return _nbln_x; }))" 96 | -- 97 | emitLet :: Env -> Exp -> Exp -> Exp -> JSProgram 98 | -- emitLet env (Var v) val body = emitUnaryApp env (Fun (Var v) body) val 99 | emitLet _ _ _ _ = "Invalid let definition." 100 | 101 | -- | Emit nullary function call. 102 | -- 103 | -- Env -> Fun or function name -> JSProgram 104 | -- 105 | emitNullaryApp :: Env -> Exp -> JSProgram 106 | emitNullaryApp _ (Var fn) = xformVar fn ++ "()" 107 | -- emitNullaryApp env (Fun var body) = emitFun env var body ++ "()" 108 | emitNullaryApp env expr = emitExp env expr ++ "()" 109 | 110 | -- | Emit unary function call. 111 | -- 112 | -- Env -> Fun or function name -> Argument expression -> JSProgram 113 | -- 114 | emitUnaryApp :: Env -> Exp -> Exp -> JSProgram 115 | emitUnaryApp env (Var fn) arg = xformVar fn ++ "(" ++ emitExp env arg ++ ")" 116 | -- emitUnaryApp env (Fun var body) arg = emitFun env var body ++ "(" ++ emitExp env arg ++ ")" 117 | emitUnaryApp env expr arg = emitExp env expr ++ "(" ++ emitExp env arg ++ ")" 118 | 119 | -- | Emit vector. 120 | -- 121 | -- >>> emitVector emptyEnv [] 122 | -- "[]" 123 | -- 124 | -- >>> emitVector emptyEnv [Lit (IntV 1), Lit (IntV 3), (Let (Var "incr") (Fun (Var "x") (Var "x")) (UnaryApp (Var "incr") (Lit (IntV 10))))] 125 | -- "[1,3,(function (_nbln_incr) { return _nbln_incr(10); })((function (_nbln_x) { return _nbln_x; }))]" 126 | -- 127 | emitVector :: Env -> [Exp] -> JSProgram 128 | emitVector _ [] = "[]" 129 | emitVector env exprs = "[" ++ L.intercalate "," (map (emitExp env) exprs) ++ "]" 130 | 131 | -- | Emit if. 132 | -- 133 | -- >>> emitIf emptyEnv (If (Lit (BoolV True)) (Lit (IntV 1)) (Lit (IntV 2))) 134 | -- "if (true) { return 1; } else { return 2; }" 135 | -- 136 | emitIf :: Env -> Exp -> JSProgram 137 | emitIf env (If p t e) = "if (" ++ emitExp env p ++ ") { return " ++ emitExp env t ++ "; } else { return " ++ emitExp env e ++ "; }" 138 | emitIf _ _ = error "Invalid if statement." 139 | 140 | -- | Emit expression. 141 | -- 142 | -- >>> emitExp emptyEnv (Var "x") 143 | -- "_nbln_x" 144 | -- 145 | emitExp :: Env -> Exp -> JSProgram 146 | emitExp _ (Lit v) = emitValue v 147 | emitExp env (List v) = emitVector env v 148 | emitExp _ (Var s) = xformVar s 149 | -- emitExp env (NullaryFun expr) = emitNullaryFun env expr 150 | -- emitExp env (Fun var expr) = emitFun env var expr 151 | emitExp env (UnaryApp fun arg) = emitUnaryApp env fun arg 152 | emitExp env (NullaryApp fun) = emitNullaryApp env fun 153 | emitExp env (Let var val body) = emitLet env var val body 154 | emitExp env e@(If {}) = emitIf env e 155 | 156 | -- | The standard library program. 157 | -- 158 | standardLib :: JSProgram 159 | standardLib = M.foldlWithKey (\js fn body -> js ++ "\nvar " ++ fn ++ "=" ++ body) "" standardFuns ++ "\n\n" 160 | 161 | -- | Emit a JavaScript program. 162 | -- 163 | emit :: Exp -> JSProgram 164 | emit = emitExp emptyEnv 165 | 166 | -- | Compile a line of Neblen to JavaScript. 167 | -- 168 | -- >>> compileLine "(foo 1 (fn [x] x) [1 2] (list 4))" 169 | -- "_nbln_foo(1)((function (_nbln_x) { return _nbln_x; }))([1,2])([4])" 170 | -- 171 | compileLine :: NeblenProgram -> JSProgram 172 | compileLine p = case parseProgram p of 173 | Right expr -> emit expr 174 | Left err -> show err 175 | 176 | -- | Compile a Neblen program to JavaScript. Includes standard library. 177 | -- 178 | compile :: NeblenProgram -> JSProgram 179 | compile p = standardLib ++ compileLine p 180 | -------------------------------------------------------------------------------- /src/Neblen/Data.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Data where 2 | 3 | import qualified Data.Map.Strict as M 4 | import qualified Data.Set as S 5 | 6 | type NeblenProgram = String 7 | 8 | type JSProgram = String 9 | 10 | type Name = String 11 | 12 | data Value = IntV Int 13 | | BoolV Bool 14 | | StringV String 15 | deriving (Show, Eq) 16 | 17 | data Exp = Lit Value 18 | | List [Exp] 19 | | Var Name -- Var "x" 20 | | Fun [Exp] Exp -- Fun [Var "x"] Exp 21 | | NullaryApp Exp -- NullaryApp (Fun or Var) 22 | | UnaryApp Exp Exp -- UnaryApp (Fun or Var) (Argument value) 23 | | Let Exp Exp Exp -- Let (Var "x") (Value of x) Body 24 | | If Exp Exp Exp -- If (Predicate : Bool) (Then clause) (Else clause) 25 | | BinOp String Exp Exp -- Primitive function with 2 arguments 26 | | PrimitiveOp String [Exp] -- Primitive function with n arguments 27 | | Data Name [Exp] -- Data type value: Data "Just" [Lit (IntV 10)] 28 | | Unit -- A "void" return type (e.g. for @print@ function) 29 | deriving (Show, Eq) 30 | 31 | -- Type variable. 32 | type TName = String 33 | 34 | -- | Data type declaration. 35 | data DeclareType = DeclareType Name [TName] [DeclareCtor] Kind 36 | deriving (Show, Eq, Ord) 37 | 38 | -- | Data type constructor declaration (not evaluation). 39 | data DeclareCtor = DeclareCtor Name [Type] 40 | deriving (Show, Eq, Ord) 41 | 42 | -- | Kinds are the "type of types". They are either monotypes or function kinds. 43 | -- Kinds are used to check that a type is well-formed. 44 | -- 45 | -- Examples of monotypes: Int, [Int], Maybe a, EitherT e m a. 46 | -- Examples of function kinds: [], Maybe, EitherT. 47 | -- 48 | data Kind = Star 49 | | KFun Kind Kind 50 | -- | Unresolved kind with free variable counter. 51 | | KUnknown Int 52 | -- | Unresolved, waiting for free variable counter. 53 | | KUnknownInit 54 | deriving (Eq, Ord) 55 | 56 | data Type = TUnit 57 | | TInt 58 | | TBool 59 | | TString 60 | | TFun [Type] 61 | | TList Type 62 | | TVar TName 63 | | TData TName [Type] -- TData "Either" [Int, TVar "b"] 64 | 65 | -- Stuff with kinds: 66 | | TConst TName Kind -- e.g. TConst "Either" (* -> * -> *) 67 | | TVarK TName Kind -- A type var with a kind 68 | | TApp Type Type 69 | 70 | deriving (Eq, Ord) -- Ord for Set functions 71 | 72 | newtype FreshCounter = FreshCounter { getFreshCounter :: Int } 73 | 74 | initFreshCounter :: FreshCounter 75 | initFreshCounter = initFreshCounterAt 0 76 | 77 | initFreshCounterAt :: Int -> FreshCounter 78 | initFreshCounterAt i = FreshCounter { getFreshCounter = i } 79 | 80 | -- data Type = TVar TName 81 | -- | TConst TName 82 | -- | TApp Type2 Type 83 | -- deriving (Eq, Ord) -- Ord for Set functions 84 | 85 | -- | Symbols that can be part of symbol-only identifiers. 86 | validIdSymbols :: String 87 | validIdSymbols = "<>=%^*-+/" 88 | 89 | symbolToJsId :: M.Map Char String 90 | symbolToJsId = M.fromList [ 91 | ('<', "lt"), 92 | ('>', "gt"), 93 | ('=', "eq"), 94 | ('%', "percent"), 95 | ('^', "hat"), 96 | ('*', "mult"), 97 | ('-', "minus"), 98 | ('+', "plus"), 99 | ('/', "div")] 100 | 101 | reservedIds :: S.Set String 102 | reservedIds = S.fromList ["fn", "let"] 103 | 104 | standardFuns :: M.Map String JSProgram 105 | standardFuns = M.fromList [ 106 | -- first-or, rest, rest-or 107 | ("_nbln_firstminusor", "function(list) { return function(or) { if (list.length === 0) { return or; } else { return list[0]; }; }; };"), 108 | ("_nbln_rest", "function(list) { if (list.length === 0) { return []; } else { return list.slice(1,list.length); }; };"), 109 | ("_nbln_restminusor", "function(list) { return function(or) { if (list.length === 0) { return or; } else { return list.slice(1,list.length); }; }; };"), 110 | 111 | -- and, or, not, xor 112 | ("_nbln_and", "function(x) { return function(y) { return x && y; }; };"), 113 | ("_nbln_or", "function(x) { return function(y) { return x || y; }; };"), 114 | ("_nbln_not", "function(x) { return !x; };"), 115 | ("_nbln_xor", "function(x) { return function(y) { return (x && !y) || (y && !x); }; };"), 116 | 117 | -- + - * 118 | ("_nbln_plus", "function(x) { return function(y) { return x + y; }; };"), 119 | ("_nbln_minus", "function(x) { return function(y) { return x - y; }; };"), 120 | ("_nbln_mult", "function(x) { return function(y) { return x * y; }; };")] 121 | 122 | instance Show Type where 123 | show TUnit = "Unit" 124 | show TInt = "Int" 125 | show TBool = "Bool" 126 | show TString = "String" 127 | show (TFun ts) = "(-> " ++ unwords (map show ts) ++ ")" 128 | show (TList a) = "[" ++ show a ++ "]" 129 | show (TVar n) = n 130 | show (TData name types) = "(" ++ name ++ " " ++ unwords (map show types) ++ ")" 131 | show (TConst n _) = n 132 | -- show (TVarK n _) = n 133 | show (TVarK n k) = n ++ " : " ++ show k 134 | show (TApp t1 t2) = "(" ++ show t1 ++ " " ++ show t2 ++ ")" 135 | 136 | instance Show Kind where 137 | show Star = "*" 138 | show (KFun k1 k2) = "(" ++ show k1 ++ " -> " ++ show k2 ++ ")" 139 | show (KUnknown i) = "k" ++ show i 140 | show KUnknownInit = "k?" 141 | 142 | 143 | showKind :: Type -> String 144 | showKind (TFun ts) = "(-> " ++ unwords (map showKind ts) ++ ")" 145 | showKind (TList a) = "[" ++ showKind a ++ "]" 146 | showKind (TConst n k) = n ++ " : " ++ show k 147 | showKind (TVarK n k) = n ++ " : " ++ show k 148 | showKind (TApp t1 t2) = "(" ++ showKind t1 ++ " " ++ showKind t2 ++ ")" 149 | showKind t = show t ++ " : " ++ show Star 150 | -------------------------------------------------------------------------------- /src/Neblen/DataTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Neblen.DataTypes where 5 | 6 | import Neblen.Data 7 | import qualified Data.Map.Strict as M 8 | import Data.Maybe (fromMaybe) 9 | import Control.Monad.Trans.State 10 | import Control.Monad (liftM) 11 | 12 | -- = Data types and kind evaluator 13 | -- 14 | -- TODO explain how kind-finding works! 15 | -- 16 | -- Neblen supports data types similar to Haskell. 17 | -- 18 | 19 | -- | Data type declarations. Separated out from regular expressions. 20 | -- 21 | -- data Declare = DeclareType Name [TName] [Declare] Kind 22 | -- | DeclareCtor Name [Type] 23 | -- deriving (Show, Eq, Ord) 24 | 25 | -- | Mapping of type variable (from TVarK) to kind. 26 | type KEnv = M.Map TName Kind 27 | 28 | -- | Mapping of unknown kind variables to kinds. 29 | type KSubst = M.Map Int Kind 30 | 31 | -- | Mapping of data type constant to kind. (e.g. Either : * -> * -> *) 32 | type KConstEnv = M.Map TName Kind 33 | 34 | -- | The KindCheck context gives a fresh variable generator for the computation 35 | -- of @a@. 36 | type KindCheck a = State FreshCounter a 37 | 38 | -- | Evaluate a type declaration. Returns a new data type environment, and the 39 | -- current data type with its kinds filled out. 40 | -- 41 | -- = Examples: 42 | -- 43 | -- Person, a simple data type: 44 | -- 45 | -- data Person = Person String Int 46 | -- (data-type Person (Person String Int)) 47 | -- 48 | -- >>> evalState (evalDataTypeKind M.empty M.empty (DeclareType "Person" [] [DeclareCtor "Person" [TString,TInt]] (KUnknown 0))) (initFreshCounterAt 10) 49 | -- (fromList [],DeclareType "Person" [] [DeclareCtor "Person" [String,Int]] *) 50 | -- 51 | -- Maybe: 52 | -- 53 | -- data Maybe a = Nothing | Just a 54 | -- (data-type Maybe (a) Nothing (Just a)) 55 | -- 56 | -- >>> evalState (evalDataTypeKind M.empty M.empty (DeclareType "Maybe" ["a"] [DeclareCtor "Nothing" [], DeclareCtor "Just" [TVarK "a" (KUnknown 0)]] (KUnknown 1))) (initFreshCounterAt 10) 57 | -- (fromList [("a",*)],DeclareType "Maybe" ["a"] [DeclareCtor "Nothing" [],DeclareCtor "Just" [a : k0]] (* -> *)) 58 | -- 59 | -- Either: 60 | -- 61 | -- data Either a b = Left a | Right b 62 | -- (data-type Either (a b) (Left a) (Right b)) 63 | -- 64 | -- >>> evalState (evalDataTypeKind M.empty M.empty (DeclareType "Either" ["a", "b"] [DeclareCtor "Left" [TVarK "a" (KUnknown 0)], DeclareCtor "Just" [TVarK "b" (KUnknown 1)]] (KUnknown 2))) (initFreshCounterAt 10) 65 | -- (fromList [("a",*),("b",*)],DeclareType "Either" ["a","b"] [DeclareCtor "Left" [a : k0],DeclareCtor "Just" [b : k1]] (* -> (* -> *))) 66 | -- 67 | -- ExceptT: 68 | -- 69 | -- >>> :{ 70 | -- evalState 71 | -- (evalDataTypeKind (M.fromList [("Either",KFun Star (KFun Star Star))]) M.empty 72 | -- (DeclareType "ExceptT" ["e","m","a"] [ 73 | -- DeclareCtor "ExceptT" [ 74 | -- TApp (TVarK "m" (KUnknown 0)) 75 | -- (TApp (TApp (TConst "Either" (KUnknown 1)) (TVarK "e" (KUnknown 2))) 76 | -- (TVarK "a" (KUnknown 3)))]] 77 | -- (KUnknown 4))) 78 | -- (initFreshCounterAt 10) 79 | -- :} 80 | -- (fromList [("a",*),("e",*),("m",(* -> *))],DeclareType "ExceptT" ["e","m","a"] [DeclareCtor "ExceptT" [(m : k0 ((Either e : k2) a : k3))]] (* -> ((* -> *) -> (* -> *)))) 81 | -- 82 | -- Tree: 83 | -- 84 | -- data Tree a = Leaf a | Branch (Tree a) (Tree a) 85 | -- (data-type Tree (a) (Leaf a) (Branch (Tree a) (Tree a))) 86 | -- 87 | -- >>> :{ 88 | -- evalState 89 | -- (evalDataTypeKind M.empty M.empty 90 | -- (DeclareType "Tree" ["a"] [ 91 | -- DeclareCtor "Leaf" [TVarK "a" (KUnknown 0)], 92 | -- DeclareCtor "Branch" [ 93 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0)), 94 | -- TApp (TConst "Tree" (KUnknown 1)) (TVarK "a" (KUnknown 0))]] 95 | -- (KUnknown 1))) 96 | -- (initFreshCounterAt 10) 97 | -- :} 98 | -- (fromList [("a",*)],DeclareType "Tree" ["a"] [DeclareCtor "Leaf" [a : k0],DeclareCtor "Branch" [(Tree a : k0),(Tree a : k0)]] (* -> *)) 99 | -- 100 | -- Complex type: 101 | -- 102 | -- data Dallas a b c d e = Dallas (a (b c) d e) 103 | -- 104 | -- >>> :{ 105 | -- evalState 106 | -- (evalDataTypeKind M.empty M.empty 107 | -- (DeclareType "Complex" ["a","b","c","d"] 108 | -- [DeclareCtor "Complex" 109 | -- [TApp (TApp (TApp (TVarK "a" (KUnknown 0)) 110 | -- (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) 111 | -- (TVarK "d" (KUnknown 3))) 112 | -- (TVarK "e" (KUnknown 4))]] 113 | -- (KUnknown 5))) 114 | -- (initFreshCounterAt 10) 115 | -- :} 116 | -- (fromList [("a",(* -> (* -> (* -> *)))),("b",(* -> *)),("c",*),("d",*),("e",*)],DeclareType "Complex" ["a","b","c","d"] [DeclareCtor "Complex" [(((a : k0 (b : k1 c : k2)) d : k3) e : k4)]] ((* -> (* -> (* -> *))) -> ((* -> *) -> (* -> (* -> *))))) 117 | -- 118 | evalDataTypeKind :: 119 | KConstEnv 120 | -- ^ Mapping of data types to its kind 121 | -> KEnv 122 | -- ^ Do we need this? Mapping of type var to kind 123 | -> DeclareType 124 | -- ^ The data type we're trying to find the kind of 125 | -> KindCheck (KEnv, DeclareType) 126 | -- ^ Returns the new KEnv and DeclareType, with its kinds filled in 127 | evalDataTypeKind cenv kenv (DeclareType name tvs ctors k) = do 128 | -- Add current data type (whose kind is unknown) into const env to handle 129 | -- recursive data types. 130 | let cenv2 = M.insert name k cenv 131 | -- Evaluate each constructor's kind, building up the substitution map. 132 | (kenv2, ksub2) <- foldl (\kindCheck ctor -> do 133 | (kenv', ksub') <- kindCheck 134 | (kenv'', ksub'') <- evalCtorKind cenv2 kenv' ksub' ctor 135 | -- Compose the new substitution with the old one 136 | return (kenv'', ksub'' `composeKSubst` ksub')) 137 | (return (kenv, M.empty)) ctors 138 | -- Substitute all type variables with the final substitution mapping. Then, 139 | -- replace all unknown kinds with Star, since at this point there are no more 140 | -- substitutions to be made. 141 | let kenv3 = replaceWithStars (kapply ksub2 kenv2) 142 | -- Find the final kind of the data type, given the data type's type variables, 143 | -- and the finalized kind environment. 144 | let dataTypeKind = findFinalKind kenv3 tvs 145 | return (kenv3, DeclareType name tvs ctors dataTypeKind) 146 | 147 | -- | Given a kind mapping, convert a list of type variables to a kind function 148 | -- that takes each type variable in order. 149 | -- 150 | -- >>> findFinalKind (M.fromList [("a",Star),("b",KFun Star Star)]) ["a","b"] 151 | -- (* -> ((* -> *) -> *)) 152 | -- 153 | findFinalKind :: KEnv -> [TName] -> Kind 154 | findFinalKind _ [] = Star 155 | findFinalKind kenv (tv:tvs) = 156 | case M.lookup tv kenv of 157 | Just k -> KFun k (findFinalKind kenv tvs) 158 | Nothing -> error $ "could not find " ++ show tv 159 | 160 | -- | Replace all unknown kinds with Star. 161 | replaceWithStars :: M.Map k Kind -> M.Map k Kind 162 | replaceWithStars = M.map replaceKindWithStars 163 | 164 | -- | Replace all unknown kinds with Star. 165 | replaceKindWithStars :: Kind -> Kind 166 | replaceKindWithStars (KFun k1 k2) = KFun (replaceKindWithStars k1) (replaceKindWithStars k2) 167 | replaceKindWithStars _ = Star 168 | 169 | -- | Evaluate the kind of a data constructor. 170 | -- 171 | -- >>> evalState (evalCtorKind M.empty M.empty M.empty (DeclareCtor "Just" [TVarK "a" (KUnknown 0)])) (initFreshCounterAt 1) 172 | -- (fromList [("a",k0)],fromList []) 173 | -- 174 | -- >>> evalState (evalCtorKind M.empty M.empty M.empty (DeclareCtor "Foo" [TApp (TVarK "a" (KUnknown 0)) (TVarK "b" (KUnknown 1)), TVarK "a" (KUnknown 0)])) (initFreshCounterAt 10) 175 | -- (fromList [("a",(k1 -> k10)),("b",k1)],fromList [(0,(k1 -> k10))]) 176 | -- 177 | evalCtorKind :: KConstEnv -> KEnv -> KSubst -> DeclareCtor -> KindCheck (KEnv, KSubst) 178 | evalCtorKind cenv kenv ksub (DeclareCtor _ types) = do 179 | (kenv2, ksub2) <- foldl (\kindCheck t -> do 180 | (kenv', ksub') <- kindCheck 181 | (kenv'', ksub'', _) <- evalKindOfType cenv kenv' ksub' t 182 | return (kenv'', ksub'' `composeKSubst` ksub')) 183 | (return (kenv, ksub)) types 184 | return (kapply ksub2 kenv2, ksub2) 185 | 186 | -- | Evaluate kind of type. 187 | -- 188 | -- >>> evalState (evalKindOfType M.empty M.empty M.empty (TVarK "a" (KUnknown 0))) (initFreshCounterAt 10) 189 | -- (fromList [("a",k0)],fromList [],k0) 190 | -- 191 | -- >>> evalState (evalKindOfType (M.fromList [("Foo", KUnknown 0)]) M.empty M.empty (TConst "Foo" (KUnknown 0))) (initFreshCounterAt 10) 192 | -- (fromList [],fromList [],k0) 193 | -- 194 | -- For below, we have: 195 | -- 196 | -- KEnv: 197 | -- a : 0 198 | -- b : 1 199 | -- 200 | -- KSubst: 201 | -- empty 202 | -- 203 | -- Expected result: 204 | -- 205 | -- KEnv: 206 | -- a : 1 -> 10 207 | -- b : 1 208 | -- 209 | -- KSubst: 210 | -- 0 : 1 -> 10 211 | -- 212 | -- >>> evalState (evalKindOfType M.empty (M.fromList [("a",KUnknown 0), ("b",KUnknown 1)]) M.empty (TApp (TVarK "a" (KUnknown 0)) (TVarK "b" (KUnknown 1)))) (initFreshCounterAt 10) 213 | -- (fromList [("a",(k1 -> k10)),("b",k1)],fromList [(0,(k1 -> k10))],k10) 214 | -- 215 | -- For below, we have: 216 | -- 217 | -- KEnv: 218 | -- a : 0 219 | -- b : 1 220 | -- c : 2 221 | -- d : 3 222 | -- 223 | -- KSubst: 224 | -- empty 225 | -- 226 | -- Expected results: 227 | -- 228 | -- KEnv: 229 | -- a : 10 -> (3 -> 12) 230 | -- b : 2 -> 10 231 | -- c : 2 232 | -- d : 3 233 | -- 234 | -- KSubst: 235 | -- 0 : 10 -> (3 -> 12) 236 | -- 1 : 2 -> 10 237 | -- 11: 3 -> 12 238 | -- 239 | -- >>> evalState (evalKindOfType M.empty (M.fromList [("a",KUnknown 0), ("b",KUnknown 1), ("c",KUnknown 2), ("d",KUnknown 3)]) M.empty (TApp (TApp (TVarK "a" (KUnknown 0)) (TApp (TVarK "b" (KUnknown 1)) (TVarK "c" (KUnknown 2)))) (TVarK "d" (KUnknown 3)))) (initFreshCounterAt 10) 240 | -- (fromList [("a",(k10 -> (k3 -> k12))),("b",(k2 -> k10)),("c",k2),("d",k3)],fromList [(0,(k10 -> (k3 -> k12))),(1,(k2 -> k10)),(11,(k3 -> k12))],k12) 241 | -- 242 | evalKindOfType :: KConstEnv -> KEnv -> KSubst -> Type -> KindCheck (KEnv, KSubst, Kind) 243 | evalKindOfType _ kenv ksub (TVarK tv (KUnknown kv)) = return (M.insert tv (KUnknown kv) kenv, ksub, KUnknown kv) 244 | evalKindOfType cenv kenv ksub (TConst name k) = 245 | if M.member name cenv 246 | then return (kenv, ksub, k) 247 | else error ("Unknown TConst: " ++ show (TConst name k)) 248 | evalKindOfType cenv kenv ksub (TApp t1 t2) = do 249 | -- Find kind and environment of LHS and RHS 250 | (kenv1, ksub1, k1) <- evalKindOfType cenv kenv ksub t1 251 | (kenv2, ksub2, k2) <- evalKindOfType cenv kenv1 (ksub1 `composeKSubst` ksub) t2 252 | -- Get a fresh kind variable; lifts `KUnknown` function into the State monad 253 | -- with the fresh integer. 254 | kv <- liftM KUnknown nextFreshCounter 255 | -- Compose all kind variable (integer) substitutions together 256 | let ksub3 = M.singleton (getKindVar k1) (KFun k2 kv) `composeKSubst` ksub2 `composeKSubst` ksub1 257 | return (kapply ksub3 kenv2, ksub3 `composeKSubst` ksub3, kv) 258 | evalKindOfType _ kenv ksub TInt = return (kenv, ksub, Star) 259 | evalKindOfType _ kenv ksub TBool = return (kenv, ksub, Star) 260 | evalKindOfType _ kenv ksub TString = return (kenv, ksub, Star) 261 | evalKindOfType _ _ _ t = error $ "Unsupported type: " ++ show t 262 | 263 | getKindVar :: Kind -> Int 264 | getKindVar (KUnknown i) = i 265 | getKindVar _ = error "Should not be called on known kind." 266 | 267 | nextFreshCounter :: KindCheck Int 268 | nextFreshCounter = do 269 | s <- get -- Same as: ExceptT (liftM Right get) 270 | put s{getFreshCounter = getFreshCounter s + 1} 271 | return $ getFreshCounter s 272 | 273 | -- Given a data type declaration, return a monad in which the KUnknowns are replaced. 274 | replaceKUnknownInitsDeclareType :: DeclareType -> KindCheck DeclareType 275 | replaceKUnknownInitsDeclareType (DeclareType name tvs ctors k) = do 276 | ctors' <- mapM replaceKUnknownsInDeclareCtorWith ctors 277 | k' <- replaceKUnknownInit k 278 | return (DeclareType name tvs ctors' k') 279 | 280 | replaceKUnknownsInDeclareCtorWith :: DeclareCtor -> KindCheck DeclareCtor 281 | replaceKUnknownsInDeclareCtorWith (DeclareCtor name types) = do 282 | filledTypes <- mapM replaceKUnknownTVarK types 283 | return (DeclareCtor name filledTypes) 284 | 285 | replaceKUnknownTVarK :: Type -> KindCheck Type 286 | replaceKUnknownTVarK (TVarK name k) = do 287 | k' <- replaceKUnknownInit k 288 | return $ TVarK name k' 289 | replaceKUnknownTVarK tvark = return tvark 290 | 291 | replaceKUnknownInit :: Kind -> KindCheck Kind 292 | replaceKUnknownInit KUnknownInit = liftM KUnknown nextFreshCounter 293 | replaceKUnknownInit k = return k 294 | 295 | -- TODO can eventually combine as `Substitutable a t`? 296 | class KSubstitutable k where 297 | kapply :: KSubst -> k -> k 298 | 299 | instance KSubstitutable Kind where 300 | kapply _ Star = Star 301 | kapply ksub (KFun k1 k2) = KFun (kapply ksub k1) (kapply ksub k2) 302 | kapply ksub (KUnknown i) = fromMaybe (KUnknown i) (M.lookup i ksub) 303 | kapply _ KUnknownInit = KUnknownInit 304 | 305 | instance KSubstitutable KEnv where 306 | kapply ksub = M.map (kapply ksub) 307 | 308 | instance KSubstitutable DeclareType where 309 | -- Replace unknown kinds with the given substitutions 310 | kapply ksub (DeclareType name tvs ctors kind) = 311 | DeclareType 312 | name tvs 313 | (map (kapply ksub) ctors) 314 | (kapply ksub kind) 315 | 316 | instance KSubstitutable DeclareCtor where 317 | kapply ksub (DeclareCtor name types) = DeclareCtor name (map (kapply ksub) types) 318 | 319 | instance KSubstitutable Type where 320 | kapply ksub (TConst name kind) = TConst name (kapply ksub kind) 321 | kapply ksub (TVarK name kind) = TVarK name (kapply ksub kind) 322 | kapply ksub (TApp t1 t2) = TApp (kapply ksub t1) (kapply ksub t2) 323 | kapply _ t = t 324 | 325 | -- | Compose KSubst, applying @ksub1@'s substitutions over values of @ksub2@. 326 | -- 327 | composeKSubst :: KSubst -> KSubst -> KSubst 328 | composeKSubst ksub1 ksub2 = M.union (M.map (kapply ksub1) ksub2) ksub1 329 | -------------------------------------------------------------------------------- /src/Neblen/Eval.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Eval where 2 | 3 | import Neblen.Data 4 | import Neblen.Utils 5 | import Neblen.TypeChecker 6 | import Neblen.Parser 7 | 8 | import qualified Data.Map.Strict as M 9 | import Control.Monad 10 | import Data.Maybe (fromMaybe) 11 | 12 | import Debug.Trace 13 | 14 | type EvalEnv = M.Map Name Exp 15 | 16 | type Answer = (Exp, Type) 17 | 18 | data EvalError = UnboundedVariable Name 19 | | GenericError String 20 | 21 | -- | Evaluates Neblen program. 22 | parseAndEval :: NeblenProgram -> Either String Answer 23 | parseAndEval p = 24 | case parseProgram p of 25 | Left err -> Left $ show err 26 | Right expr -> 27 | case eval expr of 28 | Left err -> Left $ show err 29 | Right answer -> Right answer 30 | 31 | -- | Substitute variables in expression, but don't apply. This is for @Fun@, 32 | -- since we don't want to apply the body. See usage. 33 | -- 34 | subst :: EvalEnv -> Exp -> Exp 35 | subst env expr = case expr of 36 | Lit {} -> expr 37 | List es -> List (map (subst env) es) 38 | Var n -> fromMaybe (Var n) (M.lookup n env) 39 | Fun vs body -> Fun vs (subst env body) 40 | UnaryApp f e -> UnaryApp (subst env f) (subst env e) 41 | BinOp f a b -> BinOp f (subst env a) (subst env b) 42 | e -> e 43 | 44 | defaultEnv :: M.Map Name Exp 45 | defaultEnv = M.fromList [ 46 | ("+", Fun [Var "a",Var "b"] (BinOp "+" (Var "a") (Var "b"))) 47 | ,("-", Fun [Var "a",Var "b"] (BinOp "-" (Var "a") (Var "b"))) 48 | ,("*", Fun [Var "a",Var "b"] (BinOp "*" (Var "a") (Var "b"))) 49 | 50 | ,("and", Fun [Var "a",Var "b"] (BinOp "and" (Var "a") (Var "b"))) 51 | ,("or", Fun [Var "a",Var "b"] (BinOp "or" (Var "a") (Var "b"))) 52 | ,("xor", Fun [Var "a",Var "b"] (BinOp "xor" (Var "a") (Var "b"))) 53 | 54 | ,("print", Fun [Var "a"] (PrimitiveOp "print" [Var "a"])) 55 | ] 56 | 57 | -- | Evaluates expression. 58 | -- 59 | eval :: Exp -> Either TypeError Answer 60 | eval expr = 61 | liftM (\t -> (eval' defaultEnv expr, t)) (runWithFreshCounter (checkType expr)) 62 | 63 | eval' :: EvalEnv -> Exp -> Exp 64 | eval' env expr = case expr of 65 | 66 | Lit{} -> expr 67 | 68 | Var n -> fromMaybe (neblenError expr) (M.lookup n env) 69 | 70 | List es -> List (map (eval' env) es) 71 | 72 | Fun vs e -> Fun vs (subst env e) 73 | 74 | Data name vals -> Data name (map (eval' env) vals) 75 | 76 | -- NullaryApp should only be called on nullary functions. 77 | NullaryApp (Fun [] body) -> eval' env body 78 | NullaryApp (Var v) -> 79 | let fn = eval' env (Var v) 80 | in eval' env (NullaryApp fn) 81 | NullaryApp _ -> neblenError expr 82 | 83 | -- Two cases for function application: 84 | -- 85 | -- - If `f` is a function, apply the expression into the function. 86 | -- - Otherwise, re-try the application after eval-ing `f`. 87 | -- 88 | UnaryApp f e -> do 89 | let e' = eval' env e 90 | case f of 91 | -- Only one arg left, so do the apply. 92 | Fun [Var n] fn -> do 93 | let env' = M.insert n e' env 94 | eval' env' fn 95 | 96 | -- Curry; apply only one level. 97 | Fun (Var n:vs) fn -> do 98 | let env' = M.insert n e' env 99 | eval' env' (Fun vs fn) 100 | 101 | other -> do 102 | let f' = eval' env other 103 | eval' env (UnaryApp f' e) 104 | 105 | Let (Var n) val body -> do 106 | let val' = eval' env val 107 | let env' = M.insert n val' env 108 | eval' env' body 109 | Let{} -> neblenError expr 110 | 111 | If p t e -> do 112 | let p' = eval' env p 113 | case p' of 114 | Lit (BoolV True) -> eval' env t 115 | Lit (BoolV False) -> eval' env e 116 | _ -> neblenError expr 117 | 118 | PrimitiveOp fn args -> 119 | case fn of 120 | -- TODO: how to tell interpreter to print to the screen without using 121 | -- Debug.Trace? Would need to bring in a heavy-lifting State typeclass 122 | -- with a list of things to print to the screen as part of the return 123 | -- value? 124 | -- 125 | -- TODO: 'print' should only take string, so we need to type-check that. 126 | "print" -> do 127 | let a = head args 128 | let x = eval' env a 129 | trace (show x) Unit 130 | 131 | BinOp fn a b -> case fn of 132 | "+" -> Lit (IntV (extractInt (eval' env a) + extractInt (eval' env b))) 133 | "-" -> Lit (IntV (extractInt (eval' env a) - extractInt (eval' env b))) 134 | "*" -> Lit (IntV (extractInt (eval' env a) * extractInt (eval' env b))) 135 | 136 | "and" -> Lit (BoolV (extractBool (eval' env a) && extractBool (eval' env b))) 137 | "or" -> Lit (BoolV (extractBool (eval' env a) || extractBool (eval' env b))) 138 | "xor" -> 139 | let a' = extractBool (eval' env a) 140 | b' = extractBool (eval' env b) 141 | c = (a' && not b') || (not a' && b') 142 | in Lit (BoolV c) 143 | _ -> error "Invalid BinOp." 144 | 145 | extractInt :: Exp -> Int 146 | extractInt (Lit (IntV v)) = v 147 | extractInt _ = error "not an int" 148 | 149 | extractBool :: Exp -> Bool 150 | extractBool (Lit (BoolV v)) = v 151 | extractBool _ = error "not a bool" 152 | 153 | extractString :: Exp -> String 154 | extractString (Lit (StringV v)) = v 155 | extractString _ = error "not a string" 156 | 157 | neblenError :: Exp -> t 158 | neblenError expr = error ("Neblen bug: " ++ toLisp expr ++ " should have been caught by type checker.") 159 | -------------------------------------------------------------------------------- /src/Neblen/Parser.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Parser where 2 | 3 | import Neblen.Data 4 | import Text.ParserCombinators.Parsec 5 | import qualified Control.Applicative as A 6 | import qualified Data.Set as S 7 | import Control.Monad 8 | 9 | -- $setup 10 | -- >>> import Data.Either 11 | 12 | -- | Skip one or more spaces. 13 | skipSpaces1 :: Parser () 14 | skipSpaces1 = skipMany1 space 15 | 16 | -- | Parse string. 17 | -- 18 | -- >>> parse parseString "" "\"Hello\"" 19 | -- Right (Lit (StringV "Hello")) 20 | -- 21 | -- >>> parse parseString "" "\"\"" 22 | -- Right (Lit (StringV "")) 23 | -- 24 | -- >>> isLeft $ parse parseString "" "Hello" 25 | -- True 26 | -- 27 | -- >>> isLeft $ parse parseString "" "\"Hello" 28 | -- True 29 | -- 30 | parseString :: Parser Exp 31 | parseString = do 32 | s <- between (char '"') (char '"') (many (noneOf "\"")) 33 | return $ Lit (StringV s) 34 | 35 | -- | Parse Boolean. 36 | -- 37 | -- >>> parse parseBool "" "true" 38 | -- Right (Lit (BoolV True)) 39 | -- 40 | -- >>> parse parseBool "" "false" 41 | -- Right (Lit (BoolV False)) 42 | -- 43 | -- >>> isLeft $ parse parseBool "" "\"true\"" 44 | -- True 45 | -- 46 | parseBool :: Parser Exp 47 | parseBool = do 48 | -- 'string' consumes input, so use 'try' so that no input is consumed if the 49 | -- literal is not true or false. This way, variables that are prefixed with 50 | -- any prefix of "true" or "false" can be parsed (e.g. 'fx' or 'true-thing'). 51 | s <- try (string "true") <|> try (string "false") 52 | return $ Lit (BoolV (s == "true")) 53 | 54 | -- | Parse Integers. 55 | -- 56 | -- >>> parse parseInt "" "0" 57 | -- Right (Lit (IntV 0)) 58 | -- 59 | -- >>> parse parseInt "" "123" 60 | -- Right (Lit (IntV 123)) 61 | -- 62 | -- >>> parse parseInt "" "123.456" 63 | -- Right (Lit (IntV 123)) 64 | -- 65 | -- >>> isLeft $ parse parseInt "" ".456" 66 | -- True 67 | -- 68 | parseInt :: Parser Exp 69 | parseInt = do 70 | s <- many1 digit 71 | return $ Lit (IntV (read s :: Int)) 72 | 73 | -- | Parse variable identifier. Identifiers must be prefixed with either a 74 | -- letter, dash (-) or underscore (_). Or a reserved symbol identifier. 75 | -- 76 | -- >>> parse parseVar "" "x" 77 | -- Right (Var "x") 78 | -- 79 | -- >>> parse parseVar "" "abc-def" 80 | -- Right (Var "abc-def") 81 | -- 82 | -- >>> parse parseVar "" ">>=" 83 | -- Right (Var ">>=") 84 | -- 85 | -- >>> parse parseVar "" "-" 86 | -- Right (Var "-") 87 | -- 88 | -- >>> isLeft $ parse parseVar "" "_" 89 | -- True 90 | -- 91 | -- >>> isLeft $ parse parseVar "" "fn" 92 | -- True 93 | -- 94 | parseVar :: Parser Exp 95 | parseVar = do 96 | i <- try parseAlphaNumericId <|> parseSymbolId 97 | if S.member i reservedIds 98 | then unexpected $ "reserved identifier '" ++ i ++ "'" 99 | else return $ Var i 100 | 101 | -- | Parse an alpha-numeric identifier. 102 | -- 103 | -- >>> parse parseAlphaNumericId "" "abc" 104 | -- Right "abc" 105 | -- 106 | -- >>> parse parseAlphaNumericId "" "_abc" 107 | -- Right "_abc" 108 | -- 109 | -- >>> parse parseAlphaNumericId "" "-abc_def-123-" 110 | -- Right "-abc_def-123-" 111 | -- 112 | -- >>> isLeft $ parse parseAlphaNumericId "" "-" 113 | -- True 114 | -- 115 | -- >>> isLeft $ parse parseAlphaNumericId "" "-123" 116 | -- True 117 | -- 118 | -- >>> isLeft $ parse parseAlphaNumericId "" "_" 119 | -- True 120 | -- 121 | -- >>> isLeft $ parse parseAlphaNumericId "" "123abc" 122 | -- True 123 | -- 124 | parseAlphaNumericId :: Parser String 125 | parseAlphaNumericId = do 126 | -- Get first character. 127 | p <- letter <|> char '-' <|> char '_' 128 | 129 | -- If first character was a - or _, then needs to be followed one letter, then 130 | -- zero or more alphanumerics (e.g. -123 is invalid, but -abc is valid). 131 | -- 132 | -- Else, it can be followed by zero or more alphanumerics. 133 | -- 134 | -- TODO: How to simplify this? 135 | if p == '-' || p == '_' 136 | then (do 137 | p' <- letter 138 | rest <- restOfAlphaNumericId 139 | return (p : p' : rest)) 140 | else (do 141 | rest <- restOfAlphaNumericId 142 | return (p : rest)) 143 | 144 | restOfAlphaNumericId :: Parser String 145 | restOfAlphaNumericId = many (alphaNum <|> char '-' <|> char '_') "Non-symbolic identifier must consist of alphanumeric characters, dashes and underscores." 146 | 147 | -- | Parse a symbol-only identifier. 148 | -- 149 | -- >>> parse parseSymbolId "" ">= abc" 150 | -- Right ">=" 151 | -- 152 | -- >>> parse parseSymbolId "" "+" 153 | -- Right "+" 154 | -- 155 | -- >>> parse parseSymbolId "" "+++++" 156 | -- Right "+++++" 157 | -- 158 | -- Bind operator. 159 | -- >>> parse parseSymbolId "" ">>=" 160 | -- Right ">>=" 161 | -- 162 | -- >>> parse parseSymbolId "" "+3" 163 | -- Right "+" 164 | -- 165 | -- >>> isLeft $ parse parseSymbolId "" "!!!" 166 | -- True 167 | -- 168 | parseSymbolId :: Parser String 169 | parseSymbolId = many1 symbolIds -- ID must be one or more symbols 170 | 171 | -- | Symbols that can be part of symbol-only identifiers. 172 | symbolIds :: Parser Char 173 | symbolIds = oneOf validIdSymbols 174 | 175 | -- | Parse lists. S-expressions! 176 | -- 177 | -- >>> parse parseList "" "()" 178 | -- Right (List []) 179 | -- 180 | -- >>> parse parseList "" "(list xyz-abc \"abc\" 123)" 181 | -- Right (List [Var "xyz-abc",Lit (StringV "abc"),Lit (IntV 123)]) 182 | -- 183 | -- >>> parse parseList "" "(list xyz-abc (list 0 \"foo\" true))" 184 | -- Right (List [Var "xyz-abc",List [Lit (IntV 0),Lit (StringV "foo"),Lit (BoolV True)]]) 185 | -- 186 | -- >>> parse parseList "" "(list (list 0 \"foo\" true))" 187 | -- Right (List [List [Lit (IntV 0),Lit (StringV "foo"),Lit (BoolV True)]]) 188 | -- 189 | -- >>> isLeft $ parse parseList "" "(def x 123)" 190 | -- True 191 | -- 192 | -- >>> isLeft $ parse parseList "" "(x 123 y)" 193 | -- True 194 | -- 195 | -- >>> isLeft $ parse parseList "" "(fn [x] (+ x 123))" 196 | -- True 197 | -- 198 | -- >>> isLeft $ parse parseList "" "(123 456" 199 | -- True 200 | -- 201 | parseList :: Parser Exp 202 | parseList = parseEmptyList <|> parseList' 203 | 204 | -- | Parse empty list '()'. 205 | -- 206 | -- >>> parse parseEmptyList "" "()" 207 | -- Right (List []) 208 | -- 209 | -- >>> isLeft $ parse parseEmptyList "" "(123)" 210 | -- True 211 | -- 212 | parseEmptyList :: Parser Exp 213 | parseEmptyList = try (string "()") A.*> A.pure (List []) 214 | 215 | -- | Parse list with 'list' keyword. 216 | -- 217 | -- >>> parse parseList' "" "(list)" 218 | -- Right (List []) 219 | -- 220 | -- >>> parse parseList' "" "(list 1 abc-xyz \"abc\")" 221 | -- Right (List [Lit (IntV 1),Var "abc-xyz",Lit (StringV "abc")]) 222 | -- 223 | parseList' :: Parser Exp 224 | parseList' = try (string "(list)") A.*> A.pure (List []) <|> try (parseListWithSurroundingPrefix (Just (string "list")) '(' ')' parseExps List) 225 | 226 | -- | Parse vectors (which are just lists with different syntax, for now). 227 | -- 228 | -- >>> parse parseVector "" "[]" 229 | -- Right (List []) 230 | -- 231 | -- >>> parse parseVector "" "[xyz-abc [0 \"foo\" true]]" 232 | -- Right (List [Var "xyz-abc",List [Lit (IntV 0),Lit (StringV "foo"),Lit (BoolV True)]]) 233 | -- 234 | parseVector :: Parser Exp 235 | parseVector = parseListWithSurrounding '[' ']' parseExps List 236 | 237 | -- | Parse many @p@s, separated by at least one space. 238 | parseMany :: Parser a -> Parser [a] 239 | parseMany p = sepBy p skipSpaces1 240 | 241 | parseExps :: Parser [Exp] 242 | parseExps = parseMany parseExp 243 | 244 | parseListWithSurroundingPrefix :: 245 | Maybe (Parser String) 246 | -- ^ Optional prefix parser 247 | -> Char -> Char 248 | -- ^ Start and begin char 249 | -> Parser [a] 250 | -- Parse multiple of these things 251 | -> ([a] -> a) 252 | -- Convert multiple things into one 253 | -> Parser a 254 | parseListWithSurroundingPrefix mp l r ps f = do 255 | _ <- char l 256 | case mp of 257 | Just s -> s A.*> skipSpaces1 258 | _ -> spaces 259 | 260 | -- Must be separated by at least one space 261 | exps <- ps 262 | 263 | _ <- char r 264 | return $ f exps 265 | 266 | parseListWithSurrounding :: Char -> Char -> Parser [a] -> ([a] -> a) -> Parser a 267 | parseListWithSurrounding = parseListWithSurroundingPrefix Nothing 268 | 269 | -- | Parse unary function calls. 270 | -- 271 | -- >>> parse parseUnaryApp "" "(x 123)" 272 | -- Right (UnaryApp (Var "x") (Lit (IntV 123))) 273 | -- 274 | -- Curry (x 1 2) as ((x 1) 2): 275 | -- 276 | -- >>> parse parseUnaryApp "" "(x 1 2)" 277 | -- Right (UnaryApp (UnaryApp (Var "x") (Lit (IntV 1))) (Lit (IntV 2))) 278 | -- 279 | -- >>> parse parseUnaryApp "" "(x 1 2 3)" 280 | -- Right (UnaryApp (UnaryApp (UnaryApp (Var "x") (Lit (IntV 1))) (Lit (IntV 2))) (Lit (IntV 3))) 281 | -- 282 | -- >>> parse parseUnaryApp "" "((fn [x y z] (+ x y)) 1 2 3)" 283 | -- Right (UnaryApp (UnaryApp (UnaryApp (Fun [Var "x",Var "y",Var "z"] (UnaryApp (UnaryApp (Var "+") (Var "x")) (Var "y"))) (Lit (IntV 1))) (Lit (IntV 2))) (Lit (IntV 3))) 284 | -- 285 | parseUnaryApp :: Parser Exp 286 | parseUnaryApp = try $ do 287 | _ <- char '(' 288 | varOrFn <- parseExp 289 | skipSpaces1 290 | args <- parseExps 291 | _ <- char ')' 292 | return $ buildAppStack varOrFn args 293 | 294 | -- | Convert a function call with multiple arguments to recursive unary calls. 295 | -- If no arguments are given, return a nullary function call. 296 | -- 297 | -- >>> buildAppStack (Var "x") [] 298 | -- NullaryApp (Var "x") 299 | -- 300 | -- >>> buildAppStack (Var "x") [Lit (IntV 1)] 301 | -- UnaryApp (Var "x") (Lit (IntV 1)) 302 | -- 303 | -- >>> buildAppStack (Var "x") [Lit (IntV 1),Lit (IntV 2),Lit (IntV 3)] 304 | -- UnaryApp (UnaryApp (UnaryApp (Var "x") (Lit (IntV 1))) (Lit (IntV 2))) (Lit (IntV 3)) 305 | -- 306 | buildAppStack :: Exp -> [Exp] -> Exp 307 | buildAppStack fn [] = NullaryApp fn 308 | buildAppStack fn [arg] = UnaryApp fn arg 309 | buildAppStack fn (a:as) = buildAppStack (UnaryApp fn a) as 310 | 311 | -- | Parse nullary function calls. That is, functions with no arguments. 312 | -- 313 | -- >>> parse parseNullaryApp "" "(+)" 314 | -- Right (NullaryApp (Var "+")) 315 | -- 316 | -- >>> parse parseNullaryApp "" "((fn [] 0))" 317 | -- Right (NullaryApp (Fun [] (Lit (IntV 0)))) 318 | -- 319 | -- >>> parse parseNullaryApp "" "(list)" 320 | -- Right (NullaryApp (Var "list")) 321 | -- 322 | -- >>> isLeft $ parse parseNullaryApp "" "()" 323 | -- True 324 | -- 325 | parseNullaryApp :: Parser Exp 326 | parseNullaryApp = do 327 | _ <- char '(' 328 | varOrFn <- parseExp 329 | _ <- char ')' 330 | return $ NullaryApp varOrFn 331 | 332 | -- | Parse functions. 333 | -- 334 | -- >>> parse parseFun "" "(fn [x y z] (x y z))" 335 | -- Right (Fun [Var "x",Var "y",Var "z"] (UnaryApp (UnaryApp (Var "x") (Var "y")) (Var "z"))) 336 | -- 337 | -- >>> parse parseFun "" "(fn [] 3)" 338 | -- Right (Fun [] (Lit (IntV 3))) 339 | -- 340 | parseFun :: Parser Exp 341 | parseFun = do 342 | parseStartsListWith "fn" 343 | argsVec <- parseVecOfVars 344 | body <- parseBodyOfFun 345 | return $ Fun argsVec body 346 | 347 | parseStartsListWith :: String -> Parser () 348 | parseStartsListWith keyword = do 349 | _ <- char '(' 350 | _ <- try $ string keyword 351 | skipSpaces1 352 | 353 | parseBodyOfFun :: Parser Exp 354 | parseBodyOfFun = do 355 | _ <- skipSpaces1 356 | body <- parseExp 357 | _ <- char ')' 358 | return body 359 | 360 | -- | Parse vector of vars. 361 | -- 362 | -- >>> parse parseVecOfVars "" "[]" 363 | -- Right [] 364 | -- 365 | -- >>> parse parseVecOfVars "" "[x y z]" 366 | -- Right [Var "x",Var "y",Var "z"] 367 | -- 368 | parseVecOfVars :: Parser [Exp] 369 | parseVecOfVars = do 370 | _ <- char '[' 371 | vars <- sepBy parseVar skipSpaces1 372 | _ <- char ']' 373 | return vars 374 | 375 | -- | Parse let expressions. 376 | -- 377 | -- >>> parse parseLet "" "(let [x 1 y 2] (+ x y))" 378 | -- Right (Let (Var "x") (Lit (IntV 1)) (Let (Var "y") (Lit (IntV 2)) (UnaryApp (UnaryApp (Var "+") (Var "x")) (Var "y")))) 379 | -- 380 | -- >>> isLeft $ parse parseLet "" "(let [] (+ x y))" 381 | -- True 382 | -- 383 | -- >>> isLeft $ parse parseLet "" "(let [x 1 y] (+ x y))" 384 | -- True 385 | -- 386 | parseLet :: Parser Exp 387 | parseLet = do 388 | parseStartsListWith "let" 389 | bindings <- parseVarExpPairs 390 | body <- parseBodyOfFun 391 | return $ buildLetBindingStack body bindings 392 | 393 | buildLetBindingStack :: Exp -> [(Exp, Exp)] -> Exp 394 | buildLetBindingStack _ [] = error "let must bind variables" 395 | buildLetBindingStack body [(Var v,bind)] = Let (Var v) bind body 396 | buildLetBindingStack body ((Var v,bind):bindings) = Let (Var v) bind (buildLetBindingStack body bindings) 397 | buildLetBindingStack _ _ = error "let has invalid bindings" 398 | 399 | -- | Parse (var, exp) pairs. Must have at least one. 400 | -- 401 | -- >>> parse parseVarExpPairs "" "[x 1 y 2]" 402 | -- Right [(Var "x",Lit (IntV 1)),(Var "y",Lit (IntV 2))] 403 | -- 404 | -- >>> isLeft $ parse parseLet "" "[]" 405 | -- True 406 | -- 407 | -- >>> isLeft $ parse parseLet "" "[x 1 y]" 408 | -- True 409 | -- 410 | parseVarExpPairs :: Parser [(Exp, Exp)] 411 | parseVarExpPairs = do 412 | _ <- char '[' 413 | pairs <- sepBy1 parseVarExpPair skipSpaces1 414 | _ <- char ']' 415 | return pairs 416 | 417 | parseVarExpPair :: Parser (Exp, Exp) 418 | parseVarExpPair = do 419 | var <- parseVar 420 | _ <- skipSpaces1 421 | body <- parseExp 422 | return (var, body) 423 | 424 | -- | Parse if. 425 | -- 426 | -- >>> parse parseIf "" "(if true (x 1) (y 1))" 427 | -- Right (If (Lit (BoolV True)) (UnaryApp (Var "x") (Lit (IntV 1))) (UnaryApp (Var "y") (Lit (IntV 1)))) 428 | -- 429 | parseIf :: Parser Exp 430 | parseIf = do 431 | parseStartsListWith "if" 432 | p <- parseExp 433 | _ <- skipSpaces1 434 | t <- parseExp 435 | e <- parseBodyOfFun 436 | return (If p t e) 437 | 438 | -- | Parse upper-cased string. 439 | -- 440 | -- >>> parse parseUpperCasedString "" "F" 441 | -- Right "F" 442 | -- 443 | -- >>> parse parseUpperCasedString "" "Foo" 444 | -- Right "Foo" 445 | -- 446 | -- >>> parse parseUpperCasedString "" "FooBarFar" 447 | -- Right "FooBarFar" 448 | -- 449 | -- >>> parse parseUpperCasedString "" "FooBar Far" 450 | -- Right "FooBar" 451 | -- 452 | -- >>> isLeft $ parse parseUpperCasedString "" "fooBarFar" 453 | -- True 454 | -- 455 | parseUpperCasedString :: Parser String 456 | parseUpperCasedString = do 457 | u <- upper 458 | s <- many letter 459 | return $ u : s 460 | 461 | parseDataTypeWithoutTvars :: Parser (Name,[TName]) 462 | parseDataTypeWithoutTvars = do 463 | name <- parseUpperCasedString 464 | return (name, []) 465 | 466 | parseDataTypeWithTvars :: Parser (Name,[TName]) 467 | parseDataTypeWithTvars = do 468 | _ <- char '(' 469 | name <- parseUpperCasedString 470 | tvars <- many (spaces >> many1 lower) 471 | _ <- char ')' 472 | return (name, tvars) 473 | 474 | -- | Parse data type name. 475 | -- 476 | -- >>> parse parseDataTypeName "" "Animal" 477 | -- Right ("Animal",[]) 478 | -- 479 | -- >>> parse parseDataTypeName "" "(Foo a b c)" 480 | -- Right ("Foo",["a","b","c"]) 481 | -- 482 | parseDataTypeName :: Parser (Name,[TName]) 483 | parseDataTypeName = parseDataTypeWithoutTvars <|> parseDataTypeWithTvars 484 | 485 | -- parseDatatTypeWithTapps :: Parser DeclareCtor 486 | 487 | -- | Parse data type constructor. 488 | -- 489 | -- >>> parse parseDataTypeConstructor "" "Nothing" 490 | -- Right (DeclareCtor "Nothing" []) 491 | -- 492 | -- >>> parse parseDataTypeConstructor "" "(Nothing)" 493 | -- Right (DeclareCtor "Nothing" []) 494 | -- 495 | -- >>> parse parseDataTypeConstructor "" "(Just a)" 496 | -- Right (DeclareCtor "Just" [a : k?]) 497 | -- 498 | -- >>> parse parseDataTypeConstructor "" "(Just a b c)" 499 | -- Right (DeclareCtor "Just" [a : k?,b : k?,c : k?]) 500 | -- 501 | -- >>> parse parseDataTypeConstructor "" "(Branch (Tree a) (Tree a))" 502 | -- Right (DeclareCtor "Branch" [(Tree a : k?),(Tree a : k?)]) 503 | -- 504 | -- >>> parse parseDataTypeConstructor "" "(Branch (Tree a) (Foo a b c))" 505 | -- Right (DeclareCtor "Branch" [(Tree a : k?),(((Foo a : k?) b : k?) c : k?)]) 506 | -- 507 | -- Below, Foo is another abstract data type. This is allowed: 508 | -- 509 | -- Foo = Bar | Far 510 | -- Tree a = Leaf a | Branch (Tree a) Foo -- refers to the Foo above 511 | -- 512 | -- >>> parse parseDataTypeConstructor "" "(Branch (Tree a) Foo)" 513 | -- Right (DeclareCtor "Branch" [(Tree a : k?),Foo]) 514 | -- 515 | -- >>> isLeft $ parse parseDataTypeConstructor "" "(abc)" 516 | -- True 517 | -- 518 | -- >>> isLeft $ parse parseDataTypeConstructor "" "abc" 519 | -- True 520 | -- 521 | parseDataTypeConstructor :: Parser DeclareCtor 522 | parseDataTypeConstructor = parseDataTypeConstructorSingleton <|> parseDataTypeConstructorWithParens 523 | 524 | -- | Parse data type constructors. 525 | -- 526 | -- >>> parse parseDataTypeConstructorWithParens "" "(Branch (Tree a) (Foo a b c))" 527 | -- Right (DeclareCtor "Branch" [(Tree a : k?),(((Foo a : k?) b : k?) c : k?)]) 528 | -- 529 | parseDataTypeConstructorWithParens :: Parser DeclareCtor 530 | parseDataTypeConstructorWithParens = do 531 | _ <- char '(' 532 | name <- parseUpperCasedString 533 | _ <- spaces 534 | types <- parseMany parseTypeKind 535 | _ <- char ')' 536 | return (DeclareCtor name types) 537 | 538 | parseDataTypeConstructorSingleton :: Parser DeclareCtor 539 | parseDataTypeConstructorSingleton = do 540 | name <- parseUpperCasedString 541 | return (DeclareCtor name []) 542 | 543 | -- | Parse data type. 544 | -- 545 | -- >>> parse parseDataType "" "(data-type Animal Dog Cat Cow)" 546 | -- Right (DeclareType "Animal" [] [DeclareCtor "Dog" [],DeclareCtor "Cat" [],DeclareCtor "Cow" []] k?) 547 | -- 548 | -- >>> parse parseDataType "" "(data-type (Maybe a) (Just a) Nothing)" 549 | -- Right (DeclareType "Maybe" ["a"] [DeclareCtor "Just" [a : k?],DeclareCtor "Nothing" []] k?) 550 | -- 551 | -- Invalid data type, but it is parsed. Should error in type check. 552 | -- >>> parse parseDataType "" "(data-type (Maybe a) (Just a b c) Nothing)" 553 | -- Right (DeclareType "Maybe" ["a"] [DeclareCtor "Just" [a : k?,b : k?,c : k?],DeclareCtor "Nothing" []] k?) 554 | -- 555 | -- >>> parse parseDataType "" "(data-type (Tree a) (Leaf a) (Branch (Tree a) (Tree a)))" 556 | -- Right (DeclareType "Tree" ["a"] [DeclareCtor "Leaf" [a : k?],DeclareCtor "Branch" [(Tree a : k?),(Tree a : k?)]] k?) 557 | -- 558 | -- >>> parse parseDataType "" "(data-type (Tree a) (Leaf a) (Branch (Tree a) Foo))" 559 | -- Right (DeclareType "Tree" ["a"] [DeclareCtor "Leaf" [a : k?],DeclareCtor "Branch" [(Tree a : k?),Foo]] k?) 560 | -- 561 | -- >>> parse parseDataType "" "(data-type (Either a b) (Left a) (Right b))" 562 | -- Right (DeclareType "Either" ["a","b"] [DeclareCtor "Left" [a : k?],DeclareCtor "Right" [b : k?]] k?) 563 | -- 564 | parseDataType :: Parser DeclareType 565 | parseDataType = do 566 | parseStartsListWith "data-type" 567 | (name, tvars) <- parseDataTypeName 568 | _ <- spaces 569 | ctors <- parseMany parseDataTypeConstructor 570 | _ <- char ')' 571 | return (DeclareType name tvars ctors KUnknownInit) 572 | 573 | -- | Parse expression. 574 | -- 575 | -- >>> parse parseExp "" "\"abc\"" 576 | -- Right (Lit (StringV "abc")) 577 | -- 578 | -- >>> parse parseExp "" "true" 579 | -- Right (Lit (BoolV True)) 580 | -- 581 | -- >>> parse parseExp "" "123" 582 | -- Right (Lit (IntV 123)) 583 | -- 584 | -- >>> parse parseExp "" "x" 585 | -- Right (Var "x") 586 | -- 587 | -- >>> parse parseExp "" "[+ -]" 588 | -- Right (List [Var "+",Var "-"]) 589 | -- 590 | -- >>> parse parseExp "" "(list + - abc)" 591 | -- Right (List [Var "+",Var "-",Var "abc"]) 592 | -- 593 | -- >>> parse parseExp "" "+ 13" 594 | -- Right (Var "+") 595 | -- 596 | -- >>> parse parseExp "" "(foo bar)" 597 | -- Right (UnaryApp (Var "foo") (Var "bar")) 598 | -- 599 | -- >>> parse parseExp "" "(foo)" 600 | -- Right (NullaryApp (Var "foo")) 601 | -- 602 | -- >>> parse parseExp "" "(let [x 1 y 2] (+ x y))" 603 | -- Right (Let (Var "x") (Lit (IntV 1)) (Let (Var "y") (Lit (IntV 2)) (UnaryApp (UnaryApp (Var "+") (Var "x")) (Var "y")))) 604 | -- 605 | -- >>> parse parseExp "" "(let [x 1 y 2] (if true x y))" 606 | -- Right (Let (Var "x") (Lit (IntV 1)) (Let (Var "y") (Lit (IntV 2)) (If (Lit (BoolV True)) (Var "x") (Var "y")))) 607 | -- 608 | parseExp :: Parser Exp 609 | parseExp = 610 | try parseString <|> 611 | try parseBool <|> 612 | try parseInt <|> 613 | try parseList <|> 614 | try parseVector <|> 615 | try parseIf <|> 616 | try parseLet <|> 617 | try parseUnaryApp <|> 618 | try parseNullaryApp <|> 619 | try parseFun <|> 620 | -- try parseFun <|> 621 | try parseVar 622 | 623 | -- | Parse a line of expression. 624 | -- 625 | -- >>> parse parseLine "" "[+ - >>= abc-def 123]" 626 | -- Right (List [Var "+",Var "-",Var ">>=",Var "abc-def",Lit (IntV 123)]) 627 | -- 628 | -- >>> isLeft $ parse parseLine "" "+ 13" 629 | -- True 630 | -- 631 | parseLine :: Parser Exp 632 | parseLine = do 633 | expr <- parseExp 634 | 635 | -- Expect spaces and EOF after expression. 636 | _ <- many space 637 | _ <- eof 638 | 639 | return expr 640 | 641 | -- | Parse a Neblen program. 642 | -- 643 | -- >>> parseProgram "(+ 1 2)" 644 | -- Right (UnaryApp (UnaryApp (Var "+") (Lit (IntV 1))) (Lit (IntV 2))) 645 | -- 646 | -- >>> parseProgram "(fn [x y] (x y))" 647 | -- Right (Fun [Var "x",Var "y"] (UnaryApp (Var "x") (Var "y"))) 648 | -- 649 | -- >>> isLeft $ parseProgram "+ 13" 650 | -- True 651 | parseProgram :: NeblenProgram -> Either ParseError Exp 652 | parseProgram = parse parseLine "" 653 | 654 | parseTString :: Parser Type 655 | parseTString = string "String" >> return TString 656 | 657 | parseTBool :: Parser Type 658 | parseTBool = string "Bool" >> return TBool 659 | 660 | parseTInt :: Parser Type 661 | parseTInt = string "Int" >> return TInt 662 | 663 | parseTFun :: Parser Type 664 | parseTFun = parseListWithSurroundingPrefix (Just (string "->")) '(' ')' parseTypes TFun 665 | 666 | parseTList :: Parser Type 667 | parseTList = do 668 | _ <- char '[' 669 | t <- parseType 670 | _ <- char ']' 671 | return (TList t) 672 | 673 | parseTVar :: Parser Type 674 | parseTVar = liftM TVar (many1 letter) 675 | 676 | -- | Parse type. 677 | -- 678 | -- >>> parse parseType "" "(-> a Int (-> a b [String] Bool) (-> Bool))" 679 | -- Right (-> a Int (-> a b [String] Bool) (-> Bool)) 680 | -- 681 | parseType :: Parser Type 682 | parseType = 683 | try parseTString <|> 684 | try parseTBool <|> 685 | try parseTInt <|> 686 | try parseTFun <|> 687 | try parseTList <|> 688 | try parseTVar 689 | 690 | parseTypes :: Parser [Type] 691 | parseTypes = parseMany parseType 692 | 693 | -------------------------- 694 | -- Parse "kind world" types, which differs (for now) from "non-kind" types 695 | 696 | -- | Parse type constant with unknown kind. 697 | -- 698 | -- >>> parse parseTConst "" "Tree" 699 | -- Right Tree 700 | -- 701 | -- >>> isLeft $ parse parseTConst "" "a" 702 | -- True 703 | -- 704 | -- >>> isLeft $ parse parseTConst "" "(Tree a)" 705 | -- True 706 | -- 707 | parseTConst :: Parser Type 708 | parseTConst = do 709 | name <- parseUpperCasedString 710 | return (TConst name KUnknownInit) 711 | 712 | -- | Parse type variable with unknown kind. 713 | -- 714 | -- >>> parse parseTVarK "" "abc" 715 | -- Right abc : k? 716 | -- 717 | -- >>> isLeft $ parse parseTVarK "" "Abc" 718 | -- True 719 | -- 720 | parseTVarK :: Parser Type 721 | parseTVarK = do 722 | tname <- many1 lower 723 | return (TVarK tname KUnknownInit) 724 | 725 | -- | Parse type application with unknown kinds. 726 | -- 727 | -- >>> parse parseTApp "" "(Tree a)" 728 | -- Right (Tree a : k?) 729 | -- 730 | -- >>> parse parseTApp "" "(Foo a b c)" 731 | -- Right (((Foo a : k?) b : k?) c : k?) 732 | -- 733 | -- >>> isLeft $ parse parseTApp "" "(a b)" 734 | -- True 735 | -- 736 | parseTApp :: Parser Type 737 | parseTApp = do 738 | _ <- char '(' 739 | ctor <- parseTConst 740 | _ <- spaces 741 | types <- parseMany parseTypeKind 742 | _ <- char ')' 743 | return (buildTAppStack (ctor:types)) 744 | 745 | buildTAppStack :: [Type] -> Type 746 | buildTAppStack (lhs:[rhs]) = TApp lhs rhs 747 | buildTAppStack (a:b:rest) = buildTAppStack (TApp a b:rest) 748 | buildTAppStack _ = error "buildTAppStack requires at least two arguments" 749 | 750 | parseTypeKind :: Parser Type 751 | parseTypeKind = parseTConst <|> parseTVarK <|> parseTApp 752 | 753 | -------------------------------------------------------------------------------- /src/Neblen/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | module Neblen.TypeChecker where 2 | 3 | import Neblen.Data 4 | import Neblen.Utils 5 | import qualified Data.Map.Strict as M 6 | import qualified Data.List as L 7 | import Data.Maybe (fromMaybe) 8 | import qualified Data.Set as S 9 | import Control.Monad 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.Trans.State 12 | import Control.Monad.Trans.Except 13 | 14 | -- = How the type checker works 15 | -- 16 | -- At a high level, the type checker is similar to an interpreter: you go 17 | -- through the expression tree and calculate a type for each expression. 18 | -- 19 | -- The environment of the type check includes the variable context and the type 20 | -- variable context: 21 | -- 22 | -- * 'TEnv' - The mapping of regular variables to its type. 23 | -- * 'Subst' - Short for "substitution," this maps /type/ variables to its 24 | -- type (which may be other type variables). 25 | -- 26 | -- As the checker traverses the expression, only the @Subst@ context needs to be 27 | -- threaded in-and-out. That is, a child expression may discover something about 28 | -- a type that the parent expression needs to know about. For example: 29 | -- 30 | -- @ 31 | -- (fn [x] (x true)) 32 | -- @ 33 | -- 34 | -- When checking this expression, we encounter the function and give @x@ the 35 | -- fresh type variable @a@. 36 | -- 37 | -- Then we go into the body of the function, @(x true)@, and discover that @x : 38 | -- a@ must be a function @(-> Bool b)@. This is in the 'Subst' context inside of 39 | -- @(x true)@. Finally, we pop back up to the top expression, and 'apply' this 40 | -- new knowledge back into the original @a@, and substitute @a@ with @(-> Bool 41 | -- b)@. 42 | -- 43 | -- == Unification 44 | -- 45 | -- == Type schemes and polymorphism 46 | -- 47 | -- The 'TEnv' data type actually maps to a 'TypeScheme'. Type schemes help us 48 | -- deal with polymorphic types, especially in let-polymoprhism. For example: 49 | -- 50 | -- @ 51 | -- (let [id (fn [x] x) 52 | -- u (id 3) 53 | -- v (id true)] 54 | -- ...) 55 | -- @ 56 | -- 57 | -- In this example, the function @id@ should work for both @u@ and @v@, even 58 | -- though @id@ is instantiated twice with different types. To do this, we need 59 | -- @id@ to be typed as @id : ∀a. (-> a a)@. When the type checker reaches the 60 | -- @u@ binding, it should instantiate new type variables for @id@ (say it 61 | -- chooses the type variable @b@). Then the function application @(id 3)@ is 62 | -- type-checked, we get that instance of @id : (-> Int Int)@. When we 63 | -- check @v@, we get a /new/ @id : (-> Bool Bool)@. 64 | -- 65 | -- To simplify our code, we allow type schemes over types without any free type 66 | -- variables: @∀. Int@. 67 | -- 68 | -- == The TypeCheck data type 69 | -- 70 | -- During our type checking run, we need some stuff: 71 | -- 72 | -- * A way to exit the computation if a type error is encountered. 73 | -- * A way to fresh (guaranteed to be unused) type variables (essentially, 74 | -- some stateful counter). 75 | -- * Carry around other contexts like 'Subst' 76 | -- 77 | -- To facilitate this, we use a monad transformer stack of 'ExceptT' + 'State'. 78 | -- 'ExceptT' gives us type errors (left) and no type error (right). 'State' 79 | -- gives us an incrementable counter to get fresh type variables from. 80 | 81 | -- $setup 82 | -- >>> :set -XOverloadedStrings 83 | -- >>> import qualified Data.Map.Strict as M 84 | 85 | ------------------------------------------ 86 | -- Data types 87 | ------------------------------------------ 88 | 89 | -- Monad transformer stack for TypeCheck: 90 | -- 91 | -- State (fresh type variable counter) 92 | -- ExceptT (TypeError) 93 | -- a 94 | -- 95 | type TypeCheck a = ExceptT TypeError (State FreshCounter) a 96 | 97 | -- Mapping of variables (value vars, *not* type variables) to its type. 98 | type TEnv = M.Map Name TypeScheme 99 | 100 | -- Type variable substitutions. Mapping of type variables to its type. 101 | type Subst = M.Map TName Type 102 | 103 | -- Type schemes is a way to allow let-polymorphism (ML-style polymorphism): 104 | -- functions can be instantiated with different types in the same body. See 105 | -- Pierce 22.7 Let-Polymorphism (pg 331). 106 | data TypeScheme = Forall [TName] Type 107 | deriving (Eq, Ord) 108 | 109 | data TypeError = Mismatch Type Type 110 | | FunctionExpected Type 111 | | UnboundVariable Name 112 | | InfiniteType Type Type -- InfiniteType TVar Type 113 | | GenericTypeError (Maybe String) 114 | deriving (Eq) 115 | 116 | -- Something is Substitutable if you can apply the given Subst to it, substituting 117 | -- type variables in 't' with its mapping in the Subst. 118 | class Substitutable t where 119 | -- Substitute free type variables in 't' with mapping found in Subst. 120 | apply :: Subst -> t -> t 121 | 122 | -- Returns list of free type variables found in 't'. 123 | ftvs :: t -> S.Set Type 124 | 125 | instance Substitutable a => Substitutable [a] where 126 | apply s = map (apply s) 127 | 128 | ftvs = foldl (\tvs t -> S.union tvs (ftvs t)) S.empty 129 | 130 | -- | Replace all the type variables with its mapping. 131 | -- 132 | -- >>> apply (M.fromList [("a",TVar "x"),("b",TInt)]) (TFun [TVar "a",TVar "b",TString]) 133 | -- (-> x Int String) 134 | -- 135 | -- >>> ftvs (TFun [TVar "a",TVar"b",TString]) 136 | -- fromList [a,b] 137 | -- 138 | instance Substitutable Type where 139 | apply s (TVar tv) = fromMaybe (TVar tv) (M.lookup tv s) 140 | apply s (TFun vs) = TFun (map (apply s) vs) 141 | apply s (TList t) = TList (apply s t) 142 | apply s (TData n vs) = TData n (map (apply s) vs) 143 | apply _ t = t 144 | 145 | ftvs (TVar tv) = S.singleton (TVar tv) 146 | ftvs (TFun vs) = foldl (\s v -> S.union s (ftvs v)) S.empty vs 147 | ftvs (TList t) = ftvs t 148 | ftvs _ = S.empty 149 | 150 | instance Substitutable TypeScheme where 151 | apply s (Forall tvs t) = Forall tvs (apply s t) 152 | ftvs (Forall tvs _) = S.fromList (map TVar tvs) 153 | 154 | -- | Compose two Substs together: apply u1's substitutions over u2's values. 155 | -- Example: 156 | -- 157 | -- u1: {c -> b} 158 | -- u2: {a -> (-> b c)} 159 | -- (compose u1 u2): {a -> (-> b b), c -> b} 160 | -- 161 | -- Note that order matters. u1's mapping is applied to u2's mapping, but 162 | -- not vice-versa. 163 | -- 164 | -- >>> compose (M.fromList [("c", TVar "b")]) (M.fromList [("a", TFun [TVar "b",TVar "c"])]) 165 | -- fromList [("a",(-> b b)),("c",b)] 166 | -- 167 | -- Below composes the wrong way. The resulting Subst is not useful (as the 168 | -- variables aren't all properly substituted). 169 | -- 170 | -- >>> compose (M.fromList [("a", TFun [TVar "b",TVar "c"])]) (M.fromList [("c", TVar "b")]) 171 | -- fromList [("a",(-> b c)),("c",b)] 172 | -- 173 | compose :: Subst -> Subst -> Subst 174 | compose u1 u2 = M.union (M.map (apply u1) u2) u1 175 | 176 | -- | Compose Substs left-to-right. See 'compose' function for comments. 177 | -- 178 | -- >>> composeAll [(M.fromList [("c", TVar "b")]), (M.fromList [("a", TFun [TVar "b",TVar "c"])])] 179 | -- fromList [("a",(-> b b)),("c",b)] 180 | -- 181 | composeAll :: [Subst] -> Subst 182 | composeAll = foldl compose emptySubst 183 | 184 | -- | Unify types. 185 | -- 186 | -- Unification attempts to create a new Subst universe with new mappings of type 187 | -- variables to types. A simple case: 188 | -- 189 | -- @a <==> Int@ 190 | -- 191 | -- When trying to unify @a@ with @Int@, we can simply map @a => Int@. 192 | -- 193 | unify :: Type -> Type -> TypeCheck Subst 194 | unify TInt TInt = return emptySubst 195 | unify TBool TBool = return emptySubst 196 | unify TString TString = return emptySubst 197 | unify (TVar tv) t2 = unifyTVar (TVar tv) t2 198 | unify t1 (TVar tv) = unifyTVar (TVar tv) t1 199 | 200 | -- Unify functions. 201 | -- 202 | -- How functions of differing arity are unified: 203 | -- 204 | -- * Unify the shared arguments. 205 | -- * If un-even remaining arguments, unify remaining as functions again. 206 | -- * If one of the sides has only one argument left, that argument must be the 207 | -- return type. Unify that return type with the rest. 208 | -- 209 | -- Example: 210 | -- 211 | -- 1. @(-> Int a b c) <==> (-> d e)@ 212 | -- 2. @Int@ and @d@ are unified. 213 | -- 3. @(-> a b c) <==> (-> e)@ 214 | -- 4. @(-> a b c)@ and @e@ are unified. 215 | -- 5. Unified to @(-> Int (-> a b c))@ 216 | -- 217 | unify (TFun [l]) (TFun [r]) = unify l r 218 | unify lhs@(TFun _) (TFun [r]) = unify lhs r 219 | unify (TFun [l]) rhs@(TFun _) = unify l rhs 220 | unify (TFun lhs) (TFun rhs) = 221 | let numArgs = min (length lhs) (length rhs) - 1 222 | sharedArgs = L.zip (take numArgs lhs) (take numArgs rhs) 223 | restL = drop numArgs lhs 224 | restR = drop numArgs rhs 225 | in do 226 | -- Unify the arguments shared between lhs and rhs 227 | s <- foldl 228 | (\sumSubst (l,r) -> do 229 | s <- sumSubst 230 | s1 <- unify (apply s l) (apply s r) 231 | return $ s1 `compose` s) 232 | (return emptySubst) sharedArgs 233 | 234 | -- Unify remaining args (including return value) 235 | s' <- unify (TFun (apply s restL)) (TFun (apply s restR)) 236 | return (s' `compose` s) 237 | 238 | -- Assume order implies attempted function call on a non-function. 239 | unify t TFun{} = throwE (FunctionExpected t) 240 | unify t1 t2 = throwE $ Mismatch t1 t2 241 | 242 | -- | Unify a type variable (left-hand side) with the right-hand side type. 243 | unifyTVar :: Type -> Type -> TypeCheck Subst 244 | unifyTVar t1@(TVar tv) t2 | t1 == t2 = return emptySubst 245 | | occursCheck t1 t2 = throwE $ InfiniteType t1 t2 246 | | otherwise = return (M.singleton tv t2) 247 | unifyTVar _ _ = error "Bad call to unifyTVar" 248 | 249 | -- | This occurs check asserts that if we are applying a substitution of variable 250 | -- x to an expression e, the variable x cannot be free in e. Otherwise the 251 | -- rewrite would diverge, constantly rewriting itself. 252 | -- 253 | -- That is, an infinite type. 254 | -- 255 | -- For example, this won't unify: a <==> (a -> b). 256 | -- 257 | -- But note that this should not be used to check: a <==> a. If the type 258 | -- variables are the same, it is OK (it is not infinite, we can just replace 'a' 259 | -- with any type once we resolve its type) 260 | -- 261 | -- >>> occursCheck (TVar "a") (TFun [TInt,TVar "a"]) 262 | -- True 263 | -- 264 | -- >>> occursCheck (TVar "a") (TFun [TInt,TVar "b"]) 265 | -- False 266 | -- 267 | occursCheck :: Type -> Type -> Bool 268 | occursCheck tv t = S.member tv (ftvs t) 269 | 270 | -- | Find non-universally quantified type variables in the type scheme. 271 | -- 272 | -- >>> nonFree (Forall ["x"] (TVar "x")) 273 | -- fromList [] 274 | -- 275 | -- >>> nonFree (Forall [] (TVar "x")) 276 | -- fromList [x] 277 | -- 278 | -- >>> nonFree (Forall ["x"] (TFun [TVar "x",TVar "y",TVar "z"])) 279 | -- fromList [y,z] 280 | -- 281 | nonFree :: TypeScheme -> S.Set Type 282 | nonFree (Forall tvs t) = 283 | let ftv' = ftvs t 284 | in ftv' `S.difference` S.fromList (map TVar tvs) 285 | 286 | -- | Find non-universally quantified type variables in the type schemes. 287 | -- 288 | -- >>> nonFrees [(Forall [] (TVar "a")), (Forall ["x"] (TFun [TVar "x",TVar "y",TVar "z"]))] 289 | -- fromList [a,y,z] 290 | -- 291 | nonFrees :: [TypeScheme] -> S.Set Type 292 | nonFrees = foldl (\s ts -> s `S.union` nonFree ts) S.empty 293 | 294 | -- | Generalize unbounded type variables into a for-all type scheme. 295 | -- 296 | -- >>> generalize (M.fromList [("foo",Forall [] (TVar "a"))]) (M.fromList [("b",TInt)]) (TFun [TVar "a",TVar "b",TVar "c"]) 297 | -- ∀:["c"] (-> a b c) 298 | -- 299 | generalize :: TEnv -> Subst -> Type -> TypeScheme 300 | generalize tenv s t = 301 | let bounds = nonFrees (M.elems tenv) 302 | ftv = (ftvs t `S.difference` S.fromList (map TVar (M.keys s)) `S.difference` bounds) 303 | in Forall (map toTName (S.elems ftv)) t 304 | 305 | -- | Check type and re-order type variables. 306 | -- 307 | -- (fn [f] (fn [x] (f x))) : (-> (-> a b) (-> a b)) 308 | -- >>> runWithFreshCounter (checkType (Fun [Var "f"] (Fun [Var "x"] (UnaryApp (Var "f") (Var "x"))))) 309 | -- Right (-> (-> a b) (-> a b)) 310 | -- 311 | checkType :: Exp -> TypeCheck Type 312 | checkType e = do 313 | (_, t) <- check defaultTEnv emptySubst e 314 | case evalState (runExceptT (reorderTVars t)) initFreshCounter of 315 | Right t' -> return t' 316 | Left err -> throwE err 317 | 318 | checkTypeWith :: Exp -> TEnv -> TypeCheck Type 319 | checkTypeWith e tenv = do 320 | (_, t) <- check (M.union defaultTEnv tenv) emptySubst e 321 | case evalState (runExceptT (reorderTVars t)) initFreshCounter of 322 | Right t' -> return t' 323 | Left err -> throwE err 324 | 325 | -- | Check type. 326 | -- 327 | -- Below is: 328 | -- 329 | -- (let [id (fn [x] x)] 330 | -- (let [y (id 3)] 331 | -- (let [z (id true)] z))) 332 | -- 333 | -- >>> runCheck emptyTEnv emptySubst (Let (Var "id") (Fun [Var "x"] (Var "x")) (Let (Var "y") (UnaryApp (Var "id") (Lit (IntV 3))) (Let (Var "z") (UnaryApp (Var "id") (Lit (BoolV True))) (Var "z")))) 334 | -- (fromList [("b",Int),("c",Int),("d",Bool),("e",Bool)],Bool) 335 | -- 336 | -- >>> runCheck (M.fromList [("Just", Forall ["z"] (TFun [TVar "z", TData "Maybe" [TVar "z"]]))]) emptySubst (UnaryApp (Var "Just") (Lit (IntV 10))) 337 | -- (fromList [("a",Int),("b",(Maybe Int))],(Maybe Int)) 338 | -- 339 | -- >>> runCheck (M.fromList [("Right", Forall ["x","y"] (TFun [TVar "x", TVar "y", TData "Either" [TVar "y", TVar "x"]]))]) emptySubst (UnaryApp (UnaryApp (Var "Right") (Lit (IntV 10))) (Lit (BoolV True))) 340 | -- (fromList [("a",Int),("b",Bool),("c",(-> Bool (Either Bool Int))),("d",(Either Bool Int))],(Either Bool Int)) 341 | -- 342 | -- >>> runCheck (M.fromList [("Just", Forall ["z"] (TFun [TVar "z", TData "Maybe" [TVar "z"]]))]) emptySubst (Data "Just" [Lit (IntV 10)]) 343 | -- (fromList [("a",Int),("b",(Maybe Int))],(Maybe Int)) 344 | -- 345 | check :: TEnv -> Subst -> Exp -> TypeCheck (Subst, Type) 346 | check tenv s e = case e of 347 | Lit lit -> 348 | case lit of 349 | IntV _ -> return (s, TInt) 350 | BoolV _ -> return (s, TBool) 351 | StringV _ -> return (s, TString) 352 | 353 | Var v -> 354 | case lookupTEnv tenv v of 355 | Just t -> do 356 | t' <- freshen (apply s t) 357 | return (s, t') 358 | Nothing -> throwE (UnboundVariable v) 359 | 360 | Let (Var v) rhs body -> do 361 | (s', rhsT) <- check tenv s rhs 362 | let tenv' = insertTEnv tenv v (generalize tenv s' rhsT) -- let-polymorphism 363 | (s'', bodyT) <- check tenv' s' body 364 | -- Return original tenv because 'v' is no longer in scope. 365 | return (composeAll [s'', s', s], bodyT) 366 | 367 | Let{} -> throwE (GenericTypeError (Just "Let binding must be a variable")) 368 | 369 | List elems -> 370 | case elems of 371 | [] -> getFresh >>= (\tv -> return (s, TList tv)) 372 | [el] -> do 373 | (s1, eT) <- check tenv s el 374 | return (composeAll [s1, s], TList (apply s1 eT)) 375 | (e1:e2:es) -> do 376 | (s1, e1T) <- check tenv s e1 377 | (s2, e2T) <- check tenv s1 e2 378 | s3 <- unify (apply s2 e1T) (apply s2 e2T) 379 | check tenv (composeAll [s3, s2, s1, s]) (List (e2:es)) 380 | 381 | If p t el -> do 382 | (s', pT) <- check tenv s p 383 | case pT of 384 | TBool -> do 385 | (s'', tT) <- check tenv s' t 386 | (s''', eT) <- check tenv s'' el 387 | s'''' <- unify tT eT 388 | return (composeAll [s'''', s''', s'', s', s], apply s'''' tT) 389 | otherT -> throwE $ Mismatch TBool otherT 390 | 391 | -- Function may have no arguments (e.g. have type (-> a)), which is a way of 392 | -- doing "lazy" evaluation. 393 | Fun vs body -> 394 | if not (isListOfVars vs) 395 | then throwE (GenericTypeError (Just ("Ill-defined function: " ++ toLisp e))) 396 | else do 397 | -- Get fresh type variables for every argument value variable. So with the 398 | -- function (fn [x] x), create fresh type var a1, with mapping @x: a1@. 399 | tvs <- mapM (const getFresh) vs 400 | 401 | -- Zip the argument variables with its corresponding (fresh) type variables 402 | -- (e.g. @x: a1@). Then insert all of these into the type env. 403 | let tenv' = foldl (\te (Var v, tv) -> insertTEnv te v (toScheme tv)) tenv (L.zip vs tvs) 404 | 405 | (s', bodyT) <- check tenv' s body 406 | 407 | -- May have discovered some arguments' type when body was checked, so apply 408 | -- new substitution. If not, use the fresh we got. 409 | let tvs' = map (apply s') tvs 410 | 411 | return (composeAll [s', s], TFun (tvs' ++ [bodyT])) 412 | 413 | NullaryApp (Var v) -> do 414 | (s1, t) <- check tenv s (Var v) 415 | tv <- getFresh 416 | s2 <- unify t (TFun [tv]) 417 | return (composeAll [s2, s1, s], apply s2 tv) 418 | NullaryApp (Fun [] body) -> check tenv s body 419 | NullaryApp body -> check tenv s body >>= (throwE . FunctionExpected . snd) 420 | 421 | -- To check the type, build two Fun types, one for @fn@ and one for 422 | -- @body@. Then attempt to unify. 423 | UnaryApp fn body -> do 424 | (s1, fnT) <- check tenv s fn 425 | (s2, bodyT) <- check tenv s1 body 426 | retT <- getFresh 427 | 428 | s3 <- unify (apply s2 fnT) (apply s2 (TFun (bodyT : [retT]))) 429 | return (composeAll [s3, s2, s1, s], apply s3 retT) 430 | 431 | -- This is the primitive data representation of data types. Already 432 | -- type-checked when the data constructor was applied. There is no way to 433 | -- actually type in the primitive form of a data type (e.g. "Maybe" is not a 434 | -- value to be type-checked); you have to go through the constructor. 435 | -- Data name exprs -> error "Shouldn't need to type check Data." 436 | Data name exprs -> error "not yet" 437 | 438 | BinOp{} -> error "Shouldn't need to type check BinOps." 439 | 440 | getNumArgs :: Type -> Int 441 | getNumArgs (TFun vs) = length vs - 1 442 | getNumArgs _ = 0 443 | 444 | isTFun :: Type -> Bool 445 | isTFun TFun{} = True 446 | isTFun _ = False 447 | 448 | isListOfVars :: [Exp] -> Bool 449 | isListOfVars [] = True 450 | isListOfVars (Var _:vs) = isListOfVars vs 451 | isListOfVars _ = False 452 | 453 | -- | Rename and reorder type variables to look nice. 454 | -- 455 | -- >>> runWithFreshCounter $ reorderTVars (TVar "b") 456 | -- Right a 457 | -- 458 | -- >>> runWithFreshCounter $ reorderTVars (TFun [TVar "c",TVar "b"]) 459 | -- Right (-> a b) 460 | -- 461 | -- >>> runWithFreshCounter $ reorderTVars (TFun [TVar "c",TFun [TVar "c",TVar "b"],TVar "a"]) 462 | -- Right (-> a (-> a b) c) 463 | -- 464 | -- >>> runWithFreshCounter $ reorderTVars (TFun [TVar "c",TList (TVar "c"),TVar "a"]) 465 | -- Right (-> a [a] b) 466 | -- 467 | -- >>> runWithFreshCounter $ reorderTVars (TFun [TFun [TVar "b",TVar "c"],TFun [TVar "b",TVar "c"]]) 468 | -- Right (-> (-> a b) (-> a b)) 469 | -- 470 | reorderTVars :: Type -> TypeCheck Type 471 | reorderTVars t = liftM snd (freshenWithSubst emptySubst (generalize emptyTEnv emptySubst t)) 472 | 473 | -- | Insert fresh variables for universally-quantified types. That is, given 474 | -- univerally-quantified variables, replace with new un-used type variables. 475 | -- 476 | -- >>> runWithFreshCounter (freshen (Forall ["x","y"] (TFun [TVar "x",TVar "y",TVar "c"]))) 477 | -- Right (-> a b c) 478 | -- 479 | freshen :: TypeScheme -> TypeCheck Type 480 | freshen ts = liftM snd (freshenWithSubst emptySubst ts) 481 | 482 | -- | Insert fresh variables for universally-quantified types, given a Subst 483 | -- context. Helper function for @freshen@. The Subst context in here is local to 484 | -- the universal quantifier. 485 | -- 486 | -- In the example below, we have a mapping @x: Int@ where that @x@ is the same 487 | -- @x@ in the universal quantifier. 488 | -- 489 | -- >>> runWithFreshCounter (freshenWithSubst (M.fromList [("x",TInt)]) (Forall ["x","y"] (TFun [TVar "x",TVar "y",TVar "c"]))) 490 | -- Right (fromList [("x",Int),("y",a)],(-> Int a c)) 491 | -- 492 | freshenWithSubst :: Subst -> TypeScheme -> TypeCheck (Subst, Type) 493 | freshenWithSubst s (Forall utvs (TVar tv)) = 494 | if tv `elem` utvs 495 | then case M.lookup tv s of 496 | Just ftv -> return (s, ftv) 497 | Nothing -> do 498 | ftv <- getFresh 499 | return (M.insert tv ftv s, ftv) 500 | else return (s, TVar tv) 501 | 502 | -- Perhaps this is the simpler solution, compared to below. 503 | -- freshenWithSubst s (Forall _ (TFun [])) = return (s, TFun []) 504 | -- freshenWithSubst s (Forall utvs (TFun [v])) = do 505 | -- (s1, v1) <- freshenWithSubst s (Forall utvs v) 506 | -- return (s1, TFun [v1]) 507 | -- freshenWithSubst s (Forall utvs (TFun (v:vs))) = do 508 | -- (s1, v1) <- freshenWithSubst s (Forall utvs v) 509 | -- (s2, v2) <- freshenWithSubst s1 (Forall utvs (TFun vs)) 510 | -- return (s2, TFun (v1:(getTFunArgs v2))) 511 | 512 | freshenWithSubst s (Forall utvs (TFun vs)) = do 513 | -- For each argument variable: 514 | -- 515 | -- * Grab the previous substitution and the already-freshened type vars list 516 | -- * Freshen the current type 517 | -- * Append that type to the already-freshened type vars list 518 | -- 519 | -- For example, if we have @Fun [x y z]@, we will convert @x@ to @a@, 520 | -- then @y@ to @b@, and so on. This will be built in the list as @[c b a]@. 521 | -- Note it is backwards, since we use a foldl (and not foldr since we want 522 | -- fresh variables in order). This is why we reverse it at the end. 523 | -- 524 | (s', vs') <- freshenVars s utvs vs 525 | return (s', TFun (reverse vs')) 526 | 527 | freshenWithSubst s (Forall utvs (TData name vs)) = do 528 | (s', vs') <- freshenVars s utvs vs 529 | return (s', TData name (reverse vs')) 530 | 531 | freshenWithSubst s (Forall utvs (TList tv)) = do 532 | (s1, tv1) <- freshenWithSubst s (Forall utvs tv) 533 | return (s1, TList tv1) 534 | freshenWithSubst s (Forall _ t) = return (s, t) 535 | 536 | -- | Create fresh variables for each variable in @vs@ that are universally 537 | -- quantified in @utvs@. 538 | -- 539 | -- For each argument variable: 540 | -- 541 | -- * Grab the previous substitution and the already-freshened type vars list 542 | -- * Freshen the current type 543 | -- * Append that type to the already-freshened type vars list 544 | -- 545 | -- For example, if we have @Fun [x y z]@, we will convert @x@ to @a@, 546 | -- then @y@ to @b@, and so on. This will be built in the list as @[c b a]@. 547 | -- Note it is backwards, since we use a foldl (and not foldr since we want 548 | -- fresh variables in order). This is why we reverse it at the end. 549 | -- 550 | freshenVars :: 551 | Subst 552 | -- ^ The substitution mappings 553 | -> [TName] 554 | -- ^ Universally-quantified variables 555 | -> [Type] 556 | -- ^ The types that we look for variables in the universally-quantified list 557 | -- from, to be replaced with fresh variables. 558 | -> TypeCheck (Subst, [Type]) 559 | freshenVars subst utvs = 560 | foldl 561 | (\tc v -> do 562 | (s1, sumArgs) <- tc 563 | (s2, v1) <- freshenWithSubst s1 (Forall utvs v) 564 | return (s2, v1:sumArgs)) 565 | (return (subst, [])) 566 | 567 | ------------------------------------------ 568 | -- Utilities 569 | ------------------------------------------ 570 | 571 | getTFunArgs :: Type -> [Type] 572 | getTFunArgs (TFun args) = args 573 | getTFunArgs _ = error "not TFun" 574 | 575 | defaultTEnv :: M.Map Name TypeScheme 576 | defaultTEnv = M.fromList [ 577 | ("+", Forall [] (TFun [TInt,TInt,TInt])) 578 | ,("-", Forall [] (TFun [TInt,TInt,TInt])) 579 | ,("*", Forall [] (TFun [TInt,TInt,TInt])) 580 | 581 | ,("and", Forall [] (TFun [TBool,TBool,TBool])) 582 | ,("or", Forall [] (TFun [TBool,TBool,TBool])) 583 | ,("xor", Forall [] (TFun [TBool,TBool,TBool])) 584 | 585 | ,("print", Forall [] (TFun [TString,TUnit])) 586 | ] 587 | 588 | emptyTEnv :: TEnv 589 | emptyTEnv = M.empty 590 | 591 | emptySubst :: Subst 592 | emptySubst = M.empty 593 | 594 | lookupTEnv :: TEnv -> Name -> Maybe TypeScheme 595 | lookupTEnv tenv name = M.lookup name tenv 596 | 597 | insertTEnv :: TEnv -> Name -> TypeScheme -> TEnv 598 | insertTEnv tenv name t = M.insert name t tenv 599 | 600 | letters :: [String] 601 | letters = [1..] >>= flip replicateM ['a'..'z'] 602 | 603 | -- | Get fresh variable. 604 | -- 605 | -- >>> runWithFreshCounter getFresh 606 | -- Right a 607 | -- 608 | -- >>> evalState (runExceptT getFresh) (FreshCounter { getFreshCounter = 1 }) 609 | -- Right b 610 | -- 611 | getFresh :: TypeCheck Type 612 | getFresh = do 613 | s <- lift get -- Same as: ExceptT (liftM Right get) 614 | lift $ put s{getFreshCounter = getFreshCounter s + 1} 615 | return $ TVar (letters !! getFreshCounter s) 616 | 617 | toScheme :: Type -> TypeScheme 618 | toScheme = Forall [] 619 | 620 | toTName :: Type -> TName 621 | toTName (TVar t) = t 622 | toTName _ = error "Not TVar!" 623 | 624 | emptyGenericTypeError :: TypeError 625 | emptyGenericTypeError = GenericTypeError Nothing 626 | 627 | genericTypeError :: String -> TypeError 628 | genericTypeError msg = GenericTypeError (Just msg) 629 | 630 | ------------------------------------------ 631 | -- Helpers to run the monad transformers. 632 | ------------------------------------------ 633 | 634 | runUnify :: TypeCheck Subst -> Either TypeError Subst 635 | runUnify uc = evalState (runExceptT uc) initFreshCounter 636 | 637 | runCheck :: TEnv -> Subst -> Exp -> (Subst, Type) 638 | runCheck tenv s expr = 639 | case evalState (runExceptT (check tenv s expr)) initFreshCounter of 640 | Left e -> error (show e) 641 | Right r -> r 642 | 643 | runWithFreshCounter :: ExceptT e (State FreshCounter) a -> Either e a 644 | runWithFreshCounter e = evalState (runExceptT e) initFreshCounter 645 | 646 | ------------------------------------------ 647 | -- Show instances 648 | ------------------------------------------ 649 | 650 | instance Show TypeScheme where 651 | show (Forall tvs t) = "∀:" ++ show tvs ++ " " ++ show t 652 | 653 | instance Show TypeError where 654 | show (Mismatch t1 t2) = "type mismatch: expecting " ++ show t1 ++ " but got " ++ show t2 655 | show (FunctionExpected t) = "type mismatch: expecting function but got " ++ show t 656 | show (UnboundVariable n) = "unbound variable " ++ n 657 | show (InfiniteType tvar t) = "cannot resolve infinite type " ++ show tvar ++ " in " ++ show t 658 | show (GenericTypeError (Just msg)) = "type error: " ++ msg 659 | show (GenericTypeError Nothing) = "type error" 660 | 661 | -------------------------------------------------------------------------------- /src/Neblen/Utils.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Utils where 2 | 3 | import Neblen.Data 4 | 5 | -- | Converts the AST to the original Neblen program. 6 | -- 7 | -- >>> toLisp (Lit (IntV 0)) 8 | -- "0" 9 | -- 10 | -- >>> toLisp (Lit (BoolV True)) 11 | -- "true" 12 | -- 13 | -- >>> toLisp (Lit (StringV "hello")) 14 | -- "\"hello\"" 15 | -- 16 | -- This won't type-check, but useful for test. 17 | -- >>> toLisp (List [(Lit (StringV "hello")),(Fun [Var "x"] (Var "x")),(UnaryApp (Var "x") (Var "y"))]) 18 | -- "[\"hello\" (fn [x] x) (x y)]" 19 | -- 20 | -- >>> toLisp (Let (Var "x") (Lit (StringV "hello")) (Var "x")) 21 | -- "(let [x \"hello\"] x)" 22 | -- 23 | -- >>> toLisp (If (Var "x") (Var "y") (Var "z")) 24 | -- "(if x y z)" 25 | -- 26 | -- >>> toLisp (NullaryApp (Var "x")) 27 | -- "(x)" 28 | -- 29 | -- >>> toLisp (Fun [] (Var "x")) 30 | -- "(fn [] x)" 31 | -- 32 | -- >>> toLisp (Data "Just" [Lit (IntV 3)]) 33 | -- "(Just 3)" 34 | -- 35 | toLisp :: Exp -> String 36 | toLisp (Lit (IntV v)) = show v 37 | toLisp (Lit (BoolV v)) = if v then "true" else "false" 38 | toLisp (Lit (StringV v)) = show v 39 | toLisp (List []) = "[]" 40 | toLisp (List (a:as)) = "[" ++ toLisp a ++ foldl (\s e -> s ++ " " ++ toLisp e) "" as ++ "]" 41 | toLisp (Var v) = v 42 | toLisp (Data name exprs) = "(" ++ name ++ " " ++ unwords (map toLisp exprs) ++ ")" 43 | toLisp (Fun vs body) = "(fn [" ++ unwords (map toLisp vs) ++ "] " ++ toLisp body ++ ")" 44 | toLisp (NullaryApp body) = "(" ++ toLisp body ++ ")" 45 | toLisp (UnaryApp fn body) = "(" ++ toLisp fn ++ " " ++ toLisp body ++ ")" 46 | toLisp (Let v e body) = "(let [" ++ toLisp v ++ " " ++ toLisp e ++ "] " ++ toLisp body ++ ")" 47 | toLisp (If p t e) = "(if " ++ toLisp p ++ " " ++ toLisp t ++ " " ++ toLisp e ++ ")" 48 | toLisp (BinOp f a b) = "(" ++ f ++ " " ++ toLisp a ++ " " ++ toLisp b ++ ")" 49 | toLisp (PrimitiveOp f args) = "(" ++ f ++ " " ++ unwords (fmap toLisp args) ++ ")" 50 | toLisp Unit = "" 51 | 52 | -- | Pretty-format a Neblen program. 53 | pretty :: String -> String 54 | pretty s = s 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-6.15 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /test-program.neblen: -------------------------------------------------------------------------------- 1 | 2 | ;; Hello 3 | 4 | (fn [x] x) 5 | 6 | (let [x 3] x) 7 | 8 | 9 | ;; Y-combinator cannot be typed with our type system! It is for the untyped lambda calculus. 10 | (let [y-fix (fn [f] 11 | ((fn [x] (f (fn [y] ((x x) y)))) 12 | (fn [x] (f (fn [y] ((x x) y)))))) 13 | y-fact (fn [fact] 14 | (fn [n] (if (= 0 n) 1 (* n (fact (- n 1))))))] 15 | ((y-fix y-fact) 5)) 16 | 17 | -------------------------------------------------------------------------------- /tests/Neblen/Compiler/Tests.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Compiler.Tests where 2 | 3 | import Test.Framework (Test, testGroup) 4 | import Test.Framework.Providers.HUnit (testCase) 5 | import Test.HUnit ((@?=)) 6 | import Control.Monad.Trans.State 7 | import Control.Monad.Trans.Except 8 | 9 | import qualified Data.Map.Strict as M 10 | 11 | import Neblen.Compiler 12 | 13 | tests :: Test 14 | tests = testGroup "Neblen.Compiler.Tests" $ concat 15 | [ 16 | ] 17 | 18 | -------------------------------------------------------------------------------- /tests/Neblen/Eval/Tests.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Eval.Tests where 2 | 3 | import Test.Framework (Test, testGroup) 4 | import Test.Framework.Providers.HUnit (testCase) 5 | import Test.HUnit ((@?=)) 6 | import Control.Monad.Trans.State 7 | import Control.Monad.Trans.Except 8 | 9 | import qualified Data.Map.Strict as M 10 | 11 | import Neblen.Eval 12 | import Neblen.Data 13 | import Neblen.Parser 14 | 15 | tests :: Test 16 | tests = testGroup "Neblen.Eval.Tests" $ concat 17 | [ 18 | testLit 19 | , testUnaryApp 20 | ] 21 | 22 | testLit :: [Test] 23 | testLit = 24 | [ 25 | testCase "eval: 1" $ 26 | (eval' M.empty (Lit (IntV 1))) 27 | @?= (Lit (IntV 1)) 28 | 29 | , testCase "eval: true" $ 30 | (eval' M.empty (Lit (BoolV True))) 31 | @?= (Lit (BoolV True)) 32 | 33 | , testCase "eval: \"hello\"" $ 34 | (eval' M.empty (Lit (StringV "hello"))) 35 | @?= (Lit (StringV "hello")) 36 | ] 37 | 38 | testUnaryApp :: [Test] 39 | testUnaryApp = 40 | [ 41 | testCase "eval: (((fn [x] (fn [y] y)) 10) 20) => 20" $ 42 | (eval' M.empty (p "(((fn [x] (fn [y] y)) 10) 20)")) 43 | @?= (Lit (IntV 20)) 44 | 45 | , testCase "eval: ((fn [x y] (x y)) (fn [a] a) 3) => 3" $ 46 | (eval' M.empty (p "((fn [x y] (x y)) (fn [a] a) 3)")) 47 | @?= (Lit (IntV 3)) 48 | 49 | , testCase "eval: ((fn [x y z] (x y z)) (fn [a] a) (fn [b] b) 3) => 3" $ 50 | (eval' M.empty (p "((fn [x y z] (x y z)) (fn [a] a) (fn [b] b) 3)")) 51 | @?= (Lit (IntV 3)) 52 | ] 53 | 54 | -- eval' M.empty (UnaryApp (UnaryApp (Fun (Var "x") (Fun (Var "y") (UnaryApp (Var "x") (Var "y")))) (Fun (Var "a") (Var "a"))) (Lit (IntV 3))) 55 | -- eval' M.empty (UnaryApp (UnaryApp (UnaryApp (Fun (Var "x") (Fun (Var "y") (Fun (Var "z") (UnaryApp (UnaryApp (Var "x") (Var "y")) (Var "z"))))) (Fun (Var "a") (Var "a"))) (Fun (Var "b") (Var "b"))) (Lit (IntV 3))) 56 | 57 | p :: NeblenProgram -> Exp 58 | p np = case parseProgram np of 59 | Left _ -> error "wrong program" 60 | Right e -> e 61 | -------------------------------------------------------------------------------- /tests/Neblen/Parser/Tests.hs: -------------------------------------------------------------------------------- 1 | module Neblen.Parser.Tests where 2 | 3 | import Test.Framework (Test, testGroup) 4 | import Test.Framework.Providers.HUnit (testCase) 5 | import Test.HUnit ((@?=)) 6 | import Control.Monad.Trans.State 7 | import Control.Monad.Trans.Except 8 | 9 | import qualified Data.Map.Strict as M 10 | 11 | import Neblen.Parser 12 | import Neblen.Data 13 | 14 | tests :: Test 15 | tests = testGroup "Neblen.Parser.Tests" $ concat 16 | [ 17 | ] 18 | 19 | -------------------------------------------------------------------------------- /tests/Neblen/TypeChecker/Tests.hs: -------------------------------------------------------------------------------- 1 | module Neblen.TypeChecker.Tests where 2 | 3 | import Test.Framework (Test, testGroup) 4 | import Test.Framework.Providers.HUnit (testCase) 5 | import Test.HUnit ((@?=)) 6 | 7 | import qualified Text.ParserCombinators.Parsec as P 8 | import Control.Monad.Trans.State 9 | import Control.Monad.Trans.Except 10 | import Control.Arrow (second) 11 | import qualified Data.Map.Strict as M 12 | 13 | import Neblen.Data 14 | import Neblen.TypeChecker 15 | import Neblen.Parser 16 | 17 | tests :: Test 18 | tests = testGroup "Neblen.TypeChecker.Tests" $ concat 19 | [ 20 | testUnify 21 | , testCheckLit 22 | , testCheckVar 23 | , testCheckLet 24 | , testCheckNullFun 25 | , testCheckFun 26 | , testCheckNullApp 27 | , testCheckUnaryApp 28 | , testCheckList 29 | , testCheckIf 30 | ] 31 | 32 | testUnify :: [Test] 33 | testUnify = 34 | [ 35 | "Int" <=> "Int" ==> [] 36 | , "Int" <=> "a" ==> [("a","Int")] 37 | , "Bool" "Int" ==> Mismatch TBool TInt 38 | 39 | , "(-> Int Int)" <=> "(-> a b)" ==> [("a","Int"),("b","Int")] 40 | , "(-> Int a)" <=> "(-> a b)" ==> [("a","Int"),("b","Int")] 41 | , "(-> Int a)" <=> "(-> b b)" ==> [("a","Int"),("b","Int")] 42 | 43 | , "(-> a b)" <=> "(-> a b)" ==> [] 44 | , "(-> a b)" <=> "(-> b d)" ==> [("a","d"),("b","d")] 45 | , "(-> a b)" <=> "(-> c d)" ==> [("a","c"),("b","d")] 46 | 47 | , "(-> a b c d)" <=> "(-> x y b a)" ==> [("a","x"),("b","y"),("c","y"),("d","x")] 48 | , "(-> a b c d e)" <=> "(-> x y b a)" ==> [("a","(-> d e)"),("b","y"),("c","y"),("x","(-> d e)")] 49 | , "(-> a b c d)" <=> "(-> x y)" ==> [("a","x"),("y","(-> b c d)")] 50 | , "(-> a b c Int)" <=> "(-> x y)" ==> [("a","x"),("y","(-> b c Int)")] 51 | , "(-> a b c Int)" "(-> x y z Bool)" ==> Mismatch TInt TBool 52 | , "(-> a b c)" "(-> x Int)" ==> Mismatch (TFun [TVar "b",TVar "c"]) TInt 53 | 54 | -- Nullary functions. 55 | , "(-> a)" <=> "(-> x)" ==> [("a","x")] 56 | , "(-> a)" <=> "(-> Int)" ==> [("a","Int")] 57 | , "(-> Int)" "Int" ==> Mismatch (TFun [TInt]) TInt 58 | , "(-> Int)" "(-> a b)" ==> FunctionExpected TInt 59 | 60 | , "a" "(-> a Int)" ==> InfiniteType (TVar "a") (TFun [TVar "a",TInt]) 61 | ] 62 | 63 | testCheckLit :: [Test] 64 | testCheckLit = 65 | [ 66 | "0" =~> "Int" 67 | , "true" =~> "Bool" 68 | , "\"\"" =~> "String" 69 | ] 70 | 71 | testCheckVar :: [Test] 72 | testCheckVar = 73 | [ 74 | "x" ~~> "Int" `withEnv` [("x","Int")] 75 | , "x" =!> UnboundVariable "x" 76 | ] 77 | 78 | testCheckLet :: [Test] 79 | testCheckLet = 80 | [ 81 | "(let [x 0] x)" =~> "Int" 82 | , "(let [x 0] true)" =~> "Bool" 83 | , "(let [x (fn [a] a)] (let [y (fn [b c] (b (x 0)))] (let [z (y (fn [z] z))] x)))" =~> "(-> a a)" 84 | , "(let [x (fn [a] a)] (let [y (fn [b c] (b (x 0)))] (let [z (y (fn [z] z))] y)))" =~> "(-> (-> Int a) b a)" 85 | , "(let [x (fn [a] a)] (let [y (fn [b c] (b (x 0)))] (let [z (y (fn [z] z))] z)))" =~> "(-> a Int)" 86 | , "(let [x 0] b)" ~~> "Bool" `withEnv` [("b","Bool")] 87 | 88 | -- let-polymorphism should look up existing type of 'f' when infering 'g'. 89 | , "((fn [f] (let [g f] (g 0))) (fn [x] true))" =~> "Bool" 90 | 91 | -- let-polymorphism on id function 92 | , "(let [id (fn [x] x) y (id 3) z (id true)] z)" =~> "Bool" 93 | , "(let [id (fn [x] x) y (id 3) z (id true)] y)" =~> "Int" 94 | , "(let [twice (fn [f x] (f (f x))) a (twice (fn [x] 10) 1) b (twice (fn [x] true) false)] a)" =~> "Int" 95 | , "(let [twice (fn [f x] (f (f x))) a (twice (fn [x] 10) 1) b (twice (fn [x] true) false)] b)" =~> "Bool" 96 | , "(let [twice (fn [f x] (f (f x))) a (twice (fn [x] 10) true)] a)" =!> Mismatch TInt TBool 97 | 98 | -- rank 3 let-polymorphism (@id@ and @g@ both used with two different types) 99 | , "(let [id (fn [x] x) g (fn [f x] (f x)) u (g id 3) v (g id true)] v)" =~> "Bool" 100 | 101 | -- Checks that let-polymorphism doesn't generalize variables that are bound. 102 | -- Pierce pg 334. 103 | , "((fn [f] (let [g f] (g 0))) (fn [x] (if x x x)))" =!> Mismatch TBool (TVar "c") 104 | ] 105 | 106 | testCheckNullFun :: [Test] 107 | testCheckNullFun = 108 | [ 109 | "(fn [] 0)" =~> "(-> Int)" 110 | , "(fn [] (fn [] 0))" =~> "(-> (-> Int))" 111 | , "(fn [] x)" =!> UnboundVariable "x" 112 | ] 113 | 114 | testCheckFun :: [Test] 115 | testCheckFun = 116 | [ 117 | "(fn [x] (fn [y] 0))" =~> "(-> a (-> b Int))" 118 | , "(fn [x] (fn [y] x))" =~> "(-> a (-> b a))" 119 | , "(fn [x] (x 3))" =~> "(-> (-> Int a) a)" 120 | , "(fn [x] (let [z (fn [y] (x 3))] x))" =~> "(-> (-> Int a) (-> Int a))" 121 | , "(fn [f] (fn [x] (f x)))" =~> "(-> (-> a b) (-> a b))" 122 | , "(fn [f g h] (fn [x y] (f (g (h (y x))))))" =~> "(-> (-> a b) (-> c a) (-> d c) (-> e (-> e d) b))" 123 | 124 | -- Argument should not override outside scope 125 | , "((fn [y] (fn [x] y)) x)" ~~> "(-> a Bool)" `withEnv` [("x","Bool")] 126 | 127 | -- The "double" function from Pierce (pg 333) 128 | , "(fn [f] (fn [x] (f (f x))))" =~> "(-> (-> a a) (-> a a))" 129 | 130 | , "(fn [x] (x x))" =!> InfiniteType (TVar "a") (TFun [TVar "a",TVar "b"]) 131 | ] 132 | 133 | testCheckNullApp :: [Test] 134 | testCheckNullApp = 135 | [ 136 | "(x)" ~~> "Bool" `withEnv` [("x","(-> Bool)")] 137 | , "((fn [] true))" =~> "Bool" 138 | , "(let [f (fn [] 0)] ((fn [f] (f)) f))" =~> "Int" 139 | , "(let [x true] (x))" =!> FunctionExpected TBool 140 | , "(x)" =!> UnboundVariable "x" 141 | ] 142 | 143 | testCheckUnaryApp :: [Test] 144 | testCheckUnaryApp = 145 | [ 146 | "(x 0)" ~~> "Bool" `withEnv` [("x","(-> Int Bool)")] 147 | , "(let [x true] (f x))" ~~> "Bool" `withEnv` [("f","(-> Bool Bool)")] 148 | , "((fn [x] x) f)" ~~> "(-> Int Bool)" `withEnv` [("f","(-> Int Bool)")] 149 | , "((fn [x] (fn [y] x)) 0)" =~> "(-> a Int)" 150 | , "(((fn [x] (fn [y] x)) 0) true)" =~> "Int" 151 | , "((fn [x] (x 3)) (fn [x] x))" =~> "Int" 152 | , "(let [x (fn [y] y)] (x x))" =~> "(-> a a)" 153 | , "((fn [y] (y 3)) x)" ~~> "Int" `withEnv` [("x","(-> z z)")] 154 | 155 | , "(let [x (fn [y] (+ 1 y))] (x 3))" =~> "Int" 156 | , "(let [x (fn [y] (* 2 y))] (x 3))" =~> "Int" 157 | , "(let [x (fn [y] (and y true))] (x true))" =~> "Bool" 158 | , "(let [x (fn [y] (or y true))] (x true))" =~> "Bool" 159 | , "(let [x (fn [y] (xor y true))] (x true))" =~> "Bool" 160 | 161 | , "(x 0)" =!> UnboundVariable "x" 162 | , "(x 0)" ~!> FunctionExpected TInt `withEnv` [("x","Int")] 163 | , "(x 0)" ~!> Mismatch TBool TInt `withEnv` [("x","(-> Bool Int)")] 164 | ] 165 | 166 | testCheckList :: [Test] 167 | testCheckList = 168 | [ 169 | "[]" =~> "[a]" 170 | , "[0]" =~> "[Int]" 171 | , "[0 ((fn [x] x) 0) 123]" =~> "[Int]" 172 | , "[0 true]" =!> Mismatch TInt TBool 173 | ] 174 | 175 | testCheckIf :: [Test] 176 | testCheckIf = 177 | [ 178 | "(if ((fn [x] true) 0) \"truth\" \"false\")" =~> "String" 179 | , "(if true (fn [x] x) (fn [y] y))" =~> "(-> a a)" 180 | , "(if false 0 false)" =!> Mismatch TInt TBool 181 | ] 182 | 183 | ---------------------- 184 | -- Utility functions 185 | ---------------------- 186 | 187 | toType :: String -> Type 188 | toType s = 189 | case P.parse parseType "" s of 190 | Right t -> t 191 | Left _ -> error ("Bad test case. Could not parse type: " ++ show s) 192 | 193 | toExp :: String -> Exp 194 | toExp s = 195 | case P.parse parseExp "" s of 196 | Right t -> t 197 | Left _ -> error ("Bad test case. Could not parse expression: " ++ show s) 198 | 199 | toSubst :: [(TName,String)] -> Subst 200 | toSubst pairs = M.fromList (map (second toType) pairs) 201 | 202 | -- | Create unify test with expected Subst. 203 | (<=>) :: 204 | String -- First type 205 | -> String -- Second type 206 | -> [(TName, String)] -- Expected Subst 207 | -> Test 208 | (<=>) a b pairs = 209 | testCase ("unify: " ++ a ++ " <=> " ++ b) $ 210 | run (unify (toType a) (toType b)) 211 | @?= toSubst pairs 212 | 213 | -- | Create unify test with expected TypeError. 214 | () :: 215 | String -- First type 216 | -> String -- Second type 217 | -> TypeError -- Expected error 218 | -> Test 219 | () a b e = 220 | testCase ("unify: " ++ a ++ " <=> " ++ b) $ 221 | expectE (unify (toType a) (toType b)) 222 | @?= e 223 | 224 | -- | Helper method to make tests look nicer. 225 | (==>) :: a -> a 226 | (==>) = id 227 | 228 | (~~>) :: String -> String -> [(Name,String)] -> Test 229 | (~~>) expr t tenv = 230 | testCase ("check: " ++ expr ++ " : " ++ t) $ 231 | run (checkTypeWith (toExp expr) (M.fromList (map (second (toScheme . toType)) tenv))) 232 | @?= toType t 233 | 234 | (~!>) :: 235 | String 236 | -> TypeError 237 | -> [(Name,String)] 238 | -> Test 239 | (~!>) expr err tenv = 240 | testCase ("check to error: " ++ expr) $ 241 | expectE (check (M.fromList (map (second (toScheme . toType)) tenv)) emptySubst (toExp expr)) 242 | @?= err 243 | 244 | withEnv :: a -> a 245 | withEnv = id 246 | 247 | (=~>) :: 248 | String 249 | -> String 250 | -> Test 251 | (=~>) expr t = 252 | testCase ("check: " ++ expr ++ " : " ++ t) $ 253 | run (checkType (toExp expr)) 254 | @?= toType t 255 | 256 | (=!>) :: 257 | String 258 | -> TypeError 259 | -> Test 260 | (=!>) expr err = 261 | testCase ("check to error: " ++ expr) $ 262 | expectE (check emptyTEnv emptySubst (toExp expr)) 263 | @?= err 264 | 265 | ---------------------- 266 | -- Runners 267 | ---------------------- 268 | 269 | run :: ExceptT TypeError (State FreshCounter) a -> a 270 | run u = case evalState (runExceptT u) initFreshCounter of 271 | Left e -> error $ show e 272 | Right r -> r 273 | 274 | expectE :: Show a => ExceptT TypeError (State FreshCounter) a -> TypeError 275 | expectE u = case evalState (runExceptT u) initFreshCounter of 276 | Left e -> e 277 | Right r -> error $ "Expected error but got: " ++ show r 278 | 279 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Framework 4 | import Data.Monoid 5 | 6 | import qualified Neblen.TypeChecker.Tests 7 | import qualified Neblen.Eval.Tests 8 | 9 | -- Get empty options and update with our options. 10 | runnerOpts :: RunnerOptions 11 | runnerOpts = mempty { 12 | ropt_color_mode = Just ColorAlways, 13 | ropt_hide_successes = Just False 14 | } 15 | 16 | main :: IO () 17 | main = 18 | defaultMainWithOpts 19 | [ 20 | Neblen.TypeChecker.Tests.tests 21 | , Neblen.Eval.Tests.tests 22 | ] 23 | runnerOpts 24 | --------------------------------------------------------------------------------