Bunch of little things.

compiler/capnproto-compiler.cabal

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

compiler/src/Compiler.hs

@@ -28,6 +28,8 @@ import Semantics
 import Token(Located(Located))
 import Parser(parseFile)
 import qualified Data.Map as Map
+import qualified Data.List as List
+import Data.Maybe(mapMaybe)
 import Text.Parsec.Pos(SourcePos, newPos)
 import Text.Parsec.Error(ParseError, newErrorMessage, Message(Message, Expect))
 import Text.Printf(printf)
@@ -98,6 +100,8 @@ feedback f = status where
 statusToMaybe (Active x _) = Just x
 statusToMaybe (Failed _) = Nothing
 
+doAll statuses = Active [x | (Active x _) <- statuses] (concatMap statusErrors statuses)
+
 ------------------------------------------------------------------------------------------
 -- Symbol lookup
 ------------------------------------------------------------------------------------------
@@ -150,30 +154,48 @@ builtinTypeMap = Map.fromList
 
 ------------------------------------------------------------------------------------------
 
-fromIntegerChecked :: Integral a => SourcePos -> Integer -> Status a
-fromIntegerChecked pos x = result where
+fromIntegerChecked :: Integral a => String -> SourcePos -> Integer -> Status a
+fromIntegerChecked name pos x = result where
     unchecked = fromInteger x
     result = if toInteger unchecked == x
         then succeed unchecked
-        else makeError pos "Integer out of range for type."
+        else makeError pos (printf "Integer %d out of range for type %s." x name)
 
+compileValue :: SourcePos -> TypeDesc -> FieldValue -> Status ValueDesc
 compileValue _ (BuiltinType BuiltinVoid) VoidFieldValue = succeed VoidDesc
 compileValue _ (BuiltinType BuiltinBool) (BoolFieldValue x) = succeed (BoolDesc x)
-compileValue pos (BuiltinType BuiltinInt8) (IntegerFieldValue x) = fmap Int8Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinInt16) (IntegerFieldValue x) = fmap Int16Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinInt32) (IntegerFieldValue x) = fmap Int32Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinInt64) (IntegerFieldValue x) = fmap Int64Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinUInt8) (IntegerFieldValue x) = fmap UInt8Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinUInt16) (IntegerFieldValue x) = fmap UInt16Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinUInt32) (IntegerFieldValue x) = fmap UInt32Desc (fromIntegerChecked pos x)
-compileValue pos (BuiltinType BuiltinUInt64) (IntegerFieldValue x) = fmap UInt64Desc (fromIntegerChecked pos x)
+compileValue pos (BuiltinType BuiltinInt8  ) (IntegerFieldValue x) = fmap Int8Desc   (fromIntegerChecked "Int8"   pos x)
+compileValue pos (BuiltinType BuiltinInt16 ) (IntegerFieldValue x) = fmap Int16Desc  (fromIntegerChecked "Int16"  pos x)
+compileValue pos (BuiltinType BuiltinInt32 ) (IntegerFieldValue x) = fmap Int32Desc  (fromIntegerChecked "Int32"  pos x)
+compileValue pos (BuiltinType BuiltinInt64 ) (IntegerFieldValue x) = fmap Int64Desc  (fromIntegerChecked "Int64"  pos x)
+compileValue pos (BuiltinType BuiltinUInt8 ) (IntegerFieldValue x) = fmap UInt8Desc  (fromIntegerChecked "UInt8"  pos x)
+compileValue pos (BuiltinType BuiltinUInt16) (IntegerFieldValue x) = fmap UInt16Desc (fromIntegerChecked "UInt16" pos x)
+compileValue pos (BuiltinType BuiltinUInt32) (IntegerFieldValue x) = fmap UInt32Desc (fromIntegerChecked "UInt32" pos x)
+compileValue pos (BuiltinType BuiltinUInt64) (IntegerFieldValue x) = fmap UInt64Desc (fromIntegerChecked "UInt64" pos x)
 compileValue _ (BuiltinType BuiltinFloat32) (FloatFieldValue x) = succeed (Float32Desc (realToFrac x))
 compileValue _ (BuiltinType BuiltinFloat64) (FloatFieldValue x) = succeed (Float64Desc x)
 compileValue _ (BuiltinType BuiltinFloat32) (IntegerFieldValue x) = succeed (Float32Desc (realToFrac x))
 compileValue _ (BuiltinType BuiltinFloat64) (IntegerFieldValue x) = succeed (Float64Desc (realToFrac x))
 compileValue _ (BuiltinType BuiltinText) (StringFieldValue x) = succeed (TextDesc x)
-compileValue _ (BuiltinType BuiltinBytes) (StringFieldValue x) =
-    succeed (BytesDesc (map (fromIntegral . fromEnum) x))
+compileValue _ (BuiltinType BuiltinData) (StringFieldValue x) =
+    succeed (DataDesc (map (fromIntegral . fromEnum) x))
+
+compileValue pos (EnumType desc) (IdentifierFieldValue name) =
+    case lookupMember name (enumMemberMap desc) of
+        Just (DescEnumValue value) -> succeed (EnumValueValueDesc value)
+        _ -> makeError pos (printf "Enum type %s has no value %s." (enumName desc) name)
+
+compileValue _ (StructType desc) (RecordFieldValue fields) = result where
+    result = fmap StructValueDesc (doAll (map compileFieldAssignment fields))
+    compileFieldAssignment :: (Located String, Located FieldValue) -> Status (FieldDesc, ValueDesc)
+    compileFieldAssignment (Located namePos name, Located valPos val) =
+        case lookupMember name (structMemberMap desc) of
+            Just (DescField field) ->
+                fmap (\x -> (field, x)) (compileValue valPos (fieldType field) val)
+            _ -> makeError namePos (printf "Struct %s has no field %s." (structName desc) name)
+
+compileValue _ (ListType t) (ListFieldValue l) =
+    fmap ListDesc (doAll [ compileValue vpos t v | Located vpos v <- l ])
 
 compileValue pos (BuiltinType BuiltinVoid) _ = makeError pos "Void fields cannot have values."
 compileValue pos (BuiltinType BuiltinBool) _ = makeExpectError pos "boolean"
@@ -188,12 +210,12 @@ compileValue pos (BuiltinType BuiltinUInt64) _ = makeExpectError pos "integer"
 compileValue pos (BuiltinType BuiltinFloat32) _ = makeExpectError pos "number"
 compileValue pos (BuiltinType BuiltinFloat64) _ = makeExpectError pos "number"
 compileValue pos (BuiltinType BuiltinText) _ = makeExpectError pos "string"
-compileValue pos (BuiltinType BuiltinBytes) _ = makeExpectError pos "string"
+compileValue pos (BuiltinType BuiltinData) _ = makeExpectError pos "string"
 
-compileValue pos (EnumType _) _ = makeError pos "Unimplemented: enum default values"
-compileValue pos (StructType _) _ = makeError pos "Unimplemented: struct default values"
+compileValue pos (EnumType _) _ = makeExpectError pos "enum value name"
+compileValue pos (StructType _) _ = makeExpectError pos "parenthesized list of field assignments"
 compileValue pos (InterfaceType _) _ = makeError pos "Interfaces can't have default values."
-compileValue pos (ListType _) _ = makeError pos "Unimplemented: array default values"
+compileValue pos (ListType _) _ = makeExpectError pos "list"
 
 makeFileMemberMap :: FileDesc -> Map.Map String Desc
 makeFileMemberMap desc = Map.fromList allMembers where
@@ -226,6 +248,47 @@ compileType scope (TypeExpression n (param:moreParams)) = do
                 else makeError (declNamePos n) "'List' requires exactly one type parameter."
         _ -> makeError (declNamePos n) "Only the type 'List' can have type parameters."
 
+------------------------------------------------------------------------------------------
+
+requireSequentialNumbering :: String -> [Located Integer] -> Status ()
+requireSequentialNumbering kind items = Active () (loop 0 sortedItems) where
+    sortedItems = List.sort items
+    loop _ [] = []
+    loop expected (Located pos num:rest) = result where
+        rest' = loop (num + 1) rest
+        result = if num == expected
+            then rest'
+            else err:rest' where
+                err = newErrorMessage (Message message) pos
+                message = printf "Skipped number %d.  %s must be numbered sequentially starting \
+                                 \from zero." expected kind
+
+maxFieldNumber = 1023
+
+requireFieldNumbersInRange fieldNums =
+    Active () [ fieldNumError num pos | Located pos num <- fieldNums, num > maxFieldNumber ] where
+        fieldNumError num = newErrorMessage (Message
+            (printf "Field number %d too large; maximum is %d." num maxFieldNumber))
+
+requireNoDuplicateNames :: [Declaration] -> Status()
+requireNoDuplicateNames decls = Active () (loop (List.sort locatedNames)) where
+    locatedNames = mapMaybe declarationName decls
+    loop (Located pos1 val1:Located pos2 val2:t) =
+        if val1 == val2
+            then dupError val1 pos1:dupError val2 pos2:loop2 val1 t
+            else loop t
+    loop _ = []
+    loop2 val1 l@(Located pos2 val2:t) =
+        if val1 == val2
+            then dupError val2 pos2:loop2 val1 t
+            else loop l
+    loop2 _ _ = []
+
+    dupError val = newErrorMessage (Message message) where
+        message = printf "Duplicate declaration \"%s\"." val
+
+------------------------------------------------------------------------------------------
+
 data CompiledDecl = CompiledMember String (Status Desc)
                   | CompiledOption (Status OptionAssignmentDesc)
 
@@ -242,8 +305,6 @@ compileChildDecls desc decls = Active (members, memberMap, options) errors where
                            | CompiledOption (Active o _) <- compiledDecls]
     errors = concatMap compiledErrors compiledDecls
 
-doAll statuses = Active [x | (Active x _) <- statuses] (concatMap statusErrors statuses)
-
 compileDecl scope (AliasDecl (Located _ name) target) =
     CompiledMember name (do
         targetDesc <- lookupDesc scope target
@@ -267,6 +328,8 @@ compileDecl scope (ConstantDecl (Located _ name) t (Located valuePos value)) =
 compileDecl scope (EnumDecl (Located _ name) decls) =
     CompiledMember name (feedback (\desc -> do
         (members, memberMap, options) <- compileChildDecls desc decls
+        requireNoDuplicateNames decls
+        requireSequentialNumbering "Enum values" [ num | EnumValueDecl _ num _ <- decls ]
         return (DescEnum EnumDesc
             { enumName = name
             , enumParent = scope
@@ -289,6 +352,10 @@ compileDecl scope (EnumValueDecl (Located _ name) (Located _ number) decls) =
 compileDecl scope (StructDecl (Located _ name) decls) =
     CompiledMember name (feedback (\desc -> do
         (members, memberMap, options) <- compileChildDecls desc decls
+        requireNoDuplicateNames decls
+        fieldNums <- return [ num | FieldDecl _ num _ _ _ <- decls ]
+        requireSequentialNumbering "Fields" fieldNums
+        requireFieldNumbersInRange fieldNums
         return (DescStruct StructDesc
             { structName = name
             , structParent = scope
@@ -322,6 +389,8 @@ compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp default
 compileDecl scope (InterfaceDecl (Located _ name) decls) =
     CompiledMember name (feedback (\desc -> do
         (members, memberMap, options) <- compileChildDecls desc decls
+        requireNoDuplicateNames decls
+        requireSequentialNumbering "Methods" [ num | MethodDecl _ num _ _ _ <- decls ]
         return (DescInterface InterfaceDesc
             { interfaceName = name
             , interfaceParent = scope
@@ -372,6 +441,7 @@ compileParam scope (name, typeExp, defaultValue) = do
 compileFile name decls =
     feedback (\desc -> do
         (members, memberMap, options) <- compileChildDecls (DescFile desc) decls
+        requireNoDuplicateNames decls
         return FileDesc
             { fileName = name
             , fileImports = []

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