├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── app └── Main.hs ├── artemis.cabal ├── examples ├── arithmetic.ar ├── calculator.ar ├── factorial.ar ├── matching.ar ├── mutualrecursion.ar ├── namespaces.ar └── parser.ar ├── libs ├── either.ar ├── list.ar ├── maybe.ar ├── std.ar └── tuple.ar ├── package.yaml ├── src ├── AST.hs ├── BuiltIn.hs ├── Infer.hs ├── Interpreter.hs ├── Lexer.hs ├── Name.hs ├── Parser.hs ├── Resolver.hs ├── Type.hs └── Value.hs ├── stack.yaml ├── stack.yaml.lock ├── test └── Spec.hs └── vim ├── ftdetect └── artemis.vim └── syntax └── artemis.vim /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for artemis 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Artemis 2 | 3 | Artemis is a statically typed, functional programming language with some inspirations from Rust, ML, and Haskell. It doesn't have too many exciting features as I am writing it for learning purposes. 4 | 5 | ## Features 6 | At the moment, Artemis has all of these implemented: 7 | - Type inference (Hindley-Milner) 8 | - Algebraic data types 9 | - Pattern matching 10 | - Module system via namespaces/imports 11 | - User-defined prefix/infix operators 12 | - A small standard library 13 | - Implementations for common data types (lists, tuples, etc.) 14 | - Non-significant whitespace 15 | - Automatic currying/partial application 16 | - Immutable variables by default 17 | - Built-in functions/types 18 | - Mutually recursive functions 19 | - Recursively defined types 20 | 21 | ## Planned 22 | It would be great to have these implemented eventually: 23 | - Typeclasses (for ad-hoc polymorphism) 24 | - Exhaustiveness/redundancy checking for pattern matching 25 | - An improved standard library 26 | - Bytecode VM 27 | 28 | ## Examples 29 | ``` 30 | data List = Cons(a, List) | Empty; 31 | 32 | let fold : (a -> b -> b) -> b -> List -> b 33 | = fn(f, init, list) 34 | => match list with 35 | Cons(a, list') -> f(a, fold(f, init, list')), 36 | Empty -> init; 37 | 38 | // 'fold' was automatically curried 39 | let sumInts = fold(addInt, 0); 40 | 41 | // outputs 15 42 | print(showInt(sumInts([1, 2, 3, 4, 5]))); 43 | ``` 44 | More can be found [here](https://github.com/05st/artemis/tree/master/examples). 45 | 46 | ## Contributing 47 | Feel free to open a pull request! 48 | 49 | ## Credits 50 | [brightly-salty](https://github.com/brightly-salty) 51 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Text as Text 4 | import qualified Data.Text.IO as TextIO 5 | import System.Environment 6 | import System.FilePath.Posix (takeBaseName) 7 | 8 | import Debug.Trace 9 | 10 | import Parser 11 | import Resolver 12 | import Infer 13 | import Interpreter 14 | import AST 15 | 16 | parseFiles :: [(String, Text.Text)] -> Either String UProgram 17 | parseFiles files = do 18 | modules <- mapM (\(file, input) -> parse input (takeBaseName file)) files 19 | Right (Program modules) 20 | 21 | main :: IO () 22 | main = do 23 | args <- getArgs 24 | let files = map takeBaseName args 25 | putStrLn $ "Reading " ++ show files 26 | inputs <- mapM TextIO.readFile args 27 | putStrLn $ "Parsing " ++ show files 28 | case parseFiles (zip files inputs) of 29 | Left err -> putStrLn $ "Parse Error: " ++ err 30 | Right program -> do 31 | putStrLn "Resolving names" 32 | let resolved = resolve program 33 | putStrLn "Inferring types" 34 | case annotate resolved of 35 | Left err -> putStrLn $ "Type Error: " ++ show err 36 | Right annotated -> do 37 | putStrLn "Interpreting program" 38 | interpret annotated 39 | -------------------------------------------------------------------------------- /artemis.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: artemis 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/05st/artemis#readme 11 | bug-reports: https://github.com/05st/artemis/issues 12 | author: 05st 13 | maintainer: example@example.com 14 | copyright: 2021 05st 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | ChangeLog.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/05st/artemis 25 | 26 | library 27 | exposed-modules: 28 | AST 29 | BuiltIn 30 | Infer 31 | Interpreter 32 | Lexer 33 | Name 34 | Parser 35 | Resolver 36 | Type 37 | Value 38 | other-modules: 39 | Paths_artemis 40 | hs-source-dirs: 41 | src 42 | build-depends: 43 | base >=4.7 && <5 44 | , containers 45 | , filepath 46 | , mtl 47 | , parsec 48 | , text 49 | , time 50 | default-language: Haskell2010 51 | 52 | executable artemis-exe 53 | main-is: Main.hs 54 | other-modules: 55 | Paths_artemis 56 | hs-source-dirs: 57 | app 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: 60 | artemis 61 | , base >=4.7 && <5 62 | , containers 63 | , filepath 64 | , mtl 65 | , parsec 66 | , text 67 | , time 68 | default-language: Haskell2010 69 | 70 | test-suite artemis-test 71 | type: exitcode-stdio-1.0 72 | main-is: Spec.hs 73 | other-modules: 74 | Paths_artemis 75 | hs-source-dirs: 76 | test 77 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 78 | build-depends: 79 | artemis 80 | , base >=4.7 && <5 81 | , containers 82 | , filepath 83 | , mtl 84 | , parsec 85 | , text 86 | , time 87 | default-language: Haskell2010 88 | -------------------------------------------------------------------------------- /examples/arithmetic.ar: -------------------------------------------------------------------------------- 1 | // Make sure to run with std.ar 2 | import std; 3 | 4 | let left = readFloat(input(())); 5 | let oper = match input(()) with 6 | Cons('+', Empty) -> addFloat, 7 | Cons('-', Empty) -> subFloat, 8 | Cons('*', Empty) -> mulFloat, 9 | Cons('/', Empty) -> divFloat, 10 | other -> error("Not a valid operator"); 11 | let right = readFloat(input(())); 12 | 13 | print(showFloat(oper(left, right))); 14 | -------------------------------------------------------------------------------- /examples/calculator.ar: -------------------------------------------------------------------------------- 1 | import std; // Redundant import, parser already imports std 2 | import parser; 3 | 4 | // Expression data type 5 | data Expr = Num(float) | Infix(char, Expr, Expr) | Prefix(char, Expr) | Func(List, List); 6 | 7 | let showExpr : Expr -> List 8 | = fnmatch 9 | Num(n) -> showFloat(n), 10 | Infix(op, l, r) -> "(" ++ showExpr(l) ++ [op] ++ showExpr(r) ++ ")", 11 | Prefix(op, a) -> "(" ++ [op] ++ showExpr(a) ++ ")", 12 | Func(f, args) -> f ++ "(" ++ intercalate(",", map(showExpr, args)) ++ ")"; 13 | 14 | // Parser 15 | let parseNum : Parser 16 | = fmapParser(Num . readFloat, manyParser $ parsePred(isDigit, "digit")); 17 | 18 | // Welp, we need to support mutual recursion before the calculator can be finished 19 | let parseValue : Parser 20 | = parseNum <|> parseParens(parseTerm); 21 | 22 | let parseFactor : Parser 23 | = bindParser(parseValue) 24 | $ fn(l) => bindParser(parseChar('*') <|> parseChar('/')) 25 | $ fn(op) => bindParser(parseFactor) 26 | $ fn(r) => pureParser(Infix(op, l, r)); 27 | 28 | let parseTerm : Parser 29 | = bindParser(parseFactor) 30 | $ fn(l) => bindParser(parseChar('+') <|> parseChar('-')) 31 | $ fn(op) => bindParser(parseTerm) 32 | $ fn(r) => pureParser(Infix(op, l, r)); 33 | 34 | let parse : List -> Expr 35 | = fn(input) 36 | => match runParser(parseTerm, input) with 37 | Pair(r_, Left(err)) -> error(showParserError(err)), 38 | Pair(r_, Right(expr)) -> expr; 39 | 40 | println . showExpr . parse . input $ (); 41 | -------------------------------------------------------------------------------- /examples/factorial.ar: -------------------------------------------------------------------------------- 1 | /* Prints the number of nanoseconds it took 2 | * to compute factorial(1000). 3 | * The built-in 'clock' function returns the 4 | * number of nanoseconds since the UNIX epoch. 5 | */ 6 | 7 | let factorial : int -> int 8 | = fn(n) 9 | => if eqInt(n, 2) 10 | then 2 11 | else mulInt(n, factorial(subInt(n, 1))); 12 | 13 | let init = clock(()); 14 | factorial(1000); 15 | let end = clock(()); 16 | 17 | print(showInt(subInt(end, init))); 18 | 19 | -------------------------------------------------------------------------------- /examples/matching.ar: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | // Artemis supports pattern matching: 4 | let num = readInt(input(())); 5 | 6 | match num with 7 | 0 -> println("I matched 0"), // You can match literals or value constructors 8 | 1 -> println("I matched 1"), 9 | x -> println(showInt(x)); // Variables match anything 10 | 11 | // fnmatch acts as sugar for a function followed by match expressions 12 | // It also has a unique feature, it can match all of the parameters at once 13 | // Under the hood, it is desugared into a bunch of nested match expressions. 14 | 15 | // The following function takes two bools and checks if both are true. 16 | // Obviously, this is only used for demonstrating the functionality 17 | // of fnmatch. 18 | let areBothTrue : bool -> bool -> List 19 | = fnmatch 20 | true, true -> "Yes, they're both true", 21 | false, false -> "No, they're both false", 22 | x, y -> "They aren't the same"; 23 | 24 | -------------------------------------------------------------------------------- /examples/mutualrecursion.ar: -------------------------------------------------------------------------------- 1 | let even = fnmatch 2 | 0 -> true, 3 | n -> odd(subInt(n, 1)); 4 | and odd = fnmatch 5 | 0 -> false, 6 | n -> even(subInt(n, 1)); 7 | 8 | print(showBool(even(20))); 9 | 10 | -------------------------------------------------------------------------------- /examples/namespaces.ar: -------------------------------------------------------------------------------- 1 | // Make sure you run this along with std.ar 2 | import std; 3 | 4 | namespace other { 5 | let test = "abc"; 6 | } 7 | 8 | namespace other2 { 9 | import namespaces::other; 10 | let test2 = test; 11 | namespace abc { 12 | let factorial : int -> int 13 | = fn(n) 14 | => if eqInt(n, 1) 15 | then 1 16 | else mulInt(n, factorial(subInt(n, 1))); 17 | } 18 | } 19 | 20 | namespace next { 21 | import namespaces::other2::abc; 22 | let anotherTest = test2; 23 | print(showInt(factorial(10))); 24 | print("\n"); 25 | } 26 | 27 | -------------------------------------------------------------------------------- /examples/parser.ar: -------------------------------------------------------------------------------- 1 | // This example demonstrates a very simple implementation of a parser combinator library in Artemis. 2 | 3 | import std; // uses list, tuple, either 4 | 5 | data ParserError = ExpectEncounter(List, List); 6 | 7 | let showParserError : ParserError -> List 8 | = fnmatch 9 | ExpectEncounter(expect, encounter) -> "Expected: " ++ expect ++ "; encountered: " ++ encounter ++ "."; 10 | 11 | // Parser monad definition 12 | data Parser = Parser(List -> Pair, Either>); 13 | 14 | // Extracts parser function 15 | let runParser : Parser -> List -> Pair, Either> 16 | = fnmatch 17 | Parser(f) -> f; 18 | 19 | // Parser is a functor 20 | let fmapParser : (a -> b) -> Parser -> Parser 21 | = fn(f, p) 22 | => Parser(fn(in) => 23 | match runParser(p, in) with 24 | Pair(rest, Left(err)) -> Pair(rest, Left(err)), 25 | Pair(rest, Right(parsed)) -> Pair(rest, Right(f(parsed)))); 26 | 27 | // Creates an instance of the parser monad 28 | let pureParser : a -> Parser 29 | = fn(a) 30 | => Parser(fn(in) => Pair(in, Right(a))); 31 | 32 | // Parser is an applicative (along with pureParser) 33 | let applyParser : Parser b> -> Parser -> Parser 34 | = fn(pf, p) 35 | => Parser(fn(in) => 36 | match runParser(pf, in) with 37 | Pair(rest, Left(err)) -> Pair(rest, Left(err)), 38 | Pair(rest, Right(f)) -> 39 | match runParser(p, rest) with 40 | Pair(rest', Left(err')) -> Pair(rest', Left(err')), 41 | Pair(rest', Right(x)) -> Pair(rest', Right(f(x)))); 42 | 43 | // Parser is a monad 44 | let bindParser : Parser -> (a -> Parser) -> Parser 45 | = fn(p, f) 46 | => Parser(fn(in) => 47 | match runParser(p, in) with 48 | Pair(rest, Left(err)) -> Pair(rest, Left(err)), 49 | Pair(rest, Right(a)) -> 50 | match runParser (f(a), rest) with 51 | Pair(rest', Left(err')) -> Pair(rest', Left(err')), 52 | Pair(rest', Right(b)) -> Pair(rest', Right(b))); 53 | 54 | let (:*>) : Parser -> Parser -> Parser 55 | = fn(pa, pb) 56 | => bindParser(pa, fn(a_) => pb); 57 | 58 | let (<*:) : Parser -> Parser -> Parser 59 | = fn(pa, pb) 60 | => bindParser(pa, fn(a) => pb :*> pureParser(a)); 61 | 62 | // Runs parser, reverts stream on fail 63 | let tryParser : Parser -> Parser 64 | = fn(p) 65 | => Parser(fn(in) => 66 | match runParser(p, in) with 67 | Pair(rest_, Left(err)) -> Pair(in, Left(err)), 68 | Pair(rest, Right(a)) -> Pair(rest, Right(a))); 69 | 70 | // Attempts first parser, if it fails, runs second parser with rest of stream from first. 71 | let elseParser : Parser -> Parser -> Parser 72 | = fn(pa, pb) 73 | => Parser(fn(in) => 74 | match runParser(pa, in) with 75 | Pair(rest, Left(err)) -> runParser(pb, rest), 76 | Pair(rest, Right(a)) -> Pair(rest, Right(a))); 77 | let (<|>) = elseParser; 78 | 79 | // Parses zero or more 80 | let manyParser : Parser -> Parser> 81 | = fn(p) 82 | => { 83 | let go = fn(in) 84 | => match runParser(p, in) with 85 | Pair(rest_, Left(err)) -> Pair(in, Right(Empty)), 86 | Pair(rest, Right(a)) -> 87 | match go(rest) with 88 | Pair(rest', Left(err)) -> Pair(rest', Left(err)), 89 | Pair(rest', Right(as)) -> Pair(rest', Right(Cons(a, as))); 90 | pass Parser(go); 91 | }; 92 | 93 | // Parses one or more 94 | let someParser : Parser -> Parser> 95 | = fn(p) 96 | => Parser(fn(in) => 97 | match runParser(p, in) with 98 | Pair(rest, Left(err)) -> Pair(rest, Left(err)), 99 | Pair(rest, Right(a)) -> 100 | match runParser(manyParser(p), rest) with 101 | Pair(rest', Left(err)) -> Pair(rest', Left(err)), 102 | Pair(rest', Right(as)) -> Pair(rest', Right(Cons(a, as)))); 103 | 104 | // Parses any character 105 | let parseAny : Parser 106 | = Parser(fn(in) => match in with 107 | Cons(a, t) -> Pair(t, Right(a)), 108 | Empty -> Pair(Empty, Left(ExpectEncounter("any", "end of input")))); 109 | 110 | // Parses a character based on a predicate, the second parameter is the description used in an error 111 | let parsePred : (char -> bool) -> List -> Parser 112 | = fn(pred, desc) 113 | => { 114 | let check 115 | = fn(c) 116 | => if pred(c) 117 | then pureParser(c) 118 | else Parser(fn(in) => Pair(in, Left(ExpectEncounter(desc, Cons(c, Empty))))); 119 | pass bindParser(parseAny, check); 120 | }; 121 | 122 | // Parses a single specific character 123 | let parseChar : char -> Parser 124 | = fn(c) 125 | => parsePred(eqChar(c), Cons(c, Empty)); 126 | 127 | // Parses a sequence of characters 128 | let parseString : List -> Parser> 129 | = fn(s) 130 | => match s with 131 | Empty -> pureParser(Empty), 132 | Cons(c, cs) -> applyParser(fmapParser(Cons, parseChar(c)), parseString(cs)); 133 | 134 | let parseParens : Parser -> Parser 135 | = fn(p) => parseChar('(') :*> p <*: parseChar(')'); 136 | 137 | /* 138 | match runParser(parseParens(someParser(parseChar('a'))), "(aa)ba!there") with 139 | Pair(rest, Left(err)) -> print(showParserError(err) ++ "\nRest: " ++ rest ++ "\n"), 140 | Pair(rest, Right(res)) -> print("Parsed: " ++ res ++ "\nRest: " ++ rest ++ "\n"); 141 | // FIXME: BUG ABOVE print(res ++ "\n"...) will int typecheck, even if res is a char 142 | */ 143 | -------------------------------------------------------------------------------- /libs/either.ar: -------------------------------------------------------------------------------- 1 | import maybe; 2 | 3 | // Either data type definition 4 | data Either = Left(a) | Right(b); 5 | 6 | let leftToMaybe : Either -> Maybe 7 | = fnmatch 8 | Left(a) -> Some(a), 9 | Right(b_) -> None; 10 | 11 | -------------------------------------------------------------------------------- /libs/list.ar: -------------------------------------------------------------------------------- 1 | // The List data type. Simple implementation of a singly linked list. 2 | data List = Cons(a, List) | Empty; 3 | 4 | // Applies a function 'f' to each element of a list; maps it. 5 | let map : (a -> b) -> List -> List 6 | = fn(f, list) 7 | => match list with 8 | Cons(x, xs) -> Cons(f(x), map(f, xs)), 9 | Empty -> Empty; 10 | 11 | // Combines each element of a list with some function 'f', provided an initial value. 12 | // This implements a right-fold. 13 | let fold : (a -> b -> b) -> b -> List -> b 14 | = fn(f, a, list) 15 | => match list with 16 | Cons(x, xs) -> f(x, fold(f, a, xs)), 17 | Empty -> a; 18 | 19 | // Joins (concatenates) two lists. 20 | let join : List -> List -> List 21 | = fn(a, b) 22 | => match a with 23 | Cons(x, Empty) -> Cons(x, b), 24 | Cons(x, xs) -> Cons(x, join(xs, b)); 25 | 26 | let (++) = join; 27 | 28 | // Concatenates a list of lists. 29 | let concat : List> -> List 30 | = fnmatch 31 | Cons(x, xs) -> x ++ concat(xs), 32 | Empty -> Empty; 33 | 34 | // Adds 'a' in between each element of list. 35 | let intersperse : a -> List -> List 36 | = fn(a, list) 37 | => match list with 38 | Cons(x, Empty) -> Cons(x, Empty), 39 | Cons(x, xs) -> Cons(x, Cons(a, intersperse(a, xs))), 40 | Empty -> Empty; 41 | 42 | // Read definition of function for explanation 43 | let intercalate : List -> List> -> List 44 | = fn(a, list) 45 | => concat(intersperse(a, list)); 46 | 47 | // Extracts first element of list, if empty throw an error. 48 | let head : List -> a 49 | = fnmatch 50 | Cons(x, l_) -> x, 51 | Empty -> error("list::head Empty"); 52 | 53 | // Returns entire list except first element. If empty, throws an error. 54 | let tail : List -> List 55 | = fnmatch 56 | Cons(x_, tail) -> tail, 57 | Empty -> error("list::tail Empty"); 58 | 59 | -------------------------------------------------------------------------------- /libs/maybe.ar: -------------------------------------------------------------------------------- 1 | import list; 2 | 3 | data Maybe = Some(a) | None; 4 | 5 | // Takes a default value, if the Maybe is None, evaluates to that. 6 | // Otherwise, evaluates to the value inside the Maybe. 7 | let fromMaybe : a -> Maybe -> a 8 | = fn(a, m) 9 | => match m with 10 | Some(x) -> x, 11 | None -> a; 12 | 13 | // Attempts to unwrap a Maybe. If it is None, throws an error. 14 | let unwrapMaybe : Maybe -> a 15 | = fnmatch 16 | Some(x) -> x, 17 | None -> error("maybe::unwrapMaybe None"); 18 | 19 | -------------------------------------------------------------------------------- /libs/std.ar: -------------------------------------------------------------------------------- 1 | import list; 2 | import maybe; 3 | import either; 4 | import tuple; 5 | 6 | let (+) = addInt; 7 | let (-) = subInt; 8 | let (*) = mulInt; 9 | let (/) = divInt; 10 | 11 | let (+.) = addFloat; 12 | let (-.) = subFloat; 13 | let (*.) = mulFloat; 14 | let (/.) = divFloat; 15 | 16 | let isDigit : char -> bool 17 | = fn(c) 18 | => leqInt(ordChar(c) - ordChar('0'), 7); 19 | 20 | let ($) : (a -> b) -> a -> b 21 | = fn(f, a) => f(a); 22 | 23 | let (.) : (b -> c) -> (a -> b) -> (a -> c) 24 | = fn(f, g, x) => f(g(x)); 25 | 26 | let println : List -> () 27 | = fn(out) => print(out ++ "\n"); 28 | 29 | -------------------------------------------------------------------------------- /libs/tuple.ar: -------------------------------------------------------------------------------- 1 | // Definitions of tuple types 2 | data Pair = Pair(a, b); 3 | data Tuple3 = Tuple3(a, b, c); 4 | data Tuple4 = Tuple4(a, b, c, d); 5 | data Tuple5 = Tuple5(a, b, c, d, e); 6 | 7 | // Gets the first element in a Pair 8 | let fst : Pair -> a 9 | = fnmatch 10 | Pair(a, b) -> a; 11 | 12 | // Gets the second element in a Pair 13 | let snd : Pair -> b 14 | = fnmatch 15 | Pair(a, b) -> b; 16 | 17 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: artemis 2 | version: 0.1.0.0 3 | github: "05st/artemis" 4 | license: BSD3 5 | author: "05st" 6 | maintainer: "example@example.com" 7 | copyright: "2021 05st" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - parsec 25 | - mtl 26 | - containers 27 | - text 28 | - time 29 | - filepath 30 | 31 | library: 32 | source-dirs: src 33 | 34 | executables: 35 | artemis-exe: 36 | main: Main.hs 37 | source-dirs: app 38 | ghc-options: 39 | - -threaded 40 | - -rtsopts 41 | - -with-rtsopts=-N 42 | dependencies: 43 | - artemis 44 | 45 | tests: 46 | artemis-test: 47 | main: Spec.hs 48 | source-dirs: test 49 | ghc-options: 50 | - -threaded 51 | - -rtsopts 52 | - -with-rtsopts=-N 53 | dependencies: 54 | - artemis 55 | -------------------------------------------------------------------------------- /src/AST.hs: -------------------------------------------------------------------------------- 1 | {-# Language DeriveFunctor #-} 2 | 3 | module AST where 4 | 5 | import Type 6 | import Name 7 | 8 | type Oper = String 9 | type Mutable = Bool 10 | 11 | newtype Program a = Program [Decl a] deriving (Show, Functor) 12 | data DVar a = DV Mutable (Maybe Type) QualifiedName (Expr a) deriving (Show, Functor) 13 | data Decl a = DStmt (Stmt a) 14 | | DNamespace String [Decl a] [Namespace] 15 | | DVar [DVar a] 16 | | DData QualifiedName [TVar] [(QualifiedName, [Type])] deriving (Show, Functor) 17 | data Stmt a = SExpr (Expr a) | SPass (Expr a) deriving (Show, Functor) 18 | data Expr a = EIdent a QualifiedName | ELit a Lit | EFunc a String (Expr a) 19 | | EIf a (Expr a) (Expr a) (Expr a) | EMatch a (Expr a) [(Pattern, Expr a)] | EBlock a [Decl a] 20 | | EBinary a Oper (Expr a) (Expr a) | EUnary a Oper (Expr a) | EAssign a QualifiedName (Expr a) | ECall a (Expr a) (Expr a) 21 | deriving (Show, Functor) 22 | data Lit = LInt Integer | LFloat Double | LBool Bool | LChar Char | LUnit deriving (Eq, Show) 23 | 24 | type UProgram = Program () 25 | type UDecl = Decl () 26 | type UDVar = DVar () 27 | type UStmt = Stmt () 28 | type UExpr = Expr () 29 | 30 | type TProgram = Program Type 31 | type TDecl = Decl Type 32 | type TDVar = DVar Type 33 | type TStmt = Stmt Type 34 | type TExpr = Expr Type 35 | 36 | data Pattern = PVar String | PCon QualifiedName [Pattern] | PLit Lit deriving (Eq, Show) 37 | -------------------------------------------------------------------------------- /src/BuiltIn.hs: -------------------------------------------------------------------------------- 1 | module BuiltIn (defTEnv, defEnv) where 2 | 3 | import Data.Functor 4 | import qualified Data.Set as Set 5 | import qualified Data.Map as Map 6 | 7 | import Data.Char 8 | import Data.Time 9 | import Data.Time.Clock.POSIX 10 | import System.IO 11 | 12 | import Type 13 | import Value 14 | import Name 15 | 16 | -- Built-in functions, type checker guarantees that these patterns are matched 17 | addInt [VInt a, VInt b] = return $ VInt (a + b) 18 | subInt [VInt a, VInt b] = return $ VInt (a - b) 19 | mulInt [VInt a, VInt b] = return $ VInt (a * b) 20 | divInt [VInt a, VInt b] = return $ VInt (a `div` b) 21 | floor' [VFloat a] = return $ VInt (floor a) 22 | ordChar [VChar c] = return $ VInt (fromIntegral (ord c)) 23 | 24 | addFloat [VFloat a, VFloat b] = return $ VFloat (a + b) 25 | subFloat [VFloat a, VFloat b] = return $ VFloat (a - b) 26 | mulFloat [VFloat a, VFloat b] = return $ VFloat (a * b) 27 | divFloat [VFloat a, VFloat b] = return $ VFloat (a / b) 28 | intToFloat [VInt a] = return $ VFloat (fromIntegral a) 29 | 30 | eqInt [VInt a, VInt b] = return $ VBool (a == b) 31 | eqFloat [VFloat a, VFloat b] = return $ VBool (a == b) 32 | eqBool [VBool a, VBool b] = return $ VBool (a == b) 33 | eqChar [VChar a, VChar b] = return $ VBool (a == b) 34 | 35 | leqInt [VInt a, VInt b] = return $ VBool (a <= b) 36 | 37 | showInt [VInt a] = return $ fromString (show a) 38 | showFloat [VFloat a] = return $ fromString (show a) 39 | showBool [VBool a] = return $ fromString $ if a then "true" else "false" 40 | showChar' [VChar a] = return $ fromString (show a) 41 | showUnit [VUnit] = return $ fromString "()" 42 | 43 | readInt [a] = return $ VInt (read $ toString a) 44 | readFloat [a] = return $ VFloat (read $ toString a) 45 | 46 | print' [a] = putStr (toString a) >> hFlush stdout >> return VUnit 47 | error' [a] = Prelude.error $ "ERROR: " ++ toString a 48 | clock [a] = getCurrentTime <&> VInt . floor . (1e9 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds 49 | 50 | input [a] = getLine <&> fromString 51 | 52 | 53 | -- Helper function 54 | -- Turns a List into a Haskell [Char] 55 | toString :: Value -> String 56 | toString (VData (Qualified _ "Cons") [VChar c, n]) = c : toString n 57 | toString (VData (Qualified _"Empty") []) = [] 58 | toString _ = error "Not possible" 59 | 60 | fromString :: String -> Value 61 | fromString (c : cs) = VData (Qualified (Relative Global "std") "Cons") [VChar c, fromString cs] 62 | fromString [] = VData (Qualified (Relative Global "std") "Empty") [] 63 | 64 | builtIn :: String -> ([Value] -> IO Value) -> Int -> [TVar] -> Type -> (String, Value, Scheme, Bool) 65 | builtIn name fn arity vs t = (name, VFunc (BuiltIn arity [] fn), Forall (Set.fromList vs) t, False) 66 | 67 | toQualified :: String -> QualifiedName 68 | toQualified = Qualified Global 69 | 70 | builtIns :: [(String, Value, Scheme, Bool)] 71 | builtIns = [ 72 | builtIn "addInt" addInt 2 [] (TInt :-> (TInt :-> TInt)), 73 | builtIn "subInt" subInt 2 [] (TInt :-> (TInt :-> TInt)), 74 | builtIn "mulInt" mulInt 2 [] (TInt :-> (TInt :-> TInt)), 75 | builtIn "divInt" divInt 2 [] (TInt :-> (TInt :-> TInt)), 76 | builtIn "floor" floor' 1 [] (TFloat :-> TInt), 77 | builtIn "ordChar" ordChar 1 [] (TChar :-> TInt), 78 | 79 | builtIn "addFloat" addFloat 2 [] (TFloat :-> (TFloat :-> TFloat)), 80 | builtIn "subFloat" subFloat 2 [] (TFloat :-> (TFloat :-> TFloat)), 81 | builtIn "mulFloat" mulFloat 2 [] (TFloat :-> (TFloat :-> TFloat)), 82 | builtIn "divFloat" divFloat 2 [] (TFloat :-> (TFloat :-> TFloat)), 83 | builtIn "intToFloat" intToFloat 1 [] (TInt :-> TFloat), 84 | 85 | builtIn "eqInt" eqInt 2 [] (TInt :-> (TInt :-> TBool)), 86 | builtIn "leqInt" leqInt 2 [] (TInt :-> (TInt :-> TBool)), 87 | 88 | builtIn "eqFloat" eqFloat 2 [] (TFloat :-> (TFloat :-> TBool)), 89 | builtIn "eqBool" eqBool 2 [] (TBool :-> (TBool :-> TBool)), 90 | builtIn "eqChar" eqChar 2 [] (TChar :-> (TChar :-> TBool)), 91 | 92 | builtIn "showInt" showInt 1 [] (TInt :-> TList TChar), 93 | builtIn "showFloat" showFloat 1 [] (TFloat :-> TList TChar), 94 | builtIn "showBool" showBool 1 [] (TBool :-> TList TChar), 95 | builtIn "showChar" showChar' 1 [] (TChar :-> TList TChar), 96 | builtIn "showUnit" showUnit 1 [] (TUnit :-> TList TChar), 97 | 98 | builtIn "readInt" readInt 1 [] (TList TChar :-> TInt), 99 | builtIn "readFloat" readFloat 1 [] (TList TChar :-> TFloat), 100 | 101 | builtIn "print" print' 1 [] (TList TChar :-> TUnit), 102 | builtIn "error" error' 1 [TV "a" Star] (TList TChar :-> TVar (TV "a" Star)), 103 | builtIn "clock" clock 1 [] (TUnit :-> TInt), 104 | 105 | builtIn "input" input 1 [] (TUnit :-> TList TChar) 106 | ] 107 | 108 | defTEnv :: TEnv 109 | defTEnv = Map.fromList $ map (\(i, _, s, m) -> (toQualified i, (s, m))) builtIns 110 | 111 | defEnv :: Env 112 | defEnv = Map.fromList $ map (\(i, v, _, _) -> (toQualified i, v)) builtIns 113 | -------------------------------------------------------------------------------- /src/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# Language LambdaCase #-} 2 | {-# Language TupleSections #-} 3 | 4 | module Infer (annotate) where 5 | 6 | import Debug.Trace 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.RWS 10 | 11 | import Data.Functor 12 | import Data.Functor.Identity 13 | import Data.Maybe 14 | import Data.Foldable 15 | 16 | import qualified Data.Map as Map 17 | import qualified Data.Set as Set 18 | 19 | import AST 20 | import Type 21 | import BuiltIn 22 | import Name 23 | 24 | data TypeError = Mismatch Type Type | NotDefined QualifiedName | NotDefinedMany [TVar] | UnknownOperator Oper | NotMutable QualifiedName 25 | | EmptyBlock | EmptyMatch | BlockData | GlobalPass | BlockNamespace | InfiniteType TVar Type 26 | deriving (Show) 27 | 28 | type Infer a = RWST Namespace [Constraint] (TEnv, Map.Map Namespace [Namespace], Int) (Except TypeError) a 29 | type Solve a = ExceptT TypeError Identity a 30 | 31 | type Subst = Map.Map TVar Type 32 | 33 | class Substitutable a where 34 | tvs :: a -> Set.Set TVar 35 | apply :: Subst -> a -> a 36 | 37 | instance Substitutable Type where 38 | tvs (TVar tv) = Set.singleton tv 39 | tvs (TCon _ ts) = foldr (Set.union . tvs) Set.empty ts 40 | apply s t@(TVar tv) = Map.findWithDefault t tv s 41 | apply s (TCon c ts) = TCon c $ map (apply s) ts 42 | 43 | instance Substitutable Scheme where 44 | tvs (Forall vs t) = tvs t `Set.difference` vs 45 | apply s (Forall vs t) = Forall vs $ apply (foldr Map.delete s vs) t 46 | 47 | instance Substitutable Constraint where 48 | tvs (t1 :~: t2) = tvs t1 `Set.union` tvs t2 49 | apply s (t1 :~: t2) = apply s t1 :~: apply s t2 50 | 51 | instance Substitutable a => Substitutable [a] where 52 | tvs l = foldr (Set.union . tvs) Set.empty l 53 | apply s = map (apply s) 54 | 55 | annotate :: UProgram -> Either TypeError TProgram 56 | annotate (Program decls) = 57 | case runIdentity $ runExceptT $ runRWST (annotateNamespace decls []) Global (defTEnv, Map.empty, 0) of 58 | Left err -> Left err 59 | Right (p, _, cs) -> do 60 | s <- runSolve cs 61 | return . Program $ fmap (fmap (apply s)) p 62 | 63 | compose :: Subst -> Subst -> Subst 64 | compose a b = Map.map (apply a) b `Map.union` a 65 | 66 | unify :: Type -> Type -> Solve Subst 67 | unify a b | a == b = return Map.empty 68 | unify (TVar v) t = bind v t 69 | unify t (TVar v) = bind v t 70 | unify a@(TCon (Qualified _ c1) ts1) b@(TCon (Qualified _ c2) ts2) 71 | | c1 /= c2 = throwError $ Mismatch a b 72 | | otherwise = unifyMany ts1 ts2 73 | 74 | unifyMany :: [Type] -> [Type] -> Solve Subst 75 | unifyMany [] [] = return Map.empty 76 | unifyMany (t1 : ts1) (t2 : ts2) = 77 | do su1 <- unify t1 t2 78 | su2 <- unifyMany (apply su1 ts1) (apply su1 ts2) 79 | return (su2 `compose` su1) 80 | unifyMany t1 t2 = throwError $ Mismatch (head t1) (head t2) 81 | 82 | bind :: TVar -> Type -> Solve Subst 83 | bind v t 84 | | v `Set.member` tvs t = throwError $ InfiniteType v t 85 | | otherwise = return $ Map.singleton v t 86 | 87 | solve :: Subst -> [Constraint] -> Solve Subst 88 | solve s c = 89 | case c of 90 | [] -> return s 91 | ((t1 :~: t2) : cs) -> do 92 | s1 <- unify t1 t2 93 | let nsub = s1 `compose` s 94 | solve (s1 `compose` s) (apply s1 cs) 95 | 96 | runSolve :: [Constraint] -> Either TypeError Subst 97 | runSolve cs = runIdentity $ runExceptT $ solve Map.empty cs 98 | 99 | fresh :: Infer Type 100 | fresh = do 101 | (env, m, n) <- get 102 | put (env, m, n+1) 103 | return . TVar . flip TV Star $ varNames !! n 104 | where varNames = map ('_':) $ [1..] >>= flip replicateM ['a'..'z'] 105 | 106 | generalize :: TEnv -> Type -> Scheme 107 | generalize env t = Forall vs t 108 | where vs = tvs t `Set.difference` tvs (map fst (Map.elems env)) 109 | 110 | instantiate :: Scheme -> Infer Type 111 | instantiate (Forall vs t) = do 112 | let vs' = Set.toList vs 113 | nvs <- mapM (const fresh) vs' 114 | let s = Map.fromList (zip vs' nvs) 115 | return $ apply s t 116 | 117 | scoped :: QualifiedName -> (Scheme, Bool) -> Infer a -> Infer a 118 | scoped id d toRun = do 119 | (env, m, n) <- get 120 | put (Map.insert id d (Map.delete id env), m, n) 121 | res <- toRun 122 | (_, m', n') <- get 123 | put (env, m', n') 124 | return res 125 | 126 | scopedMany :: [(QualifiedName, (Scheme, Bool))] -> Infer a -> Infer a 127 | scopedMany [] m = m 128 | scopedMany ((id, d) : vs) m = scoped id d (scopedMany vs m) 129 | 130 | constrain :: Constraint -> Infer () 131 | constrain = tell . (:[]) 132 | 133 | valueConstructors :: QualifiedName -> [TVar] -> [(QualifiedName, [Type])] -> Infer () 134 | valueConstructors _ _ [] = return () 135 | valueConstructors tc tps ((vn, vts) : vcs) = do 136 | (env, m, n) <- get 137 | let tps' = map TVar tps 138 | let vtps = tvs tps' 139 | let vvts = tvs vts 140 | if (vtps `Set.intersection` vvts) /= vvts 141 | then throwError $ NotDefinedMany (Set.toList (vvts `Set.difference` vtps)) 142 | else let sc = generalize env $ foldr (:->) (TCon tc tps') vts 143 | in put (Map.insert vn (sc, False) (Map.delete vn env), m, n) *> valueConstructors tc tps vcs 144 | 145 | annotateNamespace :: [UDecl] -> [TDecl] -> Infer [TDecl] 146 | annotateNamespace [] tds = return $ reverse tds 147 | annotateNamespace (d : ds) tds = 148 | case d of 149 | DStmt s -> annotateStmt s >>= \s' -> annotateNamespace ds (DStmt s' : tds) 150 | DData tc tps vcs -> valueConstructors tc tps vcs *> annotateNamespace ds (DData tc tps vcs: tds) 151 | DVar decls -> inferVarDecls decls >>= annotateNamespace ds . (: tds) . DVar 152 | DNamespace name nds imps -> do 153 | ns <- ask 154 | (e, m, n) <- get 155 | let newns = Relative ns name 156 | put (e, Map.insert newns imps m, n) 157 | nds' <- local (const newns) (annotateNamespace nds []) 158 | annotateNamespace ds (DNamespace name nds' imps : tds) 159 | 160 | annotateStmt :: UStmt -> Infer TStmt 161 | annotateStmt = \case 162 | SExpr e -> infer e <&> SExpr . fst 163 | SPass _ -> throwError GlobalPass 164 | 165 | inferVarDecl :: (Type, UDVar) -> Infer (TDVar, Scheme, Bool) 166 | inferVarDecl (tvar, DV isMut typeAnnotation name expr) = do 167 | (env, _, _) <- get 168 | ((expr', etype), consts) <- listen $ infer expr 169 | subst <- liftEither $ runSolve consts 170 | let etype' = apply subst etype 171 | scheme = generalize env etype' 172 | when (isJust typeAnnotation) (constrain $ fromJust typeAnnotation :~: etype') 173 | constrain $ tvar :~: etype' 174 | return (DV isMut typeAnnotation name expr', scheme, isMut) 175 | 176 | inferVarDecls :: [UDVar] -> Infer [TDVar] 177 | inferVarDecls dvars = do 178 | let varNames = map varName dvars 179 | tvars <- traverse (const fresh) dvars 180 | let tvarSchemes = map (\tvar -> (Forall Set.empty tvar, False)) tvars 181 | let envEntries = zip varNames tvarSchemes 182 | (inferredVars, schemes, isMuts) <- unzip3 <$> scopedMany envEntries (traverse inferVarDecl (zip tvars dvars)) 183 | traverse_ (\(name, scheme, isMut) -> do 184 | (env, imps, n) <- get 185 | put (Map.insert name (scheme, isMut) (Map.delete name env), imps, n)) (zip3 varNames schemes isMuts) 186 | return inferredVars 187 | where 188 | varName (DV _ _ name _) = name 189 | 190 | {- 191 | inferVarDecls :: UDecl -> Infer (TDecl, Scheme) 192 | inferVarDecls (DVar m ta id e) = do 193 | (env, _, _) <- get 194 | recurType <- fresh 195 | ((e', t), c) <- listen $ scoped id (Forall Set.empty recurType, False) (infer e) 196 | s <- liftEither $ runSolve c 197 | let t' = apply s t 198 | sc = generalize env t' 199 | when (isJust ta) (constrain $ fromJust ta :~: t') 200 | constrain $ recurType :~: t' 201 | return (DVar m ta id e', sc) 202 | inferVarDecl _ = error "Not possible" 203 | -} 204 | 205 | inferBlock :: [UDecl] -> [TDecl] -> Infer ([TDecl], Type) 206 | inferBlock [] _ = throwError EmptyBlock 207 | inferBlock (d : ds) tds = 208 | case d of 209 | DStmt (SPass e) -> do 210 | (e', t) <- infer e 211 | return (reverse $ DStmt (SPass e') : tds, t) 212 | DStmt s -> do 213 | s' <- annotateStmt s 214 | inferBlock ds (DStmt s' : tds) 215 | DData {} -> throwError BlockData 216 | DVar decls -> inferVarDecls decls >>= inferBlock ds . (: tds) . DVar 217 | DNamespace {} -> throwError BlockNamespace 218 | 219 | inferLit :: Lit -> Infer (Lit, Type) 220 | inferLit = \case 221 | LInt n -> return (LInt n, TInt) 222 | LFloat n -> return (LFloat n, TFloat) 223 | LBool b -> return (LBool b, TBool) 224 | LChar c -> return (LChar c, TChar) 225 | LUnit -> return (LUnit, TUnit) 226 | 227 | infer :: UExpr -> Infer (TExpr, Type) 228 | infer = \case 229 | EIdent _ id -> lookupType id >>= \t -> return (EIdent t id, t) 230 | ELit _ l -> inferLit l >>= \(l', t) -> return (ELit t l', t) 231 | EFunc _ p e -> do 232 | pt <- fresh 233 | ns <- ask -- SHOULD BE RESOLVED ALREADY 234 | (e', rt) <- scoped (Qualified ns p) (Forall Set.empty pt, False) (infer e) 235 | let t = pt :-> rt 236 | return (EFunc t p e', t) 237 | EIf _ c a b -> do 238 | (c', ct) <- infer c 239 | (a', at) <- infer a 240 | (b', bt) <- infer b 241 | constrain $ ct :~: TBool 242 | constrain $ at :~: bt 243 | return (EIf at c' a' b', at) 244 | EMatch _ e bs -> do 245 | (e', et) <- infer e 246 | (bs', bts) <- unzip <$> mapM (inferBranch et) bs 247 | case bts of 248 | [] -> throwError EmptyMatch 249 | (bt : bts') -> (EMatch bt e' bs', bt) <$ sequence_ [constrain $ bt' :~: bt | bt' <- bts'] 250 | EBlock _ ds -> inferBlock ds [] >>= \(ds', t) -> return (EBlock t ds', t) 251 | EBinary _ op l r -> do 252 | (l', lt) <- infer l 253 | (r', rt) <- infer r 254 | t <- fresh 255 | let t1 = lt :-> (rt :-> t) 256 | ns <- ask -- SHOULD BE RESOLVED ALREADY 257 | let op' = Qualified ns op 258 | t2 <- lookupType op' 259 | constrain $ t1 :~: t2 260 | return (ECall t (ECall (rt :-> t) (EIdent t2 op') l') r', t)--(EBinary t op l' r', t) 261 | EUnary _ op a -> do 262 | (a', at) <- infer a 263 | t <- fresh 264 | ns <- ask -- SHOULD BE RESOLVED ALREADY 265 | let op' = Qualified ns op 266 | ot <- lookupType op' 267 | constrain $ (at :-> t) :~: ot 268 | return (ECall t (EIdent ot op') a', t) -- (EUnary t op a', t) 269 | EAssign _ id r -> do 270 | (r', rt) <- infer r 271 | idt <- lookupType id 272 | mut <- lookupMut id 273 | if mut 274 | then constrain (idt :~: rt) >> return (EAssign idt id r', idt) 275 | else throwError $ NotMutable id 276 | ECall _ f a -> do 277 | (f', ft) <- infer f 278 | (a', at) <- infer a 279 | rt <- fresh 280 | constrain $ ft :~: (at :-> rt) 281 | return (ECall rt f' a', rt) 282 | 283 | inferPattern :: Pattern -> Infer (Type, [(String, Scheme)]) 284 | inferPattern (PLit l) = inferLit l >>= \(_, t) -> return (t, []) 285 | inferPattern (PVar id) = fresh <&> \t -> (t, [(id, Forall Set.empty t)]) 286 | inferPattern (PCon con ps) = do 287 | (pts, vars) <- unzip <$> mapM inferPattern ps 288 | ft <- lookupType con 289 | t <- fresh 290 | let ft' = foldr (:->) t pts 291 | constrain $ ft' :~: ft 292 | return (t, concat vars) 293 | 294 | inferBranch :: Type -> (Pattern, UExpr) -> Infer ((Pattern, TExpr), Type) 295 | inferBranch mt (p, e) = do 296 | (pt, vars) <- inferPattern p 297 | constrain $ pt :~: mt 298 | ns <- ask -- SHOULD BE RESOLVED ALREADY 299 | (e', et) <- scopedMany (map (\(id, sc) -> (Qualified ns id, (sc, False))) vars) (infer e) 300 | return ((p, e'), et) 301 | 302 | ------------ 303 | -- Lookup -- 304 | ------------ 305 | 306 | lookupType :: QualifiedName -> Infer Type 307 | lookupType name = lookupEnv name >>= instantiate . fst 308 | 309 | lookupMut :: QualifiedName -> Infer Bool 310 | lookupMut name = snd <$> lookupEnv name 311 | 312 | lookupEnv :: QualifiedName -> Infer (Scheme, Bool) 313 | lookupEnv name = do 314 | res <- lookupEnv' name name 315 | case res of 316 | Nothing -> throwError $ NotDefined name 317 | Just res' -> return res' 318 | 319 | lookupEnv' :: QualifiedName -> QualifiedName -> Infer (Maybe (Scheme, Bool)) 320 | lookupEnv' name orig = do 321 | (env, m, _) <- get 322 | case Map.lookup name env of 323 | Just x -> return (Just x) 324 | Nothing -> case name of 325 | (Qualified Global _) -> do 326 | ns <- ask 327 | let imps = fromMaybe [] (Map.lookup ns m) 328 | lookupImports imps orig 329 | (Qualified (Relative parent _) s) -> lookupEnv' (Qualified parent s) orig 330 | 331 | lookupImports :: [Namespace] -> QualifiedName -> Infer (Maybe (Scheme, Bool)) 332 | lookupImports [] _ = return Nothing 333 | lookupImports (i : is) name@(Qualified ns os) = do 334 | let name' = Qualified i os 335 | res <- local (const i) (lookupEnv' name' name') 336 | case res of 337 | Just _ -> return res 338 | Nothing -> lookupImports is name 339 | 340 | -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# Language LambdaCase #-} 2 | 3 | module Interpreter (interpret) where 4 | 5 | import qualified Data.Map as Map 6 | import Data.Foldable 7 | import Data.Bifunctor 8 | 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | import Data.Maybe 12 | 13 | import System.IO 14 | 15 | import Debug.Trace 16 | 17 | import AST 18 | import Type 19 | import Value 20 | import BuiltIn 21 | import Name 22 | 23 | type Interpret a = ReaderT Namespace (StateT (Env, Map.Map Namespace [Namespace]) IO) a 24 | 25 | interpret :: TProgram -> IO () 26 | interpret (Program ds) = evalStateT (runReaderT (evalProgram ds) Global) (defEnv, Map.empty) 27 | 28 | evalProgram :: [TDecl] -> Interpret () 29 | evalProgram = foldr ((>>) . evalDecl) (return ()) 30 | 31 | evalDecl :: TDecl -> Interpret () 32 | evalDecl = \case 33 | DStmt s -> evalStmt s 34 | DVar decls -> do 35 | (names, values) <- unzip <$> traverse evalVarDecl decls 36 | let toInject = zip names values 37 | let values' = map (fillVFunc toInject) values 38 | traverse_ (\(name, value) -> do 39 | (env, m) <- get 40 | put (Map.insert name value env, m)) (zip names values') 41 | DData tc tps cs -> mapM_ valueConstructor cs 42 | DNamespace name decls imps -> do 43 | ns <- ask 44 | (e, imap) <- get 45 | let newns = Relative ns name 46 | put (e, Map.insert newns imps imap) 47 | local (const newns) (foldr ((>>) . evalDecl) (return ()) decls) 48 | 49 | fillVFunc :: [(QualifiedName, Value)] -> Value -> Value 50 | fillVFunc injects (VFunc (UserDef namespace _ param expr closure)) = VFunc (UserDef namespace injects param expr closure) 51 | fillVFunc _ other = other 52 | 53 | evalVarDecl :: TDVar -> Interpret (QualifiedName, Value) 54 | evalVarDecl (DV _ _ name expr) = (,) name <$> evalExpr expr 55 | 56 | valueConstructor :: (QualifiedName, [Type]) -> Interpret () 57 | valueConstructor (vc, vts) = do 58 | (env, m) <- get 59 | let arity = length vts 60 | case vts of 61 | [] -> put (Map.insert vc (VData vc []) env, m) 62 | _ -> put (Map.insert vc (VFunc (BuiltIn arity [] (return . VData vc))) env, m) 63 | 64 | evalStmt :: TStmt -> Interpret () 65 | evalStmt = \case 66 | SExpr e -> void (evalExpr e) 67 | SPass _ -> error "Not possible" 68 | 69 | evalLit :: Lit -> Value 70 | evalLit = \case 71 | LInt n -> VInt n 72 | LFloat n -> VFloat n 73 | LBool b -> VBool b 74 | LChar c -> VChar c 75 | LUnit -> VUnit 76 | 77 | evalExpr :: TExpr -> Interpret Value 78 | evalExpr = \case 79 | ELit _ l -> return $ evalLit l 80 | EIdent _ name -> lookupEnv name 81 | EFunc _ p e -> do 82 | ns <- ask -- SHOULD BE RESOLVED ALREADY 83 | (env, _) <- get 84 | return . VFunc $ UserDef ns [] (Qualified ns p) e env 85 | EIf _ c a b -> do 86 | c' <- evalExpr c 87 | let VBool cv = c' 88 | if cv then evalExpr a else evalExpr b 89 | EMatch _ e bs -> do 90 | e' <- evalExpr e 91 | let (p, be) = head $ dropWhile (\(p, _) -> not $ checkPattern e' p) bs 92 | setPatternVars e' p 93 | evalExpr be 94 | EBlock _ ds -> do 95 | orig <- get 96 | v <- evalBlock ds 97 | put orig 98 | return v 99 | ECall _ f a -> do 100 | f' <- evalExpr f 101 | a' <- evalExpr a 102 | let VFunc vf = f' 103 | case vf of 104 | UserDef ns toInject p e c -> do 105 | (orig, m) <- get 106 | let toInject' = map (second (fillVFunc toInject)) toInject 107 | let c' = c `Map.union` Map.fromList toInject' 108 | put (Map.insert p a' c', m) 109 | val <- local (const ns) (evalExpr e) 110 | (_, m') <- get 111 | put (orig, m') 112 | return val 113 | BuiltIn n args f -> do 114 | let args' = args ++ [a'] 115 | if length args' == n 116 | then liftIO (f args') 117 | else return $ VFunc (BuiltIn n args' f) 118 | EAssign _ id v -> do 119 | (e, m) <- get 120 | v' <- evalExpr v 121 | put (Map.insert id v' e, m) 122 | return v' 123 | _ -> error "Not possible" 124 | 125 | evalBlock :: [TDecl] -> Interpret Value 126 | evalBlock ((DStmt (SPass e)) : ds) = evalExpr e 127 | evalBlock (d : ds) = evalDecl d >> evalBlock ds 128 | evalBlock [] = error "No pass in block" 129 | 130 | checkPattern :: Value -> Pattern -> Bool 131 | checkPattern (VData (Qualified _ dcon) []) (PCon (Qualified _ con) []) = con == dcon 132 | checkPattern (VData (Qualified _ dcon) vs) (PCon (Qualified _ con) ps) = (con == dcon) && and [checkPattern v p | (v, p) <- zip vs ps] 133 | checkPattern _ (PVar _) = True 134 | checkPattern v (PLit l) = v == evalLit l 135 | checkPattern _ _ = False 136 | 137 | setPatternVars :: Value -> Pattern -> Interpret () 138 | setPatternVars val (PVar var) = do 139 | ns <- ask 140 | (env, m) <- get 141 | put (Map.insert (Qualified ns var) val env, m) 142 | setPatternVars (VData dcon vs) (PCon con ps) = sequence_ [setPatternVars v p | (v, p) <- zip vs ps] 143 | setPatternVars _ _ = return () 144 | 145 | ------------ 146 | -- Lookup -- 147 | ------------ 148 | 149 | lookupEnv :: QualifiedName -> Interpret Value 150 | lookupEnv name = do 151 | res <- lookupEnv' name name 152 | case res of 153 | Nothing -> error $ "Undefined " ++ show name 154 | Just res' -> return res' 155 | 156 | lookupEnv' :: QualifiedName -> QualifiedName -> Interpret (Maybe Value) 157 | lookupEnv' name orig = do 158 | (env, m) <- get 159 | case Map.lookup name env of 160 | Just x -> return (Just x) 161 | Nothing -> case name of 162 | (Qualified Global _) -> do 163 | ns <- ask 164 | let imps = fromMaybe [] (Map.lookup ns m) 165 | lookupImports imps orig 166 | (Qualified (Relative parent _) s) -> lookupEnv' (Qualified parent s) orig 167 | 168 | lookupImports :: [Namespace] -> QualifiedName -> Interpret (Maybe Value) 169 | lookupImports [] _ = return Nothing 170 | lookupImports (i : is) name@(Qualified ns s) = do 171 | let name' = Qualified i s 172 | res <- local (const i) (lookupEnv' name' name') 173 | case res of 174 | Just _ -> return res 175 | Nothing -> lookupImports is name 176 | -------------------------------------------------------------------------------- /src/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | 3 | module Lexer where 4 | 5 | import Control.Monad.Reader 6 | import qualified Data.Text as Text 7 | 8 | import Text.Parsec 9 | import qualified Text.Parsec.Token as Token 10 | 11 | import Name 12 | 13 | ----------- 14 | -- Lexer -- 15 | ----------- 16 | 17 | defOps :: [String] 18 | defOps = ["+", "-", "*", "/", "^", "=", "==", "!=", ">", ">=", "<", "<=", "!", "&&", "||"] 19 | 20 | lexer :: Token.GenTokenParser Text.Text () (Reader [Namespace]) 21 | lexer = Token.makeTokenParser $ Token.LanguageDef 22 | { Token.commentStart = "/*" 23 | , Token.commentEnd = "*/" 24 | , Token.commentLine = "//" 25 | , Token.nestedComments = True 26 | , Token.identStart = letter 27 | , Token.identLetter = alphaNum <|> oneOf "_'" 28 | , Token.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 29 | , Token.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 30 | , Token.reservedNames = ["fn", "fnmatch", "true", "false", "let", "mut", "pass", "int", "float", "bool", "char", 31 | "()", "void", "if", "then", "else", "match", "with", "data", "namespace", "import"] 32 | , Token.reservedOpNames = defOps ++ ["->", "=>", "|", "::"] 33 | , Token.caseSensitive = True } 34 | 35 | identifier = Token.identifier lexer 36 | reserved = Token.reserved lexer 37 | reservedOp = Token.reservedOp lexer 38 | operator = Token.operator lexer 39 | parens = Token.parens lexer 40 | -- integer = Token.integer lexer 41 | decimal = Token.decimal lexer 42 | octal = Token.octal lexer 43 | hexadecimal = Token.hexadecimal lexer 44 | float = Token.float lexer 45 | semi = Token.semi lexer 46 | colon = Token.colon lexer 47 | whitespace = Token.whiteSpace lexer 48 | braces = Token.braces lexer 49 | comma = Token.comma lexer 50 | dot = Token.dot lexer 51 | angles = Token.angles lexer 52 | brackets = Token.brackets lexer 53 | charLiteral = Token.charLiteral lexer 54 | stringLiteral = Token.stringLiteral lexer 55 | 56 | dataIdentifier = (:) <$> upper <*> identifier 57 | -------------------------------------------------------------------------------- /src/Name.hs: -------------------------------------------------------------------------------- 1 | module Name where 2 | 3 | data Namespace = Global | Relative Namespace String deriving (Eq, Ord) 4 | data QualifiedName = Qualified Namespace String deriving (Eq, Ord) 5 | 6 | instance Show Namespace where 7 | show Global = [] 8 | show (Relative parent name) = show parent ++ "::" ++ name 9 | 10 | instance Show QualifiedName where 11 | show (Qualified namespace name) = show namespace ++ "::" ++ name 12 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# Language TupleSections #-} 2 | 3 | module Parser (Parser.parse) where 4 | 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import qualified Data.Text as Text 8 | 9 | import Data.List (nub) 10 | 11 | import Text.Parsec hiding (State) 12 | import Text.Parsec.Expr 13 | import Text.Parsec.Language 14 | 15 | import Debug.Trace 16 | 17 | import Lexer 18 | import AST 19 | import Type 20 | import Name 21 | 22 | -- The Parser monad stack, Reader monad contains all of the imports so far. 23 | -- All imports from parent namespaces "propagate" down 24 | type Parser a = ParsecT Text.Text () (Reader [Namespace]) a 25 | 26 | ------------ 27 | -- Module -- 28 | ------------ 29 | -- Parses a single module, aka file, and wraps it in a namespace with 30 | -- the same name as the file. 31 | module' :: String -> Parser UDecl 32 | module' file = do 33 | whitespace 34 | imps <- imports 35 | declarations <- local (imps ++) (many declaration) 36 | whitespace *> eof 37 | return $ DNamespace file declarations imps 38 | 39 | ------------------ 40 | -- Declarations -- 41 | ------------------ 42 | -- Parsing all of the types of declarations, 43 | -- each declaration is either for variables, data types, namespaces, or statements. 44 | declaration :: Parser UDecl 45 | declaration = (DStmt <$> statement) <|> varDecl <|> dataDecl <|> namespaceDecl 46 | 47 | -- Parse variable declaration (let x = ;). 48 | -- Mutually recursive declarations are separated by "and" 49 | -- eg (let x = y; and y = x;) 50 | varDecl :: Parser UDecl 51 | varDecl = do 52 | reserved "let" 53 | decls <- sepBy1 var (reserved "and") 54 | return $ DVar decls 55 | 56 | -- Helper function for parsing each variable declaration 57 | -- separately. 58 | var :: Parser UDVar 59 | var = do 60 | isMut <- (True <$ reserved "mut") <|> (False <$ whitespace) -- if there is a 'mut' keyword following 'let', it is mutable 61 | id <- identifier <|> parens (operator <|> choice (map (\op -> reservedOp op >> return op) defOps)) 62 | typeAnnotation <- option Nothing (Just <$> (colon *> type')) -- optional type annotation, only for variable declarations 63 | reservedOp "=" 64 | expr <- expression 65 | semi 66 | return $ DV isMut typeAnnotation (Qualified Global id) expr 67 | -- this gets resolved to the correct namespace ^ during the resolver pass 68 | -- we don't want to be able to define a variable of some other namespace 69 | 70 | 71 | -- Parse data declaration (data X = A | B | ...); 72 | dataDecl :: Parser UDecl 73 | dataDecl = do 74 | reserved "data" 75 | typeName <- Qualified Global <$> dataIdentifier -- dataIdentifiers must start with a capital letter 76 | typeParams <- option [] (angles (sepBy (flip TV Star <$> identifier) comma)) -- type parameters are just parsed as type variables 77 | reservedOp "=" 78 | valueConstructors <- sepBy1 valueConstructor (reservedOp "|") -- parse value 79 | semi 80 | return $ DData typeName typeParams valueConstructors 81 | where 82 | -- valueConstructor :: Parser (QualifiedName, [Type]) 83 | valueConstructor = do 84 | name <- Qualified Global <$> dataIdentifier 85 | types <- option [] (parens (sepBy type' comma)) -- parse fields of the value constructor 86 | return (name, types) 87 | 88 | -- Parse namespace declaration (namespace xyz { }) 89 | namespaceDecl :: Parser UDecl 90 | namespaceDecl = do 91 | reserved "namespace" 92 | name <- identifier 93 | -- each namespace starts with a list of imports, then any regular declarations after 94 | (imports, declarations) <- braces (do is <- imports ; (is,) <$> local (is++) (many declaration)) 95 | parentImports <- ask -- these imports were passed on from parent namespaces 96 | let imports' = imports ++ parentImports 97 | return $ DNamespace name declarations (nub imports') -- nub: we only want unique imports 98 | 99 | -- Parse 0 or more imports (import abc::def;) 100 | imports :: Parser [Namespace] 101 | imports = many (reserved "import" *> namespace <* semi) 102 | 103 | ---------------- 104 | -- Statements -- 105 | ---------------- 106 | -- Parse a statement, either an expression statement or a pass statement 107 | statement :: Parser UStmt 108 | statement = (SExpr <$> expression <* semi) <|> passStmt 109 | 110 | -- Parse a pass statement (pass ;) 111 | passStmt :: Parser UStmt 112 | passStmt = SPass <$> (reserved "pass" *> expression <* semi) 113 | 114 | ----------------- 115 | -- Expressions -- 116 | ----------------- 117 | -- Parsec operator table, contains pre-defined precedences for all of the built-in operators for now. 118 | -- All user defined operators have the same precedence (for now). 119 | -- This will be changed when user defined operators are able to have a precedence specified. 120 | -- User defined operators can only be prefix and infix at the moment, no postfix. 121 | opTable :: OperatorTable Text.Text () (Reader [Namespace]) UExpr 122 | opTable = 123 | [[prefixOp "-", prefixOp "!"], 124 | -- [postfixOp "?"], 125 | [infixOp "^" AssocRight], 126 | [infixOp "*" AssocLeft, infixOp "/" AssocLeft], 127 | [infixOp "+" AssocLeft, infixOp "-" AssocLeft], 128 | [infixOp ">" AssocLeft, infixOp "<" AssocLeft, infixOp ">=" AssocLeft, infixOp "<=" AssocLeft], 129 | [infixOp "==" AssocLeft, infixOp "!=" AssocLeft], 130 | [infixOp "&&" AssocLeft], 131 | [infixOp "||" AssocLeft]] 132 | where 133 | prefixOp op = Prefix (reservedOp op >> return (EUnary () op)) 134 | infixOp op = Infix (reservedOp op >> return (EBinary () op)) 135 | postfixOp op = Postfix (reservedOp op >> return (EUnary () op)) 136 | 137 | -- Parsers for any user defined operators 138 | userPrefix = Prefix (EUnary () <$> operator) 139 | userInfix = Infix (EBinary () <$> operator) AssocLeft 140 | 141 | -- general expression parser 142 | expression :: Parser UExpr 143 | expression = buildExpressionParser (opTable ++ [[userPrefix], [userInfix]]) term 144 | -- concatenate operator table with the table for user defined operators ^ 145 | 146 | -- Parse a term 147 | term :: Parser UExpr 148 | term = block <|> if' <|> match <|> try assign <|> item 149 | 150 | -- Block expression ({ }) 151 | block :: Parser UExpr 152 | block = EBlock () <$> braces (many declaration) 153 | 154 | -- If expression (if then else ) 155 | if' :: Parser UExpr 156 | if' = do 157 | reserved "if" 158 | whitespace 159 | cond <- expression 160 | whitespace 161 | reserved "then" 162 | whitespace 163 | a <- expression 164 | whitespace 165 | reserved "else" 166 | whitespace 167 | EIf () cond a <$> expression 168 | 169 | -- Match expression (match with , ..., ) 170 | -- Branches separated by commas 171 | -- Each branch is a pair (Pattern, Expr) 172 | match :: Parser UExpr 173 | match = do 174 | reserved "match" 175 | expr <- expression 176 | reserved "with" 177 | branches <- sepBy1 ((,) <$> pattern <*> (reservedOp "->" *> expression)) comma 178 | return $ EMatch () expr branches 179 | 180 | -- Assignment expression (abc = ); 181 | assign :: Parser UExpr 182 | assign = do 183 | id <- identifier 184 | reservedOp "=" 185 | EAssign () (Qualified Global id) <$> expression 186 | 187 | -- Function call expression. eg (abc(, ...)); 188 | -- Multiple arguments passed get desugared into multiple call expressions, 189 | -- since every function is curried by default. 190 | -- For example, abc(x, y, z) is sugar for ((abc(x))(y))(z) 191 | call :: Parser UExpr 192 | call = do 193 | id <- ident -- TODO: fix recursion problem, should be able to parse any expression and not just identifier for call 194 | args <- parens (sepBy1 expression comma) 195 | return $ foldl1 (.) (flip (ECall ()) <$> reverse args) id 196 | 197 | item :: Parser UExpr 198 | item = try call <|> value <|> parens expression 199 | 200 | -- Integer literal 201 | -- The lexer supports parsing in decimal (123), octal (o123), and hexadecimal (x123). 202 | int :: Parser Lit 203 | int = LInt <$> (decimal <|> try octal <|> try hexadecimal) 204 | 205 | -- Floating point number literal 206 | float' :: Parser Lit 207 | float' = LFloat <$> float 208 | 209 | -- Boolean literal 210 | bool :: Parser Lit 211 | bool = LBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false")) 212 | 213 | -- Character literal 214 | char' :: Parser Lit 215 | char' = LChar <$> charLiteral 216 | 217 | -- Parses an identifier expression 218 | ident :: Parser UExpr 219 | ident = EIdent () <$> qualified identifier 220 | 221 | -- Unit literal 222 | unit :: Parser Lit 223 | unit = LUnit <$ reserved "()" 224 | 225 | -- Parses a function expression (regular functions or fnmatches) 226 | -- Regular functions of multiple parameters automatically get desugared 227 | -- into functions of single parameters, i.e. automatically curries them 228 | -- For example, fn(a, b, c) => 229 | -- gets desugared into: fn(a) => fn(b) => fn(c) => ; 230 | function :: Parser UExpr 231 | function = fnmatch <|> do 232 | reserved "fn" 233 | params <- parens (sepBy1 identifier comma) "parameter" 234 | reservedOp "=>" 235 | expr <- expression 236 | return $ foldr (EFunc ()) expr params 237 | 238 | -- Desugars a fnmatch statement into a chain of fn(_) expressions followed by a system 239 | -- of match expressions. The arity is determined by the number of patterns. 240 | -- Example: 241 | -- fnmatch 242 | -- Test(a), Pat1(b) -> , 243 | -- Test(a), pvar -> , 244 | -- xy, Pat2(x, y) -> , 245 | -- Test(b), Pat1(b) -> 246 | -- desugars into: 247 | -- fn(_a) => fn(_b) => 248 | -- (match _a with 249 | -- Test(a) -> (match b with 250 | -- Pat1(b) -> , 251 | -- pvar -> ), 252 | -- xy -> (match b with 253 | -- Pat2(x, y) -> )) 254 | fnmatch :: Parser UExpr 255 | fnmatch = do 256 | reserved "fnmatch" 257 | branches <- sepBy1 parseBranch comma 258 | let depths@(arity : _) = map branchDepth branches 259 | if all (== arity) depths 260 | then do 261 | let expr = constructMatch . groupAll $ branches 262 | let (expr', n) = runState (fillMatchExpr "_a" expr) 1 263 | let params = take arity freeIdents 264 | let fn = foldr (EFunc ()) expr' params 265 | return fn 266 | else fail "all branches in fnmatch should be the same length" 267 | 268 | -- This function fills out the identifiers in the match expression 269 | -- State monad keeps track of the index of the next identifier 270 | fillMatchExpr :: String -> UExpr -> State Int UExpr 271 | fillMatchExpr ident (EMatch t _ branches) = do 272 | let (patterns, exprs) = unzip branches 273 | nextIdent <- nextIdentifier -- fill all children match expressions with this identifier 274 | exprs' <- traverse (fillMatchExpr nextIdent) exprs 275 | let branches' = zip patterns exprs' 276 | return $ EMatch t (EIdent () (Qualified Global ident)) branches' 277 | -- subtract 1 from state because we dont want to move up identifiers if it wasn't a match expression 278 | fillMatchExpr _ other = get >>= put . subtract 1 >> return other 279 | 280 | freeIdents :: [String] 281 | freeIdents = map ('_':) ([1..] >>= flip replicateM ['a'..'z']) 282 | 283 | nextIdentifier :: State Int String 284 | nextIdentifier = do 285 | n <- get 286 | put (n+1) 287 | return $ freeIdents !! n 288 | 289 | -- Branch is a helper data type 290 | -- Used in dealing with grouping the nested match expressions, for parsing fnmatches 291 | data Branch = Branch Pattern [Branch] | Expr Pattern UExpr deriving (Show) 292 | 293 | -- Used in figuring out the arity of the function desugared from fnmatches 294 | branchDepth :: Branch -> Int 295 | branchDepth (Expr _ _) = 1 296 | branchDepth (Branch _ (child : _)) = 1 + branchDepth child 297 | branchDepth _ = 0 298 | 299 | -- Helper function 300 | extractChilds :: Branch -> [Branch] 301 | extractChilds (Expr _ _) = [] 302 | extractChilds (Branch _ childs) = childs 303 | 304 | -- Helper function 305 | checkBranch :: Pattern -> Branch -> Bool 306 | checkBranch pat (Expr pat' _) = pat == pat' 307 | checkBranch pat (Branch pat' _) = pat == pat' 308 | 309 | -- Parses a single branch under the fnmatch expression 310 | parseBranch :: Parser Branch 311 | parseBranch = try nested <|> expr 312 | where 313 | nested = do 314 | pat <- pattern 315 | comma 316 | Branch pat . (:[]) <$> parseBranch 317 | expr = do 318 | pat <- pattern 319 | reservedOp "->" 320 | Expr pat <$> expression 321 | 322 | -- Constructs a match expression given a list of branch data types 323 | -- Done after "grouping" is done on the parsed branches 324 | constructMatch :: [Branch] -> UExpr 325 | constructMatch = EMatch () (EIdent () (Qualified Global "_")) . map constructMatch' 326 | -- The identifier in the match expression gets filled in afterwards, so "_" is used temporarily 327 | 328 | -- The main recursive function 329 | constructMatch' :: Branch -> (Pattern, UExpr) 330 | constructMatch' (Expr pat expr) = (pat, expr) 331 | constructMatch' (Branch pat childs) = 332 | let match = constructMatch childs in (pat, match) 333 | 334 | -- (all functions related to "grouping" below are to do with desugaring fnmatch expressions) 335 | -- "Grouping" basically takes all consecutive branches with the same pattern, 336 | -- and unifies them under one branch. 337 | -- so instead of 338 | -- fnmatch 339 | -- Pat1, Pat2 -> , 340 | -- Pat1, Pat3 -> 341 | -- turning to 342 | -- match _a with 343 | -- Pat1 -> match _b with 344 | -- Pat2 -> , 345 | -- Pat1 -> match _b with 346 | -- Pat3 -> 347 | -- (which is NOT what we want), it turns into 348 | -- match _a with 349 | -- Pat1 -> match _b with 350 | -- Pat2 -> , 351 | -- Pat3 -> 352 | groupAll :: [Branch] -> [Branch] 353 | groupAll = map groupChilds . groupBranches 354 | 355 | -- Recursively groups children of a branch 356 | groupChilds :: Branch -> Branch 357 | groupChilds (Branch pat childs) = Branch pat (map groupChilds (groupBranches childs)) 358 | groupChilds other = other 359 | 360 | -- Groups consecutive branches which match the same pattern. 361 | -- It takes the first pattern as a reference, and puts all 362 | -- consecutive similar branches (sharing patterns) as a child of 363 | -- the reference branch. 364 | groupBranches :: [Branch] -> [Branch] 365 | groupBranches [] = [] 366 | groupBranches (a@(Expr _ _) : rest) = a : groupBranches rest 367 | groupBranches (Branch pat childs : rest) = 368 | let (samePatterns, rest') = span (checkBranch pat) rest 369 | in Branch pat (childs ++ concatMap extractChilds samePatterns) : groupBranches rest' 370 | 371 | -- Desugars a list of expressions into calls to Cons() and Empty 372 | -- [e1, e2, e3, e4] 373 | -- [ECall "Cons" e1, ECall "Cons" e2, ECall "Cons" e3, ECall "Cons" e4] 374 | -- [ECall (ECall "Cons" e1), ECall (ECall "Cons" e2), ECall (ECall "Cons" e3), ECall (ECall "Cons" e4)] 375 | -- then foldr into a single expression 376 | -- Using this sugar syntax will throw a 'not defined' error if a list data type as below isn't defined: 377 | -- List = Cons(a, List) | Empty 378 | desugarList :: [UExpr] -> Parser UExpr 379 | desugarList exprs = do 380 | case exprs of 381 | [] -> return $ EIdent () (Qualified (Relative Global "std") "Empty") 382 | _ -> return $ foldr (ECall () . ECall () (EIdent () (Qualified (Relative Global "std") "Cons"))) (EIdent () (Qualified (Relative Global "std") "Empty")) exprs 383 | 384 | -- Regular list syntax sugar [e1, e2, e3] 385 | list :: Parser UExpr 386 | list = brackets (sepBy expression comma) >>= desugarList 387 | 388 | -- String syntax sugar "abc!\n" "hello there123" 389 | string' :: Parser UExpr 390 | string' = stringLiteral >>= desugarList . map (ELit () . LChar) 391 | 392 | -- Parses a 'value' 393 | value :: Parser UExpr 394 | value = try function <|> try (ELit () <$> lit) <|> string' <|> ident <|> list 395 | 396 | -- Parses a literal 397 | lit :: Parser Lit 398 | lit = (try float' <|> try int) <|> bool <|> char' <|> unit 399 | 400 | -------------- 401 | -- Patterns -- 402 | -------------- 403 | -- Parses a pattern 404 | pattern :: Parser Pattern 405 | pattern = (try conPattern <|> litPattern <|> varPattern) <* whitespace 406 | 407 | -- Constructor pattern, used to match value constructors eg Pair(..., ...) 408 | conPattern :: Parser Pattern 409 | conPattern = PCon <$> (Qualified Global <$> dataIdentifier) <*> option [] (parens (sepBy1 pattern comma)) 410 | 411 | -- Variable pattern, matches anything 412 | varPattern :: Parser Pattern 413 | varPattern = PVar <$> identifier 414 | 415 | -- Literal pattern, matches built-in literals 416 | litPattern :: Parser Pattern 417 | litPattern = PLit <$> (int <|> float' <|> bool <|> char' <|> unit) 418 | 419 | ----------- 420 | -- Types -- 421 | ----------- 422 | -- Parse any type 423 | -- These are only used in optional type annotations 424 | type' :: Parser Type 425 | type' = try funcType <|> try conType <|> baseType 426 | 427 | -- Function type (a -> b), right associative 428 | funcType :: Parser Type 429 | funcType = do 430 | inputType <- try conType <|> baseType 431 | reservedOp "->" 432 | (inputType :->) <$> type' 433 | 434 | -- Parses a type of the form Type 435 | conType :: Parser Type 436 | conType = do 437 | con <- qualified dataIdentifier 438 | typeParams <- option [] (angles (sepBy type' comma)) 439 | return $ TCon con typeParams 440 | 441 | -- Parses a type variable 442 | typeVar :: Parser TVar 443 | typeVar = do 444 | var <- identifier 445 | tps <- option [] (angles (sepBy typeVar comma)) 446 | let kind = foldr ((:*>) . const Star) Star tps 447 | return $ TV var kind 448 | 449 | -- A 'basetype' is just a built-in type, or a type' surrounded by parenthesis 450 | baseType :: Parser Type 451 | baseType = (TInt <$ reserved "int") <|> (TFloat <$ reserved "float") 452 | <|> (TBool <$ reserved "bool") <|> (TChar <$ reserved "char") 453 | <|> try (TUnit <$ reserved "()") <|> (TVoid <$ reserved "void") 454 | <|> (TVar <$> typeVar) <|> parens type' 455 | 456 | ----------- 457 | -- Names -- 458 | ----------- 459 | -- Parse a qualified name, something like abc::def::xyz 460 | -- parses into Qualified (Relative (Relative Global "abc") "def") "xyz" 461 | qualified :: Parser String -> Parser QualifiedName 462 | qualified p = do 463 | ids <- sepBy1 p (reservedOp "::") 464 | let namespace = foldr (flip Relative) Global (reverse . init $ ids) 465 | return $ Qualified namespace (last ids) 466 | 467 | -- Essentially the same as parsing a qualified name, except only namespaces 468 | -- Something like abc::def::xyz parses into 469 | -- Relative (Relative (Relative Global "abc") "def") "xyz" 470 | namespace :: Parser Namespace 471 | namespace = do 472 | ids <- sepBy1 identifier (reservedOp "::") 473 | return $ foldr (flip Relative) Global (reverse ids) 474 | 475 | --------- 476 | -- Run -- 477 | --------- 478 | -- Run the the module parser on Text input. Second parameter is file name (without extensions). 479 | -- Returns either an error (String), or the parsed namespace declaration of the module. 480 | parse :: Text.Text -> String -> Either String UDecl 481 | parse input file = 482 | case runReader (runParserT (module' file) () file input) [] of 483 | Left err -> Left $ show err 484 | Right decls -> {- trace (show decls) $ -} Right decls 485 | -------------------------------------------------------------------------------- /src/Resolver.hs: -------------------------------------------------------------------------------- 1 | {-# Language LambdaCase #-} 2 | {-# Language TupleSections #-} 3 | 4 | module Resolver (resolve) where 5 | 6 | import Control.Monad.Reader 7 | import Control.Monad.Except 8 | 9 | import Name 10 | import AST 11 | import Type 12 | 13 | -- The resolver pass fully qualifies all names, 14 | -- i.e, turns something like ABC.Def in the namespace "XYZ" 15 | -- to XYZ.ABC.Def 16 | 17 | type Resolve = Reader Namespace 18 | 19 | resolve :: UProgram -> UProgram 20 | resolve (Program decls) = Program $ runReader (traverse resolveDecl decls) Global 21 | 22 | fixName :: QualifiedName -> Resolve QualifiedName 23 | fixName (Qualified ns name) = do 24 | namespace <- ask 25 | return $ Qualified (namespace `combine` ns) name 26 | 27 | combine :: Namespace -> Namespace -> Namespace 28 | combine ns (Relative Global n) = Relative ns n 29 | combine ns (Relative ns' n) = Relative (combine ns ns') n 30 | combine ns Global = ns 31 | 32 | resolveConstructor :: (QualifiedName, [Type]) -> Resolve (QualifiedName, [Type]) 33 | resolveConstructor (name, ts) = (,ts) <$> fixName name 34 | 35 | resolveDecl :: UDecl -> Resolve UDecl 36 | resolveDecl = \case 37 | DVar dvars -> DVar <$> traverse resolveDVar dvars 38 | DNamespace n ds i -> flip (DNamespace n) i <$> local (`Relative` n) (traverse resolveDecl ds) 39 | DData con tvs vcs -> do 40 | con' <- fixName con 41 | vcs' <- traverse resolveConstructor vcs 42 | return $ DData con' tvs vcs' 43 | DStmt s -> DStmt <$> resolveStmt s 44 | 45 | resolveDVar :: UDVar -> Resolve UDVar 46 | resolveDVar (DV m t name e) = do 47 | t' <- case t of 48 | Just ann -> Just <$> resolveType ann 49 | Nothing -> return Nothing 50 | DV m t' <$> fixName name <*> resolveExpr e 51 | 52 | resolveStmt :: UStmt -> Resolve UStmt 53 | resolveStmt = \case 54 | SExpr e -> SExpr <$> resolveExpr e 55 | SPass e -> SPass <$> resolveExpr e 56 | 57 | resolveExpr :: UExpr -> Resolve UExpr 58 | resolveExpr = \case 59 | EIdent t name -> EIdent t <$> fixName name 60 | EFunc t p e -> EFunc t p <$> resolveExpr e 61 | EIf t c a b -> do 62 | c' <- resolveExpr c 63 | a' <- resolveExpr a 64 | b' <- resolveExpr b 65 | return $ EIf t c' a' b' 66 | EMatch t e bs -> do 67 | e' <- resolveExpr e 68 | bs' <- traverse (\(p, pe) -> (,) <$> resolvePattern p <*> resolveExpr pe) bs 69 | return $ EMatch t e' bs' 70 | EBlock t ds -> EBlock t <$> traverse resolveDecl ds 71 | EBinary t o l r -> do 72 | l' <- resolveExpr l 73 | r' <- resolveExpr r 74 | return $ EBinary t o l' r' 75 | EUnary t o e -> EUnary t o <$> resolveExpr e 76 | EAssign t id e -> EAssign t <$> fixName id <*> resolveExpr e 77 | ECall t f a -> ECall t <$> resolveExpr f <*> resolveExpr a 78 | a@(ELit _ _) -> return a 79 | 80 | resolvePattern :: Pattern -> Resolve Pattern 81 | resolvePattern (PCon name ps) = PCon <$> fixName name <*> traverse resolvePattern ps 82 | resolvePattern (PLit l) = return $ PLit l 83 | resolvePattern (PVar v) = return $ PVar v 84 | 85 | resolveType :: Type -> Resolve Type 86 | resolveType (TCon name ts) = TCon <$> fixName name <*> traverse resolveType ts 87 | resolveType (TVar tv) = return $ TVar tv 88 | -------------------------------------------------------------------------------- /src/Type.hs: -------------------------------------------------------------------------------- 1 | {-# Language PatternSynonyms #-} 2 | {-# Language LambdaCase #-} 3 | 4 | module Type where 5 | 6 | import Data.List 7 | import Data.Set 8 | import qualified Data.Map as Map 9 | import Name 10 | 11 | type TEnv = Map.Map QualifiedName (Scheme, Bool) 12 | 13 | data TVar = TV String Kind deriving (Eq, Ord) 14 | data Type = TCon QualifiedName [Type] | TVar TVar deriving (Eq) 15 | data Scheme = Forall (Set TVar) Type deriving (Show) 16 | 17 | data Kind = Star | Kind :*> Kind deriving (Show, Eq, Ord) 18 | 19 | data Constraint = Type :~: Type 20 | 21 | pattern TInt = TCon (Qualified Global "int") [] 22 | pattern TFloat = TCon (Qualified Global "float") [] 23 | pattern TBool = TCon (Qualified Global "bool") [] 24 | pattern TChar = TCon (Qualified Global "char") [] 25 | pattern TUnit = TCon (Qualified Global "()") [] 26 | pattern TVoid = TCon (Qualified Global "void") [] 27 | pattern a :-> b = TCon (Qualified Global "->") [a, b] 28 | pattern TList a = TCon (Qualified (Relative Global "std") "List") [a] 29 | 30 | instance Show Type where 31 | show = \case 32 | TVar tv -> show tv 33 | a :-> b -> '(':show a ++ " -> " ++ show b ++ ")" 34 | TCon (Qualified _ c) [] -> c 35 | TCon (Qualified _ c) ts -> c ++ '<':intercalate ", " (Prelude.map show ts) ++ ">" 36 | 37 | instance Show TVar where 38 | show (TV s _) = s 39 | 40 | instance Show Constraint where 41 | show (a :~: b) = show a ++ " ~ " ++ show b 42 | -------------------------------------------------------------------------------- /src/Value.hs: -------------------------------------------------------------------------------- 1 | module Value where 2 | 3 | import qualified Data.Map as Map 4 | 5 | import AST 6 | import Name 7 | 8 | type Env = Map.Map QualifiedName Value 9 | 10 | data VFunc = UserDef Namespace [(QualifiedName, Value)] QualifiedName TExpr Env | BuiltIn Int [Value] ([Value] -> IO Value) 11 | data Value = VInt Integer | VFloat Double | VBool Bool | VChar Char | VUnit | VFunc VFunc | VData QualifiedName [Value] deriving (Show, Eq) 12 | 13 | instance Show VFunc where 14 | show (UserDef _ injects _ _ _) = "func" ++ ' ':show injects 15 | 16 | instance Eq VFunc where 17 | a == b = False 18 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.7" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 585817 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 11 | sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887 12 | original: 13 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 14 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /vim/ftdetect/artemis.vim: -------------------------------------------------------------------------------- 1 | au BufRead,BufNewFile *.ar set filetype=artemis 2 | -------------------------------------------------------------------------------- /vim/syntax/artemis.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Artemis 3 | " Maintainer: 05st 4 | " Latest Revision: 20 August 2021 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | " Keywords 11 | syn keyword Keyword let fn data import namespace mut fnmatch and 12 | 13 | " Statements 14 | syn keyword Statement if then else match with 15 | 16 | " Built-in types 17 | syn keyword Type int float bool char void 18 | 19 | " Boolean values 20 | syn keyword Boolean true false 21 | 22 | " Integers 23 | syn match Number '[-ox]\?\d\+' 24 | 25 | " Floats 26 | syn match Float '[-]\?\d\+\.\d*' 27 | 28 | " Strings 29 | syn match SpecialChar contained "\\." 30 | syn region String start='"' end='"' contains=SpecialChar 31 | 32 | " Characters 33 | syn match Character "'.'" 34 | syn match Special "'\\.'" 35 | 36 | 37 | " Operators 38 | syn match Keyword "[:!#$%&*+./<=>\?@^|\-~]\+" 39 | 40 | " Semicolons 41 | syn match Keyword ";" 42 | 43 | " Identifiers 44 | syn match Ignore "[a-zA-Z][a-zA-Z0-9_']*" 45 | 46 | " Comments 47 | syn keyword Todo contained TODO FIXME NOTE 48 | syn match Comment "//.*$" contains=Todo 49 | syn region Comment start="/\*" end="\*/" contains=Todo 50 | 51 | --------------------------------------------------------------------------------