Bunch of little things.

compiler/capnproto-compiler.cabal

@@ -19,5 +19,6 @@ executable capnproto-compiler
                    Grammar,
                    Parser,
                    Compiler,
-                   Semantics
+                   Semantics,
+                   Util
 

compiler/src/Grammar.hs

@@ -39,8 +39,9 @@ data FieldValue = VoidFieldValue
                 | IntegerFieldValue Integer
                 | FloatFieldValue Double
                 | StringFieldValue String
-                | ArrayFieldValue [FieldValue]
-                | RecordFieldValue [(String, FieldValue)]
+                | IdentifierFieldValue String
+                | ListFieldValue [Located FieldValue]
+                | RecordFieldValue [(Located String, Located FieldValue)]
                 deriving (Show)
 
 data Declaration = AliasDecl (Located String) DeclName
@@ -56,3 +57,14 @@ data Declaration = AliasDecl (Located String) DeclName
                               TypeExpression [Declaration]
                  | OptionDecl DeclName (Located FieldValue)
                  deriving (Show)
+
+declarationName :: Declaration -> Maybe (Located String)
+declarationName (AliasDecl n _)        = Just n
+declarationName (ConstantDecl n _ _)   = Just n
+declarationName (EnumDecl n _)         = Just n
+declarationName (EnumValueDecl n _ _)  = Just n
+declarationName (StructDecl n _)       = Just n
+declarationName (FieldDecl n _ _ _ _)  = Just n
+declarationName (InterfaceDecl n _)    = Just n
+declarationName (MethodDecl n _ _ _ _) = Just n
+declarationName (OptionDecl _ _)       = Nothing

compiler/src/Lexer.hs

@@ -86,6 +86,7 @@ token = keyword
     <|> liftM (const Colon)      (symbol ":")
     <|> liftM (const Period)     (symbol ".")
     <|> liftM (const EqualsSign) (symbol "=")
+    <|> liftM (const MinusSign)  (symbol "-")
     <?> "token"
 
 locatedToken = located token

compiler/src/Main.hs

@@ -25,6 +25,10 @@ module Main ( main ) where
 
 import System.Environment
 import Compiler
+import Util(delimit)
+import Text.Parsec.Pos
+import Text.Parsec.Error
+import Text.Printf(printf)
 
 main::IO()
 main = do
@@ -35,5 +39,22 @@ handleFile filename = do
     text <- readFile filename
     case parseAndCompileFile filename text of
         Active desc [] -> print desc
-        Active _ e -> mapM_ print e
-        Failed e -> mapM_ print e
+        Active _ e -> mapM_ printError e
+        Failed e -> mapM_ printError e
+
+--printError e = mapM_ printMessage (errorMessages e) where
+--    pos = errorPos e
+--    f = sourceName pos
+--    l = sourceLine pos
+--    c = sourceColumn pos
+--    printMessage :: Message -> IO ()
+--    printMessage m = printf "%s:%d:%d: %s\n" f l c (messageString m)
+
+printError e = printf "%s:%d:%d: %s\n" f l c m' where
+    pos = errorPos e
+    f = sourceName pos
+    l = sourceLine pos
+    c = sourceColumn pos
+    m = showErrorMessages "or" "Unknown parse error" "Expected" "Unexpected" "end of expression"
+        (errorMessages e)
+    m' = delimit "; " (lines m)

compiler/src/Parser.hs

@@ -25,12 +25,31 @@ module Parser (parseFile) where
 
 import Text.Parsec hiding (tokens)
 import Token
-import Control.Monad (liftM)
 import Grammar
 import Lexer (lexer)
+import Control.Monad.Identity
 
 tokenParser :: (Located Token -> Maybe a) -> Parsec [Located Token] u a
-tokenParser = token (show . locatedValue) locatedPos
+tokenParser = token (tokenErrorString . locatedValue) locatedPos
+
+tokenErrorString (Identifier s) = "identifier \"" ++ s ++ "\""
+tokenErrorString (ParenthesizedList _) = "parenthesized list"
+tokenErrorString (BracketedList _) = "bracketed list"
+tokenErrorString (LiteralInt i) = "integer literal " ++ show i
+tokenErrorString (LiteralFloat f) = "float literal " ++ show f
+tokenErrorString (LiteralString s) = "string literal " ++  show s
+tokenErrorString AtSign = "\"@\""
+tokenErrorString Colon = "\":\""
+tokenErrorString Period = "\".\""
+tokenErrorString EqualsSign = "\"=\""
+tokenErrorString MinusSign = "\"-\""
+tokenErrorString ImportKeyword = "\"import\""
+tokenErrorString UsingKeyword = "\"using\""
+tokenErrorString ConstKeyword = "\"const\""
+tokenErrorString EnumKeyword = "\"enum\""
+tokenErrorString StructKeyword = "\"struct\""
+tokenErrorString InterfaceKeyword = "\"interface\""
+tokenErrorString OptionKeyword = "\"option\""
 
 type TokenParser = Parsec [Located Token] [ParseError]
 
@@ -49,22 +68,23 @@ matchLiteralFloat t      = case locatedValue t of { (LiteralFloat      v) -> Jus
 matchLiteralString t     = case locatedValue t of { (LiteralString     v) -> Just v; _ -> Nothing }
 matchSimpleToken expected t = if locatedValue t == expected then Just () else Nothing
 
-identifier = tokenParser matchIdentifier
-literalInt = tokenParser matchLiteralInt
-literalFloat = tokenParser matchLiteralFloat
-literalString = tokenParser matchLiteralString
-
-atSign = tokenParser (matchSimpleToken AtSign)
-colon = tokenParser (matchSimpleToken Colon)
-period = tokenParser (matchSimpleToken Period)
-equalsSign = tokenParser (matchSimpleToken EqualsSign)
-importKeyword = tokenParser (matchSimpleToken ImportKeyword)
-usingKeyword = tokenParser (matchSimpleToken UsingKeyword)
-constKeyword = tokenParser (matchSimpleToken ConstKeyword)
-enumKeyword = tokenParser (matchSimpleToken EnumKeyword)
-structKeyword = tokenParser (matchSimpleToken StructKeyword)
-interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword)
-optionKeyword = tokenParser (matchSimpleToken OptionKeyword)
+identifier = tokenParser matchIdentifier <?> "identifier"
+literalInt = tokenParser matchLiteralInt <?> "integer"
+literalFloat = tokenParser matchLiteralFloat <?> "floating-point number"
+literalString = tokenParser matchLiteralString <?> "string"
+
+atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
+colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
+period = tokenParser (matchSimpleToken Period) <?> "\".\""
+equalsSign = tokenParser (matchSimpleToken EqualsSign) <?> "\"=\""
+minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"=\""
+importKeyword = tokenParser (matchSimpleToken ImportKeyword) <?> "\"import\""
+usingKeyword = tokenParser (matchSimpleToken UsingKeyword) <?> "\"using\""
+constKeyword = tokenParser (matchSimpleToken ConstKeyword) <?> "\"const\""
+enumKeyword = tokenParser (matchSimpleToken EnumKeyword) <?> "\"enum\""
+structKeyword = tokenParser (matchSimpleToken StructKeyword) <?> "\"struct\""
+interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword) <?> "\"interface\""
+optionKeyword = tokenParser (matchSimpleToken OptionKeyword) <?> "\"option\""
 
 parenthesizedList parser = do
     items <- tokenParser matchParenthesizedList
@@ -155,16 +175,22 @@ fieldDecl statements = do
     children <- parseBlock fieldLine statements
     return (FieldDecl name ordinal t value children)
 
+negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
+                 <|> liftM (FloatFieldValue . negate) literalFloat
+
 fieldValue = liftM IntegerFieldValue literalInt
          <|> liftM FloatFieldValue literalFloat
          <|> liftM StringFieldValue literalString
-         <|> liftM ArrayFieldValue (bracketedList fieldValue)
+         <|> liftM IdentifierFieldValue identifier
+         <|> liftM ListFieldValue (bracketedList (located fieldValue))
          <|> liftM RecordFieldValue (parenthesizedList fieldAssignment)
+         <|> (minusSign >> negativeFieldValue)
+         <?> "default value"
 
 fieldAssignment = do
-    name <- identifier
+    name <- located identifier
     equalsSign
-    value <- fieldValue
+    value <- located fieldValue
     return (name, value)
 
 fieldLine :: Maybe [Located Statement] -> TokenParser Declaration
@@ -186,6 +212,7 @@ methodDecl statements = do
     atSign
     ordinal <- located literalInt
     params <- parenthesizedList paramDecl
+    colon
     t <- typeExpression
     children <- parseBlock methodLine statements
     return (MethodDecl name ordinal params t children)
@@ -227,8 +254,16 @@ parseBlock parser statements = finish where
         return [ result | Right (result, _) <- results ]
 
 parseCollectingErrors :: TokenParser a -> [Located Token] -> Either ParseError (a, [ParseError])
-parseCollectingErrors parser = runParser parser' [] "" where
+parseCollectingErrors parser tokens = runParser parser' [] "" tokens where
     parser' = do
+        -- Work around Parsec bug:  Text.Parsec.Print.token is supposed to produce a parser that
+        -- sets the position by using the provided function to extract it from each token.  However,
+        -- it doesn't bother to call this function for the *first* token, only subsequent tokens.
+        -- The first token is always assumed to be at 1:1.  To fix this, set it manually.
+        case tokens of
+            Located pos _:_ -> setPosition pos
+            [] -> return ()
+
         result <- parser
         eof
         errors <- getState

compiler/src/Semantics.hs

@@ -30,6 +30,7 @@ import Data.Word (Word8, Word16, Word32, Word64)
 import Data.Char (chr)
 import Text.Printf(printf)
 import Control.Monad(join)
+import Util(delimit)
 
 type ByteString = [Word8]
 
@@ -81,7 +82,7 @@ data BuiltinType = BuiltinVoid | BuiltinBool
                  | BuiltinInt8 | BuiltinInt16 | BuiltinInt32 | BuiltinInt64
                  | BuiltinUInt8 | BuiltinUInt16 | BuiltinUInt32 | BuiltinUInt64
                  | BuiltinFloat32 | BuiltinFloat64
-                 | BuiltinText | BuiltinBytes
+                 | BuiltinText | BuiltinData
                  deriving (Show, Enum, Bounded, Eq)
 
 builtinTypes = [minBound::BuiltinType .. maxBound::BuiltinType]
@@ -103,7 +104,10 @@ data ValueDesc = VoidDesc
                | Float32Desc Float
                | Float64Desc Double
                | TextDesc String
-               | BytesDesc ByteString
+               | DataDesc ByteString
+               | EnumValueValueDesc EnumValueDesc
+               | StructValueDesc [(FieldDesc, ValueDesc)]
+               | ListDesc [ValueDesc]
                deriving (Show)
 
 valueString VoidDesc = error "Can't stringify void value."
@@ -119,7 +123,11 @@ valueString (UInt64Desc  i) = show i
 valueString (Float32Desc x) = show x
 valueString (Float64Desc x) = show x
 valueString (TextDesc    s) = show s
-valueString (BytesDesc   s) = show (map (chr . fromIntegral) s)
+valueString (DataDesc    s) = show (map (chr . fromIntegral) s)
+valueString (EnumValueValueDesc v) = enumValueName v
+valueString (StructValueDesc l) = "(" ++  delimit ", " (map assignmentString l) ++ ")" where
+    assignmentString (field, value) = fieldName field ++ " = " ++ valueString value
+valueString (ListDesc l) = "[" ++ delimit ", " (map valueString l) ++ "]" where
 
 data TypeDesc = BuiltinType BuiltinType
               | EnumType EnumDesc

compiler/src/Token.hs

@@ -26,11 +26,17 @@ module Token where
 import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
 import Text.Printf (printf)
 
-data Located t = Located { locatedPos :: SourcePos, locatedValue :: t } deriving (Eq)
+data Located t = Located { locatedPos :: SourcePos, locatedValue :: t }
 
 instance Show t => Show (Located t) where
     show (Located pos x) = printf "%d:%d:%s" (sourceLine pos) (sourceColumn pos) (show x)
 
+instance Eq a => Eq (Located a) where
+    Located _ a == Located _ b = a == b
+
+instance Ord a => Ord (Located a) where
+    compare (Located _ a) (Located _ b) = compare a b
+
 data Token = Identifier String
            | ParenthesizedList [[Located Token]]
            | BracketedList [[Located Token]]
@@ -41,6 +47,7 @@ data Token = Identifier String
            | Colon
            | Period
            | EqualsSign
+           | MinusSign
            | ImportKeyword
            | UsingKeyword
            | ConstKeyword

compiler/src/Util.hs

+-- Copyright (c) 2013, Kenton Varda <temporal@gmail.com>
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are met:
+--
+-- 1. Redistributions of source code must retain the above copyright notice, this
+--    list of conditions and the following disclaimer.
+-- 2. 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.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+module Util where
+
+delimit delimiter list = concat $ loop list where
+    loop ("":t) = loop t
+    loop (a:"":t) = loop (a:t)
+    loop (a:b:t) = a:delimiter:loop (b:t)
+    loop a = a