Skip to content

C
capnproto
Commit 22a75445 authored by Kenton Varda's avatar Kenton Varda
Browse files
Options

Compile semantic descriptors.

parent 6bb49ca7
Show whitespace changes
Inline Side-by-side
Showing with 775 additions and 54 deletions
compiler/capnproto-compiler.cabal
View file @ 22a75445
......@@ -17,5 +17,7 @@ executable capnproto-compiler
Lexer,
Token,
Grammar,
Parser
Parser,
Compiler,
Semantics
compiler/src/Compiler.hs 0 → 100644
View file @ 22a75445
-- 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 Compiler where
import Grammar
import Semantics
import Token(Located(Located))
import Parser(parseFile)
import qualified Data.Map as Map
import Text.Parsec.Pos(SourcePos, newPos)
import Text.Parsec.Error(ParseError, newErrorMessage, Message(Message, Expect))
import Text.Printf(printf)
------------------------------------------------------------------------------------------
-- Error helpers
------------------------------------------------------------------------------------------
data Status a = Active a [ParseError]
| Failed [ParseError]
deriving(Show)
statusErrors (Active _ e) = e
statusErrors (Failed e) = e
statusAddErrors errs (Active x e) = Active x (e ++ errs)
statusAddErrors errs (Failed e) = Failed (e ++ errs)
instance Functor Status where
fmap f (Active x e) = Active (f x) e
fmap _ (Failed e) = Failed e
instance Monad Status where
(Active x e) >>= k = statusAddErrors e (k x)
(Failed e) >>= _ = Failed e
-- If the result is ignored, we can automatically recover.
(Active _ e) >> k = statusAddErrors e k
(Failed e) >> k = statusAddErrors e k
return x = Active x []
fail = makeError (newPos "?" 0 0)
recover :: a -> Status a -> Status a
recover _ (Active x e) = Active x e
recover x (Failed e) = Active x e
succeed :: a -> Status a
succeed x = Active x []
makeError pos message = Failed [ newErrorMessage (Message message) pos ]
makeExpectError pos message = Failed [ newErrorMessage (Expect message) pos ]
maybeError :: Maybe t -> SourcePos -> String -> Status t
maybeError (Just x) _ _ = succeed x
maybeError Nothing pos message = makeError pos message
declNamePos (AbsoluteName (Located pos _)) = pos
declNamePos (RelativeName (Located pos _)) = pos
declNamePos (ImportName (Located pos _)) = pos
declNamePos (MemberName _ (Located pos _)) = pos
declNameString (AbsoluteName (Located _ n)) = n
declNameString (RelativeName (Located _ n)) = n
declNameString (ImportName (Located _ n)) = n
declNameString (MemberName _ (Located _ n)) = n
-- Trick for feeding a function's own result back in as a parameter, taking advantage of
-- lazy evaluation. If the function returns a Failed status, then it must do so withous using
-- its parameter.
feedback :: (a -> Status a) -> Status a
feedback f = status where
status = f result
result = case status of
Active x _ -> x
Failed _ -> undefined
statusToMaybe (Active x _) = Just x
statusToMaybe (Failed _) = Nothing
------------------------------------------------------------------------------------------
-- Symbol lookup
------------------------------------------------------------------------------------------
-- | Look up a direct member of a descriptor by name.
descMember name (DescFile d) = lookupMember name (fileMemberMap d)
descMember name (DescEnum d) = lookupMember name (enumMemberMap d)
descMember name (DescClass d) = lookupMember name (classMemberMap d)
descMember name (DescInterface d) = lookupMember name (interfaceMemberMap d)
descMember name (DescAlias d) = descMember name (aliasTarget d)
descMember _ _ = Nothing
-- | Lookup the given name in the scope of the given descriptor.
lookupDesc :: Desc -> DeclName -> Status Desc
-- For a member, look up the parent, then apply descMember.
lookupDesc scope (MemberName parentName (Located pos name)) = do
p <- lookupDesc scope parentName
maybeError (descMember name p) pos
(printf "'%s' is not defined in '%s'." name (declNameString parentName))
-- Implement absolute, relative, and import names on the file scope by just checking the appropriate
-- map. There is not parent scope to which to recurse.
lookupDesc (DescFile desc) (AbsoluteName (Located pos name)) =
maybeError (lookupMember name (fileMemberMap desc)) pos
(printf "'%s' is not defined." name)
lookupDesc (DescFile desc) (RelativeName (Located pos name)) = result where
maybeResult = case lookupMember name (fileMemberMap desc) of
Just x -> Just x
Nothing -> Map.lookup name builtinTypeMap
result = maybeError maybeResult pos
(printf "'%s' is not defined." name)
lookupDesc (DescFile desc) (ImportName (Located pos name)) =
maybeError (fmap DescFile (Map.lookup name (fileImportMap desc))) pos
(printf "'%s' was not in the import table." name)
-- Implement other relative names by first checking the current scope, then the parent.
lookupDesc scope (RelativeName (Located pos name)) =
case descMember name scope of
Just m -> succeed m
Nothing -> lookupDesc (descParent scope) (RelativeName (Located pos name))
-- For non-relative names on non-file scopes, just recurse out to parent scope.
lookupDesc scope name = lookupDesc (descParent scope) name
builtinTypeMap :: Map.Map String Desc
builtinTypeMap = Map.fromList
([(builtinTypeName t, DescBuiltinType t) | t <- builtinTypes] ++
[("List", DescBuiltinList)])
------------------------------------------------------------------------------------------
fromIntegerChecked :: Integral a => SourcePos -> Integer -> Status a
fromIntegerChecked pos x = result where
unchecked = fromInteger x
result = if toInteger unchecked == x
then succeed unchecked
else makeError pos "Integer out of range for type."
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 _ (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 pos (BuiltinType BuiltinVoid) _ = makeError pos "Void fields cannot have values."
compileValue pos (BuiltinType BuiltinBool) _ = makeExpectError pos "boolean"
compileValue pos (BuiltinType BuiltinInt8) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt16) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt32) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt64) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt8) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt16) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt32) _ = makeExpectError pos "integer"
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 (EnumType _) _ = makeError pos "Unimplemented: enum default values"
compileValue pos (ClassType _) _ = makeError pos "Unimplemented: class default values"
compileValue pos (InterfaceType _) _ = makeError pos "Interfaces can't have default values."
compileValue pos (ListType _) _ = makeError pos "Unimplemented: array default values"
makeFileMemberMap :: FileDesc -> Map.Map String Desc
makeFileMemberMap desc = Map.fromList allMembers where
allMembers = [ (aliasName m, DescAlias m) | m <- fileAliases desc ]
++ [ (constantName m, DescConstant m) | m <- fileConstants desc ]
++ [ (enumName m, DescEnum m) | m <- fileEnums desc ]
++ [ (className m, DescClass m) | m <- fileClasses desc ]
++ [ (interfaceName m, DescInterface m) | m <- fileInterfaces desc ]
descAsType _ (DescEnum desc) = succeed (EnumType desc)
descAsType _ (DescClass desc) = succeed (ClassType desc)
descAsType _ (DescInterface desc) = succeed (InterfaceType desc)
descAsType _ (DescBuiltinType desc) = succeed (BuiltinType desc)
descAsType name (DescAlias desc) = descAsType name (aliasTarget desc)
descAsType name DescBuiltinList = makeError (declNamePos name) message where
message = printf "'List' requires exactly one type parameter." (declNameString name)
descAsType name _ = makeError (declNamePos name) message where
message = printf "'%s' is not a type." (declNameString name)
compileType :: Desc -> TypeExpression -> Status TypeDesc
compileType scope (TypeExpression n []) = do
desc <- lookupDesc scope n
descAsType n desc
compileType scope (TypeExpression n (param:moreParams)) = do
desc <- lookupDesc scope n
case desc of
DescBuiltinList ->
if null moreParams
then fmap ListType (compileType scope param)
else makeError (declNamePos n) "'List' requires exactly one type parameter."
_ -> makeError (declNamePos n) "Only the type 'List' can have type parameters."
data CompiledDecl = CompiledMember String (Status Desc)
| CompiledOption (Status OptionAssignmentDesc)
compiledErrors (CompiledMember _ status) = statusErrors status
compiledErrors (CompiledOption status) = statusErrors status
compileChildDecls :: Desc -> [Declaration] -> Status ([Desc], MemberMap, OptionMap)
compileChildDecls desc decls = Active (members, memberMap, options) errors where
compiledDecls = map (compileDecl desc) decls
memberMap = Map.fromList memberPairs
members = [member | (_, Just member) <- memberPairs]
memberPairs = [(name, statusToMaybe status) | CompiledMember name status <- compiledDecls]
options = Map.fromList [(optionName (optionAssignmentOption o), o)
| 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
return (DescAlias AliasDesc
{ aliasName = name
, aliasParent = scope
, aliasTarget = targetDesc
}))
compileDecl scope (ConstantDecl (Located _ name) t (Located valuePos value)) =
CompiledMember name (do
typeDesc <- compileType scope t
valueDesc <- compileValue valuePos typeDesc value
return (DescConstant ConstantDesc
{ constantName = name
, constantParent = scope
, constantType = typeDesc
, constantValue = valueDesc
}))
compileDecl scope (EnumDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
return (DescEnum EnumDesc
{ enumName = name
, enumParent = scope
, enumValues = [d | DescEnumValue d <- members]
, enumOptions = options
, enumMembers = members
, enumMemberMap = memberMap
})))
compileDecl scope (EnumValueDecl (Located _ name) (Located _ number) decls) =
CompiledMember name (feedback (\desc -> do
(_, _, options) <- compileChildDecls desc decls
return (DescEnumValue EnumValueDesc
{ enumValueName = name
, enumValueParent = scope
, enumValueNumber = number
, enumValueOptions = options
})))
compileDecl scope (ClassDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
return (DescClass ClassDesc
{ className = name
, classParent = scope
, classFields = [d | DescField d <- members]
, classNestedAliases = [d | DescAlias d <- members]
, classNestedConstants = [d | DescConstant d <- members]
, classNestedEnums = [d | DescEnum d <- members]
, classNestedClasses = [d | DescClass d <- members]
, classNestedInterfaces = [d | DescInterface d <- members]
, classOptions = options
, classMembers = members
, classMemberMap = memberMap
})))
compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp defaultValue decls) =
CompiledMember 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
return (DescField FieldDesc
{ fieldName = name
, fieldParent = scope
, fieldNumber = number
, fieldType = typeDesc
, fieldDefaultValue = defaultDesc
, fieldOptions = options
})))
compileDecl scope (InterfaceDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
return (DescInterface InterfaceDesc
{ interfaceName = name
, interfaceParent = scope
, interfaceMethods = [d | DescMethod d <- members]
, interfaceNestedAliases = [d | DescAlias d <- members]
, interfaceNestedConstants = [d | DescConstant d <- members]
, interfaceNestedEnums = [d | DescEnum d <- members]
, interfaceNestedClasses = [d | DescClass d <- members]
, interfaceNestedInterfaces = [d | DescInterface d <- members]
, interfaceOptions = options
, interfaceMembers = members
, interfaceMemberMap = memberMap
})))
compileDecl scope (MethodDecl (Located _ name) (Located _ number) params returnType decls) =
CompiledMember name (feedback (\desc -> do
paramDescs <- doAll (map (compileParam scope) params)
returnTypeDesc <- compileType scope returnType
(_, _, options) <- compileChildDecls desc decls
return (DescMethod MethodDesc
{ methodName = name
, methodParent = scope
, methodNumber = number
, methodParams = paramDescs
, methodReturnType = returnTypeDesc
, methodOptions = options
})))
compileDecl scope (OptionDecl name (Located valuePos value)) =
CompiledOption (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
, optionAssignmentValue = valueDesc
})
compileParam scope (name, typeExp, defaultValue) = do
typeDesc <- compileType scope typeExp
defaultDesc <- case defaultValue of
Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
Nothing -> return Nothing
return (name, typeDesc, defaultDesc)
compileFile name decls =
feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls (DescFile desc) decls
return FileDesc
{ fileName = name
, fileImports = []
, fileAliases = [d | DescAlias d <- members]
, fileConstants = [d | DescConstant d <- members]
, fileEnums = [d | DescEnum d <- members]
, fileClasses = [d | DescClass d <- members]
, fileInterfaces = [d | DescInterface d <- members]
, fileOptions = options
, fileMembers = members
, fileMemberMap = memberMap
, fileImportMap = undefined
})
parseAndCompileFile filename text = result where
(decls, parseErrors) = parseFile filename text
result = statusAddErrors parseErrors (compileFile filename decls)
compiler/src/Grammar.hs
View file @ 22a75445
......@@ -23,14 +23,15 @@
module Grammar where
data DeclName = AbsoluteName String
| RelativeName String
| ImportName String
| MemberName DeclName String
import Token (Located)
data DeclName = AbsoluteName (Located String)
| RelativeName (Located String)
| ImportName (Located String)
| MemberName DeclName (Located String)
deriving (Show)
data TypeExpression = TypeName DeclName
| Array TypeExpression
data TypeExpression = TypeExpression DeclName [TypeExpression]
deriving (Show)
data FieldValue = VoidFieldValue
......@@ -42,13 +43,16 @@ data FieldValue = VoidFieldValue
| RecordFieldValue [(String, FieldValue)]
deriving (Show)
data Declaration = ConstantDecl String (Maybe TypeExpression) FieldValue
| EnumDecl String [Declaration]
| EnumValueDecl String Integer [Declaration]
| ClassDecl String [Declaration]
| FieldDecl String Integer TypeExpression FieldValue [Declaration]
| InterfaceDecl String [Declaration]
| MethodDecl String [(String, TypeExpression, FieldValue)]
data Declaration = AliasDecl (Located String) DeclName
| ConstantDecl (Located String) TypeExpression (Located FieldValue)
| EnumDecl (Located String) [Declaration]
| EnumValueDecl (Located String) (Located Integer) [Declaration]
| ClassDecl (Located String) [Declaration]
| FieldDecl (Located String) (Located Integer)
TypeExpression (Maybe (Located FieldValue)) [Declaration]
| InterfaceDecl (Located String) [Declaration]
| MethodDecl (Located String) (Located Integer)
[(String, TypeExpression, Maybe (Located FieldValue))]
TypeExpression [Declaration]
| OptionDecl DeclName FieldValue
| OptionDecl DeclName (Located FieldValue)
deriving (Show)
compiler/src/Lexer.hs
View file @ 22a75445
......@@ -32,6 +32,7 @@ import Token
keywords =
[ (ImportKeyword, "import")
, (UsingKeyword, "using")
, (ConstKeyword, "const")
, (EnumKeyword, "enum")
, (ClassKeyword, "class")
......
compiler/src/Main.hs
View file @ 22a75445
......@@ -23,5 +23,17 @@
module Main ( main ) where
import System.Environment
import Compiler
main::IO()
main = undefined
main = do
files <- getArgs
mapM_ handleFile files
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
compiler/src/Parser.hs
View file @ 22a75445
......@@ -34,6 +34,12 @@ tokenParser = token (show . locatedValue) locatedPos
type TokenParser = Parsec [Located Token] [ParseError]
located :: TokenParser t -> TokenParser (Located t)
located p = do
input <- getInput
t <- p
return (Located (locatedPos (head input)) t)
-- Hmm, boilerplate is not supposed to happen in Haskell.
matchIdentifier t = case locatedValue t of { (Identifier v) -> Just v; _ -> Nothing }
matchParenthesizedList t = case locatedValue t of { (ParenthesizedList v) -> Just v; _ -> Nothing }
......@@ -53,6 +59,7 @@ 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)
classKeyword = tokenParser (matchSimpleToken ClassKeyword)
......@@ -67,37 +74,40 @@ bracketedList parser = do
parseList parser items
declNameBase :: TokenParser DeclName
declNameBase = liftM ImportName (importKeyword >> literalString)
<|> liftM AbsoluteName (period >> identifier)
<|> liftM RelativeName identifier
declNameBase = liftM ImportName (importKeyword >> located literalString)
<|> liftM AbsoluteName (period >> located identifier)
<|> liftM RelativeName (located identifier)
declName :: TokenParser DeclName
declName = do
base <- declNameBase
members <- many (period >> identifier)
members <- many (period >> located identifier)
return (foldl MemberName base members :: DeclName)
typeExpression :: TokenParser TypeExpression
typeExpression = do
name <- declName
suffixes <- many (bracketedList (fail "Brackets should be empty."))
return (applySuffixes (TypeName name) (length suffixes)) where
applySuffixes t 0 = t
applySuffixes t n = applySuffixes (Array t) (n - 1)
suffixes <- option [] (parenthesizedList typeExpression)
return (TypeExpression name suffixes)
topLine :: Maybe [Located Statement] -> TokenParser Declaration
topLine Nothing = optionDecl <|> constantDecl <|> implicitConstantDecl
topLine Nothing = optionDecl <|> aliasDecl <|> constantDecl
topLine (Just statements) = typeDecl statements
aliasDecl = do
usingKeyword
name <- located identifier
equalsSign
target <- declName
return (AliasDecl name target)
constantDecl = do
constKeyword
implicitConstantDecl
implicitConstantDecl = do
name <- identifier
typeName <- optionMaybe (period >> typeExpression)
name <- located identifier
colon
typeName <- typeExpression
equalsSign
value <- fieldValue
value <- located fieldValue
return (ConstantDecl name typeName value)
typeDecl statements = enumDecl statements
......@@ -106,7 +116,7 @@ typeDecl statements = enumDecl statements
enumDecl statements = do
enumKeyword
name <- identifier
name <- located identifier
children <- parseBlock enumLine statements
return (EnumDecl name children)
......@@ -115,9 +125,9 @@ enumLine Nothing = optionDecl <|> enumValueDecl []
enumLine (Just statements) = enumValueDecl statements
enumValueDecl statements = do
name <- identifier
name <- located identifier
equalsSign
value <- literalInt
value <- located literalInt
children <- parseBlock enumValueLine statements
return (EnumValueDecl name value children)
......@@ -127,7 +137,7 @@ enumValueLine (Just _) = fail "Blocks not allowed here."
classDecl statements = do
classKeyword
name <- identifier
name <- located identifier
children <- parseBlock classLine statements
return (ClassDecl name children)
......@@ -136,12 +146,12 @@ classLine Nothing = optionDecl <|> constantDecl <|> fieldDecl []
classLine (Just statements) = typeDecl statements <|> fieldDecl statements
fieldDecl statements = do
name <- identifier
name <- located identifier
atSign
ordinal <- literalInt
ordinal <- located literalInt
colon
t <- typeExpression
value <- option VoidFieldValue (equalsSign >> fieldValue)
value <- optionMaybe (equalsSign >> located fieldValue)
children <- parseBlock fieldLine statements
return (FieldDecl name ordinal t value children)
......@@ -163,7 +173,7 @@ fieldLine (Just _) = fail "Blocks not allowed here."
interfaceDecl statements = do
interfaceKeyword
name <- identifier
name <- located identifier
children <- parseBlock interfaceLine statements
return (InterfaceDecl name children)
......@@ -172,17 +182,19 @@ interfaceLine Nothing = optionDecl <|> constantDecl <|> methodDecl []
interfaceLine (Just statements) = typeDecl statements <|> methodDecl statements
methodDecl statements = do
name <- identifier
name <- located identifier
atSign
ordinal <- located literalInt
params <- parenthesizedList paramDecl
t <- typeExpression
children <- parseBlock methodLine statements
return (MethodDecl name params t children)
return (MethodDecl name ordinal params t children)
paramDecl = do
name <- identifier
colon
t <- typeExpression
value <- option VoidFieldValue (equalsSign >> fieldValue)
value <- optionMaybe (equalsSign >> located fieldValue)
return (name, t, value)
methodLine :: Maybe [Located Statement] -> TokenParser Declaration
......@@ -193,7 +205,7 @@ optionDecl = do
optionKeyword
name <- declName
equalsSign
value <- fieldValue
value <- located fieldValue
return (OptionDecl name value)
extractErrors :: Either ParseError (a, [ParseError]) -> [ParseError]
......
compiler/src/Semantics.hs 0 → 100644
View file @ 22a75445
-- 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 Semantics where
import qualified Data.Map as Map
import qualified Data.List as List
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Char (chr)
import Text.Printf(printf)
import Control.Monad(join)
type ByteString = [Word8]
data Desc = DescFile FileDesc
| DescAlias AliasDesc
| DescConstant ConstantDesc
| DescEnum EnumDesc
| DescEnumValue EnumValueDesc
| DescClass ClassDesc
| DescField FieldDesc
| DescInterface InterfaceDesc
| DescMethod MethodDesc
| DescOption OptionDesc
| DescBuiltinType BuiltinType
| DescBuiltinList
descName (DescFile _) = "(top-level)"
descName (DescAlias d) = aliasName d
descName (DescConstant d) = constantName d
descName (DescEnum d) = enumName d
descName (DescEnumValue d) = enumValueName d
descName (DescClass d) = className d
descName (DescField d) = fieldName d
descName (DescInterface d) = interfaceName d
descName (DescMethod d) = methodName d
descName (DescOption d) = optionName d
descName (DescBuiltinType d) = builtinTypeName d
descName DescBuiltinList = "List"
descParent (DescFile _) = error "File descriptor has no parent."
descParent (DescAlias d) = aliasParent d
descParent (DescConstant d) = constantParent d
descParent (DescEnum d) = enumParent d
descParent (DescEnumValue d) = enumValueParent d
descParent (DescClass d) = classParent d
descParent (DescField d) = fieldParent d
descParent (DescInterface d) = interfaceParent d
descParent (DescMethod d) = methodParent d
descParent (DescOption d) = optionParent d
descParent (DescBuiltinType _) = error "Builtin type has no parent."
descParent DescBuiltinList = error "Builtin type has no parent."
type MemberMap = Map.Map String (Maybe Desc)
lookupMember :: String -> MemberMap -> Maybe Desc
lookupMember name members = join (Map.lookup name members)
data BuiltinType = BuiltinVoid | BuiltinBool
| BuiltinInt8 | BuiltinInt16 | BuiltinInt32 | BuiltinInt64
| BuiltinUInt8 | BuiltinUInt16 | BuiltinUInt32 | BuiltinUInt64
| BuiltinFloat32 | BuiltinFloat64
| BuiltinText | BuiltinBytes
deriving (Show, Enum, Bounded, Eq)
builtinTypes = [minBound::BuiltinType .. maxBound::BuiltinType]
-- Get in-language name of type.
builtinTypeName :: BuiltinType -> String
builtinTypeName = List.drop 7 . show -- drop "Builtin" prefix
data ValueDesc = VoidDesc
| BoolDesc Bool
| Int8Desc Int8
| Int16Desc Int16
| Int32Desc Int32
| Int64Desc Int64
| UInt8Desc Word8
| UInt16Desc Word16
| UInt32Desc Word32
| UInt64Desc Word64
| Float32Desc Float
| Float64Desc Double
| TextDesc String
| BytesDesc ByteString
deriving (Show)
valueString VoidDesc = error "Can't stringify void value."
valueString (BoolDesc b) = if b then "true" else "false"
valueString (Int8Desc i) = show i
valueString (Int16Desc i) = show i
valueString (Int32Desc i) = show i
valueString (Int64Desc i) = show i
valueString (UInt8Desc i) = show i
valueString (UInt16Desc i) = show i
valueString (UInt32Desc i) = show i
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)
data TypeDesc = BuiltinType BuiltinType
| EnumType EnumDesc
| ClassType ClassDesc
| InterfaceType InterfaceDesc
| ListType TypeDesc
-- Render the type descriptor's name as a string, appropriate for use in the given scope.
typeName :: Desc -> TypeDesc -> String
typeName _ (BuiltinType t) = builtinTypeName t -- TODO: Check for shadowing.
typeName scope (EnumType desc) = descQualifiedName scope (DescEnum desc)
typeName scope (ClassType desc) = descQualifiedName scope (DescClass desc)
typeName scope (InterfaceType desc) = descQualifiedName scope (DescInterface desc)
typeName scope (ListType t) = "List(" ++ typeName scope t ++ ")"
-- Computes the qualified name for the given descriptor within the given scope.
-- At present the scope is only used to determine whether the target is in the same file. If
-- not, an "import" expression is used.
-- This could be made fancier in a couple ways:
-- 1) Drop the common prefix between scope and desc to form a minimal relative name. Note that
-- we'll need to check for shadowing.
-- 2) Examine aliases visible in the current scope to see if they refer to a prefix of the target
-- symbol, and use them if so. A particularly important case of this is imports -- typically
-- the import will have an alias in the file scope.
descQualifiedName :: Desc -> Desc -> String
descQualifiedName (DescFile scope) (DescFile desc) =
if fileName scope == fileName desc
then ""
else printf "import \"%s\"" (fileName desc)
descQualifiedName (DescFile scope) desc = printf "%s.%s" parent (descName desc) where
parent = descQualifiedName (DescFile scope) (descParent desc)
descQualifiedName scope desc = descQualifiedName (descParent scope) desc
data FileDesc = FileDesc
{ fileName :: String
, fileImports :: [FileDesc]
, fileAliases :: [AliasDesc]
, fileConstants :: [ConstantDesc]
, fileEnums :: [EnumDesc]
, fileClasses :: [ClassDesc]
, fileInterfaces :: [InterfaceDesc]
, fileOptions :: OptionMap
, fileMembers :: [Desc]
, fileMemberMap :: MemberMap
, fileImportMap :: Map.Map String FileDesc
}
data AliasDesc = AliasDesc
{ aliasName :: String
, aliasParent :: Desc
, aliasTarget :: Desc
}
data ConstantDesc = ConstantDesc
{ constantName :: String
, constantParent :: Desc
, constantType :: TypeDesc
, constantValue :: ValueDesc
}
data EnumDesc = EnumDesc
{ enumName :: String
, enumParent :: Desc
, enumValues :: [EnumValueDesc]
, enumOptions :: OptionMap
, enumMembers :: [Desc]
, enumMemberMap :: MemberMap
}
data EnumValueDesc = EnumValueDesc
{ enumValueName :: String
, enumValueParent :: Desc
, enumValueNumber :: Integer
, enumValueOptions :: OptionMap
}
data ClassDesc = ClassDesc
{ className :: String
, classParent :: Desc
, classFields :: [FieldDesc]
, classNestedAliases :: [AliasDesc]
, classNestedConstants :: [ConstantDesc]
, classNestedEnums :: [EnumDesc]
, classNestedClasses :: [ClassDesc]
, classNestedInterfaces :: [InterfaceDesc]
, classOptions :: OptionMap
, classMembers :: [Desc]
, classMemberMap :: MemberMap
}
data FieldDesc = FieldDesc
{ fieldName :: String
, fieldParent :: Desc
, fieldNumber :: Integer
, fieldType :: TypeDesc
, fieldDefaultValue :: Maybe ValueDesc
, fieldOptions :: OptionMap
}
data InterfaceDesc = InterfaceDesc
{ interfaceName :: String
, interfaceParent :: Desc
, interfaceMethods :: [MethodDesc]
, interfaceNestedAliases :: [AliasDesc]
, interfaceNestedConstants :: [ConstantDesc]
, interfaceNestedEnums :: [EnumDesc]
, interfaceNestedClasses :: [ClassDesc]
, interfaceNestedInterfaces :: [InterfaceDesc]
, interfaceOptions :: OptionMap
, interfaceMembers :: [Desc]
, interfaceMemberMap :: MemberMap
}
data MethodDesc = MethodDesc
{ methodName :: String
, methodParent :: Desc
, methodNumber :: Integer
, methodParams :: [(String, TypeDesc, Maybe ValueDesc)]
, methodReturnType :: TypeDesc
, methodOptions :: OptionMap
}
type OptionMap = Map.Map String OptionAssignmentDesc
data OptionAssignmentDesc = OptionAssignmentDesc
{ optionAssignmentOption :: OptionDesc
, optionAssignmentValue :: ValueDesc
}
data OptionDesc = OptionDesc
{ optionName :: String
, optionParent :: Desc
, optionId :: String
, optionType :: TypeDesc
, optionDefaultValue :: Maybe ValueDesc
}
-- 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 (DescAlias desc) = printf "%susing %s = %s;\n" indent
(aliasName desc)
(descQualifiedName (aliasParent desc) (aliasTarget desc))
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
(enumName desc)
(concatMap (descToCode (" " ++ indent)) (enumMembers desc))
indent
descToCode indent (DescEnumValue desc) = printf "%s%s = %d;\n" indent
(enumValueName desc) (enumValueNumber desc)
descToCode indent (DescClass desc) = printf "%sclass %s {\n%s%s}\n" indent
(className desc)
(concatMap (descToCode (" " ++ indent)) (classMembers desc))
indent
descToCode indent (DescField desc) = printf "%s%s@%d: %s%s;\n" 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
(interfaceName desc)
(concatMap (descToCode (" " ++ indent)) (interfaceMembers desc))
indent
descToCode indent (DescMethod desc) = printf "%s%s@%d(%s): %s;\n" indent
(methodName desc) (methodNumber desc)
(delimit (map paramToCode (methodParams desc)))
(typeName (methodParent desc) (methodReturnType desc)) where
delimit [] = ""
delimit (h:t) = h ++ concatMap (", " ++) t
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)
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."
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) }
instance Show EnumDesc where { show desc = descToCode "" (DescEnum desc) }
instance Show EnumValueDesc where { show desc = descToCode "" (DescEnumValue desc) }
instance Show ClassDesc where { show desc = descToCode "" (DescClass desc) }
instance Show FieldDesc where { show desc = descToCode "" (DescField desc) }
instance Show InterfaceDesc where { show desc = descToCode "" (DescInterface desc) }
instance Show MethodDesc where { show desc = descToCode "" (DescMethod desc) }
compiler/src/Token.hs
View file @ 22a75445
......@@ -23,20 +23,9 @@
module Token where
import Data.Char (toLower)
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
import Text.Printf (printf)
data PrimitiveType = Void | Bool
| Int8 | Int16 | Int32 | Int64
| UInt8 | UInt16 | UInt32 | UInt64
| Float32 | Float64
| Text | Bytes
deriving (Show, Enum, Bounded, Eq)
primitiveTypes = [(t, map toLower (show t))
| t <- [minBound::PrimitiveType .. maxBound::PrimitiveType]]
data Located t = Located { locatedPos :: SourcePos, locatedValue :: t } deriving (Eq)
instance Show t => Show (Located t) where
......@@ -53,6 +42,7 @@ data Token = Identifier String
| Period
| EqualsSign
| ImportKeyword
| UsingKeyword
| ConstKeyword
| EnumKeyword
| ClassKeyword
......
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