our
$VERSION
=
'0.011'
;
use
Carp ();
$Carp::CarpLevel
= 1;
sub
parse {
my
(
$string
) =
@_
;
return
unless
defined
$string
;
my
$statement
=
eval
{
&conceptStatement
( \
$string
) };
return
$statement
;
}
sub
conceptStatement {
my
(
$string
) =
@_
;
my
$name
=
&RestrictedId
(
$string
);
if
(
defined
$name
) {
my
$supertypes
;
if
(
$$string
=~ m.
$_colon_test
.gc ) {
$supertypes
=
&RestrictedIds
(
$string
);
die
"No supertypes after ':'"
unless
@$supertypes
;
}
else
{
$supertypes
= [];
die
"Expected ' : '"
if
$$string
=~ m.
$_colon
.gc;
}
if
(
$$string
=~ m.
$_open_brace
.gc ) {
my
$body
=
&body
(
$string
);
if
(
$$string
=~ m.
$_close_brace
.gc ) {
return
{
typeName
=>
$name
,
supertypes
=>
$supertypes
,
new
=>
sub
{
bless
{},
$_
[0] },
body
=>
$body
,
};
}
else
{
die
"Expected '}'"
;
}
}
elsif
(
$$string
=~ m.
$_open_bracket
.gc ) {
if
(
$$string
=~ m.
$_close_bracket
.gc ) {
return
{
typeName
=>
$name
,
supertypes
=>
$supertypes
,
new
=>
sub
{
bless
$_
[1] || [],
$_
[0] },
};
}
else
{
die
"Expected ']'"
;
}
}
elsif
(
$$string
=~ m.
$_open_parenthesis
.gc ) {
my
$value
;
$value
= string(
$string
);
$value
= double(
$string
)
unless
defined
$value
;
if
(
$$string
=~ m.
$_close_parenthesis
.gc ) {
return
{
typeName
=>
$name
,
supertypes
=>
$supertypes
,
new
=>
sub
{
bless
\
$value
,
$_
[0] },
};
}
else
{
die
"Expected ')'"
;
}
}
return
{
typeName
=>
$name
,
supertypes
=>
$supertypes
,
new
=>
sub
() {
die
"Package 'does not have a default value"
; },
}
unless
$@;
}
else
{
die
"Expected a package name\n"
;
}
return
;
}
sub
body {
my
(
$string
) =
@_
;
return
''
if
$$string
=~ m.
$_close_brace_test
.gc;
return
$1
if
$$string
=~ m.
$_ConceptBody
.gc;
die
"Expected '{ ... }'"
;
return
;
}
1;