packages feed

language-qux (empty) → 0.1.0.0

raw patch · 14 files changed

+1217/−0 lines, 14 filesdep +basedep +containersdep +eithersetup-changed

Dependencies added: base, containers, either, indents, mtl, parsec, pretty, transformers

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2015, Henry J. Wylde+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 Qux nor the names of its+  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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ language-qux.cabal view
@@ -0,0 +1,44 @@+name:           language-qux+version:        0.1.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:++license:        BSD3+license-file:   LICENSE++cabal-version:  >= 1.10+category:       Qux, Language+build-type:     Simple++library+    hs-source-dirs: src/+    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.Syntax,+        Language.Qux.Version+    other-modules:+        Language.Qux.Lexer++    default-language: Haskell2010+    build-depends:+        base >= 4.8 && < 5,+        containers == 0.5.*,+        either == 4.*,+        indents >= 0.3.3 && < 0.4,+        mtl == 2.*,+        parsec == 3.*,+        pretty == 1.*,+        transformers == 0.4.*+
+ src/Language/Qux/Annotated/Exception.hs view
@@ -0,0 +1,74 @@++{-|+Module      : Language.Qux.Annotated.Exception+Description : Exceptions and utility raising functions.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Exceptions and utility creation functions.+-}++module Language.Qux.Annotated.Exception (+    -- * Type exceptions+    TypeException,++    -- ** Creation functions+    duplicateFunctionName, duplicateParameterName, invalidArgumentsCount, mismatchedType,+    undefinedFunctionCall+) 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.Syntax++import Text.PrettyPrint (doubleQuotes)+++-- | An exception that occurs during type checking. See "Language.Qux.TypeChecker".+data TypeException = TypeException SourcePos String++instance Show TypeException where+    show (TypeException pos message) = show pos ++ ":\n" ++ message+++-- |    @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 ++ "\"")++-- |    @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,+    "\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)+    ]++-- | @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]+
+ src/Language/Qux/Annotated/Parser.hs view
@@ -0,0 +1,165 @@++{-|+Module      : Language.Qux.Annotated.Parser+Description : A Parsec indentation-based parser for generating a program.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++A "Text.Parsec" indentation-based parser for generating a 'Program'.+-}++module Language.Qux.Annotated.Parser (+    -- * Types+    Parser, ParseError, SourcePos,+    sourceName, sourceLine, sourceColumn,++    -- ** Parsing+    parse,++    -- ** Parsers+    program, decl, stmt, expr, value, type_+) where++import Control.Monad.State+import Control.Monad.Trans.Except++import Language.Qux.Annotated.Syntax+import Language.Qux.Lexer++import Text.Parsec hiding (State, parse)+import Text.Parsec.Expr+import Text.Parsec.Indent+++-- | 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 a -> SourceName -> String -> Except ParseError a+parse parser sourceName input = except $ runIndent sourceName (runParserT parser () sourceName input)+++-- | 'Id' parser.+id_ :: Parser (Id SourcePos)+id_ = Id <$> getPosition <*> identifier <?> "identifier"++-- | 'Program' parser.+program :: Parser (Program SourcePos)+program = do+    pos <- getPosition+    whiteSpace+    checkIndent+    decls <- block decl+    eof+    return $ Program pos decls++-- | 'Decl' parser.+decl :: Parser (Decl SourcePos)+decl = do+    pos <- getPosition+    name <- id_+    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"+    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.+expr :: Parser (Expr SourcePos)+expr = buildExpressionParser table (try application <|> term) <?> "expression"++application :: Parser (Expr SourcePos)+application = ApplicationExpr <$> getPosition <*> id_ <*> many (sameOrIndented >> term)++term :: Parser (Expr SourcePos)+term = getPosition >>= \pos -> choice [+    parens expr,+    ApplicationExpr pos <$> id_ <*> return [],+    ListExpr  pos       <$> brackets (expr `sepEndBy` comma),+    UnaryExpr pos Len   <$> pipes expr,+    ValueExpr pos       <$> value+    ]++table :: OperatorTable String () (State SourcePos) (Expr SourcePos)+table = [+    [+        Prefix (unaryExpr Neg "-")+    ],+    [+        Infix (binaryExpr Acc "!!") AssocLeft+    ],+    [+        Infix (binaryExpr Mul "*") AssocLeft,+        Infix (binaryExpr Div "/") AssocLeft,+        Infix (binaryExpr Mod "%") AssocLeft+    ],+    [+        Infix (binaryExpr Add "+") AssocLeft,+        Infix (binaryExpr Sub "-") AssocLeft+    ],+    [+        Infix (binaryExpr Lte "<=") AssocLeft,+        Infix (binaryExpr Lt "<") AssocLeft,+        Infix (binaryExpr Gte ">=") AssocLeft,+        Infix (binaryExpr Gt ">") AssocLeft+    ],+    [+        Infix (binaryExpr Eq "==") AssocLeft,+        Infix (binaryExpr Neq "!=") AssocLeft+    ]+    ]++binaryExpr :: BinaryOp -> String -> Parser ((Expr SourcePos) -> (Expr SourcePos) -> (Expr SourcePos))+binaryExpr op sym = getPosition >>= \pos -> BinaryExpr pos op <$ operator sym++unaryExpr :: UnaryOp -> String -> Parser ((Expr SourcePos) -> (Expr SourcePos))+unaryExpr op sym = getPosition >>= \pos -> UnaryExpr pos op <$ operator sym++-- | 'Value' parser.+value :: Parser Value+value = choice [+    BoolValue False <$  reserved "false",+    BoolValue True  <$  reserved "true",+    IntValue        <$> natural,+    NilValue        <$  reserved "nil"+    ] <?> "value"++-- | 'Type' parser.+type_ :: Parser (Type SourcePos)+type_ = getPosition >>= \pos -> choice [+    BoolType pos <$  reserved "Bool",+    IntType  pos <$  reserved "Int",+    ListType pos <$> brackets type_,+    NilType  pos <$  reserved "Nil"+    ] <?> "type"+
+ src/Language/Qux/Annotated/PrettyPrinter.hs view
@@ -0,0 +1,47 @@++{-|+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+
+ src/Language/Qux/Annotated/Simplify.hs view
@@ -0,0 +1,58 @@++{-|+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)+
+ src/Language/Qux/Annotated/Syntax.hs view
@@ -0,0 +1,119 @@++{-|+Module      : Language.Qux.Annotated.Syntax+Description : Abstract syntax tree nodes with annotations.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Abstract syntax tree nodes with annotations.++The annotation style was inspired by haskell-src-exts.+-}++module Language.Qux.Annotated.Syntax (+    -- * Type class+    Annotated(..),++    -- ** Annotated nodes+    Id(..), Program(..),++    Decl(..),+    name, parameters, parameterNames, parameterTypes, returnType, stmts,++    Stmt(..), Expr(..), Type(..),++    -- ** Regular nodes+    BinaryOp(..), UnaryOp(..), Value(..)+) where++import Language.Qux.Syntax (BinaryOp(..), UnaryOp(..), Value(..))+++-- | An annotated class.+class Annotated node where+    ann :: node a -> a+++-- | An identifier.+data Id a = Id a String+    deriving (Eq, 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 Annotated Program where+    ann (Program a _) = a++-- | 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++name :: Decl a -> Id a+name (FunctionDecl _ n _ _) = n++types :: Decl a -> [Type a]+types (FunctionDecl _ _ ps _) = map fst ps++parameters :: Decl a -> [(Type a, Id a)]+parameters (FunctionDecl _ _ ps _) = init ps++parameterNames :: Decl a -> [Id a]+parameterNames = (map snd) . parameters++parameterTypes :: Decl a -> [Type a]+parameterTypes = (map fst) . parameters++returnType :: Decl a -> Type a+returnType (FunctionDecl _ _ ps _) = fst $ last ps++stmts :: Decl a -> [Stmt a]+stmts (FunctionDecl _ _ _ ss) = ss++-- | 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)++instance Annotated Stmt where+    ann (IfStmt a _ _ _)    = a+    ann (ReturnStmt a _)    = a+    ann (WhileStmt a _ _)   = a++-- | A complex expression.+data Expr a = ApplicationExpr a (Id a) [Expr a]         -- ^ A function name to call and the arguments to pass.+            | 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.+            | ValueExpr a Value                         -- ^ A raw value.+    deriving (Eq, Show)++instance Annotated Expr where+    ann (ApplicationExpr a _ _) = a+    ann (BinaryExpr a _ _ _)    = a+    ann (ListExpr a _)          = a+    ann (UnaryExpr a _ _)       = a+    ann (ValueExpr a _)         = a++-- | 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)++instance Annotated Type where+    ann (BoolType a)    = a+    ann (IntType a)     = a+    ann (ListType a _)  = a+    ann (NilType a)     = a+
+ src/Language/Qux/Annotated/TypeChecker.hs view
@@ -0,0 +1,185 @@++{-|+Module      : Language.Qux.Annotated.TypeChecker+Description : Type checking functions to verify that a 'Program' is type-safe.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Type checking functions to verify that a 'Program' is type-safe.++These functions only verify that types are used correctly.+They don't verify other properties such as definite assignment.+-}++module Language.Qux.Annotated.TypeChecker (+    -- * Environment+    Evaluation, Check,++    -- * Contexts+    Context, Locals,+    context,++    -- * Type checking++    -- ** Program checking+    check,++    -- ** Other node checking+    checkProgram, checkDecl, checkStmt, checkExpr, checkValue+) 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++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+++-- |    Global context that holds function definition types.+--      The function name and parameter types are held.+data Context = Context {+    functions :: Map Id [Type]+    }++-- | Local context.+type Locals = Map Id Type+++-- | 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++    return $ maybeLocal <|> maybeDef++once :: Monad m => MonadState s m => (s -> s) -> m a -> m a+once f m = get >>= \save -> modify f >> m <* put save+++-- |    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 a program.+checkProgram :: Ann.Program SourcePos -> Check ()+checkProgram (Ann.Program _ decls) = do+    when (not $ null duplicates) (throwError $ duplicateFunctionName (head duplicates))++    mapM_ checkDecl decls+    where+        duplicates = decls \\ nubBy ((==) `on` sId . Ann.name) decls++-- | 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)+    where+        duplicates = parameters \\ nubBy ((==) `on` sId . snd) parameters++checkBlock :: [Ann.Stmt SourcePos] -> Check ()+checkBlock = mapM_ checkStmt++-- -- | Type checks a statement.+checkStmt :: Ann.Stmt SourcePos -> Check ()+checkStmt (Ann.IfStmt _ condition trueStmts falseStmts)   = do+    expectExpr condition [BoolType]++    checkBlock trueStmts+    checkBlock falseStmts+checkStmt (Ann.ReturnStmt _ expr)                         = do+    expected <- gets (! "@")++    void $ expectExpr expr [expected]+checkStmt (Ann.WhileStmt _ condition stmts)               = do+    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)++    let expected = init $ fromJust maybeTypes++    case length expected == length arguments of+        True    -> zipWithM expectExpr arguments $ map (:[]) expected+        False   -> throwError $ invalidArgumentsCount e (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++    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++-- -- | Type checks a value.+checkValue :: Value -> Check Type+checkValue (BoolValue _)        = return BoolType+checkValue (IntValue _)         = return IntType+checkValue NilValue             = return NilType+++expectExpr :: Ann.Expr SourcePos -> [Type] -> Check Type+expectExpr expr expects = (attach (Ann.ann expr) <$> checkExpr expr) >>= flip expectType expects++expectType :: Ann.Type SourcePos -> [Type] -> Check Type+expectType received expects+    | sType received `elem` expects = return $ sType received+    | otherwise                     = throwError $ mismatchedType received expects++attach :: SourcePos -> Type -> Ann.Type SourcePos+attach pos BoolType         = Ann.BoolType pos+attach pos IntType          = Ann.IntType pos+attach pos (ListType inner) = Ann.ListType pos (attach undefined inner)+attach pos NilType          = Ann.NilType pos+
+ src/Language/Qux/Interpreter.hs view
@@ -0,0 +1,148 @@++{-|+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 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+    (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+
+ src/Language/Qux/Lexer.hs view
@@ -0,0 +1,113 @@++{-|+Module      : Language.Qux.Lexer+Description : A Parsec lexer for the Qux language.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++A "Text.Parsec" lexer for the Qux language.+-}++module Language.Qux.Lexer (+    -- * Lexer+    lexer,++    -- ** Language elements+    identifier, natural, operator, reserved, symbol, whiteSpace,++    -- ** Symbols+    brackets, colon, comma, parens, pipes, rightArrow+) where++import Control.Monad.State++import Text.Parsec hiding (State)+import qualified Text.Parsec.Token as Token+++-- | Lexer for the Qux language definition.+lexer = Token.makeTokenParser quxDef+++-- | Lexemes an identifier matching @[a-zA-Z_][a-zA-Z_']*@.+identifier = Token.identifier lexer++-- | Lexemes a natural number (decimal, octal or hex).+natural = Token.natural lexer++-- | Lexemes a reserved operator from 'operators'.+operator = Token.reservedOp lexer++-- | Lexemes a reserved keyword from 'keywords'.+reserved = Token.reserved lexer++-- | Lexemes a symbol.+symbol = Token.symbol lexer++-- |    Lexemes white space.+--      White space includes comments.+whiteSpace = Token.whiteSpace lexer+++-- | @brackets p@ lexemes @p@ surrounded by @[..]@.+brackets = Token.brackets lexer++-- | Lexemes a colon, @:@.+colon = Token.colon lexer++-- | Lexemes a comma, @,@.+comma = Token.comma lexer++-- | @parens p@ lexemes @p@ surrounded by @(..)@.+parens = Token.parens lexer++-- | @pipes p@ lexemes @p@ surrounded by @|..|@.+pipes p = Token.lexeme lexer $ between (symbol "|") (symbol "|") p++-- | Lexemes a right arrow, @->@.+rightArrow = symbol "->"+++quxDef :: Token.GenLanguageDef String u (State SourcePos)+quxDef = Token.LanguageDef+    commentStart+    commentEnd+    commentLine+    nestedComments+    identStart+    identLetter+    opStart+    opLetter+    reservedNames+    reservedOpNames+    caseSensitive+        where+            commentStart    = "/*"+            commentEnd      = "*/"+            commentLine     = "#"+            nestedComments  = False+            identStart      = letter <|> char '_'+            identLetter     = alphaNum <|> oneOf ['_', '\'']+            opStart         = oneOf []+            opLetter        = oneOf []+            reservedNames   = keywords+            reservedOpNames = operators+            caseSensitive   = True++keywords = [+    "_",+    "else", "if", "return", "while",+    "false", "nil", "true",+    "Bool", "Int", "Nil"+    ]++operators = [+    "!!", "|",+    "*", "/", "%",+    "+", "-",+    "<", "<=", ">", ">=",+    "==", "!="+    ]+
+ src/Language/Qux/PrettyPrinter.hs view
@@ -0,0 +1,111 @@++{-|+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 '|'+
+ src/Language/Qux/Syntax.hs view
@@ -0,0 +1,90 @@++{-|+Module      : Language.Qux.Syntax+Description : Abstract syntax tree nodes.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Abstract syntax tree nodes.+-}++module Language.Qux.Syntax where+++-- | An identifier.+type Id = String++-- * Nodes++-- | A program is a list of declarations.+newtype Program = Program [Decl]+    deriving (Eq, Show)++-- | 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 "@".+    deriving (Eq, Show)++name :: Decl -> Id+name (FunctionDecl n _ _) = n++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)++-- | A complex expression.+data Expr   = ApplicationExpr Id [Expr]     -- ^ A function name to call and the arguments to pass.+            | BinaryExpr BinaryOp Expr Expr -- ^ A binary operation.+            | ListExpr [Expr]               -- ^ A list of expressions.+            | UnaryExpr UnaryOp Expr        -- ^ A unary oepration.+            | ValueExpr Value               -- ^ A raw value.+    deriving (Eq, Show)++-- | A binary operator.+data BinaryOp   = Acc+                | Mul | Div | Mod+                | Add | Sub+                | Lt  | Lte | Gt | Gte+                | Eq  | Neq+    deriving (Eq, Show)++-- | A unary operator.+data UnaryOp    = Len+                | Neg+    deriving (Eq, Show)++-- | 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.+            | NilValue          -- ^ A unit value.+    deriving (Eq, Show)++-- | A type.+data Type   = BoolType+            | IntType+            | ListType Type -- ^ A list type with an inner type.+            | NilType+    deriving (Eq, Show)+
+ src/Language/Qux/Version.hs view
@@ -0,0 +1,34 @@++{-|+Module      : Language.Qux.Version+Description : Haskell constants of the language version.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Haskell constants 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++-- | The patch component.+patch = 0+