Moved options to a monad

src/Options.hs

+{-# 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

@@ -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

 {-# 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