Created
December 26, 2011 14:59
-
-
Save zoetrope/1521330 to your computer and use it in GitHub Desktop.
FParsecによるCORBA IDLパーサ
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module idl.ast | |
open System | |
open FParsec.Primitives | |
open FParsec.CharParsers | |
open FParsec.Error | |
type ConstExpr = | |
| Xor of ConstExpr * ConstExpr | |
| Or of ConstExpr * ConstExpr | |
| And of ConstExpr * ConstExpr | |
| Shift of ConstExpr * ConstExpr | |
| Add of ConstExpr * ConstExpr | |
| Minus of ConstExpr * ConstExpr | |
| Multi of ConstExpr * ConstExpr | |
| Divide of ConstExpr * ConstExpr | |
| Rest of ConstExpr * ConstExpr | |
| Unary of string * ConstExpr | |
| Literal of string list | |
and Definition = | |
| Sequence of Definition * ConstExpr | |
| String of ConstExpr | |
| WString of ConstExpr | |
| Primitive of string | |
| Void | |
| ScopedType of string list | |
// 構造体 名前, メンバー | |
| Struct of string * (Definition list) | |
// | |
| Union of string * Definition * (Definition list) | |
| Case of (ConstExpr list) * Definition | |
| Element of Definition * Definition | |
// | |
| Enum of string * (string list) | |
// ネームスペース | |
| Module of string * (Definition list) | |
// typedef 型, 新しい型 | |
| Typedef of Definition * Definition | |
// 定数 型, 名前, 値 | |
| Const of string * string * string | |
// 前置インタフェース 名前, 属性 | |
| ForwardInterface of string * string | |
// インタフェース 名前, 継承元, メンバー, 属性 | |
| Interface of string * (Definition list) * (Definition list) * string | |
// 例外 名前, メンバー | |
| ExceptionType of string * (Definition list) | |
| SimpleDec of string | |
| ArrayDec of string * (ConstExpr list) | |
| AggregateDec of Definition * (Definition list) | |
// プロパティ 型, 名前 | |
| Member of Definition * (Definition list) | |
// メソッド 名前, 引数, 例外, コンテキスト, 戻り値, 属性 | |
| Operation of string * (Definition list) * (Definition list) * (string list) * Definition * string | |
// 引数 属性, 型, 名前 | |
| Parameter of string * Definition * Definition | |
// 属性 型, | |
| Attribute of string * (Definition list) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module idl.parser | |
#nowarn "40" // 循環参照で警告がでないように | |
open System | |
open System.CodeDom | |
open FParsec.Primitives | |
open FParsec.CharParsers | |
open FParsec.Error | |
open idl.ast | |
//******************************************************* | |
// Basic | |
//******************************************************* | |
let extractExprs x = | |
match x with | |
| Success (x, _, _) -> x | |
| Failure (x,y,_) -> failwith x | |
let showAst x = | |
printfn "%A" x | |
let ws = spaces | |
let str_ws s = ws >>. pstring s .>> ws | |
let stringLiteral = | |
between (pstring "\"") (pstring "\"") (many1Chars letter) | |
let stringLiteralList = | |
sepBy stringLiteral (pstring ",") | |
let tryParse p: Parser<_,unit> = | |
parse { let! _ = lookAhead p | |
let! wd = p | |
return wd } | |
let pythonIdentifier : Parser<string,unit> = | |
let isAsciiIdStart = fun c -> isAsciiLetter c || c = '_' | |
let isASciiIdContinue = fun c -> isAsciiLetter c || isDigit c || c = '_' | |
identifier (IdentifierOptions(isAsciiIdStart = isAsciiIdStart, | |
isAsciiIdContinue = isASciiIdContinue, | |
normalization = System.Text.NormalizationForm.FormKC, | |
normalizeBeforeValidation = false, | |
allowAllNonAsciiCharsInPreCheck = false)) | |
let identifier = | |
let isIdentifierFirstChar c = isLetter c || c = '_' | |
let isIdentifierChar c = isLetter c || isDigit c || c = '_' | |
(many1Satisfy2 isIdentifierFirstChar isIdentifierChar) | |
//******************************************************* | |
// メインパーサ | |
//******************************************************* | |
let rec specification = parse{ | |
let! def = many definition | |
do! eof | |
return def} | |
and definition = | |
parse{ | |
let! t = tryParse(typeDcl) | |
let! _ = str_ws ";" | |
return t} | |
(* | |
<|> parse{ | |
let! c = constDcl | |
let! _ = str_ws ";" | |
return c} | |
*) | |
<|> parse{ | |
let! e = tryParse(exceptDcl) | |
let! _ = str_ws ";" | |
return e} | |
<|> parse{ | |
let! i = tryParse(interfaceType) | |
let! _ = str_ws ";" | |
return i} | |
<|> parse{ | |
let! m = tryParse(moduleDcl) | |
let! _ = str_ws ";" | |
return m} | |
(* | |
<|> parse{ | |
let! v = valueDcl | |
let! _ = str_ws ";" | |
return v} | |
*) | |
//******************************************************* | |
// 名前空間 | |
//******************************************************* | |
and moduleDcl = parse{ | |
do! spaces | |
let! _ = pstring "module" | |
do! spaces1 | |
let! name = identifier | |
do! spaces | |
let! def = between (str_ws "{") (str_ws "}") (many definition) | |
return Module(name, def)} | |
//******************************************************* | |
// Interface | |
//******************************************************* | |
and interfaceType = | |
tryParse(interfaceDcl) | |
<|> forwardDcl | |
and interfaceDcl = parse{ | |
let! name, ins, attr = interfaceHeader | |
let! body = between (str_ws "{") (str_ws "}") interfaceBody | |
do! spaces | |
return Interface(name, ins, body, attr)} | |
and forwardDcl = parse{ | |
do! spaces | |
let! attr = pstring "abstract" <|> pstring "local" <|> parse { return null } | |
let! _ = pstring "interface" | |
do! spaces1 | |
let! name = identifier | |
return ForwardInterface(name, attr)} | |
and interfaceHeader = parse{ | |
do! spaces | |
let! attr = pstring "abstract" <|> pstring "local" <|> parse { return null } | |
let! _ = pstring "interface" | |
do! spaces1 | |
let! name = identifier | |
do! spaces | |
let! ins = interfaceInheritanceSpec <|> parse{ return[] } | |
return name, ins, attr} | |
and interfaceBody = many export; | |
and export = | |
parse{ | |
let! t = typeDcl | |
let! _ = str_ws ";" | |
return t} | |
(* | |
<|> parse{ | |
let! c = constDcl | |
let! _ = str_ws ";" | |
return c} | |
*) | |
<|> parse{ | |
let! e = exceptDcl | |
let! _ = str_ws ";" | |
return e} | |
(* | |
<|> parse{ | |
let! a = attrDcl | |
let! _ = str_ws ";" | |
return a} | |
*) | |
<|> parse{ | |
let! o = opDcl | |
let! _ = str_ws ";" | |
return o} | |
and interfaceInheritanceSpec = parse{ | |
let! _ = str_ws ":" | |
let! ins = inheritanceNameList | |
return ins} | |
and inheritanceNameList = | |
sepBy (scopedType .>> spaces) (str_ws ",") | |
//TODO: あとで直す | |
//and scopedName = (many1Chars (letter <|> digit <|> (anyOf "::"))) | |
and scopedName = parse{ | |
let! names = sepBy1 identifier (pstring "::") | |
return names} | |
and scopedType = parse{ | |
let! name = scopedName | |
return ScopedType(name)} | |
//******************************************************* | |
// Value | |
//******************************************************* | |
//TODO: あとで | |
(* | |
and valueDcl = | |
and valueForwardDcl = | |
and valueBoxDcl = | |
and valueAbsDcl = | |
and valueDcl = | |
and valueHeader = | |
and valueInheritanceSpec = | |
and valueName = | |
and valueElement = | |
and stateMember = parse{ | |
*) | |
//******************************************************* | |
// Init | |
//******************************************************* | |
(* | |
and initDcl = | |
and initParamDecls = | |
and initParamDecl = | |
and initParamAttribute = | |
*) | |
//******************************************************* | |
// Const | |
//******************************************************* | |
(* | |
and constDcl = parse{ | |
let! _ = str_ws "const" | |
let! t = constType | |
let! name = identifier | |
let! _ = str_ws "=" | |
let! exp = constExp | |
return Const(t,name,exp)} | |
and constType = | |
integerType | |
<|> charType | |
<|> booleanType | |
<|> floatingPtType | |
<|> stringType | |
<|> wideStringType | |
//<|> fixedPtConstType | |
<|> scopedName | |
<|> octetType | |
*) | |
and constExp = parse{ | |
let! l = literal | |
return Literal([l])} | |
(* | |
and constExp = orExpr | |
and orExpr = | |
xorExpr | |
<|> parse{let! x1 = orExpr | |
let! _ = pstring "|" | |
let! x2 = xorExpr | |
return Or(x1,x2)} | |
and xorExpr = | |
andExpr | |
<|> parse{let! x1 = xorExpr | |
let! _ = pstring "^" | |
let! x2 = andExpr | |
return Xor(x1,x2)} | |
and andExpr = | |
shiftExpr | |
<|> parse{let! x1 = andExpr | |
let! _ = pstring "&" | |
let! x2 = shiftExpr | |
return And(x1,x2)} | |
and shiftExpr = | |
addExpr | |
<|> parse{let! x1 = shiftExpr | |
let! _ = pstring ">>" | |
let! x2 = addExpr | |
return Shift(x1,x2)} | |
<|> parse{let! x1 = shiftExpr | |
let! _ = pstring "<<" | |
let! x2 = addExpr | |
return Shift(x1,x2)} | |
and addExpr = | |
multExpr | |
<|> parse{let! x1 = addExpr | |
let! _ = pstring "+" | |
let! x2 = multExpr | |
return Add(x1,x2)} | |
<|> parse{let! x1 = addExpr | |
let! _ = pstring "-" | |
let! x2 = multExpr | |
return Minus(x1,x2)} | |
and multExpr = | |
unaryExpr | |
<|> parse{let! x1 = multExpr | |
let! _ = pstring "*" | |
let! x2 = unaryExpr | |
return Multi(x1,x2)} | |
<|> parse{let! x1 = multExpr | |
let! _ = pstring "/" | |
let! x2 = unaryExpr | |
return Divide(x1,x2)} | |
<|> parse{let! x1 = multExpr | |
let! _ = pstring "%" | |
let! x2 = unaryExpr | |
return Rest(x1,x2)} | |
and unaryExpr = | |
parse{let! o = unaryOperator | |
let! e = primaryExpr | |
return Unary(o,e)} | |
<|> primaryExpr | |
and unaryOperator = | |
pstring "-" | |
<|> pstring "+" | |
<|> pstring "~" | |
and primaryExpr : Parser<ConstExpr> = | |
parse{ | |
let! name = scopedName | |
return Literal(name)} | |
<|> | |
parse{ | |
let! name = literal | |
return Literal([name])} | |
<|> between (str_ws "(") (str_ws ")") constExp | |
*) | |
//******************************************************* | |
// Literal | |
//******************************************************* | |
and literal = | |
integerLiteral | |
<|> stringLiteral | |
//<|> wideStringLiteral | |
//<|> characterLiteral | |
//<|> wideCharacterLiteral | |
//<|> fixedPtLiteral | |
//<|> floatingPtLiteral | |
<|> booleanLiteral | |
and booleanLiteral = | |
(str_ws "TRUE") <|> (str_ws "FALSE") | |
and positiveIntConst = constExp | |
and integerLiteral = many1Chars digit | |
//******************************************************* | |
// Type | |
//******************************************************* | |
and typeDcl = | |
tryParse(typedefDcl) | |
<|> tryParse(structType) | |
//<|> unionType | |
<|> tryParse(enumType) | |
//<|> nativeDcl | |
//<|> constrForwardDecl | |
and typedefDcl = parse { | |
do! spaces | |
let! _ = pstring "typedef" | |
do! spaces1 | |
let! t = typeDeclarator | |
return t} | |
and typeDeclarator = parse{ | |
let! t = typeSpec | |
do! spaces1 | |
let! dec = declarator | |
return Typedef(t, dec)} | |
and typeSpec = | |
simpleTypeSpec | |
<|> constrTypeSpec | |
and simpleTypeSpec = | |
baseTypeSpec | |
<|> templateTypeSpec | |
<|> scopedType | |
and baseTypeSpec = | |
floatingPtType | |
<|> integerType | |
<|> charType | |
<|> booleanType | |
<|> octetType | |
<|> anyType | |
<|> objectType | |
//<|> valueBaseType | |
and templateTypeSpec = | |
sequenceType | |
<|> stringType | |
<|> wideStringType | |
//<|> fixedPtType | |
and constrTypeSpec = | |
structType | |
<|> unionType | |
<|> enumType | |
and declarators = | |
sepBy declarator (pstring ",") | |
and declarator = | |
attempt(complexDeclarator) | |
<|> simpleDeclarator | |
and simpleDeclarator = parse{ | |
let! name = identifier | |
return SimpleDec(name)} | |
and complexDeclarator = arrayDeclarator | |
//******************************************************************** | |
// 基本型 //TODO: longXXXやstringXXXのような名前も読んでしまう | |
//******************************************************************** | |
and floatingPtType = (floatType <|> doubleType <|> longDoubleType) | |
and floatType = stringReturn "float" (Primitive("float")) | |
and doubleType = stringReturn "double" (Primitive("double")) | |
and longDoubleType = stringReturn "long double" (Primitive("long double")) | |
and integerType = (signedInt <|> unsignedInt) | |
and signedInt = (signedShortInt <|> signedLongInt <|> signedLongLongInt) | |
and signedShortInt = stringReturn "short" (Primitive("short")) | |
and signedLongInt = stringReturn "long" (Primitive("long")) | |
and signedLongLongInt = stringReturn "long long" (Primitive("long long")) | |
and unsignedInt = (unsignedShortInt <|> unsignedLongInt <|> unsignedLongLongInt) | |
and unsignedShortInt = stringReturn "unsigned short" (Primitive("unsigned short")) | |
and unsignedLongInt = stringReturn "unsigned long" (Primitive("unsigned long")) | |
and unsignedLongLongInt = stringReturn "unsigned long long" (Primitive("unsigned long long")) | |
and charType = stringReturn "char" (Primitive("char")) | |
//and wideCharType = stringReturn "char" (Primitive("wchar")) | |
and booleanType = stringReturn "boolean" (Primitive("boolean")) | |
and octetType = stringReturn "octet" (Primitive("octet")) | |
and anyType = stringReturn "any" (Primitive("any")) | |
and objectType = stringReturn "Object" (Primitive("Object")) | |
//******************************************************* | |
// Struct | |
//******************************************************* | |
and structType = parse{ | |
do! spaces | |
let! _ = pstring "struct" | |
do! spaces1 | |
let! name = identifier | |
let! members = between (str_ws "{") (str_ws "}") memberList | |
return Struct(name, members)} | |
and memberList = (many1 memberDec) | |
and memberDec = parse{ | |
do! spaces | |
let! t = typeSpec | |
do! spaces1 | |
let! dec = declarators | |
let! _ = str_ws ";" | |
return Member(t, dec)} | |
//******************************************************* | |
// Union | |
//******************************************************* | |
and unionType = parse{ | |
let! _ = str_ws "union" | |
let! name = identifier | |
let! _ = str_ws "switch" | |
let! t = between (str_ws "(") (str_ws ")") switchTypeSpec | |
let! body = between (str_ws "{") (str_ws "}") switchBody | |
return Union(name, t, body)} | |
and switchTypeSpec = | |
integerType | |
<|> charType | |
<|> booleanType | |
<|> enumType | |
<|> scopedType | |
and switchBody = many case | |
and case = parse{ | |
let! label = many caseLabel | |
let! ele = elementSpec | |
let! _ = str_ws ";" | |
return Case(label, ele)} | |
and caseLabel = | |
parse{ | |
let! _ = pstring "case" | |
do! spaces1 | |
let! exp = constExp | |
do! spaces1 | |
let! _ = pstring ":" | |
return exp} | |
<|> parse{ | |
let! _ = pstring "default" | |
do! spaces1 | |
let! _ = pstring ";" | |
return Literal(["default"])} | |
and elementSpec = parse{ | |
let! t = typeSpec | |
do! spaces1 | |
let! dec = declarator | |
return Element(t,dec)} | |
//******************************************************* | |
// Enum | |
//******************************************************* | |
and enumType = parse{ | |
let! _ = str_ws "enum" | |
let! name = identifier | |
let! list = between (str_ws "{") (str_ws "}") enumeratorList | |
return Enum(name, list)} | |
and enumeratorList = | |
sepBy enumerator (str_ws ",") | |
and enumerator = identifier .>> spaces | |
//******************************************************* | |
// Sequence | |
//******************************************************* | |
and sequenceType = | |
attempt(parse { | |
do! spaces | |
let! _ = pstring "sequence" | |
let! _ = str_ws "<" | |
let! t = simpleTypeSpec | |
let! _ = str_ws "," | |
let! count = positiveIntConst | |
let! _ = str_ws ">" | |
return Sequence(t, count)}) | |
<|> parse{ | |
do! spaces | |
let! _ = pstring "sequence" | |
let! t = between (pchar '<') (pchar '>') simpleTypeSpec | |
return Sequence(t, Literal(["0"]))} | |
//******************************************************* | |
// String | |
//******************************************************* | |
and stringType = | |
attempt( | |
parse{ | |
let! _ = str_ws "string" | |
let! count = between (pchar '<') (pchar '>') positiveIntConst | |
return String(count) | |
}) | |
<|> stringReturn "string" (String(Literal(["0"]))) | |
and wideStringType = | |
attempt( | |
parse{ | |
let! _ = str_ws "wstring" | |
let! count = between (pchar '<') (pchar '>') positiveIntConst | |
return WString(count) | |
}) | |
<|> stringReturn "wstring" (WString(Literal(["0"]))) | |
//******************************************************* | |
// Array | |
//******************************************************* | |
and arrayDeclarator = parse{ | |
let! name = identifier | |
let! size = fixedArraySizeList | |
return ArrayDec(name, size)} | |
and fixedArraySizeList = many1 fixedArraySize | |
and fixedArraySize = | |
between (str_ws "[") (str_ws "]") positiveIntConst | |
and simpleDeclaratorList = many simpleDeclarator | |
(* | |
and attrDcl = parse{ | |
let! _ = str_ws "readonly" //TODO: ない場合もある | |
let! _ = str_ws "attribute" | |
let! t = paramTypeSpec | |
let! dec = simpleDeclaratorList | |
return Attribute(t, dec)} | |
*) | |
//******************************************************* | |
// Exception | |
//******************************************************* | |
and exceptDcl = parse{ | |
do! spaces | |
let! _ = pstring "exception" | |
do! spaces1 | |
let! name = identifier | |
let! members = between (str_ws "{") (str_ws "}") memberList | |
return ExceptionType(name, members)} | |
//******************************************************* | |
// Operation | |
//******************************************************* | |
and opDcl = parse{ | |
let! attr = opAttribute <|> parse{ return null } | |
do! spaces | |
let! t = opTypeSpec | |
do! spaces1 | |
let! name = identifier | |
let! ps = parameterDcls | |
let! exps = raisesExpr <|> parse{ return[] } | |
let! context = contextExpr <|> parse{ return[] } | |
return Operation(name, ps, exps, context, t, attr)} | |
and opAttribute = str_ws "oneway" | |
and opTypeSpec : Parser<Definition,unit> = | |
stringReturn "void" Void | |
<|> paramTypeSpec | |
and parameterDcls = | |
between (str_ws "(") (str_ws ")") paramDclList | |
and paramDclList = | |
sepBy paramDcl (pstring ",") | |
and paramDcl = parse{ | |
do! spaces | |
let! attr = paramAttribute | |
do! spaces1 | |
let! t = paramTypeSpec | |
do! spaces1 | |
let! dec = simpleDeclarator | |
return Parameter(attr, t, dec)} | |
and paramAttribute = pstring "inout" <|> pstring "in" <|> pstring "out" | |
and scopedTypeList = | |
sepBy scopedType (str_ws ",") | |
and raisesExpr = parse{ | |
let! _ = str_ws "raises" | |
let! raises = between (str_ws "(") (str_ws ")") scopedTypeList | |
return raises} | |
and contextExpr = parse{ | |
let! _ = str_ws "context" | |
let! list = between (str_ws "(") (str_ws ")") stringLiteralList | |
return list} | |
and paramTypeSpec = | |
baseTypeSpec | |
<|> stringType | |
<|> wideStringType | |
<|> scopedType | |
//and fixedPtConstType = "fixed" | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment