diff --git a/language-qux.cabal b/language-qux.cabal --- a/language-qux.cabal +++ b/language-qux.cabal @@ -1,12 +1,14 @@ name: language-qux -version: 0.1.1.3 +version: 0.2.0.0 author: Henry J. Wylde maintainer: public@hjwylde.com homepage: https://github.com/qux-lang/language-qux synopsis: Utilities for working with the Qux language --- description: +description: Qux is an experimental language developed from the ground up with the aim of static + compile time verification. This package provides tools for working with it (parsing, + compiling, pretty printing and type checking). license: BSD3 license-file: LICENSE @@ -20,24 +22,29 @@ exposed-modules: Language.Qux.Annotated.Exception, Language.Qux.Annotated.Parser, - Language.Qux.Annotated.PrettyPrinter, - Language.Qux.Annotated.Simplify, Language.Qux.Annotated.Syntax, Language.Qux.Annotated.TypeChecker, - Language.Qux.Interpreter, - Language.Qux.PrettyPrinter, + Language.Qux.Annotated.TypeResolver, + Language.Qux.Llvm.Compiler, Language.Qux.Syntax, Language.Qux.Version other-modules: Language.Qux.Lexer, + Language.Qux.Llvm.Builder, Paths_language_qux default-language: Haskell2010 + other-extensions: + DeriveFunctor, + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses build-depends: base >= 4.8 && < 5, containers == 0.5.*, either == 4.*, indents >= 0.3.3 && < 0.4, + llvm-general-pure == 3.4.*, mtl == 2.*, parsec == 3.*, pretty >= 1.1.2 && < 2, diff --git a/src/Language/Qux/Annotated/Exception.hs b/src/Language/Qux/Annotated/Exception.hs --- a/src/Language/Qux/Annotated/Exception.hs +++ b/src/Language/Qux/Annotated/Exception.hs @@ -7,68 +7,59 @@ License : BSD3 Maintainer : public@hjwylde.com -Exceptions and utility creation functions. +Exceptions and utility functions. -} module Language.Qux.Annotated.Exception ( - -- * Type exceptions - TypeException, - - -- ** Creation functions - duplicateFunctionName, duplicateParameterName, invalidArgumentsCount, mismatchedType, - undefinedFunctionCall + -- * Type exception + TypeException(..), + pos, message, ) where import Data.List (intercalate) -import Language.Qux.Annotated.Parser (SourcePos, sourceName, sourceLine, sourceColumn) -import Language.Qux.Annotated.PrettyPrinter -import qualified Language.Qux.Annotated.Syntax as Ann +import Language.Qux.Annotated.Parser (SourcePos) import Language.Qux.Syntax -import Text.PrettyPrint (doubleQuotes) - --- | An exception that occurs during type checking. See "Language.Qux.TypeChecker". -data TypeException = TypeException SourcePos String +-- | An exception that occurs during type checking. See "Language.Qux.Annotated.TypeChecker". +data TypeException = TypeException SourcePos String -- ^ A generic type exception with a + -- position and message. + | DuplicateFunctionName SourcePos Id -- ^ Indicates a function of the given + -- name already exists. + | DuplicateParameterName SourcePos Id -- ^ Indicates a parameter of the given + -- name already exists. + | InvalidFunctionCall SourcePos Int Int -- ^ Indicates the wrong number of + -- arguments was passed to the + -- function call. + | MismatchedType SourcePos Id [Id] -- ^ Indicates a type mismatch. + deriving Eq instance Show TypeException where - show (TypeException pos message) = show pos ++ ":\n" ++ message - + show e = show (pos e) ++ ":\n" ++ message e --- | @duplciateFunctionName decl@ creates a 'TypeException' indicating that a duplicate function --- declaration @decl@ was found. -duplicateFunctionName :: Ann.Decl SourcePos -> TypeException -duplicateFunctionName (Ann.FunctionDecl pos (Ann.Id _ name) _ _) = TypeException pos ("duplicate function name \"" ++ name ++ "\"") +-- | Extracts the source position from the exception. +pos :: TypeException -> SourcePos +pos (TypeException p _) = p +pos (DuplicateFunctionName p _) = p +pos (DuplicateParameterName p _) = p +pos (InvalidFunctionCall p _ _) = p +pos (MismatchedType p _ _) = p --- | @duplicateParameterName parameter@ creates a 'TypeException' indicating that a duplicate --- parameter @parameter@ was found. -duplicateParameterName :: Ann.Id SourcePos -> TypeException -duplicateParameterName (Ann.Id pos name) = TypeException pos ("duplicate parameter name \"" ++ name ++ "\"") --- --- | @invalidArgumentsCount received expected@ creates a 'TypeException' indicating that an --- application call (@received@) with an invalid number of arguments was passed to a function --- expecting @expected@. -invalidArgumentsCount :: Ann.Expr SourcePos -> Int -> TypeException -invalidArgumentsCount (Ann.ApplicationExpr pos _ arguments) expected = TypeException pos $ intercalate " " [ - "invalid arguments count", show $ length arguments, +-- | Creates a human understandable message from the exception. +message :: TypeException -> String +message (TypeException _ m) = m +message (DuplicateFunctionName _ name) = "duplicate function name \"" ++ name ++ "\"" +message (DuplicateParameterName _ name) = "duplicate parameter name \"" ++ name ++ "\"" +message (InvalidFunctionCall _ received expected) = intercalate " " [ + "invalid arguments count", show received, "\nexpecting", show expected ] - --- | @mismatchedType received expects@ creates a 'TypeException' indicating that one of @expects@ --- was expected. -mismatchedType :: Ann.Type SourcePos -> [Type] -> TypeException -mismatchedType received expects = TypeException (Ann.ann received) $ intercalate " " [ - "unexpected type", renderOneLine $ doubleQuotes (pPrint received), - "\nexpecting", sentence "or" (map (renderOneLine . doubleQuotes . pPrint) expects) +message (MismatchedType _ received expects) = intercalate " " [ + "unexpected type", "\"" ++ received ++ "\"", + "\nexpecting", sentence "or" expects ] - --- | @undefinedFunctionCall app@ creates a 'TypeException' indicating that an application call --- (@app@) was made to an undefined function. -undefinedFunctionCall :: Ann.Expr SourcePos -> TypeException -undefinedFunctionCall (Ann.ApplicationExpr pos (Ann.Id _ name) _) = TypeException pos ("call to undefined function \"" ++ name ++ "\"") - -sentence :: String -> [String] -> String -sentence _ [x] = x -sentence sep xs = intercalate " " [intercalate ", " (map show $ init xs), sep, show $ last xs] + where + sentence _ [x] = x + sentence sep xs = intercalate " " [intercalate ", " (map show $ init xs), sep, show $ last xs] diff --git a/src/Language/Qux/Annotated/Parser.hs b/src/Language/Qux/Annotated/Parser.hs --- a/src/Language/Qux/Annotated/Parser.hs +++ b/src/Language/Qux/Annotated/Parser.hs @@ -11,15 +11,16 @@ -} module Language.Qux.Annotated.Parser ( - -- * Types - Parser, ParseError, SourcePos, - sourceName, sourceLine, sourceColumn, - - -- ** Parsing + -- * Parser type + Parser, ParseError, parse, - -- ** Parsers - program, decl, stmt, expr, value, type_ + -- * Source position type + SourcePos, + sourceName, sourceLine, sourceColumn, + + -- * Parsers + id_, program, decl, stmt, expr, value, type_ ) where import Control.Monad.State @@ -28,7 +29,7 @@ import Language.Qux.Annotated.Syntax import Language.Qux.Lexer -import Text.Parsec hiding (State, parse) +import Text.Parsec hiding (State, parse) import Text.Parsec.Expr import Text.Parsec.Indent @@ -36,10 +37,9 @@ -- | A 'ParsecT' that retains indentation information. type Parser a = ParsecT String () (State SourcePos) a - --- | @parse parser sourceName input@ parses @input@ using @parser@. --- Returns either a 'ParseError' or @a@. --- This method wraps 'runParserT' by running the indentation resolver over the parser's state. +-- | @parse parser sourceName input@ parses @input@ using @parser@. +-- Returns either a 'ParseError' or @a@. +-- This method wraps 'runParserT' by running the indentation resolver over the parser's state. parse :: Parser a -> SourceName -> String -> Except ParseError a parse parser sourceName input = except $ runIndent sourceName (runParserT parser () sourceName input) @@ -52,46 +52,52 @@ program :: Parser (Program SourcePos) program = do pos <- getPosition + whiteSpace checkIndent + reserved "module" + module_ <- sepBy1 id_ dot + checkIndent decls <- block decl eof - return $ Program pos decls + return $ Program pos module_ decls + "program" -- | 'Decl' parser. decl :: Parser (Decl SourcePos) decl = do pos <- getPosition + name <- id_ - symbol "::" + symbol_ "::" parameters <- (try $ (,) <$> type_ <*> id_) `endBy` rightArrow returnType <- type_ colon indented stmts <- block stmt + return $ FunctionDecl pos name (parameters ++ [(returnType, Id pos "@")]) stmts "function declaration" -- | 'Stmt' parser. stmt :: Parser (Stmt SourcePos) -stmt = choice [ - ifStmt, - returnStmt, - whileStmt - ] "statement" +stmt = choice [ifStmt, returnStmt, whileStmt] "statement" where ifStmt = do pos <- getPosition + reserved "if" condition <- expr colon indented trueStmts <- block stmt falseStmts <- option [] (checkIndent >> withBlock' (do { reserved "else"; colon }) stmt) + return $ IfStmt pos condition trueStmts falseStmts returnStmt = ReturnStmt <$> getPosition <* reserved "return" <*> expr whileStmt = do pos <- getPosition + withBlock (WhileStmt pos) (reserved "while" *> expr <* colon) stmt -- | 'Expr' parser. @@ -145,12 +151,14 @@ unaryExpr :: UnaryOp -> String -> Parser ((Expr SourcePos) -> (Expr SourcePos)) unaryExpr op sym = getPosition >>= \pos -> UnaryExpr pos op <$ operator sym --- | 'Value' parser. +-- | 'Value' parser. +-- A value doesn't have a source position attached as this can be retrieved from a 'ValueExpr'. value :: Parser Value value = choice [ BoolValue False <$ reserved "false", BoolValue True <$ reserved "true", IntValue <$> natural, + ListValue <$> brackets (value `sepEndBy` comma), NilValue <$ reserved "nil" ] "value" diff --git a/src/Language/Qux/Annotated/PrettyPrinter.hs b/src/Language/Qux/Annotated/PrettyPrinter.hs deleted file mode 100644 --- a/src/Language/Qux/Annotated/PrettyPrinter.hs +++ /dev/null @@ -1,47 +0,0 @@ - -{-| -Module : Language.Qux.Annotated.PrettyPrinter -Description : Pretty instances and rendering functions for Qux language elements. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -"Text.PrettyPrint" instances and rendering functions for Qux language elements. - -To render a program, call: @render $ pPrint program@ --} - -module Language.Qux.Annotated.PrettyPrinter ( - -- Types - Pretty(..), Style(..), Mode(..), - - -- * Rendering - render, renderStyle, renderOneLine -) where - -import Language.Qux.Annotated.Simplify -import Language.Qux.Annotated.Syntax -import Language.Qux.PrettyPrinter - -import Text.PrettyPrint (text) - - -instance Pretty (Id a) where - pPrint = text . sId - -instance Pretty (Program a) where - pPrint = pPrint . sProgram - -instance Pretty (Decl a) where - pPrint = pPrint . sDecl - -instance Pretty (Stmt a) where - pPrint = pPrint . sStmt - -instance Pretty (Expr a) where - pPrint = pPrint . sExpr - -instance Pretty (Type a) where - pPrint = pPrint . sType - diff --git a/src/Language/Qux/Annotated/Simplify.hs b/src/Language/Qux/Annotated/Simplify.hs deleted file mode 100644 --- a/src/Language/Qux/Annotated/Simplify.hs +++ /dev/null @@ -1,58 +0,0 @@ - -{-| -Module : Language.Qux.Annotated.Simplify -Description : Simplify functions that return abstract syntax tree nodes without annotations. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Simplify functions that return abstract syntax tree nodes without annotations. --} - -module Language.Qux.Annotated.Simplify ( - -- * Functions - sId, sProgram, sDecl, sStmt, sExpr, sType -) where - -import qualified Language.Qux.Annotated.Syntax as Ann -import Language.Qux.Syntax - - --- | Simplifies an identifier. -sId :: Ann.Id a -> String -sId (Ann.Id _ id) = id - --- | Simplifies a program. -sProgram :: Ann.Program a -> Program -sProgram (Ann.Program _ decls) = Program $ map sDecl decls - --- | Simplifies a declaration. -sDecl :: Ann.Decl a -> Decl -sDecl (Ann.FunctionDecl _ id parameters stmts) = FunctionDecl (sId id) (map (tmap sType sId) parameters) (map sStmt stmts) - --- | Simplifies a statement. -sStmt :: Ann.Stmt a -> Stmt -sStmt (Ann.IfStmt _ condition trueStmts falseStmts) = IfStmt (sExpr condition) (map sStmt trueStmts) (map sStmt falseStmts) -sStmt (Ann.ReturnStmt _ expr) = ReturnStmt (sExpr expr) -sStmt (Ann.WhileStmt _ condition stmts) = WhileStmt (sExpr condition) (map sStmt stmts) - --- | Simplifies an expression. -sExpr :: Ann.Expr a -> Expr -sExpr (Ann.ApplicationExpr _ id arguments) = ApplicationExpr (sId id) (map sExpr arguments) -sExpr (Ann.BinaryExpr _ op lhs rhs) = BinaryExpr op (sExpr lhs) (sExpr rhs) -sExpr (Ann.ListExpr _ elements) = ListExpr (map sExpr elements) -sExpr (Ann.UnaryExpr _ op expr) = UnaryExpr op (sExpr expr) -sExpr (Ann.ValueExpr _ value) = ValueExpr value - --- | Simplifies a type. -sType :: Ann.Type a -> Type -sType (Ann.BoolType _) = BoolType -sType (Ann.IntType _) = IntType -sType (Ann.ListType _ inner) = ListType $ sType inner -sType (Ann.NilType _) = NilType - - -tmap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) -tmap f g (a, c) = (f a, g c) - diff --git a/src/Language/Qux/Annotated/Syntax.hs b/src/Language/Qux/Annotated/Syntax.hs --- a/src/Language/Qux/Annotated/Syntax.hs +++ b/src/Language/Qux/Annotated/Syntax.hs @@ -8,112 +8,165 @@ Maintainer : public@hjwylde.com Abstract syntax tree nodes with annotations. - The annotation style was inspired by haskell-src-exts. + +Instances of 'Simplifiable' are provided for simplifying a node down to it's unannotated form and of + 'Pretty' for pretty printing. -} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Language.Qux.Annotated.Syntax ( - -- * Type class + -- * Type classes Annotated(..), - - -- ** Annotated nodes - Id(..), Program(..), - - Decl(..), - name, parameters, parameterNames, parameterTypes, returnType, stmts, + Simplifiable(..), - Stmt(..), Expr(..), Type(..), + -- * Annotated nodes + Id(..), Program(..), Decl(..), Stmt(..), Expr(..), Type(..), - -- ** Regular nodes + -- * Regular nodes BinaryOp(..), UnaryOp(..), Value(..) ) where -import Language.Qux.Syntax (BinaryOp(..), UnaryOp(..), Value(..)) +import Language.Qux.Syntax (BinaryOp(..), UnaryOp(..), Value(..)) +import qualified Language.Qux.Syntax as S +import Text.PrettyPrint.HughesPJClass + -- | An annotated class. -class Annotated node where - ann :: node a -> a +-- Annotations are used for attaching data to a node, such as a 'Text.Parsec.SourcePos'. +class Annotated n where + ann :: n a -> a +-- | A simplifiable class. +-- Simplifiable is used to simplify a node to a a simpler form. +-- See "Language.Qux.Syntax" for simpler forms of the nodes defined here. +class Simplifiable n r | n -> r where + simp :: n -> r --- | An identifier. + +-- | An identifier. Identifiers should match '[a-z_][a-zA-Z0-9_']*'. data Id a = Id a String - deriving (Eq, Show) + deriving (Eq, Functor, Show) instance Annotated Id where ann (Id a _) = a --- | A program is a list of declarations. -data Program a = Program a [Decl a] - deriving (Eq, Show) +instance Simplifiable (Id a) [Char] where + simp (Id _ id_) = id_ -instance Annotated Program where - ann (Program a _) = a +instance Pretty (Id a) where + pPrint = text . simp --- | A declaration. -data Decl a = FunctionDecl a (Id a) [(Type a, Id a)] [Stmt a] -- ^ A name, list of ('Type', 'Id') parameters and statements. The return type is treated as a parameter with id "@". - deriving (Eq, Show) -instance Annotated Decl where - ann (FunctionDecl a _ _ _) = a +-- | A program is a module identifier (list of 'Id''s) and a list of declarations. +data Program a = Program a [Id a] [Decl a] + deriving (Eq, Functor, Show) -name :: Decl a -> Id a -name (FunctionDecl _ n _ _) = n +instance Annotated Program where + ann (Program a _ _) = a -types :: Decl a -> [Type a] -types (FunctionDecl _ _ ps _) = map fst ps +instance Simplifiable (Program a) S.Program where + simp (Program _ module_ decls) = S.Program (map simp module_) (map simp decls) -parameters :: Decl a -> [(Type a, Id a)] -parameters (FunctionDecl _ _ ps _) = init ps +instance Pretty (Program a) where + pPrint = pPrint . simp -parameterNames :: Decl a -> [Id a] -parameterNames = (map snd) . parameters -parameterTypes :: Decl a -> [Type a] -parameterTypes = (map fst) . parameters +-- | A declaration. +data Decl a = FunctionDecl a (Id a) [(Type a, Id a)] [Stmt a] -- ^ A name, list of ('Type', 'Id') parameters and statements. + -- The return type is treated as a parameter with id '@'. + deriving (Eq, Functor, Show) -returnType :: Decl a -> Type a -returnType (FunctionDecl _ _ ps _) = fst $ last ps +instance Annotated Decl where + ann (FunctionDecl a _ _ _) = a -stmts :: Decl a -> [Stmt a] -stmts (FunctionDecl _ _ _ ss) = ss +instance Simplifiable (Decl a) S.Decl where + simp (FunctionDecl _ name parameters stmts) = S.FunctionDecl (simp name) (map (tmap simp simp) parameters) (map simp stmts) +instance Pretty (Decl a) where + pPrint = pPrint . simp + + -- | A statement. data Stmt a = IfStmt a (Expr a) [Stmt a] [Stmt a] -- ^ A condition, true block and false block of statements. | ReturnStmt a (Expr a) -- ^ An expression. | WhileStmt a (Expr a) [Stmt a] -- ^ A condition and block of statements. - deriving (Eq, Show) + deriving (Eq, Functor, Show) instance Annotated Stmt where ann (IfStmt a _ _ _) = a ann (ReturnStmt a _) = a ann (WhileStmt a _ _) = a +instance Simplifiable (Stmt a) S.Stmt where + simp (IfStmt _ condition trueStmts falseStmts) = S.IfStmt (simp condition) (map simp trueStmts) (map simp falseStmts) + simp (ReturnStmt _ expr) = S.ReturnStmt (simp expr) + simp (WhileStmt _ condition stmts) = S.WhileStmt (simp condition) (map simp stmts) + +instance Pretty (Stmt a) where + pPrint = pPrint . simp + + -- | A complex expression. -data Expr a = ApplicationExpr a (Id a) [Expr a] -- ^ A function name to call and the arguments to pass. +data Expr a = ApplicationExpr a (Id a) [Expr a] -- ^ A function name to call and the arguments to pass as parameters. | BinaryExpr a BinaryOp (Expr a) (Expr a) -- ^ A binary operation. - | ListExpr a [Expr a] -- ^ A list of expressions. - | UnaryExpr a UnaryOp (Expr a) -- ^ A unary oepration. + | ListExpr a [Expr a] -- ^ A list expression. + | TypedExpr a S.Type (Expr a) -- ^ A typed expression. + -- See "Language.Qux.Annotated.TypeResolver". + | UnaryExpr a UnaryOp (Expr a) -- ^ A unary operation. | ValueExpr a Value -- ^ A raw value. - deriving (Eq, Show) + deriving (Eq, Functor, Show) instance Annotated Expr where ann (ApplicationExpr a _ _) = a ann (BinaryExpr a _ _ _) = a ann (ListExpr a _) = a + ann (TypedExpr a _ _) = a ann (UnaryExpr a _ _) = a ann (ValueExpr a _) = a +instance Simplifiable (Expr a) S.Expr where + simp (ApplicationExpr _ id arguments) = S.ApplicationExpr (simp id) (map simp arguments) + simp (BinaryExpr _ op lhs rhs) = S.BinaryExpr op (simp lhs) (simp rhs) + simp (ListExpr _ elements) = S.ListExpr (map simp elements) + simp (TypedExpr _ type_ expr) = S.TypedExpr type_ (simp expr) + simp (UnaryExpr _ op expr) = S.UnaryExpr op (simp expr) + simp (ValueExpr _ value) = S.ValueExpr value + +instance Pretty (Expr a) where + pPrint = pPrint . simp + + -- | A type. data Type a = BoolType a | IntType a | ListType a (Type a) -- ^ A list type with an inner type. | NilType a - deriving (Eq, Show) + deriving (Eq, Functor, Show) instance Annotated Type where ann (BoolType a) = a ann (IntType a) = a ann (ListType a _) = a ann (NilType a) = a + +instance Simplifiable (Type a) S.Type where + simp (BoolType _) = S.BoolType + simp (IntType _) = S.IntType + simp (ListType _ inner) = S.ListType $ simp inner + simp (NilType _) = S.NilType + +instance Pretty (Type a) where + pPrint = pPrint . simp + + +-- Helper methods + +tmap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) +tmap f g (a, c) = (f a, g c) diff --git a/src/Language/Qux/Annotated/TypeChecker.hs b/src/Language/Qux/Annotated/TypeChecker.hs --- a/src/Language/Qux/Annotated/TypeChecker.hs +++ b/src/Language/Qux/Annotated/TypeChecker.hs @@ -15,171 +15,150 @@ module Language.Qux.Annotated.TypeChecker ( -- * Environment - Evaluation, Check, - - -- * Contexts - Context, Locals, - context, + Check, + runCheck, execCheck, - -- * Type checking + -- * Global context + Context(..), + context, emptyContext, - -- ** Program checking - check, + -- * Local context + Locals, + retrieve, - -- ** Other node checking - checkProgram, checkDecl, checkStmt, checkExpr, checkValue + -- * Type checking + check, checkProgram, checkDecl, checkStmt, checkExpr ) where -import Control.Applicative -import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State - -import Data.Function (on) -import Data.List ((\\), nubBy) -import Data.Map (Map, (!)) -import qualified Data.Map as Map -import Data.Maybe (fromJust, isNothing) - -import Language.Qux.Annotated.Exception -import Language.Qux.Annotated.Parser (SourcePos) -import Language.Qux.Annotated.Simplify -import qualified Language.Qux.Annotated.Syntax as Ann -import Language.Qux.Syntax - - --- | An environment that holds the global types (@Reader Context@) and the local types --- (@Locals@). -type Evaluation = StateT Locals (Reader Context) - --- | Either a 'TypeException' or an @a@. --- Contains an underlying 'Evaluation' in the monad transformer. -type Check = ExceptT TypeException Evaluation +import Control.Monad.Writer +import Data.Function (on) +import Data.List ((\\), nubBy) +import Data.Map ((!)) +import qualified Data.Map as Map --- | Global context that holds function definition types. --- The function name and parameter types are held. -data Context = Context { - functions :: Map Id [Type] - } +import Language.Qux.Annotated.Exception +import Language.Qux.Annotated.Parser (SourcePos) +import Language.Qux.Annotated.Syntax (simp) +import qualified Language.Qux.Annotated.Syntax as Ann +import Language.Qux.Annotated.TypeResolver +import Language.Qux.Syntax --- | Local context. -type Locals = Map Id Type +import Text.PrettyPrint +import Text.PrettyPrint.HughesPJClass --- | Returns a context for the given program. -context :: Program -> Context -context (Program decls) = Context { functions = Map.fromList $ map (\d -> (name d, types d)) decls } - -retrieve :: Id -> Evaluation (Maybe [Type]) -retrieve name = do - maybeLocal <- gets $ (fmap (:[])) . (Map.lookup name) - maybeDef <- asks $ (Map.lookup name) . functions +-- | A type that allows collecting errors while type checking a program. +-- Requires a 'Context' for evaluation. +type Check = ReaderT Context (Writer [TypeException]) - return $ maybeLocal <|> maybeDef +-- | Runs the given check with the context. +runCheck :: Check a -> Context -> (a, [TypeException]) +runCheck check context = runWriter $ runReaderT check context -once :: Monad m => MonadState s m => (s -> s) -> m a -> m a -once f m = get >>= \save -> modify f >> m <* put save +-- | Runs the given check with the context and extracts the exceptions. +execCheck :: Check a -> Context -> [TypeException] +execCheck check context = execWriter $ runReaderT check context --- | Type checks the program. --- If an exception occurs then the result will be a 'TypeException', otherwise 'Nothing'. --- This function wraps 'checkProgram' by building and evaluating the environment under --- the hood. -check :: Ann.Program SourcePos -> Except TypeException () -check program = mapExceptT - (return - . flip runReader (context $ sProgram program) - . flip evalStateT Map.empty) - (checkProgram program) +-- | Type checks the program, returning any errors that are found. +-- A result of @[]@ indicates the program is well-typed. +check :: Ann.Program SourcePos -> [TypeException] +check program = execCheck (checkProgram program) (context $ simp program) -- | Type checks a program. checkProgram :: Ann.Program SourcePos -> Check () -checkProgram (Ann.Program _ decls) = do - when (not $ null duplicates) (throwError $ duplicateFunctionName (head duplicates)) - - mapM_ checkDecl decls +checkProgram (Ann.Program _ _ decls) + | null duplicates = mapM_ checkDecl decls + | otherwise = tell $ [DuplicateFunctionName pos name | (Ann.FunctionDecl _ (Ann.Id pos name) _ _) <- duplicates] where - duplicates = decls \\ nubBy ((==) `on` sId . Ann.name) decls + duplicates = decls \\ nubBy ((==) `on` simp . name) decls + name (Ann.FunctionDecl _ n _ _) = n -- | Type checks a declaration. checkDecl :: Ann.Decl SourcePos -> Check () -checkDecl (Ann.FunctionDecl pos name parameters stmts) = do - when (not $ null duplicates) (throwError $ duplicateParameterName (head $ map snd duplicates)) - - once (Map.union $ Map.fromList (map (\(t, p) -> (sId p, sType t)) parameters)) (checkBlock stmts) +checkDecl (Ann.FunctionDecl _ _ parameters stmts) + | null duplicates = evalStateT (checkBlock stmts) (Map.fromList [(simp p, simp t) | (t, p) <- parameters]) + | otherwise = tell $ [DuplicateParameterName pos name | (_, Ann.Id pos name) <- duplicates] where - duplicates = parameters \\ nubBy ((==) `on` sId . snd) parameters + duplicates = parameters \\ nubBy ((==) `on` simp . snd) parameters -checkBlock :: [Ann.Stmt SourcePos] -> Check () +checkBlock :: [Ann.Stmt SourcePos] -> StateT Locals Check () checkBlock = mapM_ checkStmt --- -- | Type checks a statement. -checkStmt :: Ann.Stmt SourcePos -> Check () +-- | Type checks a statement. +checkStmt :: Ann.Stmt SourcePos -> StateT Locals Check () checkStmt (Ann.IfStmt _ condition trueStmts falseStmts) = do - expectExpr condition [BoolType] + expectExpr_ condition [BoolType] checkBlock trueStmts checkBlock falseStmts checkStmt (Ann.ReturnStmt _ expr) = do expected <- gets (! "@") - void $ expectExpr expr [expected] + expectExpr_ expr [expected] checkStmt (Ann.WhileStmt _ condition stmts) = do - expectExpr condition [BoolType] + expectExpr_ condition [BoolType] checkBlock stmts -- | Type checks an expression. -checkExpr :: Ann.Expr SourcePos -> Check Type -checkExpr e@(Ann.ApplicationExpr pos name arguments) = do - maybeTypes <- lift $ retrieve (sId name) - when (isNothing maybeTypes) (throwError $ undefinedFunctionCall e) +checkExpr :: Ann.Expr SourcePos -> StateT Locals Check Type +checkExpr (Ann.TypedExpr _ type_ (Ann.ApplicationExpr pos name arguments)) = retrieve (simp name) >>= maybe + (error "internal error: undefined function call has no type (try applying name resolution)") + (\types -> do + let expected = init types - let expected = init $ fromJust maybeTypes + zipWithM_ expectExpr arguments $ map (:[]) expected - case length expected == length arguments of - True -> zipWithM expectExpr arguments $ map (:[]) expected - False -> throwError $ invalidArgumentsCount e (length expected) + when (length expected /= length arguments) $ tell [InvalidFunctionCall pos (length arguments) (length expected)] - return $ last (fromJust maybeTypes) -checkExpr (Ann.BinaryExpr _ op lhs rhs) - | op `elem` [Acc] = do - list <- expectExpr lhs [ListType undefined] - let (ListType inner) = list in - expectExpr rhs [IntType] >> return inner - | op `elem` [Mul, Div, Mod] = expectExpr lhs [IntType] >> expectExpr rhs [IntType] - | op `elem` [Add, Sub] = expectExpr lhs [IntType, ListType undefined] >>= (expectExpr rhs) . (:[]) - | op `elem` [Lt, Lte, Gt, Gte] = expectExpr lhs [IntType] >> expectExpr rhs [IntType] >> return BoolType - | op `elem` [Eq, Neq] = ((:[]) <$> checkExpr lhs >>= expectExpr rhs) >> return BoolType -checkExpr (Ann.ListExpr _ []) = return $ ListType undefined -checkExpr (Ann.ListExpr _ elements) = do - expected <- checkExpr $ head elements + return type_) +checkExpr (Ann.TypedExpr _ type_ (Ann.BinaryExpr _ op lhs rhs)) + | op `elem` [Acc] = expectExpr_ lhs [ListType type_] >> expectExpr_ rhs [IntType] >> return type_ + | op `elem` [Mul, Div, Mod, Add, Sub] = expectExpr_ lhs [type_] >> expectExpr rhs [type_] + | op `elem` [Lt, Lte, Gt, Gte] = expectExpr_ lhs [IntType] >> expectExpr_ rhs [IntType] >> return type_ + | op `elem` [Eq, Neq] = checkExpr lhs >>= expectExpr rhs . (:[]) >> return type_ + | otherwise = error $ "internal error: type checking for \"" ++ show op ++ "\" not implemented" +checkExpr (Ann.TypedExpr _ type_ (Ann.ListExpr _ elements)) = do + let (ListType inner) = type_ - mapM_ (flip expectExpr [expected]) (tail elements) >> return expected -checkExpr (Ann.UnaryExpr _ op expr) - | op `elem` [Len] = expectExpr expr [ListType undefined] >> return IntType - | op `elem` [Neg] = expectExpr expr [IntType] -checkExpr (Ann.ValueExpr _ value) = checkValue value + mapM_ (flip expectExpr [inner]) elements --- -- | Type checks a value. -checkValue :: Value -> Check Type -checkValue (BoolValue _) = return BoolType -checkValue (IntValue _) = return IntType -checkValue NilValue = return NilType + return type_ +checkExpr (Ann.TypedExpr _ type_ (Ann.UnaryExpr _ op expr)) + | op `elem` [Len] = expectExpr_ expr [ListType $ error "internal error: top type not implemented"] >> return type_ + | op `elem` [Neg] = expectExpr expr [type_] + | otherwise = error $ "internal error: " ++ show op ++ " not implemented" +checkExpr (Ann.TypedExpr _ type_ (Ann.ValueExpr _ _)) = return type_ +checkExpr _ = error "internal error: cannot check the type of a non-typed expression (try applying type resolution)" -expectExpr :: Ann.Expr SourcePos -> [Type] -> Check Type -expectExpr expr expects = (attach (Ann.ann expr) <$> checkExpr expr) >>= flip expectType expects +expectExpr :: Ann.Expr SourcePos -> [Type] -> StateT Locals Check Type +expectExpr expr expects = do + type_ <- (attach (Ann.ann expr) <$> checkExpr expr) + lift $ expectType type_ expects + +expectExpr_ :: Ann.Expr SourcePos -> [Type] -> StateT Locals Check () +expectExpr_ = fmap void . expectExpr + expectType :: Ann.Type SourcePos -> [Type] -> Check Type expectType received expects - | sType received `elem` expects = return $ sType received - | otherwise = throwError $ mismatchedType received expects + | simp received `elem` expects = return $ simp received + | otherwise = do + tell [MismatchedType (Ann.ann received) (renderOneLine $ pPrint received) (map (renderOneLine . pPrint) expects)] + return $ simp received + attach :: SourcePos -> Type -> Ann.Type SourcePos attach pos BoolType = Ann.BoolType pos -attach pos IntType = Ann.IntType pos +attach pos IntType = Ann.IntType pos attach pos (ListType inner) = Ann.ListType pos (attach undefined inner) -attach pos NilType = Ann.NilType pos +attach pos NilType = Ann.NilType pos + +renderOneLine :: Doc -> String +renderOneLine = renderStyle (style { mode = OneLineMode }) diff --git a/src/Language/Qux/Annotated/TypeResolver.hs b/src/Language/Qux/Annotated/TypeResolver.hs new file mode 100644 --- /dev/null +++ b/src/Language/Qux/Annotated/TypeResolver.hs @@ -0,0 +1,187 @@ + +{-| +Module : Language.Qux.Annotated.TypeResolver +Description : Type resolving functions that transform the abstract syntax tree to a typed one. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Type resolving functions that transform the abstract syntax tree to a typed one. + +These functions will transform every 'Ann.Expr' into an 'Ann.TypedExpr' and return the transformed + tree. +The "Language.Qux.Annotated.TypeChecker" and "Language.Qux.Llvm.Compiler" modules require the tree + to be typed. +-} + +{-# LANGUAGE FlexibleContexts #-} + +module Language.Qux.Annotated.TypeResolver ( + -- * Environment + Resolve, + runResolve, + + -- * Global context + Context(..), + context, emptyContext, + + -- * Local context + Locals, + retrieve, + + -- * Type resolving + resolve, resolveProgram, resolveDecl, resolveStmt, resolveExpr, resolveValue, + extractType +) where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.State + +import Data.List (nub) +import Data.Map (Map) +import qualified Data.Map as Map + +import Language.Qux.Annotated.Parser (SourcePos) +import Language.Qux.Annotated.Syntax (simp) +import qualified Language.Qux.Annotated.Syntax as Ann +import Language.Qux.Syntax + + +-- | A type that allows resolving types. +-- Requires a 'Context' for evaluation. +type Resolve = Reader Context + +-- | Runs the given resolve with the context. +runResolve :: Resolve a -> Context -> a +runResolve = runReader + + +-- | Global context that holds function definition types. +data Context = Context { + functions :: Map Id [Type] -- ^ A map of function names to parameter types. + } + +-- | Returns a context for the given program. +context :: Program -> Context +context (Program _ decls) = Context { + functions = Map.fromList $ [(name, map fst parameters) | (FunctionDecl name parameters _) <- decls] + } + +-- | An empty context. +emptyContext :: Context +emptyContext = Context { functions = Map.empty } + + +-- | Local context. +-- This is a map of variable names to types (e.g., parameters). +type Locals = Map Id Type + +-- | Retrieves the type of the given identifier. +-- Preference is placed on local variables. +-- A local variable type is a singleton list, +-- while a function type is it's parameter types and return type. +retrieve :: MonadReader Context m => Id -> StateT Locals m (Maybe [Type]) +retrieve name = do + maybeLocal <- gets $ (fmap (:[])) . (Map.lookup name) + maybeDef <- asks $ (Map.lookup name) . functions + + return $ maybeLocal <|> maybeDef + + +-- | Resolves the types of the program, returning the modified syntax tree. +resolve :: Ann.Program SourcePos -> Ann.Program SourcePos +resolve program = runResolve (resolveProgram program) (context $ simp program) + +-- | Resolves the types of a program. +resolveProgram :: Ann.Program SourcePos -> Resolve (Ann.Program SourcePos) +resolveProgram (Ann.Program pos module_ decls) = mapM resolveDecl decls >>= \decls' -> return $ Ann.Program pos module_ decls' + +-- | Resolves the types of a declaration. +resolveDecl :: Ann.Decl SourcePos -> Resolve (Ann.Decl SourcePos) +resolveDecl (Ann.FunctionDecl pos name parameters stmts) = do + stmts' <- evalStateT (resolveBlock stmts) (Map.fromList [(simp p, simp t) | (t, p) <- parameters]) + + return $ Ann.FunctionDecl pos name parameters stmts' + +resolveBlock :: [Ann.Stmt SourcePos] -> StateT Locals Resolve [Ann.Stmt SourcePos] +resolveBlock = mapM resolveStmt + +-- | Resolves the types of a statement. +resolveStmt :: Ann.Stmt SourcePos -> StateT Locals Resolve (Ann.Stmt SourcePos) +resolveStmt (Ann.IfStmt pos condition trueStmts falseStmts) = do + condition' <- resolveExpr condition + trueStmts' <- resolveBlock trueStmts + falseStmts' <- resolveBlock falseStmts + + return $ Ann.IfStmt pos condition' trueStmts' falseStmts' +resolveStmt (Ann.ReturnStmt pos expr) = do + expr' <- resolveExpr expr + + return $ Ann.ReturnStmt pos expr' +resolveStmt (Ann.WhileStmt pos condition stmts) = do + condition' <- resolveExpr condition + stmts' <- resolveBlock stmts + + return $ Ann.WhileStmt pos condition' stmts' + +-- | Resolves the types of an expression. +resolveExpr :: Ann.Expr SourcePos -> StateT Locals Resolve (Ann.Expr SourcePos) +resolveExpr (Ann.ApplicationExpr pos name arguments) = retrieve (simp name) >>= maybe + (error "internal error: undefined function call has no type (try applying name resolution)") + (\types -> do + arguments_ <- mapM resolveExpr arguments + + return $ Ann.TypedExpr pos (last types) (Ann.ApplicationExpr pos name arguments_)) +resolveExpr (Ann.BinaryExpr pos op lhs rhs) = do + lhs' <- resolveExpr lhs + rhs' <- resolveExpr rhs + + let type_ = case op of + Acc -> let (ListType inner) = extractType lhs' in inner + Mul -> IntType + Div -> IntType + Mod -> IntType + Add -> extractType lhs' + Sub -> extractType lhs' + Lt -> BoolType + Lte -> BoolType + Gt -> BoolType + Gte -> BoolType + Eq -> BoolType + Neq -> BoolType + + return $ Ann.TypedExpr pos type_ (Ann.BinaryExpr pos op lhs' rhs') +resolveExpr (Ann.ListExpr pos elements) = do + elements' <- mapM resolveExpr elements + + let types = map extractType elements' + + case length (nub types) == 1 of + True -> return $ Ann.TypedExpr pos (ListType $ head types) (Ann.ListExpr pos elements') + False -> error "internal error: top type not implemented" +resolveExpr e@(Ann.TypedExpr _ _ _) = return e +resolveExpr (Ann.UnaryExpr pos op expr) = do + expr' <- resolveExpr expr + + return $ Ann.TypedExpr pos IntType (Ann.UnaryExpr pos op expr') +resolveExpr e@(Ann.ValueExpr pos value) = return $ Ann.TypedExpr pos (resolveValue value) e + +-- | Resolves the type of a value. +resolveValue :: Value -> Type +resolveValue (BoolValue _) = BoolType +resolveValue (IntValue _) = IntType +resolveValue (ListValue elements) = case length (nub types) == 1 of + True -> ListType $ head types + False -> error "internal error: top type not implemented" + where + types = map resolveValue elements +resolveValue NilValue = NilType + +-- | Extracts the type from a 'Ann.TypedExpr'. +-- If the expression isn't an 'Ann.TypedExpr', an error is raised. +extractType :: Ann.Expr a -> Type +extractType (Ann.TypedExpr _ type_ _) = type_ +extractType _ = error "internal error: type resolution not complete" + diff --git a/src/Language/Qux/Interpreter.hs b/src/Language/Qux/Interpreter.hs deleted file mode 100644 --- a/src/Language/Qux/Interpreter.hs +++ /dev/null @@ -1,154 +0,0 @@ - -{-| -Module : Language.Qux.Interpreter -Description : Functions for executing a program and retrieving the return result. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Functions for executing a program and retrieving the return result. - -This module assumes the program is well-formed. -That is, it must be well-typed (see "Language.Qux.TypeChecker"). --} - -module Language.Qux.Interpreter ( - -- * Environment - Execution, Evaluation, - runExecution, - - -- * Contexts - Context, Locals, - context, - - -- * Interpreter - - -- ** Program execution - exec, execStmt, - - -- ** Expression evaluation - evalExpr -) where - -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Either - -import Data.List ((\\)) -import Data.Map (Map, (!)) -import qualified Data.Map as Map -import Data.Maybe (fromJust, isJust) - -import Language.Qux.Syntax - - --- | An environment that holds the global state (@Reader Context@) and the local state --- (@Locals@). --- It supports breaking out of execution (via 'EitherT Value'). -type Execution = EitherT Value Evaluation - --- | An environment that holds the global state (@Reader Context@) and the local state --- (@Locals@). --- Purely for evaluation of expressions---this environment does not support breaking out of --- execution. -type Evaluation = StateT Locals (Reader Context) - - -runExecution :: (a -> Value) -> Execution a -> Evaluation Value -runExecution f exec = either id f <$> runEitherT exec - - --- | Global context that holds function definitions. --- The function name, parameter names and statements are held. -data Context = Context { - functions :: Map Id ([Id], [Stmt]) - } - --- | Local context. -type Locals = Map Id Value - - --- | Returns a context for the given program. -context :: Program -> Context -context (Program decls) = Context { functions = Map.fromList $ map (\d -> (name d, (parameterNames d, stmts d))) decls } - -once :: Monad m => MonadState s m => (s -> s) -> m a -> m a -once f m = get >>= \save -> modify f >> m <* put save - - --- | @exec program entry arguments@ executes @entry@ (passing it @arguments@) in the context --- of @program@. --- This function wraps 'execFunction' by building and evaluating the environment under --- the hood. -exec :: Program -> Id -> [Value] -> Value -exec program entry arguments = runReader (evalStateT (evalApplicationExpr entry arguments) Map.empty) (context program) - -execBlock :: [Stmt] -> Execution () -execBlock = mapM_ execStmt - --- | Executes the statement in a breaking environment. -execStmt :: Stmt -> Execution () -execStmt (IfStmt condition trueStmts falseStmts) = do - result <- lift $ evalExpr condition - - execBlock $ case runBoolValue result of - True -> trueStmts - False -> falseStmts -execStmt (ReturnStmt expr) = lift (evalExpr expr) >>= left -execStmt s@(WhileStmt condition stmts) = do - result <- lift $ evalExpr condition - - when (runBoolValue result) $ execBlock stmts >> execStmt s - --- | Reduces the expression to a value (normal form). -evalExpr :: Expr -> Evaluation Value -evalExpr (ApplicationExpr name arguments) = mapM evalExpr arguments >>= evalApplicationExpr name -evalExpr (BinaryExpr op lhs rhs) = do - lhs' <- evalExpr lhs - rhs' <- evalExpr rhs - - evalBinaryExpr op lhs' rhs' -evalExpr (ListExpr exprs) = ListValue <$> mapM evalExpr exprs -evalExpr (UnaryExpr op expr) = evalExpr expr >>= evalUnaryExpr op -evalExpr (ValueExpr value) = return value - -evalApplicationExpr :: Id -> [Value] -> Evaluation Value -evalApplicationExpr name arguments = do - maybeValue <- gets $ Map.lookup name - - if isJust maybeValue then - return $ fromJust maybeValue - else do - (parameters, stmts) <- asks $ (! name) . functions - - once (Map.union $ Map.fromList (zip parameters arguments)) (runExecution undefined (execBlock stmts)) - -evalBinaryExpr :: BinaryOp -> Value -> Value -> Evaluation Value -evalBinaryExpr Acc (ListValue elements) (IntValue rhs) = return $ elements !! (fromInteger rhs) -evalBinaryExpr Mul (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs * rhs) -evalBinaryExpr Div (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs `div` rhs) -evalBinaryExpr Mod (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs `mod` rhs) -evalBinaryExpr Add (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs + rhs) -evalBinaryExpr Add (ListValue lhs) (ListValue rhs) = return $ ListValue (lhs ++ rhs) -evalBinaryExpr Sub (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs - rhs) -evalBinaryExpr Sub (ListValue lhs) (ListValue rhs) = return $ ListValue (lhs \\ rhs) -evalBinaryExpr Lt (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs < rhs) -evalBinaryExpr Lte (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs <= rhs) -evalBinaryExpr Gt (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs > rhs) -evalBinaryExpr Gte (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs >= rhs) -evalBinaryExpr Eq (BoolValue lhs) (BoolValue rhs) = return $ BoolValue (lhs == rhs) -evalBinaryExpr Eq (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs == rhs) -evalBinaryExpr Eq (ListValue lhs) (ListValue rhs) = return $ BoolValue (lhs == rhs) -evalBinaryExpr Eq NilValue NilValue = return $ BoolValue True -evalBinaryExpr Eq _ _ = return $ BoolValue False -evalBinaryExpr Neq lhs rhs = evalBinaryExpr Eq lhs rhs >>= return . BoolValue . not . runBoolValue - -evalUnaryExpr :: UnaryOp -> Value -> Evaluation Value -evalUnaryExpr Len (ListValue elements) = return $ IntValue (toInteger $ length elements) -evalUnaryExpr Neg (IntValue value) = return $ IntValue (-value) - - -runBoolValue :: Value -> Bool -runBoolValue (BoolValue value) = value - diff --git a/src/Language/Qux/Lexer.hs b/src/Language/Qux/Lexer.hs --- a/src/Language/Qux/Lexer.hs +++ b/src/Language/Qux/Lexer.hs @@ -10,85 +10,73 @@ A "Text.Parsec" lexer for the Qux language. -} -module Language.Qux.Lexer ( - -- * Lexer - lexer, - - -- ** Language elements - identifier, natural, operator, reserved, symbol, whiteSpace, +{-# OPTIONS_HADDOCK hide, prune #-} - -- ** Symbols - brackets, colon, comma, parens, pipes, rightArrow -) where +module Language.Qux.Lexer where import Control.Monad.State -import Text.Parsec hiding (State) -import qualified Text.Parsec.Token as Token +import Text.Parsec hiding (State) +import qualified Text.Parsec.Token as Token --- | Lexer for the Qux language definition. +lexer :: Token.GenTokenParser String u (State SourcePos) lexer = Token.makeTokenParser quxDef --- | Lexemes an identifier matching @[a-zA-Z_][a-zA-Z_']*@. +identifier :: ParsecT String u (State SourcePos) String identifier = Token.identifier lexer --- | Lexemes a natural number (decimal, octal or hex). +natural :: ParsecT String u (State SourcePos) Integer natural = Token.natural lexer --- | Lexemes a reserved operator from 'operators'. +operator :: String -> ParsecT String u (State SourcePos) () operator = Token.reservedOp lexer --- | Lexemes a reserved keyword from 'keywords'. +reserved :: String -> ParsecT String u (State SourcePos) () reserved = Token.reserved lexer --- | Lexemes a symbol. +symbol :: String -> ParsecT String u (State SourcePos) String symbol = Token.symbol lexer --- | Lexemes white space. --- White space includes comments. +symbol_ :: String -> ParsecT String u (State SourcePos) () +symbol_ = void . symbol + +whiteSpace :: ParsecT String u (State SourcePos) () whiteSpace = Token.whiteSpace lexer --- | @brackets p@ lexemes @p@ surrounded by @[..]@. +brackets :: ParsecT String u (State SourcePos) a -> ParsecT String u (State SourcePos) a brackets = Token.brackets lexer --- | Lexemes a colon, @:@. -colon = Token.colon lexer +colon :: ParsecT String u (State SourcePos) () +colon = symbol_ ":" --- | Lexemes a comma, @,@. -comma = Token.comma lexer +comma :: ParsecT String u (State SourcePos) () +comma = symbol_ "," --- | @parens p@ lexemes @p@ surrounded by @(..)@. +dot :: ParsecT String u (State SourcePos) () +dot = symbol_ "." + +parens :: ParsecT String u (State SourcePos) a -> ParsecT String u (State SourcePos) a parens = Token.parens lexer --- | @pipes p@ lexemes @p@ surrounded by @|..|@. +pipes :: ParsecT String u (State SourcePos) a -> ParsecT String u (State SourcePos) a pipes p = Token.lexeme lexer $ between (symbol "|") (symbol "|") p --- | Lexemes a right arrow, @->@. -rightArrow = symbol "->" +rightArrow :: ParsecT String u (State SourcePos) () +rightArrow = symbol_ "->" quxDef :: Token.GenLanguageDef String u (State SourcePos) -quxDef = Token.LanguageDef - commentStart - commentEnd - commentLine - nestedComments - identStart - identLetter - opStart - opLetter - reservedNames - reservedOpNames - caseSensitive +quxDef = Token.LanguageDef commentStart commentEnd commentLine nestedComments identStart identLetter + opStart opLetter reservedNames reservedOpNames caseSensitive where commentStart = "/*" commentEnd = "*/" commentLine = "#" nestedComments = False - identStart = letter <|> char '_' + identStart = lower <|> char '_' identLetter = alphaNum <|> oneOf ['_', '\''] opStart = oneOf [] opLetter = oneOf [] @@ -96,13 +84,15 @@ reservedOpNames = operators caseSensitive = True +keywords :: [String] keywords = [ "_", - "else", "if", "return", "while", + "else", "if", "module", "return", "while", "false", "nil", "true", "Bool", "Int", "Nil" ] +operators :: [String] operators = [ "!!", "|", "*", "/", "%", diff --git a/src/Language/Qux/Llvm/Builder.hs b/src/Language/Qux/Llvm/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Qux/Llvm/Builder.hs @@ -0,0 +1,80 @@ + +{-| +Module : Language.Qux.Llvm.Builder +Description : Build utilities for the LLVM compiler. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Build utilities for the LLVM compiler, see "Compiler". +-} + +{-# OPTIONS_HADDOCK hide, prune #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.Qux.Llvm.Builder where + +import Control.Monad.State + +import Data.Map (Map) +import qualified Data.Map as Map + +import LLVM.General.AST + + +data Builder = Builder { + currentBlock :: Name, + blocks :: Map Name BlockBuilder, + counter :: Word + } + +initialBuilder :: Builder +initialBuilder = Builder { + currentBlock = Name ".0", + blocks = Map.singleton (Name ".0") defaultBlockBuilder { name = Name ".0" }, + counter = 1 + } + +data BlockBuilder = BlockBuilder { + name :: Name, + stack :: [Named Instruction], + term :: Maybe (Named Terminator) + } + +defaultBlockBuilder :: BlockBuilder +defaultBlockBuilder = BlockBuilder { + name = error "no block name set", + stack = [], + term = Nothing + } + +getBlock :: Monad m => MonadState Builder m => m Name +getBlock = gets currentBlock + +setBlock :: Monad m => MonadState Builder m => Name -> m () +setBlock name = modify $ \s -> s { currentBlock = name } + +addBlock :: Monad m => MonadState Builder m => Name -> m () +addBlock name' = modify $ \s -> s { blocks = Map.insert name' defaultBlockBuilder { name = name' } (blocks s) } + +modifyBlock :: Monad m => MonadState Builder m => (BlockBuilder -> BlockBuilder) -> m () +modifyBlock f = do + c <- current + modify $ \s -> s { blocks = Map.insert (name c) (f c) (blocks s) } + +current :: Monad m => MonadState Builder m => m BlockBuilder +current = getBlock >>= \name -> gets (flip (Map.!) name . blocks) + +append :: Monad m => MonadState Builder m => Named Instruction -> m () +append instr = modifyBlock $ \b -> b { stack = stack b ++ [instr] } + +terminate :: Monad m => MonadState Builder m => Named Terminator -> m () +terminate term = modifyBlock $ \b -> b { term = Just term } + +freeName :: Monad m => MonadState Builder m => m String +freeName = (("." ++) . show) <$> freeUnName + +freeUnName :: Monad m => MonadState Builder m => m Word +freeUnName = gets counter <* modify (\s -> s { counter = counter s + 1 }) + diff --git a/src/Language/Qux/Llvm/Compiler.hs b/src/Language/Qux/Llvm/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Language/Qux/Llvm/Compiler.hs @@ -0,0 +1,221 @@ + +{-| +Module : Language.Qux.Llvm.Compiler +Description : Compiles a Qux program into LLVM IR. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +A compiler that takes a 'Program' and outputs a LLVM 'Module'. +-} + +module Language.Qux.Llvm.Compiler ( + -- * Compilation + compile +) where + +import Control.Monad.Reader +import Control.Monad.State + +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Tuple (swap) + +import Language.Qux.Llvm.Builder as B +import Language.Qux.Syntax as Qux + +import LLVM.General.AST as Llvm +import LLVM.General.AST.CallingConvention +import LLVM.General.AST.Constant hiding (exact, nsw, nuw, operand0, operand1) +import LLVM.General.AST.Global as G +import LLVM.General.AST.IntegerPredicate +import LLVM.General.AST.Type + +import Prelude hiding (EQ) + + +data Context = Context { + functions :: Map Id [Qux.Type], + locals :: Map Id Qux.Type + } deriving Show + +context :: Program -> Context +context (Program _ decls) = Context { + functions = Map.fromList [(name, map fst parameters) | (FunctionDecl name parameters _) <- decls], + locals = Map.empty + } + + +-- | Compiles the program into a LLVM 'Module'. +-- Generally speaking, compilation is done using the defaults. +-- Any exceptions to this will be clearly noted. +compile :: Program -> Module +compile program = runReader (compileProgram program) (context program) + +compileProgram :: Program -> Reader Context Module +compileProgram (Program module_ decls) = do + definitions <- mapM compileDecl decls + + return $ defaultModule { + moduleName = intercalate "." module_, + moduleDefinitions = definitions + } + +compileDecl :: Decl -> Reader Context Definition +compileDecl (FunctionDecl name' parameters stmts) = local (\r -> r { locals = Map.fromList $ map swap (init parameters) }) $ do + blockBuilder <- execStateT (mapM_ compileStmt stmts) initialBuilder + + return $ GlobalDefinition functionDefaults { + G.name = Name name', + G.returnType = compileType $ fst (last parameters), + G.parameters = ([Parameter (compileType t) (Name p) [] | (t, p) <- init parameters], False), + basicBlocks = map (\b -> BasicBlock (B.name b) (stack b) (fromJust $ term b)) (Map.elems $ blocks blockBuilder) + } + +compileStmt :: Stmt -> StateT Builder (Reader Context) () +compileStmt (IfStmt condition trueStmts falseStmts) = do + operand <- compileExpr condition + + thenLabel <- Name <$> freeName + elseLabel <- Name <$> freeName + exitLabel <- Name <$> freeName + + terminate $ Do Llvm.CondBr { condition = operand, trueDest = thenLabel, falseDest = elseLabel, metadata' = [] } + + addBlock thenLabel >> setBlock thenLabel + mapM_ compileStmt trueStmts + + c <- current + when (isNothing $ term c) $ terminate (Do Llvm.Br { dest = exitLabel, metadata' = [] }) + + addBlock elseLabel >> setBlock elseLabel + mapM_ compileStmt falseStmts + + c <- current + when (isNothing $ term c) $ terminate (Do Llvm.Br { dest = exitLabel, metadata' = [] }) + + addBlock exitLabel >> setBlock exitLabel + terminate $ Do Llvm.Unreachable { metadata' = [] } +compileStmt (ReturnStmt expr) = do + operand <- compileExpr expr + + terminate $ Do Ret { returnOperand = Just operand, metadata' = [] } +compileStmt (WhileStmt condition stmts) = do + whileLabel <- Name <$> freeName + loopLabel <- Name <$> freeName + exitLabel <- Name <$> freeName + + terminate $ Do Llvm.Br { dest = whileLabel, metadata' = [] } + + addBlock whileLabel >> setBlock whileLabel + operand <- compileExpr condition + terminate $ Do Llvm.CondBr { condition = operand, trueDest = loopLabel, falseDest = exitLabel, metadata' = [] } + + addBlock loopLabel >> setBlock loopLabel + mapM_ compileStmt stmts + + c <- current + when (isNothing $ term c) $ terminate (Do Llvm.Br { dest = whileLabel, metadata' = [] }) + + addBlock exitLabel >> setBlock exitLabel + terminate $ Do Llvm.Unreachable { metadata' = [] } + +compileExpr :: Expr -> StateT Builder (Reader Context) Operand +compileExpr (TypedExpr type_ (ApplicationExpr name' arguments)) = do + operands <- mapM compileExpr arguments + + n <- freeName + + asks (Map.member name' . locals) >>= \isLocal -> case isLocal of + True -> return $ LocalReference (compileType type_) (Name name') + False -> do + append $ Name n := Call { + isTailCall = False, + Llvm.callingConvention = C, + Llvm.returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference (compileType type_) (Name name'), + arguments = [(op, []) | op <- operands], + Llvm.functionAttributes = [], + metadata = [] + } + + return $ LocalReference (compileType type_) (Name n) +compileExpr (TypedExpr type_ (BinaryExpr op lhs rhs)) = do + lhsOperand <- compileExpr lhs + rhsOperand <- compileExpr rhs + + n <- freeName + + case op of + Qux.Acc -> error "internal error: compilation for \"!!\" not implemented" + Qux.Mul -> do + append $ Name n := Llvm.Mul { nsw = False, nuw = False, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Div -> do + append $ Name n := Llvm.SDiv { exact = False, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Mod -> do + append $ Name n := Llvm.SRem { operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Add -> do + append $ Name n := Llvm.Add { nsw = False, nuw = False, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Sub -> do + append $ Name n := Llvm.Sub { nsw = False, nuw = False, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Lt -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = SLT, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Lte -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = SLE, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Gt -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = SGT, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Gte -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = SGE, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Eq -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = EQ, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) + Qux.Neq -> do + append $ Name n := Llvm.ICmp { Llvm.iPredicate = NE, operand0 = lhsOperand, operand1 = rhsOperand, metadata = [] } + return $ LocalReference (compileType type_) (Name n) +compileExpr (TypedExpr _ (ListExpr _)) = error "internal error: compilation for lists not implemented" +compileExpr (TypedExpr type_ (UnaryExpr op expr)) = do + operand <- compileExpr expr + + n <- freeName + + case op of + Len -> error "internal error: compilation for \"|..|\" not implemented" + Neg -> append $ Name n := Llvm.Mul { + nsw = False, nuw = False, metadata = [], + operand0 = operand, operand1 = (ConstantOperand $ Int { integerBits = 32, integerValue = -1 }) + } + + return $ LocalReference (compileType type_) (Name n) +compileExpr (TypedExpr _ (ValueExpr value)) = return $ ConstantOperand (compileValue value) +compileExpr _ = error "internal error: cannot compile a non-typed expression (try applying type resolution)" + +compileValue :: Value -> Constant +compileValue (BoolValue bool) = Int { + integerBits = 1, + integerValue = toInteger (fromEnum bool) + } +compileValue (IntValue int) = Int { + integerBits = 32, + integerValue = toInteger int + } +compileValue (ListValue _) = error "internal error: compilation for lists not implemented" +compileValue NilValue = error "internal error: compilation for nil not implemented" + +compileType :: Qux.Type -> Llvm.Type +compileType BoolType = i1 +compileType IntType = i32 +compileType (ListType _) = error "internal error: compilation for list types not implemented" +compileType NilType = error "internal error: compilation for nil types not implemented" + diff --git a/src/Language/Qux/PrettyPrinter.hs b/src/Language/Qux/PrettyPrinter.hs deleted file mode 100644 --- a/src/Language/Qux/PrettyPrinter.hs +++ /dev/null @@ -1,111 +0,0 @@ - -{-| -Module : Language.Qux.PrettyPrinter -Description : Pretty instances and rendering functions for Qux language elements. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -"Text.PrettyPrint" instances and rendering functions for Qux language elements. - -To render a program, call: @render $ pPrint program@ --} - -module Language.Qux.PrettyPrinter ( - -- * Types - Pretty(..), Style(..), Mode(..), - - -- * Rendering - render, renderStyle, renderOneLine -) where - -import Data.Char (toLower) - -import Language.Qux.Syntax - -import Text.PrettyPrint -import Text.PrettyPrint.HughesPJClass - - --- TODO (hjw): use maybeParens to avoid using so many parenthesis - --- | Like 'render', but renders the doc on one line. -renderOneLine :: Doc -> String -renderOneLine = renderStyle (style { mode = OneLineMode }) - - -instance Pretty Doc where - pPrint = id - -instance Pretty Program where - pPrint (Program decls) = vcat $ map (($+$ emptyLine) . pPrint) decls - -instance Pretty Decl where - pPrint (FunctionDecl name parameters stmts) = vcat [ - text name <+> text "::" <+> parametersDoc <> colon, - nest 4 (block stmts) - ] - where - parametersDoc = fsep $ punctuate - (space <> text "->") - (map (\(t, p) -> pPrint t <+> (if p == "@" then empty else text p)) parameters) - -instance Pretty Stmt where - pPrint (IfStmt condition trueStmts falseStmts) = vcat [ - text "if" <+> pPrint condition <> colon, - nest 4 (block trueStmts), - if null falseStmts then empty else text "else:", - nest 4 (block falseStmts) - ] - pPrint (ReturnStmt expr) = text "return" <+> pPrint expr - pPrint (WhileStmt condition stmts) = vcat [ - text "while" <+> pPrint condition <> colon, - nest 4 (block stmts) - ] - -instance Pretty Expr where - pPrint (ApplicationExpr name arguments) = text name <+> fsep (map pPrint arguments) - pPrint (BinaryExpr op lhs rhs) = parens $ fsep [pPrint lhs, pPrint op, pPrint rhs] - pPrint (ListExpr elements) = brackets $ fsep (punctuate comma (map pPrint elements)) - pPrint (UnaryExpr Len expr) = pipes $ pPrint expr - pPrint (UnaryExpr op expr) = pPrint op <> pPrint expr - pPrint (ValueExpr value) = pPrint value - -instance Pretty BinaryOp where - pPrint Acc = text "!!" - pPrint Mul = text "*" - pPrint Div = text "/" - pPrint Mod = text "%" - pPrint Add = text "+" - pPrint Sub = text "-" - pPrint Lt = text "<" - pPrint Lte = text "<=" - pPrint Gt = text ">" - pPrint Gte = text ">=" - pPrint Eq = text "==" - pPrint Neq = text "!=" - -instance Pretty UnaryOp where - pPrint Neg = text "-" - -instance Pretty Value where - pPrint (BoolValue bool) = text $ map toLower (show bool) - pPrint (IntValue int) = text $ show int - pPrint (ListValue elements) = brackets $ fsep (punctuate comma (map pPrint elements)) - pPrint NilValue = text "nil" - -instance Pretty Type where - pPrint BoolType = text "Bool" - pPrint IntType = text "Int" - pPrint (ListType inner) = brackets $ pPrint inner - pPrint NilType = text "Nil" - - -block :: [Stmt] -> Doc -block = vcat . (map pPrint) - -emptyLine = text "" - -pipes doc = char '|' <> doc <> char '|' - diff --git a/src/Language/Qux/Syntax.hs b/src/Language/Qux/Syntax.hs --- a/src/Language/Qux/Syntax.hs +++ b/src/Language/Qux/Syntax.hs @@ -8,83 +8,162 @@ Maintainer : public@hjwylde.com Abstract syntax tree nodes. + +Instances of 'Pretty' are provided for pretty printing. -} -module Language.Qux.Syntax where +module Language.Qux.Syntax ( + -- * Nodes + Id, Program(..), Decl(..), Stmt(..), Expr(..), BinaryOp(..), UnaryOp(..), Value(..), Type(..) +) where +import Data.Char (toLower) --- | An identifier. +import Text.PrettyPrint +import Text.PrettyPrint.HughesPJClass + + +-- | An identifier. Identifiers should match '[a-z_][a-zA-Z0-9_']*'. type Id = String --- * Nodes --- | A program is a list of declarations. -newtype Program = Program [Decl] +-- | A program is a module identifier (list of 'Id''s) and a list of declarations. +data Program = Program [Id] [Decl] deriving (Eq, Show) +instance Pretty Program where + pPrint (Program module_ decls) = vcat $ map ($+$ text "") ([ + text "module" <+> hcat (punctuate (char '.') (map text module_)) + ] ++ map pPrint decls) + + -- | A declaration. -data Decl = FunctionDecl Id [(Type, Id)] [Stmt] -- ^ A name, list of ('Type', 'Id') parameters and statements. The return type is treated as a parameter with id "@". +data Decl = FunctionDecl Id [(Type, Id)] [Stmt] -- ^ A name, list of ('Type', 'Id') parameters and statements. + -- The return type is treated as a parameter with id '@'. deriving (Eq, Show) -name :: Decl -> Id -name (FunctionDecl n _ _) = n +instance Pretty Decl where + pPrint (FunctionDecl name parameters stmts) = vcat [ + text name <+> text "::" <+> parametersDoc <> colon, + nest 4 (block stmts) + ] + where + parametersDoc = fsep $ punctuate + (space <> text "->") + (map (\(t, p) -> pPrint t <+> (if p == "@" then empty else text p)) parameters) -types :: Decl -> [Type] -types (FunctionDecl _ ps _) = map fst ps -parameters :: Decl -> [(Type, Id)] -parameters (FunctionDecl _ ps _) = init ps - -parameterNames :: Decl -> [Id] -parameterNames = (map snd) . parameters - -parameterTypes :: Decl -> [Type] -parameterTypes = (map fst) . parameters - -returnType :: Decl -> Type -returnType (FunctionDecl _ ps _) = fst $ last ps - -stmts :: Decl -> [Stmt] -stmts (FunctionDecl _ _ ss) = ss - -- | A statement. data Stmt = IfStmt Expr [Stmt] [Stmt] -- ^ A condition, true block and false block of statements. | ReturnStmt Expr -- ^ An expression. | WhileStmt Expr [Stmt] -- ^ A condition and block of statements. deriving (Eq, Show) +instance Pretty Stmt where + pPrint (IfStmt condition trueStmts falseStmts) = vcat [ + text "if" <+> pPrint condition <> colon, + nest 4 (block trueStmts), + if null falseStmts then empty else text "else:", + nest 4 (block falseStmts) + ] + pPrint (ReturnStmt expr) = text "return" <+> pPrint expr + pPrint (WhileStmt condition stmts) = vcat [ + text "while" <+> pPrint condition <> colon, + nest 4 (block stmts) + ] + + -- | A complex expression. -data Expr = ApplicationExpr Id [Expr] -- ^ A function name to call and the arguments to pass. +data Expr = ApplicationExpr Id [Expr] -- ^ A function name to call and the arguments to pass + -- as parameters. | BinaryExpr BinaryOp Expr Expr -- ^ A binary operation. - | ListExpr [Expr] -- ^ A list of expressions. - | UnaryExpr UnaryOp Expr -- ^ A unary oepration. + | ListExpr [Expr] -- ^ A list expression. + | TypedExpr Type Expr -- ^ A typed expression. + -- See "Language.Qux.Annotated.TypeResolver". + | UnaryExpr UnaryOp Expr -- ^ A unary operation. | ValueExpr Value -- ^ A raw value. deriving (Eq, Show) +instance Pretty Expr where + pPrint (ApplicationExpr name arguments) = text name <+> fsep (map pPrint arguments) + pPrint (BinaryExpr op lhs rhs) = parens $ fsep [pPrint lhs, pPrint op, pPrint rhs] + pPrint (ListExpr elements) = brackets $ fsep (punctuate comma (map pPrint elements)) + pPrint (TypedExpr _ expr) = pPrint expr + pPrint (UnaryExpr Len expr) = char '|' <> pPrint expr <> char '|' + pPrint (UnaryExpr op expr) = pPrint op <> pPrint expr + pPrint (ValueExpr value) = pPrint value + + -- | A binary operator. -data BinaryOp = Acc - | Mul | Div | Mod - | Add | Sub - | Lt | Lte | Gt | Gte - | Eq | Neq +data BinaryOp = Acc -- ^ List access. + | Mul -- ^ Multiplicaiton. + | Div -- ^ Division. + | Mod -- ^ Modulus. + | Add -- ^ Addition. + | Sub -- ^ Subtraction. + | Lt -- ^ Less than. + | Lte -- ^ Less than or equal to. + | Gt -- ^ Greater than. + | Gte -- ^ Greater than or equal to. + | Eq -- ^ Equal to. + | Neq -- ^ Not equal to. deriving (Eq, Show) +instance Pretty BinaryOp where + pPrint Acc = text "!!" + pPrint Mul = text "*" + pPrint Div = text "/" + pPrint Mod = text "%" + pPrint Add = text "+" + pPrint Sub = text "-" + pPrint Lt = text "<" + pPrint Lte = text "<=" + pPrint Gt = text ">" + pPrint Gte = text ">=" + pPrint Eq = text "==" + pPrint Neq = text "!=" + + -- | A unary operator. -data UnaryOp = Len - | Neg +data UnaryOp = Len -- ^ List length. + | Neg -- ^ Negation. deriving (Eq, Show) +instance Pretty UnaryOp where + pPrint Len = text "length" + pPrint Neg = text "-" + + -- | A value is considered to be in it's normal form. data Value = BoolValue Bool -- ^ A boolean. | IntValue Integer -- ^ An unbounded integer. - | ListValue [Value] -- ^ A normalised list of values. + | ListValue [Value] -- ^ A normalised list value. | NilValue -- ^ A unit value. deriving (Eq, Show) +instance Pretty Value where + pPrint (BoolValue bool) = text $ map toLower (show bool) + pPrint (IntValue int) = text $ show int + pPrint (ListValue elements) = brackets $ fsep (punctuate comma (map pPrint elements)) + pPrint NilValue = text "nil" + + -- | A type. data Type = BoolType | IntType | ListType Type -- ^ A list type with an inner type. | NilType deriving (Eq, Show) + +instance Pretty Type where + pPrint BoolType = text "Bool" + pPrint IntType = text "Int" + pPrint (ListType inner) = brackets $ pPrint inner + pPrint NilType = text "Nil" + + +-- Helper methods + +block :: [Stmt] -> Doc +block = vcat . (map pPrint) diff --git a/src/Language/Qux/Version.hs b/src/Language/Qux/Version.hs --- a/src/Language/Qux/Version.hs +++ b/src/Language/Qux/Version.hs @@ -1,34 +1,20 @@ {-| Module : Language.Qux.Version -Description : Haskell constants of the language version. +Description : Haskell constant of the language version. Copyright : (c) Henry J. Wylde, 2015 License : BSD3 Maintainer : public@hjwylde.com -Haskell constants of the language version. +Haskell constant of the language version. -} -module Language.Qux.Version where - -import Data.List (intercalate) - - --- * Version - --- | The version formatted as "major.minor.patch". -version = intercalate "." (map show [major, minor, patch]) - - --- ** Components - --- | The major component. -major = 0 - --- | The minor component. -minor = 1 +module Language.Qux.Version ( + -- * Version + -- | The language version. + version +) where --- | The patch component. -patch = 1 +import Paths_language_qux (version)