language-qux 0.1.1.3 → 0.2.0.0

raw patch · 15 files changed

+913/−702 lines, 15 filesdep +llvm-general-purePVP ok

version bump matches the API change (PVP)

Dependencies added: llvm-general-pure

API changes (from Hackage documentation)

Files

• language-qux.cabal +13/−6
• src/Language/Qux/Annotated/Exception.hs +38/−47
• src/Language/Qux/Annotated/Parser.hs +28/−20
• src/Language/Qux/Annotated/PrettyPrinter.hs +0/−47
• src/Language/Qux/Annotated/Simplify.hs +0/−58
• src/Language/Qux/Annotated/Syntax.hs +98/−45
• src/Language/Qux/Annotated/TypeChecker.hs +93/−114
• src/Language/Qux/Annotated/TypeResolver.hs +187/−0
• src/Language/Qux/Interpreter.hs +0/−154
• src/Language/Qux/Lexer.hs +32/−42
• src/Language/Qux/Llvm/Builder.hs +80/−0
• src/Language/Qux/Llvm/Compiler.hs +221/−0
• src/Language/Qux/PrettyPrinter.hs +0/−111
• src/Language/Qux/Syntax.hs +115/−36
• src/Language/Qux/Version.hs +8/−22

@@ -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,

@@ -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] 

@@ -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" 

@@ -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-

@@ -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)-

@@ -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) 

@@ -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 }) 

@@ -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"+

@@ -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-

@@ -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 = [     "!!", "|",     "*", "/", "%",

@@ -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 })+

@@ -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"+

@@ -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 '|'-

@@ -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) 

@@ -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)