Notice to GitKraken users: A vulnerability has been found in the SSH key generation of GitKraken versions 7.6.0 to 8.0.0 (https://www.gitkraken.com/blog/weak-ssh-key-fix). If you use GitKraken and have generated a SSH key using one of these versions, please remove it both from your local workstation and from your LRZ GitLab profile.

21.10.2021, 9:00 - 11:00: Due to updates GitLab may be unavailable for some minutes between 09:00 and 11:00.

Commit 35991dce authored by Philipp Meyer's avatar Philipp Meyer
Browse files

Moved options to a monad

parent 4d7802a2
This diff is collapsed.
{-# 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
......@@ -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
{-# 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 options
- IO functions
-}
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment