More misc stuff.

compiler/src/Compiler.hs

@@ -289,24 +289,31 @@ requireNoDuplicateNames decls = Active () (loop (List.sort locatedNames)) where
 
 ------------------------------------------------------------------------------------------
 
-data CompiledDecl = CompiledMember String (Status Desc)
-                  | CompiledOption (Status OptionAssignmentDesc)
+data CompiledStatementStatus = CompiledMemberStatus String (Status Desc)
+                             | CompiledOptionStatus (Status OptionAssignmentDesc)
 
-compiledErrors (CompiledMember _ status) = statusErrors status
-compiledErrors (CompiledOption status) = statusErrors status
+toCompiledStatement :: CompiledStatementStatus -> Maybe CompiledStatement
+toCompiledStatement (CompiledMemberStatus name (Active desc _)) = Just (CompiledMember desc)
+toCompiledStatement (CompiledOptionStatus (Active desc _)) = Just (CompiledOption desc)
+toCompiledStatement _ = Nothing
 
-compileChildDecls :: Desc -> [Declaration] -> Status ([Desc], MemberMap, OptionMap)
-compileChildDecls desc decls = Active (members, memberMap, options) errors where
+compiledErrors (CompiledMemberStatus _ status) = statusErrors status
+compiledErrors (CompiledOptionStatus status) = statusErrors status
+
+compileChildDecls :: Desc -> [Declaration]
+                  -> Status ([Desc], MemberMap, OptionMap, [CompiledStatement])
+compileChildDecls desc decls = Active (members, memberMap, options, statements) errors where
     compiledDecls = map (compileDecl desc) decls
     memberMap = Map.fromList memberPairs
     members = [member | (_, Just member) <- memberPairs]
-    memberPairs = [(name, statusToMaybe status) | CompiledMember name status <- compiledDecls]
+    memberPairs = [(name, statusToMaybe status) | CompiledMemberStatus name status <- compiledDecls]
     options = Map.fromList [(optionName (optionAssignmentOption o), o)
-                           | CompiledOption (Active o _) <- compiledDecls]
+                           | CompiledOptionStatus (Active o _) <- compiledDecls]
     errors = concatMap compiledErrors compiledDecls
+    statements = mapMaybe toCompiledStatement compiledDecls
 
 compileDecl scope (AliasDecl (Located _ name) target) =
-    CompiledMember name (do
+    CompiledMemberStatus name (do
         targetDesc <- lookupDesc scope target
         return (DescAlias AliasDesc
             { aliasName = name
@@ -315,7 +322,7 @@ compileDecl scope (AliasDecl (Located _ name) target) =
             }))
 
 compileDecl scope (ConstantDecl (Located _ name) t (Located valuePos value)) =
-    CompiledMember name (do
+    CompiledMemberStatus name (do
         typeDesc <- compileType scope t
         valueDesc <- compileValue valuePos typeDesc value
         return (DescConstant ConstantDesc
@@ -326,8 +333,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
+    CompiledMemberStatus name (feedback (\desc -> do
+        (members, memberMap, options, statements) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         requireSequentialNumbering "Enum values" [ num | EnumValueDecl _ num _ <- decls ]
         return (DescEnum EnumDesc
@@ -335,23 +342,24 @@ compileDecl scope (EnumDecl (Located _ name) decls) =
             , enumParent = scope
             , enumValues = [d | DescEnumValue d <- members]
             , enumOptions = options
-            , enumMembers = members
             , enumMemberMap = memberMap
+            , enumStatements = statements
             })))
 
 compileDecl scope (EnumValueDecl (Located _ name) (Located _ number) decls) =
-    CompiledMember name (feedback (\desc -> do
-        (_, _, options) <- compileChildDecls desc decls
+    CompiledMemberStatus name (feedback (\desc -> do
+        (_, _, options, statements) <- compileChildDecls desc decls
         return (DescEnumValue EnumValueDesc
             { enumValueName = name
             , enumValueParent = scope
             , enumValueNumber = number
             , enumValueOptions = options
+            , enumValueStatements = statements
             })))
 
 compileDecl scope (StructDecl (Located _ name) decls) =
-    CompiledMember name (feedback (\desc -> do
-        (members, memberMap, options) <- compileChildDecls desc decls
+    CompiledMemberStatus name (feedback (\desc -> do
+        (members, memberMap, options, statements) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         fieldNums <- return [ num | FieldDecl _ num _ _ _ <- decls ]
         requireSequentialNumbering "Fields" fieldNums
@@ -366,17 +374,17 @@ compileDecl scope (StructDecl (Located _ name) decls) =
             , structNestedStructs    = [d | DescStruct    d <- members]
             , structNestedInterfaces = [d | DescInterface d <- members]
             , structOptions = options
-            , structMembers = members
             , structMemberMap = memberMap
+            , structStatements = statements
             })))
 
 compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp defaultValue decls) =
-    CompiledMember name (feedback (\desc -> do
+    CompiledMemberStatus name (feedback (\desc -> do
         typeDesc <- compileType scope typeExp
         defaultDesc <- case defaultValue of
             Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
             Nothing -> return Nothing
-        (_, _, options) <- compileChildDecls desc decls
+        (_, _, options, statements) <- compileChildDecls desc decls
         return (DescField FieldDesc
             { fieldName = name
             , fieldParent = scope
@@ -384,11 +392,12 @@ compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp default
             , fieldType = typeDesc
             , fieldDefaultValue = defaultDesc
             , fieldOptions = options
+            , fieldStatements = statements
             })))
 
 compileDecl scope (InterfaceDecl (Located _ name) decls) =
-    CompiledMember name (feedback (\desc -> do
-        (members, memberMap, options) <- compileChildDecls desc decls
+    CompiledMemberStatus name (feedback (\desc -> do
+        (members, memberMap, options, statements) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         requireSequentialNumbering "Methods" [ num | MethodDecl _ num _ _ _ <- decls ]
         return (DescInterface InterfaceDesc
@@ -401,15 +410,15 @@ compileDecl scope (InterfaceDecl (Located _ name) decls) =
             , interfaceNestedStructs    = [d | DescStruct    d <- members]
             , interfaceNestedInterfaces = [d | DescInterface d <- members]
             , interfaceOptions = options
-            , interfaceMembers = members
             , interfaceMemberMap = memberMap
+            , interfaceStatements = statements
             })))
 
 compileDecl scope (MethodDecl (Located _ name) (Located _ number) params returnType decls) =
-    CompiledMember name (feedback (\desc -> do
+    CompiledMemberStatus name (feedback (\desc -> do
         paramDescs <- doAll (map (compileParam scope) params)
         returnTypeDesc <- compileType scope returnType
-        (_, _, options) <- compileChildDecls desc decls
+        (_, _, options, statements) <- compileChildDecls desc decls
         return (DescMethod MethodDesc
             { methodName = name
             , methodParent = scope
@@ -417,17 +426,19 @@ compileDecl scope (MethodDecl (Located _ name) (Located _ number) params returnT
             , methodParams = paramDescs
             , methodReturnType = returnTypeDesc
             , methodOptions = options
+            , methodStatements = statements
             })))
 
 compileDecl scope (OptionDecl name (Located valuePos value)) =
-    CompiledOption (do
+    CompiledOptionStatus (do
         uncheckedOptionDesc <- lookupDesc scope name
         optionDesc <- case uncheckedOptionDesc of
             (DescOption d) -> return d
             _ -> makeError (declNamePos name) (printf "'%s' is not an option." (declNameString name))
         valueDesc <- compileValue valuePos (optionType optionDesc) value
         return OptionAssignmentDesc
-            { optionAssignmentOption = optionDesc
+            { optionAssignmentParent = scope
+            , optionAssignmentOption = optionDesc
             , optionAssignmentValue = valueDesc
             })
 
@@ -440,7 +451,7 @@ compileParam scope (name, typeExp, defaultValue) = do
 
 compileFile name decls =
     feedback (\desc -> do
-        (members, memberMap, options) <- compileChildDecls (DescFile desc) decls
+        (members, memberMap, options, statements) <- compileChildDecls (DescFile desc) decls
         requireNoDuplicateNames decls
         return FileDesc
             { fileName = name
@@ -451,11 +462,17 @@ compileFile name decls =
             , fileStructs    = [d | DescStruct    d <- members]
             , fileInterfaces = [d | DescInterface d <- members]
             , fileOptions = options
-            , fileMembers = members
             , fileMemberMap = memberMap
             , fileImportMap = undefined
+            , fileStatements = statements
             })
 
 parseAndCompileFile filename text = result where
     (decls, parseErrors) = parseFile filename text
+    -- Here we're doing the copmile step even if there were errors in parsing, and just combining
+    -- all the errors together.  This may allow the user to fix more errors per compiler iteration,
+    -- but it might also be confusing if a parse error causes a subsequent compile error, especially
+    -- if the compile error ends up being on a line before the parse error (e.g. there's a parse
+    -- error in a type definition, causing a not-defined error on a field trying to use that type).
+    -- TODO:  Re-evaluate after getting some experience on whether this is annoing.
     result = statusAddErrors parseErrors (compileFile filename decls)

compiler/src/Main.hs

@@ -29,6 +29,7 @@ import Util(delimit)
 import Text.Parsec.Pos
 import Text.Parsec.Error
 import Text.Printf(printf)
+import qualified Data.List as List
 
 main::IO()
 main = do
@@ -39,17 +40,13 @@ handleFile filename = do
     text <- readFile filename
     case parseAndCompileFile filename text of
         Active desc [] -> print desc
-        Active _ e -> mapM_ printError e
-        Failed e -> mapM_ printError e
+        Active _ e -> mapM_ printError (List.sortBy compareErrors e)
+        Failed e -> mapM_ printError (List.sortBy compareErrors 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)
+compareErrors a b = compare (errorPos a) (errorPos b)
 
+-- TODO:  This is a fairly hacky way to make showErrorMessages' output not suck.  We could do better
+--   by interpreting the error structure ourselves.
 printError e = printf "%s:%d:%d: %s\n" f l c m' where
     pos = errorPos e
     f = sourceName pos
@@ -57,4 +54,4 @@ printError e = printf "%s:%d:%d: %s\n" f l c m' where
     c = sourceColumn pos
     m = showErrorMessages "or" "Unknown parse error" "Expected" "Unexpected" "end of expression"
         (errorMessages e)
-    m' = delimit "; " (lines m)
+    m' = delimit "; " (List.filter (not . null) (lines m))

compiler/src/Semantics.hs

@@ -25,6 +25,7 @@ module Semantics where
 
 import qualified Data.Map as Map
 import qualified Data.List as List
+import qualified Data.Maybe as Maybe
 import Data.Int (Int8, Int16, Int32, Int64)
 import Data.Word (Word8, Word16, Word32, Word64)
 import Data.Char (chr)
@@ -89,7 +90,7 @@ builtinTypes = [minBound::BuiltinType .. maxBound::BuiltinType]
 
 -- Get in-language name of type.
 builtinTypeName :: BuiltinType -> String
-builtinTypeName = List.drop 7 . show  -- drop "Builtin" prefix
+builtinTypeName = Maybe.fromJust . List.stripPrefix "Builtin" . show
 
 data ValueDesc = VoidDesc
                | BoolDesc Bool
@@ -170,9 +171,9 @@ data FileDesc = FileDesc
     , fileStructs :: [StructDesc]
     , fileInterfaces :: [InterfaceDesc]
     , fileOptions :: OptionMap
-    , fileMembers :: [Desc]
     , fileMemberMap :: MemberMap
     , fileImportMap :: Map.Map String FileDesc
+    , fileStatements :: [CompiledStatement]
     }
 
 data AliasDesc = AliasDesc
@@ -193,8 +194,8 @@ data EnumDesc = EnumDesc
     , enumParent :: Desc
     , enumValues :: [EnumValueDesc]
     , enumOptions :: OptionMap
-    , enumMembers :: [Desc]
     , enumMemberMap :: MemberMap
+    , enumStatements :: [CompiledStatement]
     }
 
 data EnumValueDesc = EnumValueDesc
@@ -202,6 +203,7 @@ data EnumValueDesc = EnumValueDesc
     , enumValueParent :: Desc
     , enumValueNumber :: Integer
     , enumValueOptions :: OptionMap
+    , enumValueStatements :: [CompiledStatement]
     }
 
 data StructDesc = StructDesc
@@ -214,8 +216,8 @@ data StructDesc = StructDesc
     , structNestedStructs :: [StructDesc]
     , structNestedInterfaces :: [InterfaceDesc]
     , structOptions :: OptionMap
-    , structMembers :: [Desc]
     , structMemberMap :: MemberMap
+    , structStatements :: [CompiledStatement]
     }
 
 data FieldDesc = FieldDesc
@@ -225,6 +227,7 @@ data FieldDesc = FieldDesc
     , fieldType :: TypeDesc
     , fieldDefaultValue :: Maybe ValueDesc
     , fieldOptions :: OptionMap
+    , fieldStatements :: [CompiledStatement]
     }
 
 data InterfaceDesc = InterfaceDesc
@@ -237,8 +240,8 @@ data InterfaceDesc = InterfaceDesc
     , interfaceNestedStructs :: [StructDesc]
     , interfaceNestedInterfaces :: [InterfaceDesc]
     , interfaceOptions :: OptionMap
-    , interfaceMembers :: [Desc]
     , interfaceMemberMap :: MemberMap
+    , interfaceStatements :: [CompiledStatement]
     }
 
 data MethodDesc = MethodDesc
@@ -248,12 +251,14 @@ data MethodDesc = MethodDesc
     , methodParams :: [(String, TypeDesc, Maybe ValueDesc)]
     , methodReturnType :: TypeDesc
     , methodOptions :: OptionMap
+    , methodStatements :: [CompiledStatement]
     }
 
 type OptionMap = Map.Map String OptionAssignmentDesc
 
 data OptionAssignmentDesc = OptionAssignmentDesc
-    { optionAssignmentOption :: OptionDesc
+    { optionAssignmentParent :: Desc
+    , optionAssignmentOption :: OptionDesc
     , optionAssignmentValue :: ValueDesc
     }
 
@@ -265,9 +270,12 @@ data OptionDesc = OptionDesc
     , optionDefaultValue :: Maybe ValueDesc
     }
 
+data CompiledStatement = CompiledMember Desc
+                       | CompiledOption OptionAssignmentDesc
+
 -- TODO:  Print options as well as members.  Will be ugly-ish.
 descToCode :: String -> Desc -> String
-descToCode indent (DescFile desc) = concatMap (descToCode indent) (fileMembers desc)
+descToCode indent (DescFile desc) = concatMap (statementToCode indent) (fileStatements desc)
 descToCode indent (DescAlias desc) = printf "%susing %s = %s;\n" indent
     (aliasName desc)
     (descQualifiedName (aliasParent desc) (aliasTarget desc))
@@ -275,30 +283,27 @@ descToCode indent (DescConstant desc) = printf "%sconst %s: %s = %s;\n" indent
     (constantName desc)
     (typeName (constantParent desc) (constantType desc))
     (valueString (constantValue desc))
-descToCode indent (DescEnum desc) = printf "%senum %s {\n%s%s}\n" indent
+descToCode indent (DescEnum desc) = printf "%senum %s%s" indent
     (enumName desc)
-    (concatMap (descToCode ("  " ++ indent)) (enumMembers desc))
-    indent
-descToCode indent (DescEnumValue desc) = printf "%s%s = %d;\n" indent
-    (enumValueName desc) (enumValueNumber desc)
-descToCode indent (DescStruct desc) = printf "%sstruct %s {\n%s%s}\n" indent
+    (blockCode indent (enumStatements desc))
+descToCode indent (DescEnumValue desc) = printf "%s%s = %d%s" indent
+    (enumValueName desc) (enumValueNumber desc) (maybeBlockCode indent $ enumValueStatements desc)
+descToCode indent (DescStruct desc) = printf "%sstruct %s%s" indent
     (structName desc)
-    (concatMap (descToCode ("  " ++ indent)) (structMembers desc))
-    indent
-descToCode indent (DescField desc) = printf "%s%s@%d: %s%s;\n" indent
+    (blockCode indent (structStatements desc))
+descToCode indent (DescField desc) = printf "%s%s@%d: %s%s%s" indent
     (fieldName desc) (fieldNumber desc)
     (typeName (fieldParent desc) (fieldType desc))
     (case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
-descToCode indent (DescInterface desc) = printf "%sinterface %s {\n%s%s}\n" indent
+    (maybeBlockCode indent $ fieldStatements desc)
+descToCode indent (DescInterface desc) = printf "%sinterface %s%s" indent
     (interfaceName desc)
-    (concatMap (descToCode ("  " ++ indent)) (interfaceMembers desc))
-    indent
-descToCode indent (DescMethod desc) = printf "%s%s@%d(%s): %s;\n" indent
+    (blockCode indent (interfaceStatements desc))
+descToCode indent (DescMethod desc) = printf "%s%s@%d(%s): %s%s" indent
     (methodName desc) (methodNumber desc)
-    (delimit (map paramToCode (methodParams desc)))
-    (typeName (methodParent desc) (methodReturnType desc)) where
-        delimit [] = ""
-        delimit (h:t) = h ++ concatMap (", " ++) t
+    (delimit ", " (map paramToCode (methodParams desc)))
+    (typeName (methodParent desc) (methodReturnType desc))
+    (maybeBlockCode indent $ methodStatements desc) where
         paramToCode (name, t, Nothing) = printf "%s: %s" name (typeName (methodParent desc) t)
         paramToCode (name, t, Just v) = printf "%s: %s = %s"
             name (typeName (methodParent desc) t) (valueString v)
@@ -306,6 +311,22 @@ descToCode _ (DescOption _) = error "options not implemented"
 descToCode _ (DescBuiltinType _) = error "Can't print code for builtin type."
 descToCode _ DescBuiltinList = error "Can't print code for builtin type."
 
+statementToCode :: String -> CompiledStatement -> String
+statementToCode indent (CompiledMember desc) = descToCode indent desc
+statementToCode indent (CompiledOption desc) = printf "%s%s.%s = %s;\n" indent
+    (descQualifiedName (optionAssignmentParent desc) $ optionParent $ optionAssignmentOption desc)
+    (optionName $ optionAssignmentOption desc)
+    (valueString (optionAssignmentValue desc))
+
+maybeBlockCode :: String -> [CompiledStatement] -> String
+maybeBlockCode _ [] = ";\n"
+maybeBlockCode indent statements = blockCode indent statements
+
+blockCode :: String -> [CompiledStatement] -> String
+blockCode indent statements = printf " {\n%s%s}\n"
+    (concatMap (statementToCode ("  " ++ indent)) statements)
+    indent
+
 instance Show FileDesc where { show desc = descToCode "" (DescFile desc) }
 instance Show AliasDesc where { show desc = descToCode "" (DescAlias desc) }
 instance Show ConstantDesc where { show desc = descToCode "" (DescConstant desc) }

compiler/src/Util.hs

@@ -23,8 +23,11 @@
 
 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
+delimit _ [] = ""
+delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
+
+--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