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
35991dce
Commit
35991dce
authored
Dec 24, 2014
by
Philipp Meyer
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Moved options to a monad
parent
4d7802a2
Changes
4
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
389 additions
and
360 deletions
+389
-360
src/Main.hs
src/Main.hs
+125
-344
src/Options.hs
src/Options.hs
+232
-0
src/Solver.hs
src/Solver.hs
+13
-10
src/Util.hs
src/Util.hs
+19
-6
No files found.
src/Main.hs
View file @
35991dce
This diff is collapsed.
Click to expand it.
src/Options.hs
0 → 100644
View file @
35991dce
{-# LANGUAGE TupleSections #-}
module
Options
(
InputFormat
(
..
),
OutputFormat
(
..
),
NetTransformation
(
..
),
ImplicitProperty
(
..
),
Options
(
..
),
startOptions
,
options
,
parseArgs
,
usageInformation
)
where
import
Control.Applicative
((
<$>
))
import
System.Console.GetOpt
import
System.Environment
(
getArgs
)
data
InputFormat
=
PNET
|
LOLA
|
TPN
|
MIST
deriving
(
Show
,
Read
)
data
OutputFormat
=
OutLOLA
|
OutSARA
|
OutSPEC
|
OutDOT
deriving
(
Read
)
instance
Show
OutputFormat
where
show
OutLOLA
=
"LOLA"
show
OutSARA
=
"SARA"
show
OutSPEC
=
"SPEC"
show
OutDOT
=
"DOT"
data
NetTransformation
=
TerminationByReachability
|
ValidateIdentifiers
data
ImplicitProperty
=
Termination
|
DeadlockFree
|
DeadlockFreeUnlessFinal
|
FinalStateUnreachable
|
ProperTermination
|
Safe
|
Bounded
Integer
|
StructFreeChoice
|
StructParallel
|
StructFinalPlace
|
StructCommunicationFree
deriving
(
Show
,
Read
)
data
Options
=
Options
{
inputFormat
::
InputFormat
,
optVerbosity
::
Int
,
optShowHelp
::
Bool
,
optShowVersion
::
Bool
,
optProperties
::
[
ImplicitProperty
]
,
optTransformations
::
[
NetTransformation
]
,
optRefine
::
Bool
,
optInvariant
::
Bool
,
optOutput
::
Maybe
String
,
outputFormat
::
OutputFormat
,
optUseProperties
::
Bool
,
optPrintStructure
::
Bool
}
startOptions
::
Options
startOptions
=
Options
{
inputFormat
=
PNET
,
optVerbosity
=
1
,
optShowHelp
=
False
,
optShowVersion
=
False
,
optProperties
=
[]
,
optTransformations
=
[]
,
optRefine
=
True
,
optInvariant
=
False
,
optOutput
=
Nothing
,
outputFormat
=
OutLOLA
,
optUseProperties
=
True
,
optPrintStructure
=
False
}
options
::
[
OptDescr
(
Options
->
Either
String
Options
)
]
options
=
[
Option
""
[
"pnet"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
PNET
}))
"Use the pnet input format"
,
Option
""
[
"lola"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
LOLA
}))
"Use the lola input format"
,
Option
""
[
"tpn"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
TPN
}))
"Use the tpn input format"
,
Option
""
[
"spec"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
MIST
}))
"Use the mist input format"
,
Option
"s"
[
"structure"
]
(
NoArg
(
\
opt
->
Right
opt
{
optPrintStructure
=
True
}))
"Print structural information"
,
Option
""
[
"validate-identifiers"
]
(
NoArg
(
\
opt
->
Right
opt
{
optTransformations
=
ValidateIdentifiers
:
optTransformations
opt
}))
"Make identifiers valid for lola"
,
Option
""
[
"termination-by-reachability"
]
(
NoArg
(
\
opt
->
Right
opt
{
optTransformations
=
TerminationByReachability
:
optTransformations
opt
}))
"Prove termination by reducing it to reachability"
,
Option
""
[
"termination"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
Termination
:
optProperties
opt
}))
"Prove that the net is terminating"
,
Option
""
[
"proper-termination"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
ProperTermination
:
optProperties
opt
}))
"Prove termination in the final marking"
,
Option
""
[
"deadlock-free"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
DeadlockFree
:
optProperties
opt
}))
"Prove that the net is deadlock-free"
,
Option
""
[
"deadlock-free-unless-final"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
DeadlockFreeUnlessFinal
:
optProperties
opt
}))
(
"Prove that the net is deadlock-free
\n
"
++
"unless it is in the final marking"
)
,
Option
""
[
"final-state-unreachable"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
FinalStateUnreachable
:
optProperties
opt
}))
"Prove that the final state is unreachable"
,
Option
""
[
"safe"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
Safe
:
optProperties
opt
}))
"Prove that the net is safe, i.e. 1-bounded"
,
Option
""
[
"bounded"
]
(
ReqArg
(
\
arg
opt
->
case
reads
arg
of
[(
k
,
""
)]
->
Right
opt
{
optProperties
=
Bounded
k
:
optProperties
opt
}
_
->
Left
(
"invalid argument for k-bounded option: "
++
arg
)
)
"K"
)
"Prove that the net is K-bounded"
,
Option
""
[
"free-choice"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
StructFreeChoice
:
optProperties
opt
}))
"Prove that the net is free-choice"
,
Option
""
[
"parallel"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
StructParallel
:
optProperties
opt
}))
"Prove that the net has non-trivial parallellism"
,
Option
""
[
"final-place"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
StructFinalPlace
:
optProperties
opt
}))
"Prove that there is only one needed final place"
,
Option
""
[
"communication-free"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
StructCommunicationFree
:
optProperties
opt
}))
"Prove that the net is communication-free"
,
Option
"n"
[
"no-refinement"
]
(
NoArg
(
\
opt
->
Right
opt
{
optRefine
=
False
}))
"Don't use refinement"
,
Option
"i"
[
"invariant"
]
(
NoArg
(
\
opt
->
Right
opt
{
optInvariant
=
True
}))
"Try to generate an invariant"
,
Option
"o"
[
"output"
]
(
ReqArg
(
\
arg
opt
->
Right
opt
{
optOutput
=
Just
arg
})
"FILE"
)
"Write net and properties to FILE"
,
Option
""
[
"out-lola"
]
(
NoArg
(
\
opt
->
Right
opt
{
outputFormat
=
OutLOLA
}))
"Use the lola output format"
,
Option
""
[
"out-sara"
]
(
NoArg
(
\
opt
->
Right
opt
{
outputFormat
=
OutSARA
}))
"Use the sara output format"
,
Option
""
[
"out-spec"
]
(
NoArg
(
\
opt
->
Right
opt
{
outputFormat
=
OutSPEC
}))
"Use the spec output format"
,
Option
""
[
"out-dot"
]
(
NoArg
(
\
opt
->
Right
opt
{
outputFormat
=
OutDOT
}))
"Use the dot output format"
,
Option
""
[
"no-given-properties"
]
(
NoArg
(
\
opt
->
Right
opt
{
optUseProperties
=
False
}))
"Do not use the properties given in the input file"
,
Option
"v"
[
"verbose"
]
(
NoArg
(
\
opt
->
Right
opt
{
optVerbosity
=
optVerbosity
opt
+
1
}))
"Increase verbosity (may be specified more than once)"
,
Option
"q"
[
"quiet"
]
(
NoArg
(
\
opt
->
Right
opt
{
optVerbosity
=
optVerbosity
opt
-
1
}))
"Decrease verbosity (may be specified more than once)"
,
Option
"V"
[
"version"
]
(
NoArg
(
\
opt
->
Right
opt
{
optShowVersion
=
True
}))
"Show version"
,
Option
"h"
[
"help"
]
(
NoArg
(
\
opt
->
Right
opt
{
optShowHelp
=
True
}))
"Show help"
]
parseArgs
::
IO
(
Either
String
(
Options
,
[
String
]))
parseArgs
=
do
args
<-
getArgs
case
getOpt
Permute
options
args
of
(
actions
,
files
,
[]
)
->
return
$
(,
files
)
<$>
foldl
(
>>=
)
(
return
startOptions
)
actions
(
_
,
_
,
errs
)
->
return
$
Left
$
concat
errs
usageInformation
::
String
usageInformation
=
usageInfo
"SLAPnet"
options
src/Solver.hs
View file @
35991dce
...
...
@@ -10,6 +10,8 @@ import Data.SBV
import
qualified
Data.Map
as
M
import
Util
import
Options
import
Control.Monad.IO.Class
type
ConstraintProblem
a
b
=
(
String
,
String
,
[
String
],
(
String
->
SBV
a
)
->
SBool
,
(
String
->
a
)
->
b
)
...
...
@@ -26,20 +28,21 @@ symConstraints vars constraint = do
syms
<-
mapM
exists
vars
return
$
constraint
$
val
$
M
.
fromList
$
vars
`
zip
`
syms
checkSat
::
(
SatModel
a
,
SymWord
a
,
Show
a
,
Show
b
)
=>
Int
->
ConstraintProblem
a
b
->
IO
(
Maybe
b
)
checkSat
verbosity
(
problemName
,
resultName
,
vars
,
constraint
,
interpretation
)
=
do
verbosePut
verbosity
1
$
"Checking SAT of "
++
problemName
result
<-
satWith
z3
{
verbose
=
verbosity
>=
4
}
$
symConstraints
vars
constraint
checkSat
::
(
SatModel
a
,
SymWord
a
,
Show
a
,
Show
b
)
=>
ConstraintProblem
a
b
->
OptIO
(
Maybe
b
)
checkSat
(
problemName
,
resultName
,
vars
,
constraint
,
interpretation
)
=
do
verbosePut
1
$
"Checking SAT of "
++
problemName
verbosity
<-
opt
optVerbosity
result
<-
liftIO
(
satWith
z3
{
verbose
=
verbosity
>=
4
}
(
symConstraints
vars
constraint
))
case
rebuildModel
vars
(
getModel
result
)
of
Nothing
->
do
verbosePut
verbosity
2
"- unsat"
verbosePut
2
"- unsat"
return
Nothing
Just
rawModel
->
do
verbosePut
verbosity
2
"- sat"
verbosePut
2
"- sat"
let
model
=
interpretation
$
val
rawModel
verbosePut
verbosity
3
$
"- "
++
resultName
++
": "
++
show
model
verbosePut
verbosity
4
$
"- raw model: "
++
show
rawModel
verbosePut
3
$
"- "
++
resultName
++
": "
++
show
model
verbosePut
4
$
"- raw model: "
++
show
rawModel
return
$
Just
model
src/Util.hs
View file @
35991dce
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}
module
Util
(
verbosePut
,
elems
,
items
,
emap
,
prime
,
numPref
,
(
elems
,
items
,
emap
,
prime
,
numPref
,
listSet
,
listMap
,
val
,
vals
,
mval
,
zeroVal
,
positiveVal
,
sumVal
,
makeVarMap
,
makeVarMapWith
,
buildVector
,
makeVector
,
getNames
,
Vector
,
Model
,
VarMap
,
SIMap
,
SBMap
,
IMap
,
BMap
,
showWeighted
)
Vector
,
Model
,
VarMap
,
SIMap
,
SBMap
,
IMap
,
BMap
,
showWeighted
,
OptIO
,
verbosePut
,
opt
,
putLine
)
where
import
Data.SBV
...
...
@@ -13,6 +14,9 @@ import Control.Monad
import
Data.List
import
Data.Ord
import
Data.Function
import
Control.Monad.Reader
import
Options
{-
- Various maps and functions on them
...
...
@@ -93,12 +97,21 @@ listMap = map (foldl1 (\(x1,y1) (_,y2) -> (x1,y1 + y2))) .
groupBy
((
==
)
`
on
`
fst
)
.
sortBy
(
comparing
fst
)
{-
-
TODO: IO wrapper with op
tions
-
IO func
tions
-}
verbosePut
::
Int
->
Int
->
String
->
IO
()
verbosePut
verbosity
level
str
=
when
(
verbosity
>=
level
)
(
putStrLn
str
)
type
OptIO
a
=
ReaderT
Options
IO
a
opt
::
(
Options
->
a
)
->
OptIO
a
opt
getOpt
=
liftM
getOpt
ask
verbosePut
::
Int
->
String
->
OptIO
()
verbosePut
level
str
=
do
verbosity
<-
opt
optVerbosity
when
(
verbosity
>=
level
)
(
putLine
str
)
putLine
::
String
->
OptIO
()
putLine
=
liftIO
.
putStrLn
{-
- String functions
...
...
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