Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
9.2.2023: Due to updates GitLab will be unavailable for some minutes between 9:00 and 11:00.
Open sidebar
i7
peregrine
Commits
35991dce
Commit
35991dce
authored
Dec 24, 2014
by
Philipp Meyer
Browse files
Moved options to a monad
parent
4d7802a2
Changes
4
Expand all
Hide whitespace changes
Inline
Side-by-side
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
Supports
Markdown
0%
Try again
or
attach a new 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