diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e6925c8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.stack-work/ +Contua.cabal +*~ +.idea \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..52b2082 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for Contua + +## Unreleased changes diff --git a/Contua.iml b/Contua.iml new file mode 100644 index 0000000..779f445 --- /dev/null +++ b/Contua.iml @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..102126f --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..5fa4c06 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# Contua diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..81ff9de --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Parser.Parser + +main :: IO () +main = putStrLn "Not done yet!" diff --git a/examples/test.cont b/examples/test.cont new file mode 100644 index 0000000..f4f0edd --- /dev/null +++ b/examples/test.cont @@ -0,0 +1 @@ +type :: a = [2, 1, 3, 7] \ No newline at end of file diff --git a/lang_overview/lang_overview.pdf b/lang_overview/lang_overview.pdf new file mode 100644 index 0000000..3949f44 Binary files /dev/null and b/lang_overview/lang_overview.pdf differ diff --git a/lang_overview/lang_overview.tex b/lang_overview/lang_overview.tex new file mode 100644 index 0000000..3568178 --- /dev/null +++ b/lang_overview/lang_overview.tex @@ -0,0 +1,124 @@ +\documentclass{article} +\usepackage[utf8]{inputenc} +\usepackage{amsfonts} +\usepackage{soul} +\usepackage{textcomp} +\usepackage{color} +\usepackage{enumitem} +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{mathtools} +\usepackage{listings} +\usepackage{amsthm} +\usepackage[dvipsnames]{xcolor} +\usepackage[a4paper, total={6.5in, 10in}]{geometry} +\definecolor{dkgreen}{rgb}{0,0.6,0} +\definecolor{gray}{rgb}{0.5,0.5,0.5} +\definecolor{mauve}{rgb}{0.58,0,0.82} +\lstset{frame=tb, + language=Haskell, + aboveskip=3mm, + belowskip=3mm, + showstringspaces=false, + columns=flexible, + basicstyle={\small\ttfamily}, + numbers=none, + numberstyle=\tiny\color{gray}, + keywordstyle=\color{blue}, + commentstyle=\color{dkgreen}, + stringstyle=\color{mauve}, + breaklines=true, + breakatwhitespace=true, + escapeinside={(*}{*)}, % if you want to add LaTeX within your code + tabsize=4 +} + +\title{Overview of the Contua programming language.} +\author{Jacek Olczyk} +\date{Feb 2019} + +\begin{document} +\maketitle +\section{Introduction} +\paragraph{Contua} is a strongly typed functional programming language. It is conceived on a basis of the idea that the language should force the programmer to write all the functions continuation-style. It is not immediately clear what measures needs to be taken to disallow regular functions. I needed to come up with some conventions to achieve that result. +\section{The syntax} +Since the language will be pretty complicated in the 'backend', I tried to keep the syntax as simple as possible. In this grammar I omitted the whitespace rules. +\begin{align*} +% program +\texttt{program} =\ & \texttt{\{ \color{gray}typeDecl \color{black} \}, \{ \color{red}funDecl \color{black} \}}\\ +% funDecl +\texttt{\color{red}funDecl\color{black}} =\ & \texttt{\color{ForestGreen}type\color{black}, '::', id, \{ id \}, "=", \color{RoyalPurple}expr\color{black}}\\ +% typeDecl +\texttt{\color{gray}typeDecl\color{black}} =\ &\texttt{\color{blue}'type'\color{black}, ID, \{ id \}, "=", \color{RubineRed}typeCtor\color{black}, \{ "|", \color{RubineRed}typeCtor \color{black} \}}\\ +% type +\texttt{\color{ForestGreen}type\color{black}} =\ &\texttt{\color{CadetBlue}basicType \color{black} | (\color{ForestGreen}type\color{black}, \{ '->', \color{ForestGreen}type \color{black} \}) | "(", \color{ForestGreen}type\color{black}, ")"}\\ +% basicType +\texttt{\color{CadetBlue}basicType} =\ & \texttt{\color{RubineRed}typeCtor \color{black}| id | "[", id, "]"}\\ +% typeCtor +\texttt{\color{RubineRed}typeCtor\color{black}} =\ & \texttt{ID, \{ \color{ForestGreen}type \color{black} \}}\\ +% function +% \texttt{\color{brown}function\color{black}} =\ & \texttt{}\\ +% expr +\texttt{\color{RoyalPurple}expr\color{black}} =\ & \texttt{ + % variables + id + % type ctors + | ID + % + + | \color{RoyalPurple}expr\color{black}, "+", \color{RoyalPurple}expr \color{black} + % - + | \color{RoyalPurple}expr\color{black}, "-", \color{RoyalPurple}expr \color{black} + % * + | \color{RoyalPurple}expr\color{black}, "*", \color{RoyalPurple}expr \color{black} + % - unary + | "-", \color{RoyalPurple}expr \color{black} +|}\\ +&\texttt{ + % () + | "(", \color{RoyalPurple}expr\color{black}, ")" + % application + | \color{RoyalPurple}expr\color{black}, \color{RoyalPurple}expr \color{black} + % lambda + | \color{blue}'fn'\color{black}, \{ id \}, ".", \color{RoyalPurple}expr \color{black} + % listExpr + | \color{RawSienna}listExpr \color{black} +|}\\ +&\texttt{ + % where + | \color{RoyalPurple}expr\color{black}, \color{blue}'where'\color{black}, \color{red} funDecl\color{black}, \{ \color{blue}'and'\color{black}, \color{red}funDecl \color{black} \} + % let in + | \color{blue}'let'\color{black}, \color{red}funDecl\color{black}, \color{blue}'in'\color{black}, \color{RoyalPurple}expr \color{black} +|}\\ +&\texttt{ + % match + | \color{blue}'match'\color{black}, \color{RoyalPurple}expr\color{black}, \color{blue}'with'\color{black}, \{ "|", \color{RoyalPurple}expr\color{black}, '=>', \color{RoyalPurple}expr \color{black} \} +|}\\ +&\texttt{ + % if then else + | \color{blue}'if'\color{black}, \color{Goldenrod}bexpr\color{black}, \color{blue}'then'\color{black}, \color{RoyalPurple}expr\color{black}, \color{blue}'else'\color{black}, \color{RoyalPurple}expr\color{black} +}\\ +% bexpr +\texttt{\color{Goldenrod}bexpr\color{black}} =\ &\texttt{ + % boolean variable + id + % conjunction + | \color{Goldenrod}bexpr\color{black}, \color{blue}'and'\color{black}, \color{Goldenrod}bexpr \color{black} + % disjunction + | \color{Goldenrod}bexpr\color{black}, \color{blue} 'or'\color{black}, \color{Goldenrod}bexpr \color{black} + % negation + | \color{blue} 'or'\color{black}, \color{Goldenrod}bexpr \color{black} + % less + | \color{RoyalPurple}expr\color{black}, '<=', \color{RoyalPurple}expr\color{black} +}\\ +% listExpr +\texttt{\color{RawSienna}listExpr\color{black}} =\ &\texttt{ + % list literal + [\color{RoyalPurple}expr\color{black}, \{",", \color{RoyalPurple}expr \color{black}\}] + % head/tail + | \color{RoyalPurple} expr\color{black}, ":", \color{RawSienna}listExpr \color{black} + % concatenation + | \color{RawSienna}listExpr\color{black}, "++", \color{RawSienna}listExpr \color{black} +} +\end{align*} +\section{Forcing continuation style} +\end{document} \ No newline at end of file diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..c63edc9 --- /dev/null +++ b/package.yaml @@ -0,0 +1,54 @@ +name: Contua +version: 0.1.0.0 +github: "Joald/Contua" +license: BSD3 +author: "Jacek Olczyk" +maintainer: "jacek.olczyk98@gmail.com" +copyright: "2019 Jacek Olczyk" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- megaparsec >= 7 +- mtl +- text +- parser-combinators +- hspec >= 2.6.1 +- hspec-megaparsec + +library: + source-dirs: src + +executables: + Contua-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - Contua + +tests: + Contua-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - Contua diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs new file mode 100644 index 0000000..e1ebc58 --- /dev/null +++ b/src/Parser/Expr.hs @@ -0,0 +1,130 @@ +module Parser.Expr where + +import Control.Monad +import Control.Monad.Combinators.Expr +import Text.Megaparsec +import qualified Text.Megaparsec.Char.Lexer as L + +import Parser.TypeDefs +import Parser.Utils +import Parser.TypeDecls +import Data.List.NonEmpty (fromList) + +funDecl :: Parser FunDecl +funDecl = do + fnType <- type_ + void (symbol "::") + name <- identifier + args <- many identifier + void (symbol "=") + e <- expr + void (symbol ";") + return $ FunDecl fnType name args e + + +lambda :: Parser Expr +lambda = do + void (symbol "fn") + ids <- many identifier + void (symbol ".") + ELambda ids <$> expr + +matchExpr :: Parser Expr +matchExpr = do + void (symbol "match") + em <- expr + void (symbol "in") + pats <- many $ do + void (symbol "|") + expr + return $ EMatch em pats + +whereExpr :: Parser Expr +whereExpr = do + ep <- expr + void (symbol "where") + fs <- many funDecl + return $ EWhere ep (fromList fs) + +listExpr :: Parser List +listExpr = choice + [ LVar <$> identifier + , brackets listLiteral + , listCons + , listConcat + ] + +listLiteral :: Parser List +listLiteral = do + e <- expr + rest <- many (symbol "," >> expr) + return . LLiteral $ e : rest + + +listCons :: Parser List +listCons = do + e <- expr + void (symbol ":") + LCons e <$> listExpr + +listConcat :: Parser List +listConcat = do + l <- listExpr + ls <- symbol "++" >> (listExpr <|> listConcat) + return $ LConcat l ls + + +letExpr :: Parser Expr +letExpr = do + void (symbol "let") + var <- identifier + void (symbol "=") + e1 <- expr + void (symbol "in") + ELet var e1 <$> expr + + + + +application :: Parser Expr +application = do + e1 <- expr + es <- some expr + return $ applicationHelper e1 es + where + applicationHelper e es + | [] <- es = e + | x : xs <- es = applicationHelper (EApply e x) xs + + + +exprTerm :: Parser Expr +exprTerm = choice + [ try (parens expr) + , try (EInt <$> lexeme L.decimal) + , lambda + , try (EVar <$> identifier) -- needs to be last to not parse keywords as ids +-- , matchExpr +-- , whereExpr +-- , letExpr +-- , EList <$> listExpr + ] + +binary :: String -> (Expr -> Expr -> Expr) -> Operator Parser Expr +binary name f = InfixL (f <$ symbol name) + +prefix, postfix :: String -> (Expr -> Expr) -> Operator Parser Expr +prefix name f = Prefix (f <$ symbol name) +postfix name f = Postfix (f <$ symbol name) + +exprOperatorTable :: [[Operator Parser Expr]] +exprOperatorTable = + [ [ binary "" EApply] + , [ prefix "-" ENeg ] + , [ binary "*" EMul ] + , [ binary "+" EAdd + , binary "-" ESub ] + ] + +expr :: Parser Expr +expr = makeExprParser exprTerm exprOperatorTable diff --git a/src/Parser/Parser.hs b/src/Parser/Parser.hs new file mode 100644 index 0000000..b920ceb --- /dev/null +++ b/src/Parser/Parser.hs @@ -0,0 +1,36 @@ +module Parser.Parser + ( parseProgram + , program + ) where + +import Control.Applicative hiding (many, some) +import Control.Monad +import Text.Megaparsec hiding (State) +import Data.List.NonEmpty + + +import Parser.Utils +import Parser.TypeDefs +import Parser.Expr +import Parser.TypeDecls + + +{- | This is the Contua language, the parser part. + Much of it, especially the Utils module has been taken directly from: + https://markkarpov.com/megaparsec/megaparsec.html +-} + +keywords = ["type", "fn", "let", "in", "match", "with", "if", "then", "else", "and", "or", "not"] + + +program :: Parser AST +program = do + types <- many $ try typeDecl + funcs <- some funDecl + return $ AST types funcs + +parseProgram :: String -> IO () +parseProgram = parseTest program + + + diff --git a/src/Parser/TypeDecls.hs b/src/Parser/TypeDecls.hs new file mode 100644 index 0000000..60fd595 --- /dev/null +++ b/src/Parser/TypeDecls.hs @@ -0,0 +1,17 @@ +module Parser.TypeDecls where + +import Control.Monad +import Text.Megaparsec + + +import Parser.TypeDefs +import Parser.Utils +import Text.Megaparsec.Char + +type_ :: Parser Type +type_ = do + void (symbol "type") + return TInt + +typeDecl :: Parser TypeDecl +typeDecl = (\x -> TypeDecl x [] TInt) <$> symbol "xd" diff --git a/src/Parser/TypeDefs.hs b/src/Parser/TypeDefs.hs new file mode 100644 index 0000000..5395e6b --- /dev/null +++ b/src/Parser/TypeDefs.hs @@ -0,0 +1,24 @@ +module Parser.TypeDefs where + +import Data.List.NonEmpty + +data AST = AST [TypeDecl] [FunDecl] deriving (Show, Eq) + +data FunDecl = FunDecl Type Name [Name] Expr deriving (Show, Eq) + +data TypeDecl = TypeDecl TypeName [Name] Type deriving (Show, Eq) + +data Type = TInt | TBool | TFun [Type] | TAbstract Name deriving (Show, Eq) + +type Name = String + +type TypeName = String + +data Expr = EVar Name | EInt Int | ETypeName TypeName | EAdd Expr Expr | ENeg Expr + | ESub Expr Expr | EMul Expr Expr | EParen Expr | EApply Expr Expr | ELambda [Name] Expr + | EList List | EWhere Expr (NonEmpty FunDecl) | EIf BExpr Expr Expr | EMatch Expr [Expr] + | ELet Name Expr Expr deriving (Show, Eq) + +data BExpr = BVal Name | BAnd BExpr BExpr | BOr BExpr BExpr | BNot BExpr | BLeq Expr Expr deriving (Show, Eq) + +data List = LVar Name | LLiteral [Expr] | LCons Expr List | LConcat List List deriving (Show, Eq) diff --git a/src/Parser/Utils.hs b/src/Parser/Utils.hs new file mode 100644 index 0000000..7da4763 --- /dev/null +++ b/src/Parser/Utils.hs @@ -0,0 +1,30 @@ +module Parser.Utils where + +import Data.Void +import Text.Megaparsec hiding (State) +import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char + +type Parser = Parsec Void String + +sc :: Parser () +sc = L.space + space1 + (L.skipLineComment "#") + (L.skipBlockComment "#{" "}#") + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: String -> Parser String +symbol = L.symbol sc + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +identifier :: Parser String +identifier = lexeme ((:) <$> lowerChar <*> many alphaNumChar "identifier") + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8f0da1b --- /dev/null +++ b/stack.yaml @@ -0,0 +1,64 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-13.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.9" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..8c3d29e --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,81 @@ +import Control.Exception +import Test.Hspec +import Test.Hspec.Megaparsec + +import Parser.Utils +import Parser.TypeDefs +import Parser.Parser +import Control.Monad +import Text.Megaparsec (runParser, parse) + + +main :: IO () +main = + hspec $ + describe "Parser" $ do + describe "arithmetic parser" $ do + it "parses integer literals" $ do + parse program "" "type :: a =3;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 3)] + parse program "" "type :: a =31234;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 31234)] + parse program "" "type :: a= 145674653;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 145674653)] + parse program "" "type ::a = 1234112343423413;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 1234112343423413)] + parse program "" "type:: a = 123412343;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 123412343)] + parse program "" "type :: a = 31234153423451243;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 31234153423451243)] + parse program "" "type::a=8567643737876983;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 8567643737876983)] + parse program "" "type::a=00000002137;" `shouldParse` AST [] [FunDecl TInt "a" [] (EInt 2137)] + it "parses addition" $ do + parse program "" "type :: a=aAaAaAaA+bBbBbBbB;" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EVar "aAaAaAaA") (EVar "bBbBbBbB"))] + parse program "" "type :: a=123412341243+aadfawevxz4231313245;" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EInt 123412341243) (EVar "aadfawevxz4231313245"))] + parse program "" "type :: a=31423+a12341234;" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EInt 31423) (EVar "a12341234"))] + parse program "" "type :: a=0039679887+a0000000kkkk;" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EInt 39679887) (EVar "a0000000kkkk"))] + parse program "" "type :: a=0+0+3+9+67+a+0+k+k+k+k;" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EAdd (EAdd (EAdd (EAdd (EAdd (EAdd (EAdd (EAdd (EAdd (EInt 0) (EInt 0)) (EInt 3)) (EInt 9)) (EInt 67)) (EVar "a")) (EInt 0)) (EVar "k")) (EVar "k")) (EVar "k")) (EVar "k")) ] + parse program "" "type :: a=2137+(-a0000000kkkk);" `shouldParse` AST [] [FunDecl TInt "a" [] (EAdd (EInt 2137) (ENeg(EVar "a0000000kkkk")))] + it "parses subtraction" $ + parse program "" "type :: a=3-a;" `shouldParse` AST [] [FunDecl TInt "a" [] (ESub (EInt 3) (EVar "a"))] + it "parses multiplication" $ + parse program "" "type :: a=3*a;" `shouldParse` AST [] [FunDecl TInt "a" [] (EMul (EInt 3) (EVar "a"))] + it "parses complex arithmetic expressions" $ + parse program "" "type :: a = ((b + 1) * 3);" `shouldParse` AST [] [FunDecl TInt "a" [] (EMul (EAdd (EVar "b") (EInt 1)) (EInt 3))] + describe "function application parser" $ do + it "parses simple expression application" $ do + parse program "" "type::a=a b;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EVar "a") (EVar "b")] + parse program "" "type::a=a 1;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EVar "a") (EInt 1)] + parse program "" "type::a=3 1;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EInt 3) (EInt 1)] + parse program "" "type::a=1234 1;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EInt 1234) (EInt 1)] + parse program "" "type::a=a a12341;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EVar "a") (EVar "a12341")] + it "parser complex application" $ do + parse program "" "type::a= f g h;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EApply (EVar "f") (EVar "g")) (EVar "h")] + parse program "" "type::a= a b c d e f g h;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EApply (EApply (EApply (EApply (EApply (EApply (EVar "a") (EVar "b")) (EVar "c")) (EVar "d")) (EVar "e")) (EVar "f")) (EVar "g")) (EVar "h")] + parse program "" "type::a= f (2137 + g) h;" `shouldParse` AST [] [FunDecl TInt "a" [] $ EApply (EApply (EVar "f") (EAdd (EInt 2137) (EVar "g"))) (EVar "h")] + + +{- + +data Test a = Assert String a | ExpectError String + + +parserTests :: [Test AST] +parserTests = + [ Assert "type :: a =3;" (AST [] [FunDecl TInt "a" [] (EInt 3)]) + , Assert "type :: a = 3+ a;" (AST [] [FunDecl TInt "a" [] (EAdd (EInt 3) (EVar "a"))]) + , Assert "type :: a = ((b + 1) * 3) 2137;" (AST [] [FunDecl TInt "a" [] (EApply (EMul (EAdd (EVar "b") (EInt 1)) (EInt 3)) (EInt 2137))]) + , Assert "type :: a = fn x y . y x;" (AST [] [FunDecl TInt "a" [] (ELambda ["x","y"] (EApply (EVar "y") (EVar "x")))]) + , ExpectError "type :: " + , ExpectError "type :: a" + , ExpectError "type :: a =" + , ExpectError "type :: a =;" + ] + +runTest :: (Eq a, Show a) => Parser a -> Test a -> IO () +runTest p (Assert str x) = either print verify (runParser p "Test" str) + where + verify res = + if res == x + then return () + else putStrLn $ "Error when parsing \"" ++ str ++ "\": expected " ++ show x ++ ", got " ++ show res +runTest p (ExpectError str) = either (const $ return ()) (putStrLn . ("Expected an error, got: " ++) . show) (runParser p "Test" str) + + +runTests :: (Eq a, Show a) => Parser a -> [Test a] -> IO () +runTests parser suite = putStrLn "\nStarting tests..." >> mapM_ (runTest parser) suite +-} \ No newline at end of file