Skip to content

C
capnproto
Commit 4b4c3970 authored by Kenton Varda's avatar Kenton Varda
Browse files
Options

More misc stuff.

parent f0877237
Hide whitespace changes
Inline Side-by-side
Showing with 106 additions and 68 deletions
compiler/src/Compiler.hs
View file @ 4b4c3970
......@@ -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
View file @ 4b4c3970
......@@ -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
View file @ 4b4c3970
......@@ -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
View file @ 4b4c3970
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment