Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
peregrine
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Environments
Analytics
Analytics
CI / CD
Insights
Issue
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Jobs
Commits
Open sidebar
i7
peregrine
Commits
a786fec0
Commit
a786fec0
authored
Apr 22, 2014
by
Philipp Meyer
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added parser for property
parent
177c0295
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
149 additions
and
16 deletions
+149
-16
src/Parser.hs
src/Parser.hs
+82
-16
src/Property.hs
src/Property.hs
+67
-0
No files found.
src/Parser.hs
View file @
a786fec0
...
...
@@ -2,13 +2,13 @@ module Parser
(
parseString
,
parseFile
)
where
import
Control.Applicative
((
<*
))
import
Control.Monad
(
liftM
)
import
Control.Applicative
((
<*
),(
*>
),(
<*>
),(
<$>
))
import
Text.Parsec
import
Text.Parsec.Language
(
LanguageDef
,
emptyDef
)
import
qualified
Text.Parsec.Token
as
Token
import
PetriNet
(
PetriNet
,
makePetriNet
)
import
Property
type
Parser
u
a
=
Parsec
String
u
a
...
...
@@ -40,10 +40,14 @@ brackets :: Parser u a -> Parser u a
brackets
=
Token
.
brackets
lexer
-- parses p surrounded by brackets
braces
::
Parser
u
a
->
Parser
u
a
braces
=
Token
.
braces
lexer
-- parses p surrounded by braces
parens
::
Parser
u
a
->
Parser
u
a
parens
=
Token
.
parens
lexer
-- parses p surrounded by parenthesis
natural
::
Parser
u
Integer
natural
=
Token
.
natural
lexer
-- parses a natural number
integer
::
Parser
u
Integer
integer
=
Token
.
integer
lexer
-- parses an integer
comma
::
Parser
u
String
comma
=
Token
.
comma
lexer
-- parses a comma
comma
=
Token
.
comma
lexer
-- parses a comma
whiteSpace
::
Parser
u
()
whiteSpace
=
Token
.
whiteSpace
lexer
-- parses whitespace
...
...
@@ -51,7 +55,7 @@ optionalCommaSep :: Parser u a -> Parser u [a]
optionalCommaSep
p
=
many
(
p
<*
optional
comma
)
singleOrList
::
Parser
u
a
->
Parser
u
[
a
]
singleOrList
p
=
braces
(
optionalCommaSep
p
)
<|>
liftM
(
:
[]
)
p
singleOrList
p
=
braces
(
optionalCommaSep
p
)
<|>
(
:
[]
)
<$>
p
numberOption
::
Parser
u
Integer
numberOption
=
option
1
(
brackets
natural
)
...
...
@@ -63,13 +67,13 @@ identList :: Parser u [String]
identList
=
singleOrList
ident
places
::
Parser
u
[
String
]
places
=
reserved
"places"
>
>
identList
places
=
reserved
"places"
*
>
identList
transitions
::
Parser
u
[
String
]
transitions
=
reserved
"transitions"
>
>
identList
transitions
=
reserved
"transitions"
*
>
identList
initial
::
Parser
u
[(
String
,
Integer
)]
initial
=
reserved
"initial"
>
>
singleOrList
(
do
initial
=
reserved
"initial"
*
>
singleOrList
(
do
n
<-
ident
i
<-
numberOption
return
(
n
,
i
)
...
...
@@ -98,14 +102,13 @@ data Statement = Places [String] | Transitions [String] |
Arcs
[(
String
,
String
,
Integer
)]
|
Initial
[(
String
,
Integer
)]
statement
::
Parser
u
Statement
statement
=
liftM
Places
places
<|>
liftM
Transitions
transitions
<|>
liftM
Arcs
arcs
<|>
liftM
Initial
initial
statement
=
Places
<$>
places
<|>
Transitions
<$>
transitions
<|>
Arcs
<$>
arcs
<|>
Initial
<$>
initial
petriNet
::
Parser
u
PetriNet
petriNet
=
do
whiteSpace
reserved
"petri"
reserved
"net"
name
<-
option
""
ident
...
...
@@ -120,15 +123,78 @@ petriNet = do
Arcs
a
->
(
ps
,
ts
,
a
++
as
,
is
)
Initial
i
->
(
ps
,
ts
,
as
,
i
++
is
)
parseString
::
String
->
PetriNet
preFactor
::
Parser
u
Integer
preFactor
=
(
reservedOp
"-"
*>
return
(
-
1
))
<|>
(
reservedOp
"+"
*>
return
1
)
linAtom
::
Integer
->
Parser
u
LinAtom
linAtom
fac
=
(
natural
>>=
\
lhs
->
option
(
Const
(
fac
*
lhs
))
((
Var
(
fac
*
lhs
))
<$>
(
reservedOp
"*"
*>
ident
))
)
<|>
((
Var
fac
)
<$>
ident
)
term
::
Parser
u
Term
term
=
Term
<$>
((
:
)
<$>
(
option
1
preFactor
>>=
linAtom
)
<*>
(
many
(
preFactor
>>=
linAtom
)))
parseOp
::
Parser
u
Op
parseOp
=
(
reservedOp
"<"
*>
return
Lt
)
<|>
(
reservedOp
"<="
*>
return
Le
)
<|>
(
reservedOp
"="
*>
return
Eq
)
<|>
(
reservedOp
">"
*>
return
Gt
)
<|>
(
reservedOp
">="
*>
return
Ge
)
atom
::
Parser
u
Formula
atom
=
do
lhs
<-
term
op
<-
parseOp
rhs
<-
term
return
(
Atom
(
LinIneq
lhs
op
rhs
))
parensForm
::
Parser
u
Formula
parensForm
=
atom
<|>
parens
formula
negation
::
Parser
u
Formula
negation
=
(
Neg
<$>
(
reservedOp
"!"
*>
negation
))
<|>
parensForm
conjunction
::
Parser
u
Formula
conjunction
=
do
lhs
<-
negation
option
lhs
((
lhs
:&:
)
<$>
(
reservedOp
"&"
*>
conjunction
))
disjunction
::
Parser
u
Formula
disjunction
=
do
lhs
<-
conjunction
option
lhs
((
lhs
:|:
)
<$>
(
reservedOp
"|"
*>
disjunction
))
formula
::
Parser
u
Formula
formula
=
disjunction
propertyType
::
Parser
u
PropertyType
propertyType
=
(
reserved
"safety"
*>
return
Safety
)
<|>
(
reserved
"liveness"
*>
return
Liveness
)
property
::
Parser
u
Property
property
=
do
ptype
<-
propertyType
reserved
"property"
name
<-
option
""
ident
pformulas
<-
braces
formula
return
$
Property
name
ptype
pformulas
parseContent
::
Parser
u
Property
parseContent
=
whiteSpace
*>
property
parseString
::
String
->
Property
parseString
str
=
case
parse
p
etriNe
t
""
str
of
case
parse
p
arseConten
t
""
str
of
Left
e
->
error
$
show
e
Right
r
->
r
parseFile
::
String
->
IO
P
etriNet
parseFile
::
String
->
IO
P
roperty
parseFile
file
=
do
contents
<-
readFile
file
case
parse
p
etriNe
t
file
contents
of
case
parse
p
arseConten
t
file
contents
of
Left
e
->
print
e
>>
fail
"parse error"
Right
r
->
return
r
src/Property.hs
0 → 100644
View file @
a786fec0
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module
Property
(
Property
(
..
),
PropertyType
(
..
),
Formula
(
..
),
LinearInequation
(
..
),
Op
(
..
),
Term
(
..
),
LinAtom
(
..
))
where
import
Data.List
(
intercalate
)
data
LinAtom
=
Var
Integer
String
|
Const
Integer
instance
Show
LinAtom
where
show
(
Var
c
x
)
|
c
==
1
=
x
show
(
Var
c
x
)
|
c
==
-
1
=
"-"
++
x
show
(
Var
c
x
)
=
show
c
++
"*"
++
x
show
(
Const
c
)
=
show
c
data
Term
=
Term
[
LinAtom
]
instance
Show
Term
where
show
(
Term
xs
)
=
intercalate
" + "
(
map
show
xs
)
data
Op
=
Gt
|
Ge
|
Eq
|
Le
|
Lt
instance
Show
Op
where
show
Gt
=
">"
show
Ge
=
">="
show
Eq
=
"="
show
Le
=
"<="
show
Lt
=
"<"
data
LinearInequation
=
LinIneq
Term
Op
Term
instance
Show
LinearInequation
where
show
(
LinIneq
lhs
op
rhs
)
=
show
lhs
++
" "
++
show
op
++
" "
++
show
rhs
data
Formula
=
Atom
LinearInequation
|
Neg
Formula
|
Formula
:&:
Formula
|
Formula
:|:
Formula
infixr
3
:&:
infixr
2
:|:
instance
Show
Formula
where
show
(
Atom
a
)
=
show
a
show
(
Neg
p
)
=
"¬"
++
show
p
show
(
p
:&:
q
)
=
"("
++
show
p
++
" ∧ "
++
show
q
++
")"
show
(
p
:|:
q
)
=
"("
++
show
p
++
" ∨ "
++
show
q
++
")"
data
PropertyType
=
Safety
|
Liveness
instance
Show
PropertyType
where
show
Safety
=
"safety"
show
Liveness
=
"liveness"
data
Property
=
Property
String
PropertyType
Formula
instance
Show
Property
where
show
(
Property
name
ptype
formula
)
=
show
ptype
++
" "
++
show
name
++
" { "
++
show
formula
++
" }"
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment