packages feed

syfco (empty) → 1.1.0.0

raw patch · 58 files changed

+13323/−0 lines, 58 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, convertible, directory, mtl, parsec, transformers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Felix Klein++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,42 @@+# Synthesis Format Conversion Tool++A tool for reading, manipulating and transforming synthesis+specifications in [TLSF](https://arxiv.org/abs/1604.02284).++## About this tool++The tool interprets the high level constructs of [TLSF 1.1](https://arxiv.org/abs/1604.02284)+(functions, sets, ...) and supports the transformation of the+specification to Linear Temporal Logic (LTL) in different output+formats. The tool has been designed to be modular with respect to the+supported output formats and semantics. Furthermore, the tool allows+to identify and manipulate parameters, targets and semantics of a+specification on the fly. This is especially thought to be useful for+comparative studies, as they are for example needed in the+[Synthesis Competition](http://www.syntcomp.org).++The main features of the tool are summarized as follows:++* Interpretation of high level constructs, which allows to reduce the+  specification to its basic fragment where no more parameter and+  variable bindings occur (i.e., without the GLOBAL section).++* Transformation to other existing specification formats, like+  Basic TLSF, [Promela LTL](http://spinroot.com/spin/Man/ltl.html), [PSL](https://en.wikipedia.org/wiki/Property_Specification_Language), [Unbeast](https://www.react.uni-saarland.de/tools/unbeast), [Wring](http://www.ist.tugraz.at/staff/bloem/wring.html),+  [structured Slugs](https://github.com/VerifiableRobotics/slugs/blob/master/doc/input_formats.md#structuredslugs), and [SlugsIn](https://github.com/VerifiableRobotics/slugs/blob/master/doc/input_formats.md#slugsin).++* Syntactical analysis of membership in GR(k) for any k (modulo+  Boolean identities).++* On the fly adjustment of parameters, semantics or targets.++* Preprocessing of the resulting LTL formula.++* Conversion to negation normal form.++* Replacement of derived operators.++* Pushing/pulling next, eventually, or globally operators+  inwards/outwards.++* Standard simplifications.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Arguments.hs view
@@ -0,0 +1,301 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Arguments+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Argument parser.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Arguments+  ( parseArguments+  ) where++-----------------------------------------------------------------------------++import Syfco+  ( Configuration(..)+  , WriteMode(..)+  , defaultCfg+  , verify+  , update+  )++import Data.Convertible+  ( safeConvert+  )++import Info+  ( prError+  )++import System.Directory+  ( doesFileExist+  )++import Control.Monad+  ( void+  , unless+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec+  ( parse+  )++import Text.Parsec+  ( (<|>)+  , (<?>)+  , char+  , oneOf+  , many+  , many1+  , digit+  , alphaNum+  , eof+  )++import Text.Parsec.Token+  ( LanguageDef+  , GenLanguageDef(..)+  , makeTokenParser+  , stringLiteral+  , identifier+  , reserved+  , reservedOp+  , whiteSpace+  )++import Reader.Parser.Data+  ( globalDef+  )++-----------------------------------------------------------------------------++data Args a = None a | Single a++-----------------------------------------------------------------------------++-- | Argument parser, which reads the given command line arguments to+-- the internal configuration and checks whether the given+-- combinations are realizable.++parseArguments+  :: [String] -> IO Configuration++parseArguments args = do+  c <- traverse defaultCfg args++  case verify c of+    Left err -> prError $ show err+    _        -> return c++  where+    traverse c = \case+      x:y:xr -> do+        r <- parseArgument c x (Just y)+        case r of+          Single c'-> traverse c' xr+          None c'  -> traverse c' (y:xr)+      [x]    -> do+        r <- parseArgument c x Nothing+        case r of+          None c'   -> return c'+          Single c' -> return c'+      []     -> return c++    parseArgument c arg next = case arg of+      "-o"                       -> case next of+        Just x  -> return $ Single $ c { outputFile = Just x }+        Nothing -> argsError "\"-o\": No output file"+      "--output"                 -> case next of+        Nothing -> argsError "\"--output\": No output file"+        _       -> parseArgument c "-o" next+      "-r"                       -> case next of+        Just file -> do+          exists <- doesFileExist file+          unless exists $ argsError $ "File does not exist: " ++ file+          fmap (update c) (readFile file) >>= \case+            Left err -> prError $ show err+            Right c' -> return $ Single c'+        Nothing   -> argsError "\"-r\": No configuration file"+      "--read-config"            -> case next of+        Nothing -> argsError "\"--read-config\": No configuration file"+        _       -> parseArgument c "-r" next+      "-w"                       -> case next of+        Just file ->+          return $ Single $ c { saveConfig = file : saveConfig c }+        Nothing   -> argsError "\"-w\": Missing file path"+      "--write-config"           -> case next of+        Nothing -> argsError "\"--write-config\": Missing file path"+        _       -> parseArgument c "-w" next+      "-f"                       -> case next of+        Just x  -> case safeConvert x of+          Left err -> prError $ show err+          Right y -> return $ Single $ c { outputFormat = y }+        Nothing ->+          argsError "\"-f\": No format given"+      "--format"                 -> case next of+        Nothing -> argsError "\"--format\": No format given"+        _       -> parseArgument c "-f" next+      "-m"                       -> case next of+        Just "pretty" -> return $ Single $ c { outputMode = Pretty }+        Just "fully"  -> return $ Single $ c { outputMode = Fully }+        Just x        -> argsError ("Unknown mode: " ++ x)+        Nothing       -> argsError "\"-m\": No mode given"+      "--mode"                   -> case next of+        Nothing -> argsError "\"--mode\": no mode given"+        _       -> parseArgument c "-m" next+      "-pf"                      -> case next of+        Just x  -> return $ Single $ c { partFile = Just x }+        Nothing -> argsError "\"-pf\": No partition file"+      "-bd"                      -> case next of+        Just x  -> return $ Single $ c { busDelimiter = x }+        Nothing -> argsError "\"-bd\": No delimiter given"+      "--bus-delimiter"          -> case next of+        Nothing -> argsError "\"--bus-delimiter\": No delimiter given"+        _       -> parseArgument c "-bd" next+      "-ps"                      -> case next of+        Just x  -> return $ Single $ c { primeSymbol = x }+        Nothing -> argsError "\"-ps\": No symbol replacement given"+      "--prime-symbol"           -> case next of+        Just x  -> return $ Single $ c { primeSymbol = x }+        Nothing -> argsError "\"--prime-symbol\": No symbol replacement given"+      "-as"                      -> case next of+        Just x  -> return $ Single $ c { atSymbol = x }+        Nothing -> argsError "\"-as\": No symbol replacement given"+      "--at-symbol"              -> case next of+        Just x  -> return $ Single $ c { atSymbol = x }+        Nothing -> argsError "\"--at-symbol\": No symbol replacement given"+      "-in"                      -> return $ None $ c { fromStdin = True }+      "-os"                      -> case next of+        Just x  -> case safeConvert x of+          Left err -> prError $ show err+          Right y  -> return $ Single $ c { owSemantics = Just y }+        Nothing -> argsError "\"-os\": No semantics given"+      "--overwrite-semantics"    -> case next of+        Nothing -> argsError "\"--overwrite-semantics\": No semantics given"+        _       -> parseArgument c "-os" next+      "-ot"                      -> case next of+        Just x  -> case safeConvert x of+          Left err -> prError $ show err+          Right y  -> return $ Single $ c { owTarget = Just y }+        Nothing -> argsError "\"-ot\": No target given"+      "--overwrite-target"       -> case next of+        Nothing -> argsError "\"--overwrite-target\": No target given"+        _       -> parseArgument c "-ot" next+      "-op"                      -> case next of+        Just x  -> case parse parameterParser "Overwrite Parameter Error" x of+          Left err -> prError $ show err+          Right y  -> return $ Single $ c { owParameter = y : owParameter c }+        Nothing -> argsError "\"-op\": No parameter given"+      "--overwrite-parameter"    -> case next of+        Nothing -> argsError "\"--overwrite-parameter\": No parameter given"+        _       -> parseArgument c "-op" next+      "-s0"                      -> simple $ c { simplifyWeak = True }+      "-s1"                      -> simple $ c { simplifyStrong = True }+      "-nnf"                     -> simple $ c { negNormalForm = True }+      "-pgi"                     -> simple $ c { pushGlobally = True }+      "-pfi"                     -> simple $ c { pushFinally = True }+      "-pxi"                     -> simple $ c { pushNext = True }+      "-pgo"                     -> simple $ c { pullGlobally = True }+      "-pfo"                     -> simple $ c { pullFinally = True }+      "-pxo"                     -> simple $ c { pullNext = True }+      "-nw"                      -> simple $ c { noWeak = True }+      "-nr"                      -> simple $ c { noRelease = True }+      "-nf"                      -> simple $ c { noFinally = True }+      "-ng"                      -> simple $ c { noGlobally = True }+      "-nd"                      -> simple $ c { noDerived = True }+      "-gr"                      -> simple $ (clean c) { cGR = True }+      "-c"                       -> simple $ (clean c) { check = True }+      "-t"                       -> simple $ (clean c) { pTitle = True }+      "-d"                       -> simple $ (clean c) { pDesc = True }+      "-s"                       -> simple $ (clean c) { pSemantics = True }+      "-g"                       -> simple $ (clean c) { pTarget = True }+      "-a"                       -> simple $ (clean c) { pTags = True }+      "-p"                       -> simple $ (clean c) { pParameters = True }+      "-ins"                     -> simple $ (clean c) { pInputs = True }+      "-outs"                    -> simple $ (clean c) { pOutputs = True }+      "-i"                       -> simple $ (clean c) { pInfo = True }+      "-v"                       -> simple $ (clean c) { pVersion = True }+      "-h"                       -> simple $ (clean c) { pHelp = True }+      "--readme"                 -> simple $ (clean c) { pReadme = True }+      "--readme.md"              -> simple $ (clean c) { pReadmeMd = True }+      "--part-file"              -> parseArgument c "-pf" next+      "--stdin"                  -> parseArgument c "-in" next+      "--weak-simplify"          -> parseArgument c "-s0" next+      "--strong-simplify"        -> parseArgument c "-s1" next+      "--negation-normal-form"   -> parseArgument c "-nnf" next+      "--push-globally-inwards"  -> parseArgument c "-pgi" next+      "--push-finally-inwards"   -> parseArgument c "-pfi" next+      "--push-next-inwards"      -> parseArgument c "-pni" next+      "--pull-globally-outwards" -> parseArgument c "-pgo" next+      "--pull-finally-outwards"  -> parseArgument c "-pfo" next+      "--pull-next-outwards"     -> parseArgument c "-pxo" next+      "--no-weak-until"          -> parseArgument c "-nw" next+      "--no-realease"            -> parseArgument c "-nr" next+      "--no-finally"             -> parseArgument c "-nf" next+      "--no-globally"            -> parseArgument c "-ng" next+      "--no-derived"             -> parseArgument c "-nd" next+      "--generalized-reactivity" -> parseArgument c "-gr" next+      "--check"                  -> parseArgument c "-c" next+      "--print-title"            -> parseArgument c "-t" next+      "--print-description"      -> parseArgument c "-d" next+      "--print-semantics"        -> parseArgument c "-s" next+      "--print-target"           -> parseArgument c "-g" next+      "--print-tags"             -> parseArgument c "-a" next+      "--print-parameters"       -> parseArgument c "-p" next+      "--print-input-signals"    -> parseArgument c "-ins" next+      "--print-output-signals"   -> parseArgument c "-outs" next+      "--print-info"             -> parseArgument c "-i" next+      "--version"                -> parseArgument c "-v" next+      "--help"                   -> parseArgument c "-h" next+      _                          -> return $ None $ c {+                                     inputFiles = arg : inputFiles c+                                     }++    argsError str = do+      prError $ "\"Error\" " ++ str++    clean a = a {+      check = False,+      pTitle = False,+      pDesc = False,+      pSemantics = False,+      pTarget = False,+      pParameters = False,+      pInfo = False,+      pVersion = False,+      pHelp = False,+      pReadme = False,+      pReadmeMd = False+      }++    simple = return . None++-----------------------------------------------------------------------------++parameterParser+  :: Parser (String, Int)++parameterParser = do+  name <- identifier $ makeTokenParser globalDef+  void $ char '='+  x <- many1 digit+  eof+  return (name, read x)++-----------------------------------------------------------------------------
+ src/Config.hs view
@@ -0,0 +1,953 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Config+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Configuration of the tool, set up via the command line arguments.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , MultiParamTypeClasses+  , TypeSynonymInstances+  , FlexibleInstances+  , FlexibleContexts+  , RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Config+  ( Configuration(..)+  , defaultCfg+  , update+  , verify+  ) where++-----------------------------------------------------------------------------++import Data.Convertible+  ( Convertible(..)+  , ConvertError(..)+  , safeConvert+  , convert+  )++import Data.Char+  ( toLower+  )++import Data.Info+  ( name+  , version+  , defaultDelimiter+  , defaultPrimeSymbol+  , defaultAtSymbol+  )++import Data.Maybe+  ( isJust+  , catMaybes+  )++import System.Directory+  ( doesFileExist+  )++import Data.Types+  ( Semantics(..)+  , Target(..)+  )++import Data.Error+  ( Error+  , prError+  , parseError+  , cfgError+  )++import Writer.Formats+  ( WriteFormat(..)+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec+  ( (<|>)+  , (<?>)+  , char+  , oneOf+  , many+  , many1+  , digit+  , alphaNum+  , eof+  )++import Control.Monad+  ( void+  , liftM+  , when+  , unless+  )++import Writer.Data+  ( WriteMode(..)+  )++import Reader.Parser.Info+  ( targetParser+  , semanticsParser+  )++import Reader.Parser.Data+  ( globalDef+  )++import Text.Parsec.Prim+  ( parserZero+  )++import Text.Parsec.Token+  ( LanguageDef+  , GenLanguageDef(..)+  , makeTokenParser+  , stringLiteral+  , identifier+  , reserved+  , reservedOp+  , whiteSpace+  )++import Text.Parsec.Language+  ( emptyDef+  )++import qualified Text.Parsec as P++-----------------------------------------------------------------------------++-- | The data type contains all flags and settings+-- that can be adjusted to influence the behavior of the library:++data Configuration =+  Configuration+  { inputFiles :: [FilePath]+    -- ^ The list of input files containing the specifications.++  , outputFile :: Maybe FilePath+    -- ^ An optional path to the output file, the transformed+    -- specification is written to.++  , outputFormat :: WriteFormat+    -- ^ The format specifiying the corresponding writer to use.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ format = ... @ /)/++  , outputMode :: WriteMode+    -- ^ The output mode used by the writer.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ mode = ... @ /)/++  , partFile :: Maybe String+    -- ^ Optional path to a parition file, which is created if+    -- set.++  , busDelimiter :: String+    -- ^ The delimiter string to seperate the bus index from the+    -- signal name.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ bus_delimiter = ... @ /)/++  , primeSymbol :: String+    -- ^ The prime symbol \/ string representing primes in signals of+    -- the input format.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ prime_symbol = ... @ /)/++  , atSymbol :: String+    -- ^ The at symbol \/ string representing at symbols in signals+    -- of the input format.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ at_symbol = ... @ /)/++  , fromStdin :: Bool+    -- ^ A boolean flag specifying whether the input should be read+    -- from STDIN or not.++  , owSemantics :: Maybe Semantics+    -- ^ An optional flag which allows to overwrite the semantics of+    -- the given input specifications.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ overwrite_semantics = ... @ /)/++  , owTarget :: Maybe Target+    -- ^ An optional flag which allows to overwrite the target of+    -- the given input specifications.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ overwrite_target = ... @ /)/++  , owParameter :: [(String,Int)]+    -- ^ An optional flag which allows to overwrite a list of+    -- parameters of the given input specification.++  , simplifyWeak :: Bool+    -- ^ A boolean flag specifying whether weak simplifications+    -- should be applied or not.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ weak_simplify = ... @ /)/++  , simplifyStrong :: Bool+    -- ^ A boolean flag specifying whether strong simplifications+    -- should be applied or not.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ strong_simplify = ... @ /)/++  , negNormalForm :: Bool+    -- ^ A boolean flag specifying whether the given specification+    -- should be turned into negation normal form.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ negation_normal_form = ... @ /)/++  , pushGlobally :: Bool+    -- ^ A boolean flag specifying whether globally operators should+    -- be pushed over conjunctions deeper into the formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ push_globally_inwards = ... @ /)/++  , pushFinally :: Bool+    -- ^ A boolean flag specifying whether finally operators should+    -- be pushed over disjunctions deeper into the formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ push_finally_inwards = ... @ /)/++  , pushNext :: Bool+    -- ^ A boolean flag specifying whether next operators should be+    -- pushed over conjunctions and disjunctions deeper into the+    -- formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ push_next_inwards = ... @ /)/++  , pullGlobally :: Bool+    -- ^ A boolean flag specifying whether globally perators should+    -- be pulled over conjunctions outside the formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ pull_globally_outwards = ... @ /)/++  , pullFinally :: Bool+    -- ^ A boolean flag specifying whether finally operators should+    -- be pulled over disjunctions outside the formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ pull_finally_outwards = ... @ /)/++  , pullNext :: Bool+    -- ^ A boolean flag specifying whether next operators should be+    -- pulled over conjunctions and disjunctions outside the+    -- formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ pull_next_outwards = ... @ /)/++  , noWeak :: Bool+    -- ^ A boolean flag specifying whether weak until operators+    -- should be replaced by alternative operators inside the+    -- created formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ no_weak_until = ... @ /)/++  , noRelease :: Bool+    -- ^ A boolean flag specifying whether release operators should+    -- be replaced by alternative operators inside the created+    -- formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ no_release = ... @ /)/++  , noFinally :: Bool+    -- ^ A boolean flag specifying whether finally operators should+    -- be replaced by alternative operators inside the created+    -- formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ no_finally = ... @ /)/++  , noGlobally :: Bool+    -- ^ A boolean flag specifying whether globally operators should+    -- be replaced by alternative operators inside the created+    -- formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ no_globally = ... @ /)/++  , noDerived :: Bool+    -- ^ A boolean flag specifying whether any derived operators+    -- should be replaced by alternative operators inside the+    -- created formula.+    --+    --   /(can be changed via a configuration file, use:/ &#160;+    --   @ no_derived = ... @ /)/++  , cGR :: Bool+    -- ^ A boolean flag specifying whether to check, whether the+    -- input belongs to the class of Generalized Reactivity+    -- specifications or not.++  , check :: Bool+    -- ^ A boolean flag specifying whether the given input files+    -- should just be checked for syntactical and type correctenss.++  , pTitle :: Bool+    -- ^ A boolean flag specifying whether just the title of the+    -- given input files should be printed or not.++  , pDesc :: Bool+    -- ^ A boolean flag specifying whether just the description of+    -- the given input files should be printed or not.++  , pSemantics :: Bool+    -- ^ A boolean flag specifying whether just the semantics of+    -- the given input files should be printed or not.++  , pTarget :: Bool+    -- ^ A boolean flag specifying whether just the target of the+    -- given input files should be printed or not.++  , pTags :: Bool+    -- ^ A boolean flag specifying whether just the tag list of+    -- the given input files should be printed or not,++  , pParameters :: Bool+    -- ^ A boolean flag specifying whether just the parameter list+    -- of the given specification should be printed or not.++  , pInputs :: Bool+    -- ^ A boolean flag specifying whether just the input signals+    -- of the given specification should be printed or not.++  , pOutputs :: Bool+    -- ^ A boolean flag specifying whether just the output signals+    -- of the given specification should be printed or not.++  , pInfo :: Bool+    -- ^ A boolean flag specifying whether just the complete input+    -- section of the given input files should be printed or not.++  , pVersion :: Bool+    -- ^ A boolean flag specifying whether the version info should+    -- be printed or not.++  , pHelp :: Bool+    -- ^ A boolean flag specifying whether the help info should be+    -- printed or not.+  , pReadme :: Bool+    -- ^ A boolean flag specifying whether the content of the README+    -- file should be printed to STDOUT or not.+  , pReadmeMd :: Bool+    -- ^ A boolean flag specifying whether the content of the+    -- README.md file should be printed to STDOUT or not.+  , saveConfig :: [FilePath]+    -- ^ List of file paths to store the current configuration.+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++-- |+-- @+-- inputFiles     = []+-- outputFile     = Nothing+-- outputFormat   = FULL+-- outputMode     = Pretty+-- partFile       = Nothing+-- busDelimiter   = "_"+-- primeSymbol    = "'"+-- atSymbol       = "@"+-- fromStdin      = False+-- owSemantics    = Nothing+-- owTarget       = Nothing+-- owParameter    = []+-- simplifyWeak   = False+-- simplifyStrong = False+-- negNormalForm  = False+-- pushGlobally   = False+-- pushFinally    = False+-- pushNext       = False+-- pullGlobally   = False+-- pullFinally    = False+-- pullNext       = False+-- noWeak         = False+-- noRelease      = False+-- noFinally      = False+-- noGlobally     = False+-- noDerived      = False+-- cGR            = False+-- check          = False+-- pTitle         = False+-- pDesc          = False+-- pSemantics     = False+-- pTarget        = False+-- pTags          = False+-- pParameters    = False+-- pInputs        = False+-- pOutputs       = False+-- pInfo          = False+-- pVersion       = False+-- pHelp          = False+-- pReadme        = False+-- pReadmeMd      = False+-- saveConfig     = []+-- @++defaultCfg+  :: Configuration++defaultCfg = Configuration+  { inputFiles     = []+  , outputFile     = Nothing+  , outputFormat   = FULL+  , outputMode     = Pretty+  , partFile       = Nothing+  , busDelimiter   = defaultDelimiter+  , primeSymbol    = defaultPrimeSymbol+  , atSymbol       = defaultAtSymbol+  , fromStdin      = False+  , owSemantics    = Nothing+  , owTarget       = Nothing+  , owParameter    = []+  , simplifyWeak   = False+  , simplifyStrong = False+  , negNormalForm  = False+  , pushGlobally   = False+  , pushFinally    = False+  , pushNext       = False+  , pullGlobally   = False+  , pullFinally    = False+  , pullNext       = False+  , noWeak         = False+  , noRelease      = False+  , noFinally      = False+  , noGlobally     = False+  , noDerived      = False+  , cGR            = False+  , check          = False+  , pTitle         = False+  , pDesc          = False+  , pSemantics     = False+  , pTarget        = False+  , pTags          = False+  , pParameters    = False+  , pInputs        = False+  , pOutputs       = False+  , pInfo          = False+  , pVersion       = False+  , pHelp          = False+  , pReadme        = False+  , pReadmeMd      = False+  , saveConfig     = []+  }++-----------------------------------------------------------------------------++-- | Verifies that a configuration does not contain invalid parameter+-- combinations.++verify+  :: Configuration -> Either Error ()++verify Configuration{..}+  | pHelp || pVersion || pReadme || pReadmeMd =++      return ()++  | null inputFiles && not fromStdin && null saveConfig =++      cfgError+        "No input specified."++  | not (null inputFiles) && fromStdin =++      cfgError+        "Select either \"-in, --stdin\" or give an input file."++  | pushGlobally && pullGlobally =++      cfgError $+        "Select either \"-pgi, --push-globally-inwards\" or " +++        "\"-pgo, --pull-globally-outwards\"."++  | pushFinally && pullFinally =++      cfgError $+        "Select either \"-pfi, --push-finally-inwards\" or " +++        "\"-pfo, --pull-finally-outwards\"."++  | pushNext && pullNext =++      cfgError $+        "Select either \"-pxi, --push-next-inwards\" or " +++        "\"-pxo, --pull-next-outwards\"."++  | simplifyStrong && (pushGlobally || pushFinally ||+                      pushNext  || noFinally ||+                      noGlobally || noDerived) =++      cfgError $+        "The flag 'Advanced Simplifications' cannot be combined " +++        "with any other non-included transformation."++  | negNormalForm && noRelease && noGlobally && noWeak =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, " +++        "no globally operators, and no weak until operatators)" +++        "is impossible to satisfy.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noRelease && noDerived =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operatators, " +++        "and no derived operators) is impossible to satisfy.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noRelease &&+    (noGlobally || noDerived) && outputFormat == LTLXBA =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, and " +++        "no globally / derived operators) " +++        "is impossible to satisfy when outputting to the " +++        "LTL2BA / LTL3BA format, since it does not support " +++        "the weak until operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noRelease &&+    (noGlobally || noDerived) && outputFormat == WRING =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, and " +++        "no globally / derived operators) " +++        "is impossible to satisfy when outputting to the " +++        "Wring format, since it does not support " +++        "the weak until operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noRelease &&+    (noGlobally || noDerived) && outputFormat == LILY =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, and " +++        "no globally / derived operators) " +++        "is impossible to satisfy when outputting to the " +++        "Lily format, since it does not support " +++        "the weak until operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm &&+    (noGlobally || noDerived) && outputFormat == ACACIA =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, and " +++        "no globally / derived operators) " +++        "is impossible to satisfy when outputting to the " +++        "Acacia/Aciacia+ format, since it does not support " +++        "the weak until nor the release operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noRelease &&+    (noGlobally || noDerived) && outputFormat == SMV =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form, no release operators, and " +++        "no globally / derived operators) " +++        "is impossible to satisfy when outputting to the " +++        "SMV format, since it does not support " +++        "the weak until operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noGlobally && outputFormat == PSL =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form and no globally operators)" +++        "is impossible to satisfy when outputting to the " +++        "PSL format, since it does not support " +++        "the weak until and the release operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noDerived && outputFormat == PSL =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form and no derived operators)" +++        "is impossible to satisfy when outputting to the " +++        "PSL format, since it does not support " +++        "the release operator.\n" +++        "Remove at least one of these constraints."++  | negNormalForm && noDerived && outputFormat == UNBEAST =++      cfgError $+        "The given combination of transformations " +++        "(negation normal form and no derived operators)" +++        "is impossible to satisfy when outputting to the " +++        "UNBEAST format, since it does not support " +++        "the release operator.\n" +++        "Remove at least one of these constraints."++  | outputFormat == FULL &&+    (isJust owSemantics || isJust owTarget ||+     simplifyWeak || simplifyStrong || negNormalForm ||+     pushGlobally || pushFinally || pushNext ||+     pullGlobally || pullFinally || pullNext ||+     noWeak || noRelease || noFinally || noGlobally ||+     noDerived) =++      cfgError $+        "Applying adaptions is only possible, when transforming to " +++        "low level backends.\n Returning full TLSF only " +++        "allows to change parameters."++  | otherwise = return ()++  where+    missingQuotes str =+      length str < 2 ||+      head str /= '"' ||+      last str /= '"'++-----------------------------------------------------------------------------++-- | Creates the content of a parsable configuration file restricted+-- to supported configuration file parameters.++instance Convertible Configuration String where+  safeConvert Configuration{..} = return $ unlines+    [ comment "This configuration file has been automatically " +++      "generated using"+    , comment $ name ++ " (v" ++ version +++      "). To reload the configuration pass this file to "+    , comment $ name ++ " via '-c <path to config file>'. " +++      "Configuration files can be"+    , comment $ "used together with arguments passed via the command " +++      "line interface."+    , comment $ "If a parameter occurs multiple times, then it is " +++      "assigned the last"+    , comment $ "value in the order of declaration. The same principle " +++      "applies, if"+    , comment "multiple configuration files are loaded."+    , comment ""+    , comment $ "All entries of this configuration file are optional. " +++      "If not set,"+    , comment $ "either the default values or the values, passed via " +++      "the command"+    , comment "line arguments, are used."+    , emptyline+    , comment $ "Specifies the format of the generated output file. " +++      "Use "+    , comment $ "\"" ++ name ++ " --help\" to check for possible " +++      "values."+    , set "format" $ convert $ outputFormat+    , emptyline+    , comment $ "Specifies the representation mode of the output. " +++      "Use "+    , comment $ "\"" ++ name ++ " --help\" to check for possible " +++      "values."+    , set "mode" $ convert $ outputMode+    , emptyline+    , comment $ "Specifies the bus delimiter symbol / string. The " +++      "value has to be "+    , comment "encapsulated into quotation marks."+    , set "bus_delimiter" $ "\"" ++ busDelimiter ++ "\""+    , emptyline+    , comment $ "Specifies the output representation of prime " +++      "symbols. The value "+    , comment "has to be encapsulated into quotation marks."+    , set "prime_symbol" $ "\"" ++ primeSymbol ++ "\""+    , emptyline+    , comment $ "Specifies the output representation of \"@\"-" +++      "symbols. The value "+    , comment "has to be encapsulated into quotation marks."+    , set "at_symbol" $ "\"" ++ atSymbol ++ "\""+    , emptyline+    , comment $ "Overwrites the semantics of the input " +++      "specification. Do not set"+    , comment "to keep the value unchanged."+    , ifJust owSemantics "overwrite_semantics" convert+    , emptyline+    , comment $ "Overwrites the target of the input " +++      "specification. Do not set"+    , comment "to keep the value unchanged."+    , ifJust owTarget "overwrite_target" convert+    , emptyline+    , comment $ "Either enable or disable weak simplifications on " +++      "the LTL"+    , comment $ "formula level. Possible values are either \"true\" " +++      "or \"false\"."+    , set "weak_simplify" $ convert simplifyWeak+    , emptyline+    , comment $ "Either enable or disable strong simplifications on " +++      "the LTL"+    , comment $ "formula level. Possible values are either \"true\" " +++      "or \"false\"."+    , set "strong_simplify" $ convert simplifyStrong+    , emptyline+    , comment $ "Either enable or disable that the resulting " +++      "formula is"+    , comment "converted into negation normal form. Possible values " +++      "are"+    , comment "either \"true\" or \"false\"."+    , set "negation_normal_form" $ convert negNormalForm+    , emptyline+    , comment $ "Either enable or disable to push globally operators " +++      "inwards,"+    , comment "i.e., to apply the following equivalence:"+    , comment ""+    , comment "  G (a && b) => (G a) && (G b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "push_globally_inwards" $ convert pushGlobally+    , emptyline+    , comment $ "Either enable or disable to push finally operators " +++      "inwards,"+    , comment "i.e., to apply the following equivalence:"+    , comment ""+    , comment "  F (a || b) => (F a) || (F b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "push_finally_inwards" $ convert pushFinally+    , emptyline+    , comment $ "Either enable or disable to next operators " +++      "inwards, i.e.,"+    , comment "to apply the following equivalences:"+    , comment ""+    , comment "  X (a && b) => (X a) && (X b)"+    , comment "  X (a || b) => (X a) || (X b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "push_next_inwards" $ convert pushNext+    , emptyline+    , comment $ "Either enable or disable to pull globally operators " +++      "outwards,"+    , comment "i.e., to apply the following equivalence:"+    , comment ""+    , comment "  (G a) && (G b) => G (a && b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "pull_globally_outwards" $ convert pullGlobally+    , emptyline+    , comment $ "Either enable or disable to pull finally operators " +++      "outwards,"+    , comment "i.e., to apply the following equivalence:"+    , comment ""+    , comment "  (F a) || (F b) => F (a || b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "pull_finally_outwards" $ convert pullFinally+    , emptyline+    , comment $ "Either enable or disable to pull next operators " +++      "outwards,"+    , comment "i.e., to apply the following equivalences:"+    , comment ""+    , comment "  (X a) && (X b) => X (a && b)"+    , comment "  (X a) || (X b) => X (a || b)"+    , comment ""+    , comment "Possible values are either \"true\" or \"false\"."+    , set "pull_next_outwards" $ convert pullNext+    , emptyline+    , comment $ "Either enable or disable to resolve weak until " +++      "operators."+    , comment "Possible values are either \"true\" or \"false\"."+    , set "no_weak_until" $ convert noWeak+    , emptyline+    , comment $ "Either enable or disable to resolve release " +++      "operators."+    , comment "Possible values are either \"true\" or \"false\"."+    , set "no_release" $ convert noRelease+    , emptyline+    , comment $ "Either enable or disable to resolve finally " +++      "operators."+    , comment "Possible values are either \"true\" or \"false\"."+    , set "no_finally" $ convert noFinally+    , emptyline+    , comment $ "Either enable or disable to resolve globally " +++      "operators."+    , comment "Possible values are either \"true\" or \"false\"."+    , set "no_globally" $ convert noGlobally+    , emptyline+    , comment $ "Either enable or disable to resolve derived " +++      "operators, i.e.,"+    , comment "weak until, finally, globally, ... . Possible " +++      "values are"+    , comment "either \"true\" or \"false\"."+    , set "no_derived" $ convert noDerived+    , emptyline+    ]++    where+      emptyline = ""+      comment = ("# " ++)+      set s v = s ++ " = " ++ v+      ifJust x s f = case x of+        Nothing -> "#\n# " ++ set s "..."+        Just y  -> set s $ f y++-----------------------------------------------------------------------------++-- | Parses configuration parameters from the content of a+-- configuration file and updates the respective entries in the+-- provided configuration.++update+  :: Configuration -> String -> Either Error Configuration++update c str =+  case P.parse configParser "Configuration Error" str of+    Left err -> parseError err+    Right xs -> return $ foldl (\x f -> f x) c xs++-----------------------------------------------------------------------------++-- | Configuration file parser, that parses the file to a list of+-- configuration updates to preserve the order inside the+-- configuration file.++configParser+  :: Parser [Configuration -> Configuration]++configParser = (~~) >> many entryParser++  where+    entryParser =+          (mParser "format"+             >>= (\v -> return (\c -> c { outputFormat = v })))+      <|> (mParser "mode"+             >>= (\v -> return (\c -> c { outputMode = v })))+      <|> (sParser "bus_delimiter"+             >>= (\v -> return (\c -> c { busDelimiter = v })))+      <|> (sParser "prime_symbol"+             >>= (\v -> return (\c -> c { primeSymbol = v })))+      <|> (sParser "at_symbol"+             >>= (\v -> return (\c -> c { atSymbol = v })))+      <|> (mParser "overwrite_semantics"+             >>= (\v -> return (\c -> c { owSemantics = Just v })))+      <|> (mParser "overwrite_target"+             >>= (\v -> return (\c -> c { owTarget = Just v })))+      <|> (mParser "weak_simplify"+             >>= (\v -> return (\c -> c { simplifyWeak = v })))+      <|> (mParser "strong_simplify"+             >>= (\v -> return (\c -> c { simplifyStrong = v })))+      <|> (mParser "negation_normal_form"+             >>= (\v -> return (\c -> c { negNormalForm = v })))+      <|> (mParser "push_globally_inwards"+             >>= (\v -> return (\c -> c { pushGlobally = v })))+      <|> (mParser "push_finally_inwards"+             >>= (\v -> return (\c -> c { pushFinally = v })))+      <|> (mParser "push_next_inwards"+             >>= (\v -> return (\c -> c { pushNext = v })))+      <|> (mParser "pull_globally_outwards"+             >>= (\v -> return (\c -> c { pullGlobally = v })))+      <|> (mParser "pull_finally_outwards"+             >>= (\v -> return (\c -> c { pullFinally = v })))+      <|> (mParser "pull_next_outwards"+             >>= (\v -> return (\c -> c { pullNext = v })))+      <|> (mParser "no_weak_until"+             >>= (\v -> return (\c -> c { noWeak = v })))+      <|> (mParser "no_release"+             >>= (\v -> return (\c -> c { noRelease = v })))+      <|> (mParser "no_finally"+             >>= (\v -> return (\c -> c { noFinally = v })))+      <|> (mParser "no_globally"+             >>= (\v -> return (\c -> c { noGlobally = v })))+      <|> (mParser "no_derived"+             >>= (\v -> return (\c -> c { noDerived = v })))++    sParser str = do+      keyword str+      op "="+      stringLiteral tokenparser++    mParser str = do+      keyword str+      op "="+      v <- identifier tokenparser+      case safeConvert v of+        Left _  -> parserZero <?> v+        Right m -> return m++    tokenparser = makeTokenParser configDef++    keyword = void . reserved tokenparser++    (~~) = whiteSpace tokenparser++    op = reservedOp tokenparser++    configDef = emptyDef+      { opStart = oneOf "="+      , opLetter = oneOf "="+      , identStart = alphaNum+      , identLetter = alphaNum <|> char '_'+      , commentLine = "#"+      , nestedComments = False+      , caseSensitive = True+      , reservedOpNames = ["="]+      , reservedNames =+        [ "format", "mode", "bus_delimiter", "prime_symbol", "at_symbol",+          "overwrite_semantics", "overwrite_target", "weak_simplify",+          "strong_simplify", "negation_normal_form",+          "push_globally_inwards", "push_finally_inwards",+          "push_next_inwards", "pull_globally_outwards",+          "pull_finally_outwards", "pull_next_outwards", "no_weak_until",+           "no_release", "no_finally", "no_globally", "no_derived" ]+  }++-----------------------------------------------------------------------------++instance Convertible Bool String where+  safeConvert = return . \case+    True  -> "true"+    False -> "false"++-----------------------------------------------------------------------------++instance Convertible String Bool where+  safeConvert = \case+    "true"  -> return True+    "false" -> return False+    str     -> Left ConvertError+      { convSourceValue = str+      , convSourceType = "String"+      , convDestType = "Bool"+      , convErrorMessage = "Unknown value"+      }++-----------------------------------------------------------------------------
+ src/Data/Binding.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Binding+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- A data type to store an identifier bound to an expression.+-- +-----------------------------------------------------------------------------++module Data.Binding+    ( Binding+    , BindExpr(..)+    ) where++-----------------------------------------------------------------------------++import Data.Expression+    ( Expr+    , ExprPos+    )++-----------------------------------------------------------------------------++-- | We use the type @Binding@ as a shortcut for a binding of an expression+-- to an integer.++type Binding = BindExpr Int++-----------------------------------------------------------------------------++-- | The data type @Bind a@ expresses a binding of some instance of type+-- @a@ to some expression. The identifiers inside this expression need to+-- be represented by instances of type @a@ as well. Finally, a binding also+-- containts the source position of the bound identifier as well as possible+-- arguments in case the bindings represents a function.++data BindExpr a =+  BindExpr+  { bIdent :: a+  , bArgs :: [(a,ExprPos)]    +  , bPos :: ExprPos      +  , bVal :: [Expr a]+  } deriving (Show)++-----------------------------------------------------------------------------             +
+ src/Data/Enum.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Enum+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Data types to store enum definitions and applications.+-- +-----------------------------------------------------------------------------++module Data.Enum+    ( EnumDefinition(..)+    , EnumId(..)+    ) where++-----------------------------------------------------------------------------++import Data.Expression+    ( ExprPos+    )++-----------------------------------------------------------------------------++-- | An enumeration definiton consists of a name, the number of+-- entries, the values associated with each entry, the position, a list+-- of entries not explicitly listed and ?.++data EnumDefinition a =+  EnumDefinition+  { eName :: a+  , eSize :: Int+  , eValues :: [(a, ExprPos, [Int -> Either Bool ()])]+  , ePos :: ExprPos+  , eMissing  :: [Int -> Either Bool ()]+  , eDouble :: Maybe ((a,ExprPos), (a, ExprPos), (a,ExprPos), Int -> Either Bool ())+  } ++-----------------------------------------------------------------------------++-- | An @EnumId@ contains all information to uniqely identify an+-- enumaration.++data EnumId a =+  EnumId+  { eIName :: a+  , eIPos :: ExprPos +  , eISize :: Int+  , eIVName :: a+  , eIValue :: Int -> Bool+  }  ++-----------------------------------------------------------------------------
+ src/Data/Error.hs view
@@ -0,0 +1,252 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Error+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Data structures to wrap all contents, that are needed to print nice+-- error messages.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Data.Error+  ( Error+  , syntaxError+  , runtimeError+  , typeError+  , bindingError+  , conversionError+  , depError+  , cfgError+  , parseError+  , prError+  , prErrPos+  ) where++-----------------------------------------------------------------------------++import Data.Expression+  ( ExprPos(..)+  , SrcPos(..)+  )++import Text.Parsec.Error+  ( ParseError+  )++import System.Exit+  ( exitFailure+  )++import System.IO+  ( hPrint+  , stderr+  )++-----------------------------------------------------------------------------++-- | Internal representation of an error.++data Error =+    ErrType TypeError+  | ErrParse ParseError+  | ErrBnd BindingError+  | ErrDep DependencyError+  | ErrSyntax SyntaxError+  | ErrRunT RunTimeError+  | ErrConv ConvError+  | ErrCfg CfgError++-----------------------------------------------------------------------------++data TypeError =+  TypeError+  { errTPos :: ExprPos+  , errTMsgs :: [String]+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data BindingError =+  BindingError+  { errBPos :: ExprPos+  , errBMsgs :: [String]+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data DependencyError =+  DependencyError+  { errDPos :: ExprPos+  , errDMsgs :: [String]+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data SyntaxError =+  SyntaxError+  { errSPos :: ExprPos+  , errSMsgs :: [String]+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data RunTimeError =+  RunTimeError+  { errRPos :: ExprPos+  , errRMsgs :: [String]+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data ConvError =+  ConvError+  { title :: String+  , cmsg :: String+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++data CfgError =+  ConfigError+  { fmsg :: String+  } deriving (Eq, Ord)++-----------------------------------------------------------------------------++instance Show Error where+  show = \case+    ErrParse x                 -> show x+    ErrType TypeError{..}      -> pr "Type Error" errTPos errTMsgs+    ErrBnd BindingError{..}    -> pr "Binding Error" errBPos errBMsgs+    ErrDep DependencyError{..} -> pr "Dependency Error" errDPos errDMsgs+    ErrSyntax SyntaxError{..}  -> pr "Syntax Error" errSPos errSMsgs+    ErrRunT RunTimeError{..}   -> pr "Runtime Error" errRPos errRMsgs+    ErrCfg ConfigError{..}     -> "\"Error\":\n" ++ fmsg+    ErrConv ConvError{..}      -> "\"Conversion Error\": " ++ title +++                                 "\n" ++ cmsg++    where+      pr errname pos msgs =+        "\"" ++ errname ++ "\" (" ++ prErrPos pos ++ "):\n" ++ concat msgs++-----------------------------------------------------------------------------++-- | Use this error constructor, if some sytax related misbehavior is+-- detected.++syntaxError+  :: ExprPos -> String -> Either Error a++syntaxError pos msg = Left $ ErrSyntax $ SyntaxError pos [msg]++-----------------------------------------------------------------------------++-- | Use this error constructor, if some runtime execution fails.++runtimeError+  :: ExprPos -> String -> Either Error a++runtimeError pos msg = Left $ ErrRunT $ RunTimeError pos [msg]++-----------------------------------------------------------------------------++-- | Use this error constructor, if some type related misbehavior is+-- detected.++typeError+  :: ExprPos -> String -> Either Error a++typeError pos msg = Left $ ErrType $ TypeError pos [msg]++-----------------------------------------------------------------------------++-- | Use this error constructor, if some identifier binding related+-- misbehavior is detected.++bindingError+  :: ExprPos -> String -> Either Error a++bindingError pos msg = Left $ ErrBnd $ BindingError pos [msg]++-----------------------------------------------------------------------------++-- | Use this error constructor, if some misbehavior concerning dependencies+-- between identifiers is detected.++depError+  :: ExprPos -> String -> Either Error a++depError pos msg = Left $ ErrDep $ DependencyError pos [msg]+++-----------------------------------------------------------------------------++-- | Use this error constructor, if some unresolvable inconsistency in the+-- configuration exists.++cfgError+  :: String -> Either Error a++cfgError msg = Left $ ErrCfg $ ConfigError msg++-----------------------------------------------------------------------------++-- | Use this error constructor, if an invalid command line setting is+-- detected.++conversionError+  :: String -> String -> Either Error a++conversionError t msg = Left $ ErrConv $ ConvError t msg++-----------------------------------------------------------------------------++-- | Use this error constructor, whenever a parser fails.++parseError+  :: ParseError -> Either Error a++parseError err = Left $ ErrParse err++-----------------------------------------------------------------------------++-- | Prints an error to STDERR and then terminates the program.++prError+  :: Error -> IO a++prError err = do+  hPrint stderr $ show err+  exitFailure++-----------------------------------------------------------------------------++-- | Prints the position of an error related token.++prErrPos+  :: ExprPos -> String++prErrPos pos =+  let+    bl = srcLine $ srcBegin pos+    bc = srcColumn $ srcBegin pos+    el = srcLine $ srcEnd pos+    ec = srcColumn $ srcEnd pos+  in+    "line " ++ show bl ++ "," +++    "column " ++ show bc +++    if bl == el+    then " - " ++ show ec+    else " - line " ++ show el ++ ", column " ++ show ec++-----------------------------------------------------------------------------
+ src/Data/Expression.hs view
@@ -0,0 +1,394 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Expression+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Data types to store expressions and some helper functions.+--+-----------------------------------------------------------------------------++module Data.Expression+    ( Constant+    , Expr(..)+    , Expr'(..)+    , ExprPos(..)+    , SrcPos(..)+    , subExpressions+    , applySub+    , prExpr+    , prPrettyExpr+    ) where++-----------------------------------------------------------------------------++-- | A constant is represted by an integer++type Constant = Int++-----------------------------------------------------------------------------++-- | Each expression consists of two parts, the main expression itself, i.e.,+-- the basic term or an operation, and the position of the expression in the+-- source code. The type $a$ specifies the representation of an identifier.++data Expr a =+  Expr+  { expr :: Expr' a+  , srcPos :: ExprPos+  } deriving (Show,Eq)++-----------------------------------------------------------------------------++-- | An expression is either a basic term or the composition of multiple+-- sub-expressions using an operator. To obtain a stepwise refinement of the+-- parsed data, an expression does not need to be type consistent ia the+-- first place, e.g., techniqually we could add to boolean expressions.+-- Such behaviour is ruled out later during the type analysis.++data Expr' a =+    BaseWild+  | BaseTrue+  | BaseFalse+  | BaseOtherwise+  | BaseCon Constant+  | BaseId a+  | BaseBus (Expr a) a+  | BaseFml [Expr a] a++  | NumSMin (Expr a)+  | NumSMax (Expr a)+  | NumSSize (Expr a)+  | NumSizeOf (Expr a)+  | NumPlus (Expr a) (Expr a)+  | NumRPlus [Expr a] (Expr a)+  | NumMinus (Expr a) (Expr a)+  | NumMul (Expr a) (Expr a)+  | NumRMul [Expr a] (Expr a)+  | NumDiv (Expr a) (Expr a)+  | NumMod (Expr a) (Expr a)++  | SetExplicit [Expr a]+  | SetRange (Expr a) (Expr a) (Expr a)+  | SetCup (Expr a) (Expr a)+  | SetRCup [Expr a] (Expr a)+  | SetCap (Expr a) (Expr a)+  | SetRCap [Expr a] (Expr a)+  | SetMinus (Expr a) (Expr a)++  | BlnEQ (Expr a) (Expr a)+  | BlnNEQ (Expr a) (Expr a)+  | BlnGE (Expr a) (Expr a)+  | BlnGEQ (Expr a) (Expr a)+  | BlnLE (Expr a) (Expr a)+  | BlnLEQ (Expr a) (Expr a)+  | BlnElem (Expr a) (Expr a)+  | BlnNot (Expr a)+  | BlnOr (Expr a) (Expr a)+  | BlnROr [Expr a] (Expr a)+  | BlnAnd (Expr a) (Expr a)+  | BlnRAnd [Expr a] (Expr a)+  | BlnImpl (Expr a) (Expr a)+  | BlnEquiv (Expr a) (Expr a)++  | LtlNext (Expr a)+  | LtlRNext (Expr a) (Expr a)+  | LtlGlobally (Expr a)+  | LtlRGlobally (Expr a) (Expr a)+  | LtlFinally (Expr a)+  | LtlRFinally (Expr a) (Expr a)+  | LtlUntil (Expr a) (Expr a)+  | LtlWeak (Expr a) (Expr a)+  | LtlRelease (Expr a) (Expr a)++  | Colon (Expr a) (Expr a)+  | Pattern (Expr a) (Expr a)+  deriving (Show, Eq)++-----------------------------------------------------------------------------++-- | The position of an expression is denoted by its starting position and+-- ending position in the source code.++data ExprPos =+  ExprPos+  { srcBegin :: SrcPos+  , srcEnd :: SrcPos+  } deriving (Eq, Ord, Show)+++-----------------------------------------------------------------------------++-- | A position in the source code is uniquely identified by its line and+-- column.++data SrcPos =+  SrcPos+  { srcLine :: Int+  , srcColumn :: Int+  } deriving (Eq, Ord, Show)++-----------------------------------------------------------------------------++-- | Returns all direct sub-formulas of the given formula, i.e., the formulas+-- that appear under the first operator. If the given formula is a basic+-- term, an empty list is returned.++subExpressions+  :: Expr a -> [Expr a]++subExpressions e = case expr e of+  BaseWild         -> []+  BaseTrue         -> []+  BaseFalse        -> []+  BaseCon _        -> []+  BaseId _         -> []+  BaseOtherwise    -> []+  BaseBus x _      -> [x]+  NumSMin x        -> [x]+  NumSMax x        -> [x]+  NumSSize x       -> [x]+  NumSizeOf x      -> [x]+  BlnNot x         -> [x]+  LtlNext x        -> [x]+  LtlGlobally x    -> [x]+  LtlFinally x     -> [x]+  NumPlus x y      -> [x,y]+  NumMinus x y     -> [x,y]+  NumMul x y       -> [x,y]+  NumDiv x y       -> [x,y]+  NumMod x y       -> [x,y]+  SetCup x y       -> [x,y]+  SetCap x y       -> [x,y]+  SetMinus x y     -> [x,y]+  BlnEQ x y        -> [x,y]+  BlnNEQ x y       -> [x,y]+  BlnGE x y        -> [x,y]+  BlnGEQ x y       -> [x,y]+  BlnLE x y        -> [x,y]+  BlnLEQ x y       -> [x,y]+  BlnElem x y      -> [x,y]+  BlnOr x y        -> [x,y]+  BlnAnd x y       -> [x,y]+  BlnImpl x y      -> [x,y]+  BlnEquiv x y     -> [x,y]+  LtlRNext x y     -> [x,y]+  LtlRGlobally x y -> [x,y]+  LtlRFinally x y  -> [x,y]+  LtlUntil x y     -> [x,y]+  LtlWeak x y      -> [x,y]+  LtlRelease x y   -> [x,y]+  Colon x y        -> [x,y]+  Pattern x y      -> [x,y]+  SetRange x y z   -> [x,y,z]+  SetExplicit xs   -> xs+  BaseFml xs _     -> xs+  NumRPlus xs x    -> x:xs+  NumRMul xs x     -> x:xs+  SetRCup xs x     -> x:xs+  SetRCap xs x     -> x:xs+  BlnROr xs x      -> x:xs+  BlnRAnd xs x     -> x:xs++-----------------------------------------------------------------------------++-- | Applies function 'f' to the fist level sup-expressions of 'e'.+++applySub+  :: (Expr a -> Expr a) -> Expr a -> Expr a++applySub f e =+  let+    e' = case expr e of+      BaseWild         -> BaseWild+      BaseTrue         -> BaseTrue+      BaseFalse        -> BaseFalse+      BaseCon i        -> BaseCon i+      BaseOtherwise    -> BaseOtherwise+      BaseId i         -> BaseId i+      NumSMin x        -> NumSMin $ f x+      NumSMax x        -> NumSMax $ f x+      NumSSize x       -> NumSSize $ f x+      NumSizeOf x      -> NumSizeOf $ f x+      BlnNot x         -> BlnNot $ f x+      LtlNext x        -> LtlNext $ f x+      LtlGlobally x    -> LtlGlobally $ f x+      LtlFinally x     -> LtlFinally  $ f x+      BaseBus x i      -> BaseBus (f x) i+      NumPlus x y      -> NumPlus (f x) (f y)+      NumMinus x y     -> NumMinus (f x) (f y)+      NumMul x y       -> NumMul (f x) (f y)+      NumDiv x y       -> NumDiv (f x) (f y)+      NumMod x y       -> NumMod (f x) (f y)+      SetCup x y       -> SetCup (f x) (f y)+      SetCap x y       -> SetCap (f x) (f y)+      SetMinus x y     -> SetMinus (f x) (f y)+      BlnEQ x y        -> BlnEQ (f x) (f y)+      BlnNEQ x y       -> BlnNEQ (f x) (f y)+      BlnGE x y        -> BlnGE (f x) (f y)+      BlnGEQ x y       -> BlnGEQ (f x) (f y)+      BlnLE x y        -> BlnLE (f x) (f y)+      BlnLEQ x y       -> BlnLEQ (f x) (f y)+      BlnElem x y      -> BlnElem (f x) (f y)+      BlnOr x y        -> BlnOr (f x) (f y)+      BlnAnd x y       -> BlnAnd (f x) (f y)+      BlnImpl x y      -> BlnImpl (f x) (f y)+      BlnEquiv x y     -> BlnEquiv (f x) (f y)+      LtlRNext x y     -> LtlRNext (f x) (f y)+      LtlRGlobally x y -> LtlRGlobally (f x) (f y)+      LtlRFinally x y  -> LtlRFinally (f x) (f y)+      LtlUntil x y     -> LtlUntil (f x) (f y)+      LtlWeak x y      -> LtlWeak (f x) (f y)+      LtlRelease x y   -> LtlRelease (f x) (f y)+      Colon x y        -> Colon (f x) (f y)+      Pattern x y      -> Pattern (f x) (f y)+      SetRange x y z   -> SetRange (f x) (f y) (f z)+      SetExplicit xs   -> SetExplicit $ map f xs+      BaseFml xs i     -> BaseFml (map f xs) i+      NumRPlus xs x    -> NumRPlus (map f xs) (f x)+      NumRMul xs x     -> NumRMul (map f xs) (f x)+      SetRCup xs x     -> SetRCup (map f xs) (f x)+      SetRCap xs x     -> SetRCap (map f xs) (f x)+      BlnROr xs x      -> BlnROr (map f xs) (f x)+      BlnRAnd xs x     -> BlnRAnd (map f xs) (f x)+  in+    Expr e' $ srcPos e++-----------------------------------------------------------------------------++-- | Some debugging function to give a more readable version of the expression.+-- In constrast to @show@, this function drops all position information in the+-- resulting output (for debugging purposes only).++prExpr+  :: Expr Int -> String++prExpr e = case expr e of+  BaseWild         -> "WILD"+  BaseTrue         -> "TRUE"+  BaseFalse        -> "FALSE"+  BaseOtherwise    -> "OTHERWISE"+  BaseCon x        -> "(CON " ++ show x ++ ")"+  BaseId x         -> "(ID " ++ show x ++ ")"+  BaseBus x y      -> "(BUS " ++ show y ++ "[" ++ prExpr x ++ "])"+  BaseFml xs y     -> "(FUN " ++ show y ++ "(" +++                      (if null xs then ""+                       else prExpr (head xs) +++                            concatMap ((:) ',' . prExpr) (tail xs)) ++ ")"+  NumSMin x        -> "(MIN " ++ prExpr x ++ ")"+  NumSMax x        -> "(MAX " ++ prExpr x ++ ")"+  NumSSize x       -> "(SIZE " ++ prExpr x ++ ")"+  NumSizeOf x      -> "(SIZEOF " ++ prExpr x ++ ")"+  BlnNot x         -> "(NOT " ++ prExpr x ++ ")"+  LtlNext x        -> "(X " ++ prExpr x ++ ")"+  LtlGlobally x    -> "(G " ++ prExpr x ++ ")"+  LtlFinally x     -> "(F " ++ prExpr x ++ ")"+  NumPlus x y      -> "(PLUS " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMinus x y     -> "(MINUS " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMul x y       -> "(MUL " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumDiv x y       -> "(DIV " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMod x y       -> "(MOD " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  SetCup x y       -> "(CUP " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  SetCap x y       -> "(CAP " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  SetMinus x y     -> "(DIFF " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnEQ x y        -> "(EQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnNEQ x y       -> "(NEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnGE x y        -> "(GE " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnGEQ x y       -> "(GEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnLE x y        -> "(LE " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnLEQ x y       -> "(LEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnElem x y      -> "(ELEM " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnOr x y        -> "(OR " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnAnd x y       -> "(AND " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnImpl x y      -> "(IMPL " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnEquiv x y     -> "(EQIV " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlRNext x y     -> "(X[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlRGlobally x y -> "(G[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlRFinally x y  -> "(F[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlUntil x y     -> "(U " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlWeak x y      -> "(W " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlRelease x y   -> "(R " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  Colon x y        -> prExpr x ++ " : " ++ prExpr y+  Pattern x y      -> prExpr x ++ " ~ " ++ prExpr y+  SetRange x y z   -> "(SR " ++ prExpr x ++ " " ++ prExpr y ++ " " ++ prExpr z ++ ")"+  SetExplicit xs   -> "(SET " ++ concatMap (flip (++) " " . prExpr) xs ++ ")"+  NumRPlus xs x    -> "(PLUS[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  NumRMul xs x     -> "(MUL[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  SetRCup xs x     -> "(CUP[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  SetRCap xs x     -> "(CAP[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  BlnROr xs x      -> "(OR[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  BlnRAnd xs x     -> "(AND[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"++-----------------------------------------------------------------------------++-- | Some debugging function to give a very well readable version of+-- the expression.  In constrast to @show@, this function drops all+-- position information in the resulting output (for debugging+-- purposes only).++prPrettyExpr+  :: Expr Int -> String++prPrettyExpr e = case expr e of+  BaseWild         -> "_"+  BaseTrue         -> "true"+  BaseFalse        -> "false"+  BaseOtherwise    -> "OTHERWISE"+  BaseCon x        -> "(CON " ++ show x ++ ")"+  BaseId x         -> "(ID " ++ show x ++ ")"+  BaseBus x y      -> "(BUS " ++ show y ++ "[" ++ prExpr x ++ "])"+  BaseFml xs y     -> "(FUN " ++ show y ++ "(" +++                      (if null xs then ""+                       else prExpr (head xs) +++                            concatMap ((:) ',' . prExpr) (tail xs)) ++ ")"+  NumSMin x        -> "(MIN " ++ prExpr x ++ ")"+  NumSMax x        -> "(MAX " ++ prExpr x ++ ")"+  NumSSize x       -> "(SIZE " ++ prExpr x ++ ")"+  NumSizeOf x      -> "(SIZEOF " ++ prExpr x ++ ")"+  BlnNot x         -> "(NOT " ++ prExpr x ++ ")"+  LtlNext x        -> "(X " ++ prExpr x ++ ")"+  LtlGlobally x    -> "(G " ++ prExpr x ++ ")"+  LtlFinally x     -> "(F " ++ prExpr x ++ ")"+  NumPlus x y      -> "(PLUS " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMinus x y     -> "(MINUS " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMul x y       -> "(MUL " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumDiv x y       -> "(DIV " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  NumMod x y       -> "(MOD " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  SetCup x y       -> case expr x of+    SetExplicit [] -> prPrettyExpr y+    _              -> case expr y of+      SetExplicit [] -> prPrettyExpr x+      _              -> prPrettyExpr x ++ " ∪ " ++ prPrettyExpr y+  SetCap x y       -> "(CAP " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  SetMinus x y     -> "(DIFF " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnEQ x y        -> "(EQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnNEQ x y       -> "(NEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnGE x y        -> "(GE " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnGEQ x y       -> "(GEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnLE x y        -> "(LE " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnLEQ x y       -> "(LEQ " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnElem x y      -> "(ELEM " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnOr x y        -> "(OR " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnAnd x y       -> "(AND " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnImpl x y      -> "(IMPL " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  BlnEquiv x y     -> "(EQIV " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlRNext x y     -> "(X[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlRGlobally x y -> "(G[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlRFinally x y  -> "(F[" ++ prExpr x ++ "] " ++ prExpr y ++ ")"+  LtlUntil x y     -> "(U " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlWeak x y      -> "(W " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  LtlRelease x y   -> "(R " ++ prExpr x ++ " " ++ prExpr y ++ ")"+  Colon x y        -> prExpr x ++ " : " ++ prExpr y+  Pattern x y      -> prExpr x ++ " ~ " ++ prExpr y+  SetRange x y z   -> "(SR " ++ prExpr x ++ " " ++ prExpr y ++ " " ++ prExpr z ++ ")"+  SetExplicit []   -> "∅"+  SetExplicit xs   -> "{ " ++ concatMap (flip (++) ", " . prExpr) xs ++ "}"+  NumRPlus xs x    -> "(PLUS[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  NumRMul xs x     -> "(MUL[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  SetRCup xs x     -> "(CUP[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  SetRCap xs x     -> "(CAP[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  BlnROr xs x      -> "(OR[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"+  BlnRAnd xs x     -> "(AND[" ++ concatMap (flip (++) " " . prExpr) xs ++ "] " ++ prExpr x ++ ")"++-----------------------------------------------------------------------------
+ src/Data/Info.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Info+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Information shared by different modules.+--+-----------------------------------------------------------------------------++module Data.Info+  ( name+  , version+  , defaultDelimiter+  , defaultPrimeSymbol+  , defaultAtSymbol+  ) where++-----------------------------------------------------------------------------++import qualified Paths_syfco as P+  ( version+  )++import Data.Version+  ( Version(..)+  , showVersion+  )++import Data.Char+  ( toLower+  )++-----------------------------------------------------------------------------++-- | The default delimiter symbol++defaultDelimiter+  :: String++defaultDelimiter = "_"++-----------------------------------------------------------------------------++-- | The default prime symbol++defaultPrimeSymbol+  :: String++defaultPrimeSymbol = "'"+++-----------------------------------------------------------------------------++-- | The default at symbol++defaultAtSymbol+  :: String++defaultAtSymbol = "@"++-----------------------------------------------------------------------------++-- | The name of the tool.++name+  :: String++name = "SyFCo"++-----------------------------------------------------------------------------++-- | Returns the build version of the library. Requires the library to+-- be built with cabal or stack.++version = case P.version of+  Version [0,0,0,0] [] -> "no version information available"+  _                    -> showVersion P.version++-----------------------------------------------------------------------------
+ src/Data/LTL.hs view
@@ -0,0 +1,386 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.LTL+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Internal representation of Linear Temporal Logic formulas.+-- +-----------------------------------------------------------------------------++module Data.LTL+    ( Atomic(..)+    , Formula(..)+    , subFormulas      +    , applySub  +    , applyAtomic+    , fmlSignals+    , fmlInputs+    , fmlOutputs+    , isBooleanFormula+    , isBooleanNextFormula+    , simplePrint      +    , fNot        +    , fAnd+    , fOr+    , fGlobally+    , fFinally+    ) where++-----------------------------------------------------------------------------++import qualified Data.Set as S+    ( toList+    , insert+    , empty+    )++-----------------------------------------------------------------------------++-- | Internal representation of an atomic proposition. Each atomic+-- proposition is either an input or output signal.++data Atomic =+    Input String+  | Output String+  deriving (Eq)++-----------------------------------------------------------------------------++instance Ord Atomic where+  compare x y = case (x,y) of+    (Input _, Output _)  -> LT+    (Output _, Input _)  -> GT+    (Input a, Input b)   -> compare a b+    (Output a, Output b) -> compare a b++-----------------------------------------------------------------------------    ++instance Show Atomic where+  show a = case a of+    Input x  -> x+    Output x -> x++-----------------------------------------------------------------------------++-- | Internal representation of a Linear Temporal Logic formula.++data Formula =+    TTrue+  | FFalse+  | Atomic Atomic+  | Not Formula+  | Implies Formula Formula+  | Equiv Formula Formula+  | And [Formula]+  | Or [Formula]+  | Next Formula    +  | Globally Formula+  | Finally Formula+  | Until Formula  Formula+  | Release Formula Formula+  | Weak Formula Formula  +  deriving (Eq, Show)++-----------------------------------------------------------------------------++instance Ord Formula where+  compare x y = case (x,y) of+    (Atomic a, Atomic b)       -> compare a b+    (Not a, Not b)             -> compare a b+    (Next a, Next b)           -> compare a b+    (Globally a, Globally b)   -> compare a b+    (Finally a, Finally b)     -> compare a b+    (Implies a b, Implies c d) -> case compare a c of+      EQ -> compare b d+      v  -> v+    (Equiv a b, Equiv c d)     -> case compare a c of+      EQ -> compare b d+      v  -> v+    (Until a b, Until c d)     -> case compare a c of+      EQ -> compare b d+      v  -> v+    (Release a b, Release c d) -> case compare a c of+      EQ -> compare b d+      v  -> v+    (And xs, And ys)           -> case foldl lexord EQ $ zip xs ys of+      EQ -> compare (length xs) (length ys)+      v  -> v+    (Or xs, Or ys)             -> case foldl lexord EQ $ zip xs ys of+      EQ -> compare (length xs) (length ys)+      v  -> v+    _                          -> compare (num x) (num y)  ++    where+      num :: Formula -> Int+      +      num f = case f of+        FFalse      -> 0        +        TTrue       -> 1+        Atomic {}   -> 2+        Not {}      -> 3+        Implies {}  -> 4+        Equiv {}    -> 5+        And {}      -> 6+        Or {}       -> 7+        Next {}     -> 8+        Globally {} -> 9+        Finally {}  -> 10+        Until {}    -> 11+        Release {}  -> 12+        Weak {}     -> 13++      lexord a (b,c) = case a of+        EQ -> compare b c+        v  -> v++-----------------------------------------------------------------------------++-- | @applySub f fml@ applies the function @f@ to the direct sub-formulas of+-- @fml@, i.e., every sub-formula under the first operator that appears.+-- If @fml@ is a basic term, the formula remains unchanged.++applySub+  :: (Formula -> Formula) -> Formula -> Formula++applySub f fml = case fml of+  Not x       -> Not $ f x+  Next x      -> Next $ f x+  Globally x  -> Globally $ f x+  Finally x   -> Finally $ f x+  And xs      -> And $ map f xs+  Or xs       -> Or $ map f xs+  Equiv x y   -> Equiv (f x) (f y)+  Implies x y -> Implies (f x) (f y)+  Until x y   -> Until (f x) (f y)+  Release x y -> Release (f x) (f y)+  Weak x y    -> Weak (f x) (f y)+  _           -> fml++-----------------------------------------------------------------------------++-- | @applyAtomic f fml@ applies the function @f@ to every atomic+-- proposition of @fml@.++applyAtomic+  :: (Atomic -> Formula) -> Formula -> Formula++applyAtomic f fml = case fml of+  Atomic x -> f x+  _        -> applySub (applyAtomic f) fml++-----------------------------------------------------------------------------++-- | Returns the list of Atomic propositions that appear inside the given+-- formula.++fmlSignals+  :: Formula -> [Atomic]++fmlSignals = S.toList . signals' S.empty +  where+    signals' a fml = case fml of+      Atomic x -> S.insert x a+      _        -> foldl signals' a $ subFormulas fml++-----------------------------------------------------------------------------++-- | Returns the list of input signals that appear inside the given formula.      ++fmlInputs+  :: Formula -> [String]++fmlInputs fml = map (\(Input x) -> x) $ filter isInput $ fmlSignals fml+  where+    isInput (Input _)  = True+    isInput (Output _) = False++-----------------------------------------------------------------------------++-- | Returns the list of output signals that appear inside the given formula.          ++fmlOutputs+  :: Formula -> [String]++fmlOutputs fml = map (\(Output x) -> x) $ filter isOutput $ fmlSignals fml+  where+    isOutput (Output _)  = True+    isOutput (Input _) =False     ++-----------------------------------------------------------------------------++-- | Returns all direct sub-formulas of the given formula, i.e., the formulas+-- that appear under the first operator. If the given formula is a basic+-- term, an empty list is returned.++subFormulas+  :: Formula -> [Formula]++subFormulas fml = case fml of+  TTrue       -> []+  FFalse      -> []+  Atomic _    -> []+  Not x       -> [x]+  Next x      -> [x]+  Globally x  -> [x]+  Finally x   -> [x]+  Implies x y -> [x,y]+  Equiv x y   -> [x,y]+  Until x y   -> [x,y]+  Release x y -> [x,y]+  Weak x y    -> [x,y]+  And xs      -> xs+  Or xs       -> xs++-----------------------------------------------------------------------------++-- | Checks whether a given formula is free of temporal operators.++isBooleanFormula+  :: Formula -> Bool++isBooleanFormula fml = case fml of+  TTrue     -> True+  FFalse    -> True+  Atomic {} -> True+  Not x     -> isBooleanFormula x+  And xs    -> all isBooleanFormula xs+  Or xs     -> all isBooleanFormula xs+  _         -> False++-----------------------------------------------------------------------------  ++-- | Checks whether a given formula contains 'next' as the only temporal+-- operator.++isBooleanNextFormula+  :: Formula -> Bool++isBooleanNextFormula fml = case fml of+  TTrue     -> True+  FFalse    -> True+  Atomic {} -> True+  Not x     -> isBooleanNextFormula x+  And xs    -> all isBooleanNextFormula xs+  Or xs     -> all isBooleanNextFormula xs+  Next x    -> isBooleanFormula x+  _         -> False  +  +-----------------------------------------------------------------------------++-- | Smart 'And' constructur.++fAnd+  :: [Formula] -> Formula++fAnd xs =+  case filter (/= TTrue) $ warp xs of+    []  -> TTrue+    [x] -> x+    _   -> And xs++  where+    warp = concatMap wAnd+    wAnd fml = case fml of+      And x -> x+      _     -> [fml]    ++-----------------------------------------------------------------------------++-- | Smart 'Or' constructur.  ++fOr+  :: [Formula] -> Formula++fOr xs =+  case filter (/= FFalse) $ warp xs of  +    []  -> FFalse+    [x] -> x+    _   -> Or xs++  where+    warp = concatMap wOr+    wOr fml = case fml of+      Or x -> x+      _    -> [fml]      ++-----------------------------------------------------------------------------++-- | Smart 'Not' constructur.++fNot+  :: Formula -> Formula++fNot fml = case fml of+  TTrue           -> FFalse+  FFalse          -> TTrue+  Atomic x        -> Not $ Atomic x+  Not x           -> x+  Next x          -> Next $ fNot x+  Globally x      -> Finally $ fNot x+  Finally x       -> Globally $ fNot x+  Implies x y     -> And [x, fNot y]+  Equiv (Not x) y -> Equiv x y+  Equiv x (Not y) -> Equiv x y+  Equiv x y       -> Equiv (fNot x) y+  Until x y       -> Release (fNot x) (fNot y)+  Release x y     -> Until (fNot x) (fNot y)+  Weak x y        -> Until (fNot y) (And [fNot x, fNot y])+  And xs          -> Or $ map fNot xs+  Or xs           -> And $ map fNot xs++-----------------------------------------------------------------------------++-- | Smart 'Globally' constructur.++fGlobally+  :: Formula -> Formula++fGlobally fml = case fml of+  Globally FFalse -> FFalse+  Globally TTrue  -> TTrue+  Globally _      -> fml+  _               -> Globally fml++-----------------------------------------------------------------------------++-- | Smart 'Globally' constructur.++fFinally+  :: Formula -> Formula++fFinally fml = case fml of+  Finally FFalse -> FFalse+  Finally TTrue  -> TTrue  +  Finally _      -> fml+  _              -> Finally fml++-----------------------------------------------------------------------------    ++-- | Simple printing.  ++simplePrint+  :: Formula -> String++simplePrint fml = case fml of+  TTrue           -> "true"+  FFalse          -> "false"+  Atomic x        -> show x+  Not x           -> '!' : simplePrint x+  Next x          -> 'X' : ' ' : simplePrint x+  Globally x      -> 'G' : ' ' : simplePrint x+  Finally x       -> 'F' : ' ' : simplePrint x+  Implies x y     -> "(" ++ simplePrint x ++ " -> " ++ simplePrint y ++ ")"+  Equiv x y       -> "(" ++ simplePrint x ++ " <-> " ++ simplePrint y ++ ")"+  Until x y       -> "(" ++ simplePrint x ++ " U " ++ simplePrint y ++ ")"+  Release x y     -> "(" ++ simplePrint x ++ " R " ++ simplePrint y ++ ")"+  Weak x y        -> "(" ++ simplePrint x ++ " W " ++ simplePrint y ++ ")"+  And []          -> simplePrint TTrue+  And [x]         -> simplePrint x+  And (x:xr)      -> "(" ++ simplePrint x +++                     concatMap ((" && " ++) . simplePrint) xr ++ ")"+  Or []           -> simplePrint FFalse+  Or (x:xr)       -> "(" ++ simplePrint x +++                     concatMap ((" || " ++) . simplePrint) xr ++ ")"++-----------------------------------------------------------------------------
+ src/Data/Specification.hs view
@@ -0,0 +1,136 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Specification+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Internal data structure of a specification.+--+-----------------------------------------------------------------------------++module Data.Specification+  ( Specification(..)+  , Expression+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( SignalDecType+  )++import Data.Expression+  ( Expr+  , ExprPos+  )++import Data.Types+  ( Semantics+  , Target+  )++import Data.Binding+  ( Binding+  )++import Data.SymbolTable+  ( SymbolTable+  )++import Data.Enum+  ( EnumDefinition+  )++-----------------------------------------------------------------------------++-- | We use the type @Expression@ as a shortcut for expressions, where+-- identifiers are denoted by integers.++type Expression = Expr Int++-----------------------------------------------------------------------------++-- | Internal representation of a specification.++data Specification =+  Specification+    { -- | Returns the TSLF source of a specification.+      source :: String++    , -- | Returns the title of a specification.+      title :: String++    , -- | Returns the description of a specification.+      description :: String++    , -- | Returns the semantics of a specification.+      semantics :: Semantics++    , -- | Returns the target flag of a specification.+      target :: Target++    , -- | Returns the tag list of a specification.+      tags :: [String]++    , -- | Positions of the tags in the tags list. Each expression+      -- matches with the corresponding tag in order.+      tagsPos :: [ExprPos]++    , -- | Position of the title in the source file.+      titlePos :: ExprPos++    , -- | Position of the description in the source file.+      descriptionPos :: ExprPos++    , -- | Position of the semantics flag in the source file.+      semanticsPos :: ExprPos++    , -- | Poisition of the target flag in the source file.+      targetPos :: ExprPos++    , -- | List of enumeration definitions.+      enumerations :: [EnumDefinition Int]++    , -- | List of bindings of an identifier to an expression defined in+      -- the PARAMETERS subsection.+      parameters :: [Binding]++    , -- | List of bindings of an identifier to any other expression,+      -- defined in the DEFINITIONS subsection.+      definitions :: [Binding]++    , -- | List of input signals.+      inputs :: [SignalDecType Int]++    , -- | List of output signals.+      outputs :: [SignalDecType Int]++    , -- | List of expresssions representing the initial input of the+      -- environment.+      initially :: [Expression]++    , -- | List of expresssions representing the initial output of the+      -- system.+      preset :: [Expression]++    , -- | List of expresssions representing the globally asserted+      -- requirements on the inputs of the specification.+      requirements :: [Expression]++    , -- | List of expresssions representing the assumptions of the+      -- specification.+      assumptions :: [Expression]++    , -- | List of expressions representing the invariants of the+      -- specification.+      invariants :: [Expression]++    , -- | List of expressions representing the guarantees of the+      -- specification.+      guarantees :: [Expression]++    , -- | Symbol table used to access information about an identifier.+      symboltable :: SymbolTable+    }++-----------------------------------------------------------------------------
+ src/Data/StringMap.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.StringMap+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- A simple data structure to map strings to integers.+-- +-----------------------------------------------------------------------------++module Data.StringMap+    ( StringMap+    , empty+    , lookup+    , insert+    ) where++-----------------------------------------------------------------------------++import Prelude hiding (lookup)++-----------------------------------------------------------------------------++-- | Internal data structure of the mapping.++data StringMap =+    Empty+  | Leaf (String, Int)+  | Node (Maybe Int, [(Char, StringMap)])++-----------------------------------------------------------------------------++-- | Returns the empty mapping.++empty+  :: StringMap++empty = Empty++-----------------------------------------------------------------------------++-- | Lookups a string in the mapping.++lookup+  :: String -> StringMap -> Maybe Int++lookup str mapping = case mapping of+  Empty       -> Nothing+  Leaf (e,v)  -> if e == str then Just v else Nothing+  Node (v,xs) -> case str of+    []   -> v+    x:xr -> case findMatch x xs of+      Just mapping' -> lookup xr mapping'+      _             -> Nothing++  where+    findMatch x xs = case xs of+      []           -> Nothing+      ((y,n) : xr) -> if x == y then Just n+                     else findMatch x xr      ++-----------------------------------------------------------------------------++-- | Inserts a new string-int pair to the given mapping. If the mapping +-- already containts the given string, then the corresponding value is+-- updated.      ++insert+  :: String -> Int -> StringMap -> StringMap++insert s i m = case m of+  Empty      -> Leaf (s,i)+  Leaf (e,v) -> if e == s then Leaf (s,i) else case e of+    []     -> Node (Just v, [(head s, Leaf (tail s,i))])+    (x:xr) -> case s of+      []     -> Node (Just i, [(x,Leaf (xr,v))])+      (y:yr) ->+        if x == y then+          Node (Nothing, [(x, insert yr i (Leaf (xr,v)))])+        else+          Node (Nothing, [(x, Leaf (xr,v)),(y, Leaf (yr,i))])+  Node (v,xs) -> case s of+    []     -> Node (Just i,xs)+    (x:xr) -> Node (v, add x xr i xs)++  where+    add x xr j xs = case xs of+      []         -> [(x, Leaf (xr,j))]+      ((c,n):yr) ->+        if x == c then+          (c,insert xr j n):yr+        else+          (c,n) : add x xr j yr++-----------------------------------------------------------------------------
+ src/Data/SymbolTable.hs view
@@ -0,0 +1,241 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SymbolTable+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Data type to store all identifier specific content.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    ViewPatterns+  , LambdaCase+  , RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Data.SymbolTable+    ( SymbolTable+    , IdRec(..)+    , st2csv+    ) where++-----------------------------------------------------------------------------++import Data.Types+   ( IdType(..)+   , SignalType(..)+   )++import Data.Expression+   ( Expr(..)+   , Expr'(..)+   , ExprPos(..)+   , SrcPos(..)+   , prExpr+   , expr+   )++import Data.Char+   ( ord+   , chr+   )++import Data.Array+   ( Array+   , (!)+   , assocs+   )++-----------------------------------------------------------------------------++-- | A symbol table is an array mapping identifieres, represend by integers,+-- to blocks of information.++type SymbolTable = Array Int IdRec++-----------------------------------------------------------------------------++-- | Data type representing a single entry  in the symbol table.++data IdRec =++  IdRec+    { -- | The name of the identifier.+      idName :: String++    , -- | The position of the identifer definition in the source file.+      idPos :: ExprPos++    , -- | The arguemnts, in case the identifier describes a function.+      idArgs :: [Int]++    , -- | The expression, the identifier is bound to.+      idBindings :: Expr Int++    , -- | The type of the identifier.+      idType :: IdType++    , -- | The list of identifiers, which have to be evaluated first+      -- to evaluate this identifier.+      idDeps :: [Int]++    }++-----------------------------------------------------------------------------++-- | Prints a symbol table in the CVS format (for debugging purposes only).++st2csv+  :: SymbolTable -> String++st2csv lt =+ "Id;Name;Position;Arguments;Type;Dependencies;\n"+--    putStrLn "Id;Name;Position;Arguments;Bindings;Type;Dependencies;"+ ++ (unlines $ map printEntry $ assocs lt)++  where+    printEntry (i,r@IdRec{..}) =+      concat+        [ show i+        , ";"+        , "\"" ++ idName ++ "\""+        , ";"+        , prExprPos idPos+        , ";"+        , commasepxs idArgs+        , ";"+--        , prPrettyExpr lt r idBindings+--        , ";"+        , prType idArgs idType+        , ";"+        , commasepxs idDeps+        , ";"+        ]++    commasepxs = \case+      (x:xr) -> show x ++ concatMap ((:) ',') (map show xr)+      []     -> ""++    prExprPos pos =+      let+        bl = srcLine $ srcBegin pos+        bc = srcColumn $ srcBegin pos+        el = srcLine $ srcEnd pos+        ec = srcColumn $ srcEnd pos+      in+        "(" ++ show bl ++ "," ++ show bc +++        if bl == el then+          "-" ++ show ec ++ ")"+        else+          show el ++ ":" ++ show ec ++ ")"++    prType xs t = concatMap prArgType xs ++ case t of+      TNumber   -> "Int"+      TLtl      -> "Ltl"+      TBoolean  -> "Bool"+      TPattern  -> "Pattern"+      TEmptySet -> "Empty Set"+      TSet x    -> prType [] x ++ " Set"+      TPoly i   ->+        if i >= ord 'a' && i <= ord 'z'+        then [chr i]+        else "a" ++ show i+      TSignal STInput  -> "Input"+      TSignal STOutput  -> "Output"+      TSignal STGeneric -> "In|Out"+      TBus STInput      -> "Input Bus"+      TBus STOutput     -> "Output Bus"+      TBus STGeneric    -> "In|Out Bus"+      TTypedBus STInput s _ -> "Input[" ++ s ++ "]"+      TTypedBus STOutput s _ -> "Output[" ++ s ++ "]"+      TTypedBus STGeneric s _ -> "In|Out[" ++ s ++ "]"+      TEnum s _ -> s++    prArgType x =+      let+        r = lt ! x+        args = idArgs r+      in+         if length args > 1+         then "(" ++ prType args (idType r)  ++ ") -> "+         else prType args (idType r) ++ " -> "++-----------------------------------------------------------------------------++prPrettyExpr+  :: SymbolTable -> IdRec -> Expr Int -> String++prPrettyExpr _  _ (expr -> SetExplicit []) = ""+prPrettyExpr st r e = pr e++  where+    pr = pr' . expr++    pr' = \case+      BaseWild         -> "_"+      BaseTrue         -> "\"true\""+      BaseFalse        -> "\"false\""+      BaseOtherwise    -> "otherwise"+      BaseCon x        -> "\"" ++ show x ++ "\""+      BaseId x         -> "\"" ++ idName (st ! x) ++ "\"<" ++ show x ++ ">"+      BaseBus x y      -> "\"" ++ idName (st ! y) ++ "\"<" ++ show y ++ ">[" ++ pr x ++ "]"+      BaseFml xs y     -> "\"" ++ idName (st ! y) ++ "\"<" ++ show y ++ ">(" +++                          (if null xs then ""+                           else pr (head xs) +++                                concatMap ((:) ',' . pr) (tail xs)) ++ ")"+      NumSMin x        -> "min " ++ pr x+      NumSMax x        -> "max " ++ pr x+      NumSSize x       -> "|" ++ pr x ++ "|"+      NumSizeOf x      -> "sizeof " ++ pr x ++ ")"+      BlnNot x         -> "¬" ++ pr x+      LtlNext x        -> "X " ++ pr x+      LtlGlobally x    -> "G " ++ pr x+      LtlFinally x     -> "F " ++ pr x+      NumPlus x y      -> pr x ++ " + " ++ pr y+      NumMinus x y     -> pr x ++ " - " ++ pr y+      NumMul x y       -> pr x ++ " * " ++ pr y+      NumDiv x y       -> pr x ++ " / " ++ pr y+      NumMod x y       -> pr x ++ " % " ++ pr y+      SetCup (expr -> SetExplicit []) x -> pr x+      SetCup x (expr -> SetExplicit []) -> pr x+      SetCup x y                       -> pr x ++ " ∪ " ++ pr y+      SetCap (expr -> SetExplicit []) x -> pr x+      SetCap x (expr -> SetExplicit []) -> pr x+      SetCap x y                       -> pr x ++ " ∩ " ++ pr y+      SetMinus x y     -> pr x ++ " ∖ " ++ pr y+      BlnEQ x y        -> pr x ++ " = " ++ pr y+      BlnNEQ x y       -> pr x ++ " ≠ " ++ pr y+      BlnGE x y        -> pr x ++ " > " ++ pr y+      BlnGEQ x y       -> pr x ++ " ≥ " ++ pr y+      BlnLE x y        -> pr x ++ " < " ++ pr y+      BlnLEQ x y       -> pr x ++ " < " ++ pr y+      BlnElem x y      -> pr x ++ " ≤ " ++ pr y+      BlnOr x y        -> pr x ++ " ∨ " ++ pr y+      BlnAnd x y       -> pr x ++ " ∧ " ++ pr y+      BlnImpl x y      -> pr x ++ " → " ++ pr y+      BlnEquiv x y     -> pr x ++ " ↔ " ++ pr y+      LtlRNext x y     -> "X [ " ++ pr x ++ " ] " ++ pr y+      LtlRGlobally x y -> "G [ " ++ pr x ++ " ] " ++ pr y+      LtlRFinally x y  -> "F [ " ++ pr x ++ " ] " ++ pr y+      LtlUntil x y     -> pr x ++ " U " ++ pr y+      LtlWeak x y      -> pr x ++ " W " ++ pr y+      LtlRelease x y   -> pr x ++ " R " ++ pr y+      Colon x y        -> pr x ++ " : " ++ pr y+      Pattern x y      -> pr x ++ " ~ " ++ pr y+      SetRange x y z   -> "[ " ++ pr x ++ ", " ++ pr y ++ " .. " ++ pr z ++ " ]"+      SetExplicit []     -> "∅"+      SetExplicit [x]    -> "{ " ++ pr x ++ " }"+      SetExplicit (x:xr) -> "{ " ++ pr x ++ concatMap ((',':) . (' ':) . pr) xr ++ "}"+      NumRPlus xs x    -> "Σ [ " ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x+      NumRMul xs x     -> "Π [" ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x+      SetRCup xs x     -> "⋃ [" ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x+      SetRCap xs x     -> "⋂ [" ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x+      BlnROr xs x      -> "⋁ [" ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x+      BlnRAnd xs x     -> "⋀ [ " ++ concatMap (flip (++) " " . pr) xs ++ "] " ++ pr x++-----------------------------------------------------------------------------
+ src/Data/Types.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Types+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Types of the different expressions, semantics and targets.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , MultiParamTypeClasses+  , TypeSynonymInstances+  , FlexibleInstances++  #-}++-----------------------------------------------------------------------------++module Data.Types+  ( Target(..)+  , Semantics(..)+  , SignalType(..)+  , IdType(..)+  , SignalDecType(..)+  ) where++-----------------------------------------------------------------------------++import Data.Convertible+  ( Convertible(..)+  , ConvertError(..)+  )++import Data.Expression+  ( ExprPos+  , Expr+  )++-----------------------------------------------------------------------------++-- | Target types.++data Target =+    TargetMealy+    -- ^ Mealy machine target+  | TargetMoore+    -- ^ Moore machine target+  deriving (Eq, Ord)++-----------------------------------------------------------------------------++instance Convertible Target String where+  safeConvert = return . \case+    TargetMealy -> "mealy"+    TargetMoore -> "moore"++-----------------------------------------------------------------------------++instance Convertible String Target where+  safeConvert = \case+    "mealy" -> return TargetMealy+    "moore" -> return TargetMoore+    str     -> Left ConvertError+      { convSourceValue = str+      , convSourceType = "String"+      , convDestType = "Target"+      , convErrorMessage = "Unknown target"+      }++-----------------------------------------------------------------------------++-- | Semantic types.++data Semantics =+    SemanticsMealy+    -- ^ Standard Mealy machine semantics.+  | SemanticsMoore+    -- ^ Standard Moore machine semantics.+  | SemanticsStrictMealy+    -- ^ Mealy machine semantics with strict envionment assumptions.+  | SemanticsStrictMoore+    -- ^ Moore machine semantics with strict envionment assumptions.+  deriving (Eq, Ord)++-----------------------------------------------------------------------------++instance Convertible Semantics String where+  safeConvert = return . \case+    SemanticsMealy       -> "mealy"+    SemanticsMoore       -> "moore"+    SemanticsStrictMealy -> "mealy,strict"+    SemanticsStrictMoore -> "moore,strict"++-----------------------------------------------------------------------------++instance Convertible String Semantics where+  safeConvert = \case+    "mealy"        -> return SemanticsMealy+    "moore"        -> return SemanticsMoore+    "mealy,strict" -> return SemanticsStrictMealy+    "moore,strict" -> return SemanticsStrictMoore+    str            -> Left ConvertError+      { convSourceValue = str+      , convSourceType = "String"+      , convDestType = "Semantics"+      , convErrorMessage = "Unknown semantics"+      }++-----------------------------------------------------------------------------++-- | Signal types.++data SignalType =+    STInput+  | STOutput+  | STGeneric+  deriving (Eq)++-----------------------------------------------------------------------------++-- | Signal decleration types.++data SignalDecType a =+    SDSingle (a,ExprPos)+  | SDBus (a,ExprPos) (Expr a)+  | SDEnum (a,ExprPos) (a,ExprPos)++-----------------------------------------------------------------------------++-- | Expression types.++data IdType =+    TEmptySet+  | TSignal SignalType+  | TBus SignalType+  | TTypedBus SignalType String Int+  | TEnum String Int+  | TNumber+  | TBoolean+  | TLtl+  | TPattern+  | TPoly Int+  | TSet IdType+  deriving (Eq)++-----------------------------------------------------------------------------++instance Show IdType where+  show x = case x of+    TEmptySet               -> "empty set"+    TSignal STInput         -> "input signal"+    TSignal STOutput        -> "output signal"+    TSignal STGeneric       -> "signal"+    TBus STInput            -> "input bus"+    TBus STOutput           -> "output bus"+    TBus STGeneric          -> "bus"+    TTypedBus STInput t _   -> t ++ " input bus"+    TTypedBus STOutput t _  -> t ++ " output bus"+    TTypedBus STGeneric t _ -> t ++ " bus"+    TEnum t _               -> t+    TNumber                 -> "numerical"+    TBoolean                -> "boolean"+    TLtl                    -> "ltl"+    TPattern                -> "pattern"+    TPoly y                 -> "a" ++ show y+    TSet y                  -> show y ++ " set"++-----------------------------------------------------------------------------
+ src/Detection.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Detection+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Detection of different fragements of LTL+--+-----------------------------------------------------------------------------++module Detection+  ( GRFormula(..)+  , Refusal+  , detectGR+  , checkGR+  ) where++-----------------------------------------------------------------------------++import Detection.GeneralizedReactivity+  ( GRFormula(..)+  , Refusal+  , detectGR+  , checkGR+  )++-----------------------------------------------------------------------------
+ src/Detection/GeneralizedReactivity.hs view
@@ -0,0 +1,969 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Detection.GeneralizedReactivity+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Detect whether a specification belongs to the Generalized+-- Reactivity fragment or not.+--+-----------------------------------------------------------------------------++module Detection.GeneralizedReactivity+  ( GRFormula(..)+  , Refusal+  , detectGR+  , checkGR+  ) where++-----------------------------------------------------------------------------++import Simplify+  ( simplify+  )++import Config+  ( Configuration(..)+  , defaultCfg+  )++import Data.Specification+  ( Specification(..)+  )++import Data.Either+  ( partitionEithers+  )++import Data.List+  ( sortBy+  , partition+  , sort+  , find+  )++import Data.Types+  ( Semantics(..)+  )++import Data.Function+  ( on+  )++import Control.Monad+  ( unless+  )++import Utils+  ( strictSort+  , bucketSort+  )++import Data.LTL+  ( Atomic(..)+  , Formula(..)+  , fmlOutputs+  , subFormulas+  , isBooleanFormula+  , isBooleanNextFormula+  , simplePrint+  , applySub+  , fFinally+  , fGlobally+  , fNot+  , fAnd+  , fOr+  )++import Data.Error+  ( Error+  )++import Writer.Eval+  ( eval+  )++import Writer.Utils+  ( merge+  )++import Control.Exception+  ( assert+  )++-----------------------------------------------------------------------------++import qualified Data.Map.Strict as M++-----------------------------------------------------------------------------++-- | Type of the data structure describing the refusal.++type Refusal = String++-----------------------------------------------------------------------------++-- | Structure representing a Generalized Reactivity formula.++data GRFormula =+  GRFormula+  { level :: Int+  , initEnv :: [Formula]+  , initSys :: [Formula]+  , assertEnv :: [Formula]+  , assertSys :: [Formula]+  , liveness :: [([Formula],[Formula])]+  } deriving (Show)++-----------------------------------------------------------------------------++data TFml =+    TTTrue+  | TFFalse+  | TAtomic Int+  | TAnd [TFml]+  | TOr [TFml]+  deriving (Ord, Eq, Show)++-----------------------------------------------------------------------------++-- | Checks whether a given specification is in the Generalized+-- Reactivity fragment. If this is the case, the reactivity level is+-- returned. Otherwise, the check returns "@-1@".++checkGR+  :: Specification -> Either Error Int++checkGR s = case detectGR defaultCfg s of+  Right fml -> return $ level fml+  Left x    -> case x of+    Left err -> Left err+    Right _  -> return (-1)++-----------------------------------------------------------------------------++-- | Detect whether a given specification belongs to the GR+-- fragment of LTL. If so, a 'GRFormula' is returned. Otherwise,+-- either an error occured, or the formula is not in the GR) fragment+-- such that the reason for the refusal is returned.++detectGR+  :: Configuration -> Specification -> Either (Either Error Refusal) GRFormula++detectGR c s = do+  let+    c' = c {+      simplifyStrong = False,+      noDerived = False,+      noWeak = True,+      noFinally = False,+      noGlobally = False,+      pushGlobally = False,+      pushFinally = False,+      pushNext = True,+      pullFinally = True,+      pullGlobally = True,+      pullNext = False,+      noRelease = True,+      owSemantics = case semantics s of+        SemanticsStrictMoore -> Just SemanticsStrictMealy+        SemanticsMoore       -> Just SemanticsMealy+        _                    -> Nothing+      }++    strict = semantics s `elem` [SemanticsStrictMealy, SemanticsStrictMoore]++  case eval' c' s of+    Left x                    -> Left $ Left x+    Right y -> case quickCheckGR strict y of+      Just f  -> return f+      Nothing ->+        let+          fml = do+            let c'' = c' {+                  negNormalForm = True,+                  simplifyWeak = True+                  }++            (es,ss,rs,as,is,gs) <- eval c'' s+            fml' <- merge es ss rs as is gs+            simplify c'' $ noImplication $ noEquivalence fml'++        in case fml of+          Left x  -> Left $ Left x+          Right x -> case transformToGR strict x of+            Left z  -> Left $ Right z+            Right z -> return z++  where+    eval' x y = do+      (es,ss,rs,as,is,gs) <- eval x y+      es' <- mapM (simplify x) es+      ss' <- mapM (simplify x) ss+      rs' <- mapM (simplify x) rs+      as' <- mapM (simplify x) as+      is' <- mapM (simplify x) is+      gs' <- mapM (simplify x) gs++      return (es',ss',rs',as',is',gs')++    noImplication fml = case fml of+      Implies x y -> let+          x' = noImplication x+          y' = noImplication y+        in+          Or [Not x', y']+      _           ->+        applySub noImplication fml++    noEquivalence fml = case fml of+      Equiv x y -> let+          x' = noEquivalence x+          y' = noEquivalence y+        in+          And [Implies x' y', Implies y' x']+      _         ->+        applySub noEquivalence fml++-----------------------------------------------------------------------------++-- | Transforms an evaluated, but not combined list of formula to GR,+-- if possible.++quickCheckGR+  :: Bool -> ([Formula],[Formula],[Formula],[Formula],[Formula],[Formula])+  -> Maybe GRFormula++quickCheckGR strict (es,ss,rs,as,is,gs) = do+  mapM_ boolIn es+  mapM_ boolFml ss++  let+    rs'' = case pullG $ fAnd $ concatMap pullG rs of+      Globally (And xs) : ys -> xs ++ ys+      Globally x : ys        -> x : ys+      zs                     -> zs++    (rs',as') = case pullG $ fAnd $ concatMap pullG as of+      Globally (And xs) : ys ->+        let (ls,os) = partitionEithers $ map boolNextInE xs+        in (rs'' ++ ls, map Globally os ++ ys)+      Globally x : ys -> case boolNextIn x of+        Just ()  -> (x:rs'',ys)+        Nothing -> (rs'', Globally x : ys)+      zs                     -> (rs'',zs)++  case as' of+    [] -> do+      mapM_ boolNextIn rs'++      let+        is'' = case pullG $ fAnd $ concatMap pullG is of+          Globally (And xs) : ys -> xs ++ ys+          Globally x : ys        -> x : ys+          zs                     -> zs++        (is',gs') = case pullG $ fAnd $ concatMap pullG gs of+          Globally (And xs) : ys ->+            let (ls,os) = partitionEithers $ map boolNextFmlE xs+            in (is'' ++ ls, map Globally os ++ ys)+          Globally x : ys -> case boolNextFml x of+            Just ()  -> (x:is'',ys)+            Nothing -> (is'', Globally x : ys)+          zs                     -> (is'',zs)++      mapM_ boolNextFml is'++      case separateStandardLiveness $+           noImplEquiv $ fAnd gs' of+        Right (ls,[]) -> return+          GRFormula+            { level = length ls+            , initEnv = es+            , initSys = ss+            , assertEnv = rs'+            , assertSys = is'+            , liveness = ls+            }+        _             -> Nothing++    _  -> do+      unless strict Nothing++      mapM_ boolNextIn rs'++      let is' = case pullG $ fAnd $ concatMap pullG is of+            Globally (And xs) : ys -> xs ++ ys+            Globally x : ys        -> x : ys+            zs                     -> zs++      mapM_ boolNextFml is'++      case separateStandardLiveness $+           noImplEquiv $ Implies (fAnd as') (fAnd gs) of+        Right ([x],[]) -> return+          GRFormula+            { level = 1+            , initEnv = es+            , initSys = ss+            , assertEnv = rs'+            , assertSys = is'+            , liveness = [x]+            }+        _            -> Nothing++  where+    boolIn fml = case fml of+      TTrue            -> return ()+      FFalse           -> return ()+      Atomic (Input _) -> return ()+      Not x            -> boolIn x+      And xs           -> mapM_ boolIn xs+      Or xs            -> mapM_ boolIn xs+      Implies x y      -> mapM_ boolIn [x,y]+      Equiv x y        -> mapM_ boolIn [x,y]+      _                -> Nothing++    boolFml fml = case fml of+      TTrue       -> return ()+      FFalse      -> return ()+      Atomic _    -> return ()+      Not x       -> boolFml x+      And xs      -> mapM_ boolFml xs+      Or xs       -> mapM_ boolFml xs+      Implies x y -> mapM_ boolFml [x,y]+      Equiv x y   -> mapM_ boolFml [x,y]+      _           -> Nothing++    boolNextIn fml = case fml of+      TTrue             -> return ()+      FFalse            -> return ()+      Atomic _          -> return ()+      Not x             -> boolNextIn x+      And xs            -> mapM_ boolNextIn xs+      Or xs             -> mapM_ boolNextIn xs+      Implies x y       -> mapM_ boolNextIn [x,y]+      Equiv x y         -> mapM_ boolNextIn [x,y]+      Next x            -> boolIn x+      _                 -> Nothing++    boolNextInE fml = case boolNextIn fml of+      Just ()  -> Left fml+      Nothing -> Right fml++    boolNextFml fml = case fml of+      TTrue       -> return ()+      FFalse      -> return ()+      Atomic _    -> return ()+      Not x       -> boolNextFml x+      And xs      -> mapM_ boolNextFml xs+      Or xs       -> mapM_ boolNextFml xs+      Implies x y -> mapM_ boolNextFml [x,y]+      Equiv x y   -> mapM_ boolNextFml [x,y]+      Next x      -> boolFml x+      _           -> Nothing++    noImplEquiv fml = case fml of+      TTrue             -> fml+      FFalse            -> fml+      Atomic _          -> fml+      And xs            -> fAnd $ map noImplEquiv xs+      Or xs             -> fOr $ map noImplEquiv xs+      Implies x y       -> fOr [fNot (noImplEquiv x), noImplEquiv y]+      Equiv x y         ->+        let x' = noImplEquiv x+            y' = noImplEquiv y+        in fOr [fAnd [x',y'], fAnd [fNot x', fNot y']]+      _                 -> fml+++    boolNextFmlE fml = case boolNextFml fml of+      Just ()  -> Left fml+      Nothing -> Right fml++    pullG f = case f of+      And xs -> let+          ys = concatMap pullG xs+          (zs,os) = partitionEithers $ map isG ys+        in+          Globally (And zs) : os+      _ -> [f]++    isG f = case f of+      Globally x -> case isG x of+        Left y  -> Left y+        Right y -> Left y+      _          -> Right f+++-----------------------------------------------------------------------------++-- | Transforms an "evaluated" formula to GR, if possible. If it is+-- not possible, the reason for the refusal is returend.++transformToGR+  :: Bool -> Formula -> Either Refusal GRFormula++transformToGR strict fml = do+  -- check that there is no until formula+  noUntil fml+  -- check that there is no next formula on the initial level+  noDirectNext fml+  -- turn the first boolean level of the formula into CNF+  let xs = firstLevelCNF $ pullTogether fml+  -- separate the initial constraints1+  (is,ps,ys) <- separateInitials xs+  -- separate the requirements+  (fs,fr) <- separateRequirements is $ fAnd $ map fOr ys+  -- separate remaining sub-formulas+  (gs,ls,rs) <-+    if strict+    then case separateStandard fr of+      Right (a,b,[]) -> return (a,b,[])+      _              -> separateStrict fr+    else separateStandard fr++  case rs of+    [] -> return+      GRFormula+        { level = length ls+        , initEnv = is+        , initSys = ps+        , assertEnv = fs+        , assertSys = gs+        , liveness = ls+        }++    _  -> errIncompatible $ map fOr rs++-----------------------------------------------------------------------------++separateStrict+  :: Formula+  -> Either Refusal ([Formula],[([Formula],[Formula])],[[Formula]])++separateStrict fml = let+    -- convert to DNF+    xs = firstLevelDNF $ pullTogether fml+    -- pull globally formulas outwards+    ys = map (pullG . fAnd) xs+    -- ckassify the different elements+    (c1,c2,c3,xr) = foldl classify ([],[],[],[]) ys+  in do+    (gs,ff) <- case c3 of+      []  -> case c2 of+        [] -> return ([],fOr (map (Finally . Globally) c1 ++ map fAnd xr))+        _  -> errIncompatible $+               map (\(x,y) -> fAnd [Finally (Globally x), Globally y]) c2+      [x] -> let+          cs = firstLevelCNF $ fOr $ pullF x+          (fs,zs) = partitionEithers $ map isFL cs+        in if null xr then+             case find ((sort zs /=) . sort . firstLevelCNF . snd) c2 of+               Nothing ->+                 return (map fOr zs,+                         fOr (map (Finally . Globally) (c1 ++ map fst c2) +++                              map (Globally . Finally) fs))+               Just r  -> errIncompatible [+                           fAnd $ map fOr zs,+                           fAnd $ map fOr $ firstLevelCNF $ snd r+                           ]+           else+             errIncompatible $ map fOr xr+      _   -> assert False undefined+    (ls,rs) <- separateStandardLiveness ff+    return (gs,ls,rs)+++  where+    pullG f = case f of+      And xs -> let+          ys = concatMap pullG xs+          (gs,rs) = partitionEithers $ map isG ys+        in+          Globally (And gs) : rs+      _ -> [f]++    isG f = case f of+      Globally x -> Left x+      _          -> Right f++    pullF f = case f of+      Or xs -> let+          ys = concatMap pullF xs+          (fs,rs) = partitionEithers $ map isF ys+        in+          Finally (Or fs) : rs+      _ -> [f]++    isF f = case f of+      Finally x -> Left x+      _          -> Right f++    isFL fs = case fs of+      [Finally x] -> Left x+      _           -> Right fs++    classify (a,b,c,d) xs = case xs of+      [Finally (Globally x)]             -> (x:a,b,c,d)+      [Finally (Globally x), Globally y] -> (a,(x,y):b,c,d)+      [Globally y, Finally (Globally x)] -> (a,(x,y):b,c,d)+      [Globally x]                       -> (a,b,x:c,d)+      _                                  -> (a,b,c,xs:d)++-----------------------------------------------------------------------------++-- | Separation of the invariants and the lifeness constraints under+-- standard semantics.++separateStandard+  :: Formula+  -> Either Refusal ([Formula],[([Formula],[Formula])],[[Formula]])++separateStandard fml = do+  -- convert to CNF+  let xs = firstLevelCNF $ pullTogether fml+  -- separate singleton globally formulas+  (cG,ys) <- separateGlobally xs+  -- check for boolean sub-formulas+  let (gs,lg) = partition isBooleanNextFormula cG+  -- separate the liveness constriants+  (ls,rs) <- separateStandardLiveness $ fAnd $ map fOr $+              ys ++ map ((: []) . fGlobally) lg+  -- return all sub-formulas+  return (gs,ls,rs)++-----------------------------------------------------------------------------++-- | Check that there is no unil operator inside the formula.++noUntil+  :: Formula -> Either Refusal ()++noUntil fml = case fml of+  TTrue      -> return ()+  FFalse     -> return ()+  Atomic {}  -> return ()+  Until {}   -> Left $+    "Generalized Reactivity does not allow until sub-formulas:\n"+    ++ "  " ++ simplePrint fml+  Release {} -> assert False undefined+  Weak {}    -> assert False undefined+  _          -> mapM_ noUntil $ subFormulas fml++-----------------------------------------------------------------------------++-- | Check that there is no next operator not guraded by some finally+-- or globally operator.++noDirectNext+  :: Formula -> Either Refusal ()++noDirectNext fml = case fml of+  TTrue       -> return ()+  FFalse      -> return ()+  Atomic {}   -> return ()+  Globally {} -> return ()+  Finally {}  -> return ()+  Next {}     -> Left $+    "GeneralizedReactivity does not allow next sub-formulas on the initial level:\n"+    ++ "  " ++ simplePrint fml+  _           -> mapM_ noDirectNext $ subFormulas fml++-----------------------------------------------------------------------------++-- | Separate the non-temproal fragment of a formula from the temporal+-- one, where the first boolean level of the formula is either given+-- in DNF or CNF.++separateBoolean+  :: [[Formula]] -> Either Refusal ([[Formula]],[[Formula]])++separateBoolean = return . partition (all isBooleanFormula)++-----------------------------------------------------------------------------++-- | Separate Globally sub-formulas from the formula, given in CNF or DNF.++separateGlobally+  :: [[Formula]] -> Either Refusal ([Formula],[[Formula]])++separateGlobally xs = do+  let (a,b) = partitionEithers $ map separateFormula xs+  return (concat a, b)++  where+    separateFormula ys = case ys of+      [Globally (And zs)] -> Left  zs+      [Globally x]        -> Left [x]+      _                   -> Right ys++-----------------------------------------------------------------------------++-- | Separate Finally sub-formulas from the formula, given in CNF or DNF.++separateFinally+  :: [[Formula]] -> Either Refusal ([Formula],[[Formula]])++separateFinally xs = do+  let (a,b) = partitionEithers $ map separateFml xs+  return (concat a, b)++  where+    separateFml ys = case ys of+      [Finally (Or zs)] -> Left  zs+      [Finally x]       -> Left [x]+      _                 -> Right ys++-----------------------------------------------------------------------------++-- | Separate the initial constraints from the formula.++separateInitials+  :: [[Formula]] -> Either Refusal ([Formula],[Formula],[[Formula]])++separateInitials xs = do+  -- separate the boolean fragment+  (bs,rs) <- separateBoolean xs+  -- convert into DNF+  let ys = firstLevelDNF $ pullTogether $ fAnd $ map fOr bs+  -- separate formulas over inputs from the remaining ones+  let (is,ps) = partitionEithers $ map pureInputFml ys+  -- convert to Generalize Reactivity format+  return (map fNot is, ps, rs)++  where+    pureInputFml ys =+      if null $ fmlOutputs $ fOr ys+      then Left $ fAnd ys+      else Right $ fAnd ys++-----------------------------------------------------------------------------++-- | Separates the requirements from the formula and checks the+-- consisitency of the initial conditions.++separateRequirements+  :: [Formula] -> Formula+  -> Either Refusal ([Formula], Formula)++separateRequirements is fml = do+  -- convert formulas to DNF+  let ys = firstLevelDNF $ pullTogether fml+  -- separate the boolean fragment+  (bs,ns) <- separateBoolean ys+  -- check for compatibility+  unless (map (fNot . fAnd) bs == is) $ Left $+    "The initial constraints cannot be refined to fit into the "+    ++ "Generalized Reactivity format."+  -- separate singleton finally formulas+  (cF,fr) <- separateFinally ns+  -- check for boolean sub-formulas+  let (fs,lf) = partition isBooleanNextFormula cF+  -- check for inputs under next+  mapM_ checkInputsUnderNext fs+  -- return the result+  return (map fNot fs, fOr $ map fAnd fr ++ map fFinally lf)++  where+    checkInputsUnderNext f = case f of+      Next x ->+        unless (null $ fmlOutputs x) $ Left $+          "GeneralizedReactivity does not allow to constraint "+          ++ "outputs under a transition target of "+          ++ "the environment:\n"+          ++ "  " ++ simplePrint f+      _      -> mapM_ checkInputsUnderNext $ subFormulas f+++-----------------------------------------------------------------------------++-- | Separate the GR liveness condition form the formula.++separateStandardLiveness+  :: Formula -> Either Refusal ([([Formula],[Formula])],[[Formula]])++separateStandardLiveness fml =+  let+    -- ensure that we have no messed up formula+    ys = firstLevelCNF $ pullTogether fml+    -- check each separate disjunct+    (zs,rs) = partitionEithers $ map classify ys+    -- sort on the first component+    zs' = sortBy (compare `on` fst) zs+    -- join them+    ls = foldl join [] zs'+  in+    return (ls, rs)++  where+    -- join common prefices+    join [] (fs,gs) = [(fs,gs)]+    join ((fs,gs):rs) (fs',gs')+      | fs == fs'  = (fs,gs ++ gs'):rs+      | otherwise = (fs',gs'):(fs,gs):rs++    -- classify all sub-formulas that fit into the GR format+    classify ys+      | not (all isFGB ys) = Right ys+      | otherwise        =+        let (a,b) = partitionEithers $ map sepFG ys+        in Left (strictSort a, strictSort b)++    isFGB formula = case formula of+      Finally (Globally f) -> isBooleanFormula f+      Globally (Finally f) -> isBooleanFormula f+      _                    -> False++    sepFG formula = case formula of+      Finally (Globally f) -> Left $ fNot f+      Globally (Finally f) -> Right f+      _                    -> assert False undefined++-----------------------------------------------------------------------------++-- | Moves finally operators and globally operators inside the formula+-- closer together, i.e., operators of the first level are pushed inside,+-- while operators of the second level are pulled outwards.++pullTogether+  :: Formula -> Formula++pullTogether formula = case formula of+  Globally (And ys) -> fAnd $ map (pullTogether . fGlobally) ys+  Globally f        -> fGlobally $ pullUp f+  Finally (Or ys)   -> fOr $ map (pullTogether . fFinally) ys+  Finally f         -> fFinally $ pullUp f+  _                 -> applySub pullTogether formula++  where+    pullUp fml = case fml of+      And []  -> TTrue+      And [y] -> pullUp y+      And ys  ->+        let zs = map pullUp ys+        in if all isGlobally zs+           then fGlobally $ fAnd $ map rmG zs+           else fAnd zs+      Or []   -> FFalse+      Or [y]  -> pullUp y+      Or ys   ->+        let zs = map pullUp ys+        in if all isFinally zs+           then fFinally $ fOr $ map rmF zs+           else fOr zs+      _       -> applySub pullUp fml++    isGlobally fml = case fml of+      Globally _ -> True+      _          -> False++    isFinally fml = case fml of+      Finally _ -> True+      _         -> False++    rmG fml = case fml of+      Globally f -> f+      _          -> fml++    rmF fml = case fml of+      Finally f -> f+      _         -> fml++-----------------------------------------------------------------------------++-- | Turns the boolean formula of the first level not containing any+-- temporal operators into DNF. The result is returned as a list of+-- cubes, each consisting of a list of literals, i.e., formulas+-- guarded by a temporal operator.++firstLevelDNF+  :: Formula -> [[Formula]]++firstLevelDNF = firstLevelCNF . swapAndOr++  where+    -- swaps conjunctions and disjunctions on the first, temporal+    -- operator free level.+    swapAndOr f = case f of+      And xs -> Or $ map swapAndOr xs+      Or xs  -> And $ map swapAndOr xs+      _      -> f++-----------------------------------------------------------------------------++-- | Turns the boolean formula of the first level not containing any+-- temporal operators into CNF. The result is returned as a list of+-- clauses, each consisting of a list of literals, i.e., formulas+-- guarded by a temporal operator.++firstLevelCNF+  :: Formula -> [[Formula]]++firstLevelCNF formula =+  let+    ys = levelOneAtoms [] formula+    (mm,bb,_) = foldl f (M.empty, M.empty, 0 :: Int) ys+    f (m,b,i) x = case M.lookup x m of+      Just _ -> (m,b,i)+      Nothing -> case M.lookup (fNot x) m of+        Just i' -> (M.insert x (i'+1) m,M.insert (i'+1) x b, i)+        Nothing -> (M.insert x (2*i) m, M.insert (2*i) x b, i+2)+    fml' = replaceLevelOneAtoms mm formula+  in+    map (map (bb M.!)) $ fCNF fml'++  where+    replaceLevelOneAtoms mm fml = case fml of+      TTrue           -> TTTrue+      FFalse          -> TFFalse+      Atomic {}       -> TAtomic $ mm M.! fml+      Not (Atomic {}) -> TAtomic $ mm M.! fml+      Next {}         -> TAtomic $ mm M.! fml+      Finally {}      -> TAtomic $ mm M.! fml+      Globally {}     -> TAtomic $ mm M.! fml+      And xs          -> TAnd $ map (replaceLevelOneAtoms mm) xs+      Or xs           -> TOr $ map (replaceLevelOneAtoms mm) xs+      _               -> assert False undefined++    levelOneAtoms a fml = case fml of+      TTrue           -> a+      FFalse          -> a+      Atomic {}       -> fml : a+      Not (Atomic {}) -> fml : a+      Next {}         -> fml : a+      Finally {}      -> fml : a+      Globally {}     -> fml : a+      And xs          -> foldl levelOneAtoms a xs+      Or xs           -> foldl levelOneAtoms a xs+      _               -> assert False undefined++    fCNF fml =+      strictSort $ map strictSort $+      case alreadyCNF $ warp fml of+        Left (us,ps) -> ps ++ concatMap toCNF us+        Right x      -> x++    -- turns non-CNF sub-formulas into CNF+    toCNF (us,ds) = swap $ map (map (ds ++) . fCNF) us++    -- swap and/or alternation in the boolean formula tree++    swap (x:xr) = foldl joinFml x xr+    swap []     = assert False undefined++    joinFml b = simpleFml . concatMap (\zs -> map (zs ++) b)++    simpleFml = filterSupSets . map filternegations++    filternegations = filternegations' [] . bucketSort+    filternegations' a xs = case xs of+      (x : y : xr)+        | x + 1 == y -> []+        | otherwise -> filternegations' (x : a) (y : xr)+      (x : xr) -> filternegations' (x : a) xr+      [] -> reverse a++    -- checks wether the formula is already in CNF and converts+    -- to the list representation, if in CNF. Otherwise the+    -- literals of the clauses not in CNF are separated for the+    -- later conversion+    alreadyCNF fml = case fml of+      TTTrue    -> Right []+      TFFalse   -> Right [[]]+      TAtomic x -> Right [[x]]+      TAnd xs   -> case partitionEithers $ map pureOr xs of+        ([],zs) -> Right zs+        (ys,zs) -> Left (ys,zs)+      TOr {}    -> alreadyCNF $ TAnd [fml]++    -- separates pure disjunctions of a formula+    pureOr fml = case fml of+      TOr xs    -> case partitionEithers $ map pure xs of+        ([],zs) -> Right zs+        (ys,zs) -> Left (ys,zs)+      TAtomic x -> Right [x]+      _         -> assert False undefined++    -- separates conjunctions of a formula+    pure fml = case fml of+      TAnd {}   -> Left fml+      TAtomic x -> Right x+      _         -> assert False undefined++    -- merge all two level And and Or+    warp fml = case fml of+      TAnd []  -> TTTrue+      TAnd [x] -> warp x+      TAnd xs+        | TFFalse `elem` xs -> TFFalse+        | otherwise         -> case filter (/= TTTrue) xs of+          []  -> TTTrue+          [x] -> warp x+          ys  -> TAnd $ warpAnd $ map warp ys+      TOr []   -> TFFalse+      TOr [x]  -> warp x+      TOr xs+        | TTTrue `elem` xs -> TTTrue+        | otherwise        -> case filter (/= TFFalse) xs of+          []  -> TFFalse+          [x] -> warp x+          ys  -> TOr $ warpOr $ map warp ys+      _        -> fml++    -- merge two level And+    warpAnd = concatMap wAnd+    wAnd fml = case fml of+      TAnd x -> x+      _      -> [fml]++    -- merge two level Or+    warpOr = concatMap wOr+    wOr fml = case fml of+      TOr x -> x+      _     -> [fml]++-----------------------------------------------------------------------------++-- | Removes sets from a set of sets of integers (sets are represented+-- as lists), that are a superset of some other set in the set.++filterSupSets+  :: [[Int]] -> [[Int]]++filterSupSets xs =+  let ys = sortBy (compare `on` length) xs+  in filtersets [] ys++  where+    filtersets a [] = a+    filtersets a ([]:xr) =+      filtersets a xr+    filtersets a (x:xr) =+      filtersets (x:a) (rmsup x [] xr)++    rmsup _ a [] = reverse a+    rmsup x a (y:yr)+      | subset x y  = rmsup x a yr+      | otherwise   = rmsup x (y:a) yr++    subset x y = null $ foldl eatup x y++    eatup [] _ = []+    eatup (x:xr) y+      | x == y     = xr+      | otherwise = x:xr++-----------------------------------------------------------------------------++-- | Returns an error listing all incompatible sub-formulas.++errIncompatible+  :: [Formula] -> Either Refusal a++errIncompatible xs =+  Left $ "The following sub-formulas cannot be refined "+         ++ "to fit the GeneralizedReactivity requirements:"+         ++ concatMap (\x -> "\n  * " ++ simplePrint x) xs++-----------------------------------------------------------------------------
+ src/Info.hs view
@@ -0,0 +1,736 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Info+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Several printers to report information back to the user.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , MultiParamTypeClasses+  , TypeSynonymInstances+  , FlexibleContexts++  #-}++-----------------------------------------------------------------------------++module Info+  ( prTitle+  , prDescription+  , prSemantics+  , prTarget+  , prTags+  , prInfo+  , prParameters+  , prInputs+  , prOutputs+  , prVersion+  , prHelp+  , prReadme+  , prReadmeMd+  , prError+  ) where++-----------------------------------------------------------------------------++import Syfco+  ( Configuration(..)+  , Semantics(..)+  , Target(..)+  , WriteFormat(..)+  , WriteMode(..)+  , Specification+  , defaultCfg+  , title+  , description+  , semantics+  , target+  , tags+  , parameters+  , inputs+  , outputs+  , version+  )++import Data.Convertible+  ( Convertible+  , convert+  )++import Data.Array+  ( (!)+  )++import Control.Monad+  ( unless+  )++import System.Exit+  ( exitFailure+  )++import System.IO+  ( hPutStrLn+  , stderr+  )++-----------------------------------------------------------------------------++data Mode = Plain | Help | Markdown++-----------------------------------------------------------------------------++-- | Prints the title of the given specification.++prTitle+  :: Specification -> IO ()++prTitle s =+  putStrLn $ title s++-----------------------------------------------------------------------------++-- | Prints the description of the given specification.++prDescription+  :: Specification -> IO ()++prDescription s =+  putStrLn $ description s++-----------------------------------------------------------------------------++-- | Prints the semantics of the given specification.++prSemantics+  :: Specification -> IO ()++prSemantics s =+  putStrLn $ case semantics s of+    SemanticsMealy -> "Mealy"+    SemanticsMoore -> "Moore"+    SemanticsStrictMealy -> "Strict,Mealy"+    SemanticsStrictMoore -> "Strict,Moore"++-----------------------------------------------------------------------------++-- | Prints the target of the given specification.++prTarget+  :: Specification -> IO ()++prTarget s =+  putStrLn $ case target s of+    TargetMealy -> "Mealy"+    TargetMoore -> "Moore"++-----------------------------------------------------------------------------++-- | Prints the tag list of the given specification.++prTags+  :: Specification -> IO ()++prTags s = case tags s of+  [] -> return ()+  xs -> putStrLn $ head xs ++ concatMap ((:) ' ' . (:) ',') (tail xs)++-----------------------------------------------------------------------------++-- | Prints the parameters of the given specification.++prParameters+  :: Specification -> IO ()++prParameters s = putStrLn $ case parameters s of+  (x:xr) -> x ++ concatMap ((:) ',' . (:) ' ') xr+  []     -> ""++-----------------------------------------------------------------------------++-- | Prints the input signals of the given specification.++prInputs+  :: Configuration -> Specification -> IO ()++prInputs c s = case inputs c s of+  Left err     -> prError $ show err+  Right (x:xr) -> putStrLn $ x ++ concatMap ((:) ',' . (:) ' ') xr+  _            -> return ()++-----------------------------------------------------------------------------++-- | Prints the output signals of the given specification.++prOutputs+  :: Configuration -> Specification -> IO ()++prOutputs c s = case outputs c s of+  Left err     -> prError $ show err+  Right (x:xr) -> putStrLn $ x ++ concatMap ((:) ',' . (:) ' ') xr+  _            -> return ()++-----------------------------------------------------------------------------++-- | Prints the complete INFO section of the given specification.++prInfo+  :: Specification -> IO ()++prInfo s = do+  putStrLn $ "Title:         \"" ++ title s ++ "\""+  putStrLn $ "Description:   \"" ++ description s ++ "\""+  putStr "Semantics:     "+  prSemantics s+  putStr "Target:        "+  prTarget s+  unless (null $ tags s) $ do+    putStr "Tags:          "+    prTags s++-----------------------------------------------------------------------------++-- | Prints the version and the program name.++prVersion+  :: IO ()++prVersion = do+  putStrLn $ "SyFCo (v" ++ version ++ ")"+  putStrLn "The Synthesis Format Converter"++-----------------------------------------------------------------------------++-- | Prints the help of the program.++prHelp+  :: IO ()++prHelp = putStr $ usage Help++-----------------------------------------------------------------------------++-- | Prints the content of the README file.++prReadme+  :: IO ()++prReadme = putStr $ readme Plain++-----------------------------------------------------------------------------++-- | Prints the content of the README.md file.++prReadmeMd+  :: IO ()++prReadmeMd = putStr $ readme Markdown++-----------------------------------------------------------------------------++usage+  :: Mode -> String++usage m =+  unlines $+    [ switch "## Usage\n\n" "Usage: " "## Usage\n\n" +++      code m ("syfco [OPTIONS]... <file>") +++      switch "\n" ("\n\nA Synthesis Format Converter to read and " +++                   "transform Temporal Logic\nSpecification Format " +++                   "(TLSF) files.") "" ] +++    section "File Operations" (prTable foTable) +++    section "File Modifications" (prTable fmTable) +++    section ("Formula Transformations " +++             "(disabled by default)") (prTable ftTable) +++    section "Check Specification Type (and exit)" (prTable csTable) +++    section "Extract Information (and exit)" (prTable eiTable) +++    section "Sample Usage" sample++  where+    idl (s1,s2,_,_) = length s1 + length s2 + 7++    len = foldl max 0 $+      [ foldl max 0 $ map idl foTable+      , foldl max 0 $ map idl fmTable+      , foldl max 0 $ map idl ftTable+      , foldl max 0 $ map idl csTable+      , foldl max 0 $ map idl eiTable ]++    switch s1 s2 s3 = case m of+      Plain    -> s1+      Help     -> s2+      Markdown -> s3++    section h xs = [ "", ind ++ h ++ ":", "" ] ++ xs++    ind = case m of+      Plain    -> "### "+      Help     -> ""+      Markdown -> "#### "++    wrap str = case m of+      Markdown -> code m str+      _        -> "`" ++ str ++ "`"++    sample = [ codeblock m $ map (("syfco ") ++)+      [ "-o converted -f promela -m fully -nnf -nd file.tlsf"+      , "-f psl -op n=3 -os Strict,Mealy -o converted file.tlsf"+      , "-o converted -in"+      , "-t file.tlsf" ] ]++    prTable xs =+      let xs' =+            map (\(x,y,z,vs) ->+                (x,y,adaptsub (80 - len - 3) z,+                 adapt (80 - len - 3) vs)) xs+      in case m of+        Markdown ->+          [ "|Command|Description|"+          , "|-------|-----------|" ]+          ++ map prMRow (filter (\(s,_,_,_) -> not $ null s) xs')+        _        ->+          concatMap prRow xs'++    adaptsub l c = case c of+      Nothing -> Nothing+      Just xs -> Just $ map (\(a,b,c) -> (a,b,adapt l c)) xs++    adapt+      :: Int -> [String] -> [String]++    adapt l xs = concatMap (adapt' l) xs++    adapt' l str+      | length str <= l = [str]+      | otherwise      = case m of+        Markdown -> [str]+        _        -> rearrange l [] [] 0 $ words str++    rearrange l a b n [] =+      reverse ((unwords $ reverse b):a)+    rearrange l a [] _ (x:xr)+      | length x > l = rearrange l (x:a) [] 0 xr+      | otherwise    = rearrange l a [x] (length x) xr+    rearrange l a b n (x:xr)+      | n + length x + 1 > l =+        rearrange l ((unwords $ reverse b):a) [x] (length x) xr+      | otherwise =  rearrange l a (x:b) (n + length x + 1) xr++    prMRow (short,long,sub,desc) =+      "|" ++ code m ("-" ++ short ++ ", --" ++ long) ++ "|" +++      ( case desc of+           []   -> ""+           x:xr -> concat (x : map ("</br> " ++) xr) +++                  case sub of+                    Nothing -> ""+                    Just ys -> "</br> <table><tbody> " +++                              concatMap prMSub ys +++                              " </tbody></table>"+      ) ++ "|"++    prMSub (name,d,desc) =+      "<tr><td>" ++ code m name +++      "</td><td>" ++ concat (addbreaks desc) +++      (if d then " (default)" else "") +++      "</td></tr>"++    addbreaks xs = case xs of+      []   -> []+      x:xr -> x : map ("</br>" ++) xr++    prRow (short,long,sub,desc)+      | short == "" = [ "" ]+      | otherwise  = case desc of+        []   ->+          prRow (short,long,sub,[""])+        x:xr ->+          ( ( "  -" ++ short ++ ", --" ++ long +++              replicate (len - (length short + length long + 7)) ' '+              ++ " : " ++ x)+            : ( [ replicate (len + 3) ' ' ++ y | y <- xr ] +++                (case sub of+                    Nothing -> []+                    Just ys -> [""] ++ concatMap prSub ys ++ [""] ) ) )++    prSub (n,d,desc) = case desc of+      []   -> prSub (n,d,[""])+      x:xr ->+        ("    * " ++ n +++         (if d then+            " [default]" ++ replicate (len - 16 - length n) ' '+          else+            replicate (len - 6 - length n) ' ') +++         " : " ++ x) :+        map ((replicate (len+3) ' ') ++) xr++    foTable =+      [ ("o", "output", Nothing,+         [ "path of the output file (results are printed " +++           "to STDOUT if not set)" ])+      , ("r", "read-config", Nothing,+         [ "read parameters from the given configuration file (may " +++           "overwrite prior arguments)" ])+      , ("w", "write-config", Nothing,+         [ "write the current configuration to the given path " +++           "(includes later arguments)" ])+      , ("f", "format", Just formats,+         [ "output format - possible values are:" ])+      , ("m", "mode", Just modes,+         [ "output mode - possible values are:" ])+      , ("pf", "part-file", Nothing,+         [ "create a partitioning (" ++ code m ".part" ++ ") file" ])+      , ("bd", "bus-delimiter", Nothing,+         [ "delimiter used to print indexed bus signals",+           "(default: "++ wrap (busDelimiter defaultCfg) ++ ")" ])+      , ("ps", "prime-symbol", Nothing,+         [ "symbol/string denoting primes in signals",+           "(default: " ++ wrap (primeSymbol defaultCfg) ++ ")" ])+      , ("as", "at-symbol", Nothing,+         [ "symbol/string denoting @-symbols in signals",+           "(default: " ++ wrap (atSymbol defaultCfg) ++ ")" ])+      , ("in", "stdin", Nothing,+         [ "read the input file from STDIN" ]) ]++    fmTable =+      [ ("os", "overwrite-semantics", Nothing,+         [ "overwrite the semantics of the file" ])+      , ("ot", "overwrite-target", Nothing,+         [ "overwrite the target of the file" ])+      , ("op", "overwrite-parameter", Nothing,+         [ "overwrite a parameter of the file" ]) ]++    ftTable =+      [ ("s0", "weak-simplify", Nothing,+         [ "simple simplifications (removal of true/false " +++           "in boolean connectives, redundant temporal " +++           "operators, etc.)" ])+      , ("s1", "strong-simplify", Nothing,+         [ "advanced simplifications",+           "(includes: " +++           code m "-s0 -nnf -nw -nr -pgo -pfo -pxo" ++ ")" ])+      , ("nnf", "negation-normal-form", Nothing,+         [ "convert the resulting LTL formula into negation " +++           "normal form" ])+      , ("pgi", "push-globally-inwards", Nothing,+         [ "push global operators inwards",+           "  " ++ code m "G (a && b) => (G a) && (G b)" ])+      , ("pfi", "push-finally-inwards", Nothing,+         [ "push finally operators inwards",+           "  " ++ code m "F (a || b) => (F a) || (F b)" ])+      , ("pxi", "push-next-inwards", Nothing,+         [ "push next operators inwards",+           "  " ++ code m "X (a && b) => (X a) && (X b)",+           "  " ++ code m "X (a || b) => (X a) || (X b)" ])+      , ("pgo", "pull-globally-outwards", Nothing,+         [ "pull global operators outwards",+           "  " ++ code m "(G a) && (G b) => G (a && b)" ])+      , ("pfo", "pull-finally-outwards", Nothing,+         [ "pull finally operators outwards",+           "  " ++ code m "(F a) || (F b) => F (a || b)" ])+      , ("pxo", "pull-next-outwards", Nothing,+         [ "pull next operators outwards",+           "  " ++ code m "(X a) && (X b) => X (a && b)",+           "  " ++ code m "(X a) || (X b) => X (a || b)" ])+      , ("nw", "no-weak-until", Nothing,+         [ "replace weak until operators",+           "  " ++ code m "a W b => (a U b) || (G a)" ])+      , ("nr", "no-release", Nothing,+         [ "replace release operators",+           "  " ++ code m "a R b => b W (a && b)" ])+      , ("nf", "no-finally", Nothing,+         [ "replace finally operators",+           "  " ++ code m "F a => true U a" ])+      , ("ng", "no-globally", Nothing,+         [ "replace global operators",+           "  " ++ code m "G a => false R a" ])+      , ("nd", "no-derived", Nothing,+         [ "same as: " ++ code m "-nw -nf -ng" ]) ]++    csTable =+      [ ("gr", "generalized-reactivity", Nothing,+         [ "check whether the input is in the " +++           "Generalized Reactivity fragment" ]) ]++    eiTable =+      [ ("c", "check", Nothing,+         [ "check that input conforms to TLSF" ])+      , ("t", "print-title", Nothing,+         [ "output the title of the input file" ])+      , ("d", "print-description", Nothing,+         [ "output the description of the input file" ])+      , ("s", "print-semantics", Nothing,+         [ "output the semantics of the input file" ])+      , ("g", "print-target", Nothing,+         [ "output the target of the input file" ])+      , ("a", "print-tags", Nothing,+         [ "output the target of the input file" ])+      , ("p", "print-parameters", Nothing,+         [ "output the parameters of the input file" ])+      , ("i", "print-info", Nothing,+         [ "output all data of the info section" ])+      , ("ins", "print-input-signals", Nothing,+         [ "output the input signals of the specification" ])+      , ("outs", "print-output-signals", Nothing,+         [ "output the output signals of the specification" ])+      , ("","", Nothing,+         [])+      , ("v", "version", Nothing,+         [ "output version information" ])+      , ("h", "help", Nothing,+         [ "display this help" ]) ]++    formats =+      [ (convert FULL, True,+         ["input file with applied transformations"])+      , (convert BASIC, False,+         ["high level format (without global section)"])+      , (convert UTF8, False,+         ["human readable output using UTF8 symbols"])+      , (convert WRING, False,+         ["Wring input format"])+      , (convert LILY, False,+         ["Lily input format"])+      , (convert ACACIA, False,+         ["Acacia / Acacia+ input format"])+      , (convert ACACIASPECS, False,+         ["Acacia input format with spec units"])+      , (convert LTLXBA, False,+         ["LTL2BA / LTL3BA input format"])+      , (convert PROMELA, False,+         ["Promela LTL"])+      , (convert UNBEAST, False,+         ["Unbeast input format"])+      , (convert SLUGS, False,+         ["structured Slugs format [GR(1) only]"])+      , (convert SLUGSIN, False,+         ["SlugsIn format [GR(1) only]"])+      , (convert PSL, False,+         ["PSL Syntax"])+      , (convert SMV, False,+         ["SMV file format"])+      , (convert BOSY, False,+         ["Bosy input format"])+      ]++    modes =+      [ (convert Pretty, True,+         ["pretty printing (as less parentheses as possible)"])+      , (convert Fully, False,+         ["output fully parenthesized formulas"]) ]++-----------------------------------------------------------------------------++readme+  :: Mode -> String++readme m = appendlinks $ unlines+  [ switch+      ("# Synthesis Format Conversion Tool\n# (Version " +++       version ++ ")")+      ("# Synthesis Format Conversion Tool<br/>(Version " +++       version ++ ")")+  , ""+  , "A tool for reading, manipulating and transforming synthesis"+  , "specifications in " +++    link "TLSF" "https://arxiv.org/abs/1604.02284" ++ "."+  , ""+  , "## About this tool"+  , ""+   , "The tool interprets the high level constructs of " +++    link "TLSF 1.1" "https://arxiv.org/abs/1604.02284"+  , "(functions, sets, ...) and supports the transformation of the"+  , "specification to Linear Temporal Logic (LTL) in different output"+  , "formats. The tool has been designed to be modular with respect to the"+  , "supported output formats and semantics. Furthermore, the tool allows"+  , "to identify and manipulate parameters, targets and semantics of a"+  , "specification on the fly. This is especially thought to be useful for"+  , "comparative studies, as they are for example needed in the"+  , link "Synthesis Competition" "http://www.syntcomp.org" ++ "."+  , ""+  , "The main features of the tool are summarized as follows:"+  , ""+  , "* Interpretation of high level constructs, which allows to reduce the"+  , "  specification to its basic fragment where no more parameter and"+  , "  variable bindings occur (i.e., without the GLOBAL section)."+  , ""+  , "* Transformation to other existing specification formats, like"+  , "  Basic TLSF, " +++    link "Promela LTL" "http://spinroot.com/spin/Man/ltl.html" ++ ", " +++    link "PSL" ("https://en.wikipedia.org/wiki/" +++                "Property_Specification_Language")+    ++ ", " +++    link "Unbeast" "https://www.react.uni-saarland.de/tools/unbeast"+    ++ ", " +++    link "Wring" "http://www.ist.tugraz.at/staff/bloem/wring.html"+    ++ ","+  , "  " +++    link "structured Slugs"+      ("https://github.com/VerifiableRobotics/slugs/" +++       "blob/master/doc/input_formats.md#structuredslugs")+    ++ ", and " ++ link "SlugsIn"+    ("https://github.com/VerifiableRobotics/slugs/blob/master/" +++     "doc/input_formats.md#slugsin") ++ "."+  , ""+  , "* Syntactical analysis of membership in GR(k) for any k (modulo"+  , "  Boolean identities)."+  , ""+  , "* On the fly adjustment of parameters, semantics or targets."+  , ""+  , "* Preprocessing of the resulting LTL formula."+  , ""+  , "* Conversion to negation normal form."+  , ""+  , "* Replacement of derived operators."+  , ""+  , "* Pushing/pulling next, eventually, or globally operators"+  , "  inwards/outwards."+  , ""+  , "* Standard simplifications."+  , switch "\n" ""+  , "## Installation"+  , ""+  , "SyfCo is written in Haskell and can be compiled using the"+  , "Glasgow Haskell Compiler (GHC). To install the tool you can either"+  , "use " ++ link "cabal" "https://www.haskell.org/cabal" ++ " or " +++    link "stack" "https://docs.haskellstack.org/en/stable/README/" +++    " (recommended)."+  , "For more information about the purpose of these tools and why you"+  , "should prefer using stack instead of cabal, we recommend reading"+  ,  link "this blog post"+       "https://www.fpcomplete.com/blog/2015/06/why-is-stack-not-cabal" +++    " by Mathieu Boespflug. "+  , ""+  , "To install the tool with stack use:"+  , ""+  , scb "stack install"+  , ""+  , "Stack then automatically fetches the right compiler version"+  , "and required dependencies. After that it builds and installs"+  , "the package into you local stack path. If you instead prefer"+  , "to build only, use `stack build`."+  , ""+  , "If you insist to use cabal instead, we recommend at least to use"+  , "a sandbox. Initialize the sandbox and configure the project via"+  , ""+  , scb "cabal sandbox init && cabal configure"+  , ""+  , "Then use `cabal build` or `cabal install` to build or install the"+  , "tool."+  , ""+  , "Note that (independent of the chosen build method) building the"+  , "tool will only create the final executable in a hidden sub-folder,"+  , "which might get cumbersome for development or testing local changes."+  , "Hence, for this purpose, you may prefer to use `make`. The makefile"+  , "determines the chosen build method, rebuilds the package, and copies"+  , "the final `syfco` executable to the root directory of the project."+  , ""+  , "If you still encounter any problems, please inform us via the"+  , switch+      ("project bug tracker:\n\n  " +++       "https://github.com/reactive-systems/syfco/issues\n\n")+      (link "project bug tracker"+            "https://github.com/reactive-systems/syfco/issues"+            ++ ".\n")+  , usage m+  , "## Examples"+  , ""+  , "A number of synthesis benchmarks in TLSF can be found in the"+  , code m "/examples" ++ " directory."+  , ""+  , "## Syfco Library"+  , ""+  , "Syfco is also provided as a Haskell library. In fact, the syfco"+  , "executable is nothing different than a fancy command line interface"+  , "to this library. If you are interested in using the interface, we"+  , "recommend to build and check the interface documentation, which is"+  , "generated by:"+  , ""+  , scb "make haddock"+  , ""+  , "## Editor Support"+  , ""+  , "If you use " ++ link "Emacs" "https://www.gnu.org/software/emacs" +++    ", you should try our emacs mode (" ++ code m "tlsf-mode.el" ++ "),"+  , "which can be found in the " ++ code m "/misc" ++ " directory."+  , ""+  , "## Adding output formats"+  , ""+  , "If you like to add a new output format, first consider"+  , code m "/Writer/Formats/Example.hs" +++    ", which contains the most common"+  , "standard constructs and a short tutorial." ]++  where+    scb str = case m of+      Markdown -> "`" ++ str ++ "`"+      _        -> "  " ++ str++    switch s1 s2 = case m of+      Markdown -> s2+      _        -> s1++    link n url = "[" ++ n ++ "](" ++ url ++ ")"++    appendlinks str = case m of+      Markdown -> str+      _        ->+        let (str',ls) = replclct [] [] [] [] 0 0 str+        in str' +++           "\n--------------------------------------------------\n\n" +++           concatMap (\(n,s1,s2) -> "[" ++ show n ++ "]" +++                                    replicate (4 - length (show n)) ' '+                                    ++ s2 ++ "\n") ls++    replclct a b c1 c2 n m xs = case xs of+      []   -> case m of+        0 -> (reverse b, reverse a)+        1 -> (reverse (c1 ++ ('[' : b)), reverse a)+        2 -> (reverse (('(' : ']' : c1) ++ ('[' : b)), reverse a)+        _ -> (reverse (c2 ++ ('(' : ']' : c1) ++ ('[' : b)), reverse a)+      x:xr -> case (x,m) of+        ('[',0) -> replclct a b c1 c2 n 1 xr+        ( _ ,0) -> replclct a (x:b) c1 c2 n 0 xr+        (']',1) -> replclct a b c1 c2 n 2 xr+        ( _ ,1) -> replclct a b (x:c1) c2 n 1 xr+        ('(',2) -> replclct a b c1 c2 n 3 xr+        ( _ ,2) -> replclct a (x:(']':c1) ++ ('[': b)) [] [] n 0 xr+        (')',_) -> replclct ((n,reverse c1, reverse c2):a)+                   ((']' : reverse (show n)) ++ ('[' : ' ' : c1) ++ b)+                   [] [] (n+1) 0 xr+        ( _ ,_) -> replclct a b c1 (x:c2) n 3 xr++-----------------------------------------------------------------------------++code+  :: Mode -> String -> String++code m str = case m of+  Markdown -> "```" ++ str ++ "```"+  _        -> str++-----------------------------------------------------------------------------++codeblock+  :: Mode -> [String] -> String++codeblock m xs = case m of+  Markdown -> "```\n" ++ unlines xs ++ "```\n"+  _        -> unlines $ map ((' ':) . (' ':)) xs++-----------------------------------------------------------------------------++-- | Prints an error to STDERR and then terminates the program.++prError+  :: String -> IO a++prError err = do+  hPutStrLn stderr err+  exitFailure++-----------------------------------------------------------------------------
+ src/Main.hs view
@@ -0,0 +1,209 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- The main module.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    MultiWayIf++  #-}++-----------------------------------------------------------------------------++module Main+  ( main+  ) where++-----------------------------------------------------------------------------++import Syfco+  ( Configuration(..)+  , WriteFormat(..)+  , Specification+  , signals+  , fromTLSF+  , apply+  , checkGR+  )++import Data.Convertible+  ( convert+  )++import Info+  ( prTitle+  , prDescription+  , prSemantics+  , prTarget+  , prTags+  , prParameters+  , prInputs+  , prOutputs+  , prInfo+  , prVersion+  , prHelp+  , prReadme+  , prReadmeMd+  , prError+  )++import Arguments+  ( parseArguments+  )++import Data.Maybe+  ( isJust+  , fromJust+  )++import System.Environment+  ( getArgs+  )++import System.Directory+  ( doesFileExist+  )++import Control.Monad+  ( when+  )++import GHC.IO.Encoding+  ( setLocaleEncoding+  , setFileSystemEncoding+  , setForeignEncoding+  , utf8+  )++-----------------------------------------------------------------------------++-- | The main function executed at the program invocation.++main+  :: IO ()++main = do+  setLocaleEncoding utf8+  setFileSystemEncoding utf8+  setForeignEncoding utf8+  args <- getArgs+  c <- parseArguments args+  if | pHelp c     -> prHelp+     | pVersion c  -> prVersion+     | pReadme c   -> prReadme+     | pReadmeMd c -> prReadmeMd+     | otherwise   -> readContents c++-----------------------------------------------------------------------------++readContents+  :: Configuration -> IO ()++readContents c = do+  mapM_ (writeConfiguration c) $ saveConfig c+  when (not (null (inputFiles c)) || fromStdin c) $ do+    contents <- readInput c+    mapM_ (readContent c) contents++-----------------------------------------------------------------------------++readContent+  :: Configuration -> (String,Maybe String) -> IO ()++readContent c (content,file) = case fromTLSF content of+  Left err -> prError $ show err+  Right s+    | check c       -> do+        case apply c s of+          Left err -> prError $ show err+          Right _  ->+            case file of+              Nothing -> putStrLn "valid"+              Just f  -> putStrLn $ "valid: " ++ f+    | cGR c       ->+        case checkGR s of+          Left err   -> prError $ show err+          Right (-1) -> case file of+            Nothing ->+              putStrLn "NOT in the Generalized Reacitvity fragment"+            Just f  ->+              putStrLn $ "NOT in the Generalized Reactivity fragment: " ++ f+          Right x    -> case file of+            Nothing ->+              putStrLn $ "IN GR(" ++ show x ++ ")"+            Just f  -> do+              putStrLn $ "IN GR(" ++ show x ++ "): " ++ f+    | pTitle c      -> prTitle s+    | pDesc c       -> prDescription s+    | pSemantics c  -> prSemantics s+    | pTarget c     -> prTarget s+    | pTags c       -> prTags s+    | pParameters c -> prParameters s+    | pInputs c     -> prInputs c s+    | pOutputs c    -> prOutputs c s+    | pInfo c       -> prInfo s+    | otherwise     -> writeOutput c s++-----------------------------------------------------------------------------++readInput+  :: Configuration -> IO [(String,Maybe String)]++readInput c = case inputFiles c of+  [] -> do+    x <- getContents+    return [(x,Nothing)]+  xs -> mapM (\f -> do+    exists <- doesFileExist f+    if exists then do+      r <- readFile f+      return (r,Just f)+    else+      prError $ "File does not exist: " ++ f) xs++-----------------------------------------------------------------------------++writeOutput+  :: Configuration -> Specification -> IO ()++writeOutput c s = case apply c s of+  Left err -> prError $ show err+  Right wc -> do+    case outputFile c of+      Nothing -> putStrLn wc+      Just f  -> case outputFormat c of+        BASIC   -> writeFile (rmSuffix f ++ ".tlsf") wc+        FULL    -> writeFile (rmSuffix f ++ ".tlsf") wc+        UNBEAST -> writeFile (rmSuffix f ++ ".xml") wc+        _       -> writeFile f wc++    when (isJust $ partFile c) $ case signals c s of+      Left err      -> prError $ show err+      Right (is,os) ->+        writeFile (fromJust $ partFile c) $ unlines+          [ ".inputs" ++ concatMap (' ' :) is+          , ".outputs" ++ concatMap (' ' :) os+          ]++  where+    rmSuffix path = case reverse path of+      'f':'s':'l':'t':'.':xr -> reverse xr+      'l':'m':'x':'.':xr     -> reverse xr+      'l':'t':'l':'.':xr     -> reverse xr+      _                      -> path++-----------------------------------------------------------------------------++writeConfiguration+  :: Configuration -> FilePath -> IO ()++writeConfiguration c file =+  writeFile file $ convert c++-----------------------------------------------------------------------------
+ src/Reader.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- The module reads a specification to the internal format.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Reader+  ( fromTLSF+  ) where++-----------------------------------------------------------------------------++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Error+  ( Error+  )++import Data.SymbolTable+  ( SymbolTable+  , IdRec(..)+  )++import Data.Specification+  ( Specification(..)+  )++import Reader.Sugar+  ( replaceSugar+  )++import Reader.Parser+  ( parse+  )++import Reader.Bindings+  ( specBindings+  )++import Reader.InferType+  ( inferTypes+  )++import Reader.Abstraction+  ( abstract+  )++import Data.Maybe+  ( fromJust+  )++import Data.List+  ( zip7+  )++import qualified Data.IntMap as IM+  ( null+  , toAscList+  , minViewWithKey+  , maxViewWithKey+  )++import qualified Data.Array.IArray as A+  ( array+  )++import qualified Reader.Data as RD+  ( Specification(..)+  )++import qualified Reader.Parser.Data as PD+  ( enumerations+  )++import Debug.Trace++-----------------------------------------------------------------------------++-- | Parses a specification in TLSF.++fromTLSF+  :: String -> Either Error Specification++fromTLSF str =+  -- parse the input+  parse str >>=++  -- replace variable names by a unique identifier+  abstract >>=++  -- replace syntactic sugar constructs for later converison+  replaceSugar >>=++  -- retrieve the bindings of expression variables+  specBindings >>=++  -- infer types and typecheck+  inferTypes >>=++  -- lift reader specification to global specification+  \(s @ RD.Specification {..}) -> return+    Specification+      { source         = str+      , title          = fst title+      , titlePos       = snd title+      , description    = fst description+      , descriptionPos = snd description+      , semantics      = fst semantics+      , semanticsPos   = snd semantics+      , target         = fst target+      , targetPos      = snd target+      , tags           = map fst $ tags+      , tagsPos        = map snd $ tags+      , enumerations   = enumerations+      , parameters     = parameters+      , definitions    = definitions+      , inputs         = inputs+      , outputs        = outputs+      , initially      = initially+      , preset         = preset+      , requirements   = requirements+      , assumptions    = assumptions+      , invariants     = invariants+      , guarantees     = guarantees+      , symboltable    = symtable s+      }++-----------------------------------------------------------------------------++symtable+  :: RD.Specification -> SymbolTable++symtable (RD.Specification {..}) =+  let+    minkey = key IM.minViewWithKey+    maxkey = key IM.maxViewWithKey++    is = map fst $ IM.toAscList names+    ns = map snd $ IM.toAscList names+    ps = map snd $ IM.toAscList positions+    as = map snd $ IM.toAscList arguments+    bs = map snd $ IM.toAscList bindings+    ts = map snd $ IM.toAscList types+    ds = map snd $ IM.toAscList dependencies++    ys = zip7 is ns ps as bs ts ds+    xs = map (\(a,b,c,d,e,f,g) -> (a,IdRec b c d e f g)) ys+  in+    A.array (minkey, maxkey) xs++  where+    key f+      | IM.null names = 0+      | otherwise     =+          fst $ fst $ fromJust $ f names++-----------------------------------------------------------------------------
+ src/Reader/Abstraction.hs view
@@ -0,0 +1,431 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Abstraction+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Abstracts from identifier names to integer IDs.+--+-----------------------------------------------------------------------------++module Reader.Abstraction+  ( abstract+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( SignalDecType(..)+  )++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Binding+  ( BindExpr(..)+  )++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  , ExprPos+  )++import Reader.Data+  ( NameTable+  , PositionTable+  , ArgumentTable+  , Specification(..)+  )++import Reader.Error+  ( Error+  , errUnknown+  , errConflict+  , errPattern+  )++import Data.Maybe+  ( mapMaybe+  )++import Control.Monad.State+  ( StateT(..)+  , evalStateT+  , get+  , put+  , void+  )++import qualified Reader.Parser.Data as PD+  ( Specification(..)+  )++import qualified Data.IntMap.Strict as IM+  ( empty+  , insert+  , lookup+  )++import qualified Data.StringMap as SM+  ( StringMap+  , empty+  , insert+  , lookup+  )++-----------------------------------------------------------------------------++type Abstractor a b = a -> StateT ST (Either Error) b++-----------------------------------------------------------------------------++data ST = ST+  { count :: Int+  , tIndex :: SM.StringMap+  , tName :: NameTable+  , tPos :: PositionTable+  , tArgs :: ArgumentTable+  }++-----------------------------------------------------------------------------++-- | Abstracts from identifiers represeted by strings to identifiers+-- represented by integers. Additionally, a mapping from the integer+-- representation back to the string representation as well as mapping to+-- possible arguments and the position in the source file is created.++abstract+  :: PD.Specification -> Either Error Specification++abstract spec =+  evalStateT (abstractSpec spec)+    ST { count = 1+       , tIndex = SM.empty+       , tName = IM.empty+       , tPos = IM.empty+       , tArgs = IM.empty+       }++-----------------------------------------------------------------------------++abstractSpec+  :: Abstractor PD.Specification Specification++abstractSpec s = do+  mapM_ (\x -> add (bIdent x,bPos x)) $ PD.parameters s+  mapM_ (mapM_ (\(y,z,_) -> add (y,z)) . eValues) $ PD.enumerations s+  mapM_ (\x -> add (bIdent x,bPos x)) $ PD.definitions s+  ps <- mapM abstractBind $ PD.parameters s+  vs <- mapM abstractBind $ PD.definitions s++  let+    (ig,ib,ie) = foldl classify ([],[],[]) $ PD.inputs s+    (og,ob,oe) = foldl classify ([],[],[]) $ PD.outputs s++  a <- get+  ms <- mapM abstractEnum $ PD.enumerations s+  ie' <- mapM abstractSignalType ie+  oe' <- mapM abstractSignalType oe+  a' <- get+  put a' {+    tIndex = tIndex a+    }++  ig' <- mapM add ig+  og' <- mapM add og+  ib' <- mapM abstractBus ib+  ob' <- mapM abstractBus ob+  ie'' <- mapM abstractTypedBus ie'+  oe'' <- mapM abstractTypedBus oe'++  let+    is =+      map SDSingle ig' +++      map (uncurry SDBus) ib' +++      map (uncurry SDEnum) ie''+    os =+      map SDSingle og' +++      map (uncurry SDBus) ob' +++      map (uncurry SDEnum) oe''++  es <- mapM abstractExpr $ PD.initially s+  ss <- mapM abstractExpr $ PD.preset s+  rs <- mapM abstractExpr $ PD.requirements s+  as <- mapM abstractExpr $ PD.assumptions s+  bs <- mapM abstractExpr $ PD.invariants s+  gs <- mapM abstractExpr $ PD.guarantees s++  st <- get++  return $ Specification+    (PD.title s)+    (PD.description s)+    (PD.semantics s)+    (PD.target s)+    (PD.tags s)+    ms ps vs is os es ss rs as bs gs+    IM.empty+    (tName st)+    (tPos st)+    (tArgs st)+    IM.empty+    IM.empty++  where+    classify (a,b,c) x = case x of+      SDSingle y -> (y:a,b,c)+      SDBus y z  -> (a,(y,z):b,c)+      SDEnum y z -> (a,b,(y,z):c)++    abstractTypedBus (n,m) = do+      a <- add n+      return (a,m)++-----------------------------------------------------------------------------++abstractSignalType+  :: Abstractor ((String,ExprPos),(String,ExprPos))+               ((String,ExprPos),(Int,ExprPos))++abstractSignalType (n,(t,p)) = do+  a <- get+  i <- case SM.lookup t $ tIndex a of+    Just j  -> return j+    Nothing -> errUnknown t p+  return (n,(i,p))++-----------------------------------------------------------------------------++abstractBus+  :: Abstractor ((String,ExprPos),Expr String)+               ((Int,ExprPos),Expr Int)++abstractBus ((s,p),e) = do+  (i,p') <- add (s,p)+  e' <- abstractExpr e+  return ((i,p'),e')++-----------------------------------------------------------------------------++abstractEnum+  :: Abstractor (EnumDefinition String) (EnumDefinition Int)++abstractEnum b = do+  (n,p) <- add (eName b, ePos b)+  vs <- mapM abstractEnumV $ eValues b++  return EnumDefinition+    { eName = n+    , eSize = eSize b+    , eValues = vs+    , ePos = p+    , eMissing = eMissing b+    , eDouble = Nothing+    }++  where+    abstractEnumV (n,p,f) = do+      a <- get+      case SM.lookup n $ tIndex a of+        Just j  -> return (j,p,f)+        Nothing -> errUnknown n p++-----------------------------------------------------------------------------++abstractBind+  :: Abstractor (BindExpr String) (BindExpr Int)++abstractBind b = do+  a <- get+  as <- mapM add $ bArgs b+  es <- mapM abstractExpr $ bVal b+  a' <- get+  i <- case SM.lookup (bIdent b) $ tIndex a of+    Just j  -> return j+    Nothing -> errUnknown (bIdent b) (bPos b)++  put $ a' {+    tIndex = tIndex a,+    tArgs = IM.insert i (map fst as) $ tArgs a'+    }++  return BindExpr+    { bIdent = i+    , bArgs = as+    , bPos = bPos b+    , bVal = es+    }++-----------------------------------------------------------------------------++add+  :: Abstractor (String,ExprPos) (Int,ExprPos)++add (i,pos) = do+  a <- get+  case SM.lookup i $ tIndex a of+    Nothing -> do+      put ST+        { count = count a + 1+        , tIndex = SM.insert i (count a) $ tIndex a+        , tName = IM.insert (count a) i $ tName a+        , tPos = IM.insert (count a) pos $ tPos a+        , tArgs = IM.insert (count a) [] $ tArgs a+        }+      return (count a,pos)+    Just j ->+      let Just p = IM.lookup j $ tPos a+      in errConflict i p pos++-----------------------------------------------------------------------------++check+  :: Abstractor (String,ExprPos) (Int,ExprPos)++check (i,pos) = do+  a <- get+  case SM.lookup i $ tIndex a of+    Nothing -> errUnknown i pos+    Just j  -> return (j,pos)++-----------------------------------------------------------------------------++abstractExpr+  :: Abstractor (Expr String) (Expr Int)++abstractExpr e = case expr e of+  BaseOtherwise    -> return $ Expr BaseOtherwise $ srcPos e+  BaseWild         -> return $ Expr BaseWild $ srcPos e+  BaseTrue         -> return $ Expr BaseTrue $ srcPos e+  BaseFalse        -> return $ Expr BaseFalse $ srcPos e+  BaseCon x        -> return $ Expr (BaseCon x) $ srcPos e+  BlnNot x         -> lift' BlnNot x+  NumSMin x        -> lift' NumSMin x+  NumSMax x        -> lift' NumSMax x+  NumSSize x       -> lift' NumSSize x+  NumSizeOf x      -> lift' NumSizeOf x+  LtlNext x        -> lift' LtlNext x+  LtlGlobally x    -> lift' LtlGlobally x+  LtlFinally x     -> lift' LtlFinally x+  NumPlus x y      -> lift2' NumPlus x y+  NumMinus x y     -> lift2' NumMinus x y+  NumMul x y       -> lift2' NumMul x y+  NumDiv x y       -> lift2' NumDiv x y+  NumMod x y       -> lift2' NumMod x y+  SetCup x y       -> lift2' SetCup x y+  SetCap x y       -> lift2' SetCap x y+  SetMinus x y     -> lift2' SetMinus x y+  BlnEQ x y        -> lift2' BlnEQ x y+  BlnNEQ x y       -> lift2' BlnNEQ x y+  BlnGE x y        -> lift2' BlnGE x y+  BlnGEQ x y       -> lift2' BlnGEQ x y+  BlnLE x y        -> lift2' BlnLE x y+  BlnLEQ x y       -> lift2' BlnLEQ x y+  BlnElem x y      -> lift2' BlnElem x y+  BlnOr x y        -> lift2' BlnOr x y+  BlnAnd x y       -> lift2' BlnAnd x y+  BlnImpl x y      -> lift2' BlnImpl x y+  BlnEquiv x y     -> lift2' BlnEquiv x y+  LtlRNext x y     -> lift2' LtlRNext x y+  LtlRGlobally x y -> lift2' LtlRGlobally x y+  LtlRFinally x y  -> lift2' LtlRFinally x y+  LtlUntil x y     -> lift2' LtlUntil x y+  LtlWeak x y      -> lift2' LtlWeak x y+  LtlRelease x y   -> lift2' LtlRelease x y+  NumRPlus xs x    -> cond NumRPlus xs x+  NumRMul xs x     -> cond NumRMul xs x+  SetRCup xs x     -> cond SetRCup xs x+  SetRCap xs x     -> cond SetRCap xs x+  BlnROr xs x      -> cond BlnROr xs x+  BlnRAnd xs x     -> cond BlnRAnd xs x+  BaseId x         -> do+    (x',p) <- check (x,srcPos e)+    return $ Expr (BaseId x') p+  BaseBus x y      -> do+    (y',p) <- check (y,srcPos e)+    x' <- abstractExpr x+    return $ Expr (BaseBus x' y') p+  BaseFml xs x     -> do+    (x',p) <- check (x,srcPos e)+    xs' <- mapM abstractExpr xs+    return $ Expr (BaseFml xs' x') p+  SetExplicit xs   -> do+    xs' <- mapM abstractExpr xs+    return $ Expr (SetExplicit xs') $ srcPos e+  SetRange x y z   -> do+    x' <- abstractExpr x+    y' <- abstractExpr y+    z' <- abstractExpr z+    return $ Expr (SetRange x' y' z') $ srcPos e+  Colon v z        -> case expr v of+    Pattern x y -> do+      a <- get+      x' <- abstractExpr x+      getPatternIds y+      y' <- abstractExpr y+      z' <- abstractExpr z+      a' <- get+      put $ a' { tIndex = tIndex a }+      return $ Expr (Colon (Expr (Pattern x' y') (srcPos v)) z') (srcPos e)+    _ -> lift2' Colon v z+  Pattern x y      -> lift2' Pattern x y++  where+    lift' c x = do+      x' <- abstractExpr x+      return $ Expr (c x') (srcPos e)++    lift2' c x y = do+      x' <- abstractExpr x+      y' <- abstractExpr y+      return $ Expr (c x' y') (srcPos e)++    cond c xs x = do+      a <- get+      mapM_ add $ mapMaybe getId xs+      xs' <- mapM abstractExpr xs+      x' <- abstractExpr x+      a' <- get+      put $ a' { tIndex = tIndex a }+      return $ Expr (c xs' x') (srcPos e)++    getId x = case expr x of+      BlnElem y _ -> isid y+      BlnLE n _   -> range n+      BlnLEQ n _  -> range n+      _          -> Nothing++    range n = case expr n of+      BlnLE _ m  -> isid m+      BlnLEQ _ m -> isid m+      _          -> Nothing++    isid m = case expr m of+      BaseId i -> Just (i,srcPos m)+      _        -> Nothing++    getPatternIds z = case expr z of+      BaseWild         -> return ()+      BaseTrue         -> return ()+      BaseFalse        -> return ()+      BaseOtherwise    -> return ()+      BaseId i         -> void $ add (i,srcPos z)+      BlnNot x         -> getPatternIds x+      BlnOr x y        -> mapM_ getPatternIds [x,y]+      BlnAnd x y       -> mapM_ getPatternIds [x,y]+      BlnImpl x y      -> mapM_ getPatternIds [x,y]+      BlnEquiv x y     -> mapM_ getPatternIds [x,y]+      LtlNext x        -> getPatternIds x+      LtlRNext _ x     -> getPatternIds x+      LtlGlobally x    -> getPatternIds x+      LtlRGlobally _ x -> getPatternIds x+      LtlFinally x     -> getPatternIds x+      LtlRFinally _ x  -> getPatternIds x+      LtlUntil x y     -> mapM_ getPatternIds [x,y]+      LtlWeak x y      -> mapM_ getPatternIds [x,y]+      LtlRelease x y   -> mapM_ getPatternIds [x,y]+      _                -> errPattern $ srcPos z++-----------------------------------------------------------------------------
+ src/Reader/Bindings.hs view
@@ -0,0 +1,297 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Bindings+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Extracts the static expression bindings from the specification.+--+-----------------------------------------------------------------------------++module Reader.Bindings+  ( specBindings+  ) where++-----------------------------------------------------------------------------++import Utils+  ( strictSort+  , imLookup+  )++import Data.Types+  ( SignalDecType(..)+  )++import Data.Binding+  ( Binding+  , BindExpr(..)+  )++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  , SrcPos(..)+  , ExprPos(..)+  , subExpressions+  )++import Reader.Data+  ( Specification(..)+  , ExpressionTable+  , NameTable+  , PositionTable+  , ArgumentTable+  )++import Reader.Error+  ( Error+  , errArgArity+  , errConditional+  , errCircularDep+  )++import Data.Graph+  ( buildG+  , scc+  )++import Data.Tree+  ( flatten+  )++import Data.Maybe+  ( fromJust+  )++import Control.Monad.State+  ( StateT(..)+  , execStateT+  , put+  , get+  , when+  )++import qualified Data.IntMap.Strict as IM+  ( IntMap+  , map+  , insert+  , toList+  , null+  , minViewWithKey+  , maxViewWithKey+  )++-----------------------------------------------------------------------------++type ArityTable = IM.IntMap Int++-----------------------------------------------------------------------------++type BindingsBuilder a = a -> StateT ST (Either Error) ()++-----------------------------------------------------------------------------++data ST = ST+  { tBinding :: ExpressionTable+  , tName :: NameTable+  , tPos :: PositionTable+  , tArgs :: ArgumentTable+  , tAry :: ArityTable+  }++-----------------------------------------------------------------------------++-- | Extracts the static expression bindings from the specification and+-- stores them in a corresponding mapping. Furthermore, depencency+-- constraints are already checked.++specBindings+  :: Specification -> Either Error Specification++specBindings spec = do+  let+    p = SrcPos (-1) (-1)+    pos = ExprPos p p+    empty = Expr (SetExplicit []) pos+    a =+      ST { tBinding = IM.map (const empty) $ names spec+         , tName = names spec+         , tPos = positions spec+         , tArgs = arguments spec+         , tAry = IM.map length $ arguments spec+         }++  a' <- execStateT (specificationBindings spec) a++  checkCircularDeps spec+    { bindings = tBinding a'+    , dependencies = IM.map deps $ tBinding a'+    }++-----------------------------------------------------------------------------++specificationBindings+  :: BindingsBuilder Specification++specificationBindings s = do+  mapM_ binding $ parameters s+  mapM_ binding $ definitions s+  mapM_ signalBinding $ inputs s+  mapM_ signalBinding $ outputs s+  mapM_ exprBindings $ initially s+  mapM_ exprBindings $ preset s+  mapM_ exprBindings $ requirements s+  mapM_ exprBindings $ invariants s+  mapM_ exprBindings $ assumptions s+  mapM_ exprBindings $ guarantees s++  where+    signalBinding x = case x of+      SDSingle {}   -> return ()+      SDEnum {}     -> return ()+      SDBus (y,_) e -> do+        addBinding (y,e)+        exprBindings e++-----------------------------------------------------------------------------++binding+  :: BindingsBuilder Binding++binding b = do+  mapM_ (\a -> addBinding (bIdent b,a)) $ bVal b+  mapM_ exprBindings $ bVal b++-----------------------------------------------------------------------------++exprBindings+  :: BindingsBuilder (Expr Int)++exprBindings e = case expr e of+  NumRPlus xs x -> mapM_ conditional xs >> exprBindings x+  NumRMul xs x  -> mapM_ conditional xs >> exprBindings x+  SetRCup xs x  -> mapM_ conditional xs >> exprBindings x+  SetRCap xs x  -> mapM_ conditional xs >> exprBindings x+  BlnRAnd xs x  -> mapM_ conditional xs >> exprBindings x+  BlnROr xs x   -> mapM_ conditional xs >> exprBindings x+  BaseId x      -> checkArity x 0+  BaseFml xs x  -> checkArity x (length xs)+  BaseBus x y   -> checkArity y 0 >> exprBindings x+  _             -> mapM_ exprBindings $ subExpressions e++  where+    checkArity x j = do+      a <- get+      let n = imLookup x $ tAry a+      when (n /= j) $+        let m = imLookup x $ tName a+            p = imLookup x $ tPos a+        in errArgArity m n p $ srcPos e++    conditional x = case expr x of+      BlnElem l s -> case expr l of+        BaseId i -> do+          a <- get+          put a {+            tBinding = IM.insert i s $ tBinding a+            }+        _        -> errConditional $ srcPos e+      BlnLE s r -> case expr s of+        BlnLE l i  -> range i (op NumPlus l) (op NumMinus r) $ srcPos x+        BlnLEQ l i -> range i l (op NumMinus r) $ srcPos x+        _          -> errConditional $ srcPos e+      BlnLEQ s r -> case expr s of+        BlnLE l i  -> range i (op NumPlus l) r $ srcPos x+        BlnLEQ l i -> range i l r $ srcPos x+        _          -> errConditional $ srcPos e+      _           -> errConditional $ srcPos e++    op c x = Expr (c x (Expr (BaseCon 1) (srcPos x))) (srcPos x)++    range x l u p = case expr x of+      BaseId i -> do+        a <- get+        let s = Expr (SetRange l (op NumPlus l) u) p+        put a {+          tBinding = IM.insert i s $ tBinding a+          }+      _        -> errConditional $ srcPos e++-----------------------------------------------------------------------------++addBinding+  :: BindingsBuilder (Int,Expr Int)++addBinding (i,x) = do+  a <- get+  let y = imLookup i $ tBinding a+      z = Expr (SetExplicit [x]) $ srcPos x+      s = Expr (SetCup y z) $ srcPos y+  put a {+    tBinding = IM.insert i s $ tBinding a+    }++-----------------------------------------------------------------------------++deps+  :: Expr Int -> [Int]++deps = strictSort . deps' []+  where+    deps' a e = case expr e of+      BaseFml xs x  -> foldl conditional (x:a) xs+      BaseId x      -> x:a+      BaseBus x y   -> deps' (y:a) x+      NumRPlus xs x -> foldl conditional (deps' a x) xs+      NumRMul xs x  -> foldl conditional (deps' a x) xs+      SetRCup xs x  -> foldl conditional (deps' a x) xs+      SetRCap xs x  -> foldl conditional (deps' a x) xs+      BlnRAnd xs x  -> foldl conditional (deps' a x) xs+      BlnROr xs x   -> foldl conditional (deps' a x) xs+      Colon x y     -> case expr x of+        Pattern z _ -> deps' (deps' a z) y+        _           -> deps' (deps' a x) y+      _              -> foldl deps' a $ subExpressions e++    conditional k x = case expr x of+      BlnElem _ y -> deps' k y+      _           -> deps' k x++-----------------------------------------------------------------------------++checkCircularDeps+  :: Specification -> Either Error Specification++checkCircularDeps s = do+  let+    ys = concatMap (\(i,zs) -> map (\z -> (i,z)) zs) $+         filter isunary $ IM.toList $+         dependencies s+    minkey =+      if IM.null $ dependencies s then 0 else+        fst $ fst $ fromJust $ IM.minViewWithKey $ dependencies s+    maxkey =+      if IM.null $ dependencies s then 0 else+        fst $ fst $ fromJust $ IM.maxViewWithKey $ dependencies s+    c = map flatten $ scc $ buildG (minkey,maxkey) ys++  mapM_ check c+  mapM_ checkSingelton ys+  return s++  where+    isunary (x,_) = null $ imLookup x $ arguments s++    check xs = when (length xs > 1) $+      let+        p = imLookup (head xs) $ positions s+        ys = map (\i -> (imLookup i $ names s, imLookup i $ positions s)) xs+      in+        errCircularDep ys p++    checkSingelton (i,j) = when (i == j) $+      errCircularDep [(imLookup i $ names s, imLookup i $ positions s)] $+      imLookup i $ positions s++-----------------------------------------------------------------------------
+ src/Reader/Data.hs view
@@ -0,0 +1,172 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Data+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Common data used by the reader module.+--+-----------------------------------------------------------------------------++module Reader.Data+  ( NameTable+  , PositionTable+  , ArgumentTable+  , ExpressionTable+  , TypeTable+  , DependencyTable+  , Specification(..)+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( SignalDecType+  )++import Data.Enum+  ( EnumDefinition+  )++import Data.Types+  ( IdType+  , Semantics+  , Target+  )++import Data.Expression+  ( Expr+  , ExprPos+  )++import Data.Binding+  ( Binding+  )++import  Data.IntMap.Strict+  ( IntMap+  )++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their correpsonding name.++type NameTable = IntMap String++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their defining position in the source+-- file.++type PositionTable = IntMap ExprPos++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their arguments, in case the bound+-- expression is a function.++type ArgumentTable   = IntMap [Int]++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their bound expression.++type ExpressionTable = IntMap (Expr Int)++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their correspoinging type.++type TypeTable       = IntMap IdType++-----------------------------------------------------------------------------++-- | Mapping to map identifier IDs to their the list of identifier IDs it+-- depends on.++type DependencyTable = IntMap [Int]++-----------------------------------------------------------------------------++-- | The internal representation of a specification used by the reader+-- module.++data Specification =+  Specification+  { -- | The title of the specification.+    title :: (String, ExprPos)++  , -- | The description of the specification.+    description :: (String, ExprPos)++  , -- | The semantics flag of the specification.+    semantics :: (Semantics, ExprPos)++  , -- | The target flag of the specification.+    target :: (Target, ExprPos)++  , -- | The tag list of the specification.+    tags :: [(String, ExprPos)]++  , -- | The list of defined enumeration types.+    enumerations :: [EnumDefinition Int]++  , -- | The list of bindings of an identifier to an expression+    -- defined in the PARAMETERS subsection.+    parameters :: [Binding]++  , -- | The list of bindings of an identifier to any other expression+    -- defined in the DEFINITIONS subsection.+    definitions :: [Binding]++  , -- | The list of input signals.+    inputs :: [SignalDecType Int]++  , -- | The list of output signals.+    outputs :: [SignalDecType Int]++  , -- | The list of expresssions representing the initial input of+    -- the environment.+    initially :: [Expr Int]++  , -- | The list of expresssions representing the initial output of+    -- the system.+    preset :: [Expr Int]++  , -- | The list of expresssions representing the globally asserted+    -- requirements on the inputs of the specification.+    requirements :: [Expr Int]++  , -- | The list of expresssions representing the assumptions of the+    -- specification.+    assumptions :: [Expr Int]++  , -- | The list of expressions representing the invariants of the+    -- specification.+    invariants :: [Expr Int]++  , -- | The list of expressions representing the guarantees of the+    -- specification.+    guarantees :: [Expr Int]++  , -- | The id to bounded-expression mapping.+    bindings :: ExpressionTable++  , -- | The id to name mapping.+    names :: NameTable++  , -- | The id to source position mapping.+    positions :: PositionTable++  , -- | The id to arguments mapping.+    arguments :: ArgumentTable++  , -- | The id to depending ids mapping.+    dependencies :: DependencyTable++  , -- | The id to type of the bound expression mapping.+    types :: TypeTable++  }++-----------------------------------------------------------------------------
+ src/Reader/Error.hs view
@@ -0,0 +1,219 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Error+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Pretty and informative error messages that may be thrown while reading+-- the specification.+--+-----------------------------------------------------------------------------++module Reader.Error+  ( Error+  , errUnknown+  , errConflict+  , errEnumConflict+  , errPattern+  , errArgArity+  , errConditional+  , errCircularDep+  , errExpect+  , errRange+  , errNoPFuns+  , errNoHigher+  , errEquality+  , errInfinite+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( IdType(..)+  )++import Data.Error+  ( Error+  , depError+  , typeError+  , syntaxError+  , bindingError+  , prErrPos+  )++import Data.Expression+  ( ExprPos+  )++import Control.Monad.State+  ( StateT(..)+  )++-----------------------------------------------------------------------------++-- | Throws an error that indicates an unbound identifier name.++errUnknown+  :: String -> ExprPos -> StateT a (Either Error) b++errUnknown i pos =+  let msg = "identifiyer not in scope: " ++ i+  in StateT $ \_ -> bindingError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates two conflicting identifier bindings.++errConflict+  :: String -> ExprPos -> ExprPos -> StateT a (Either Error) b++errConflict i x y =+  let msg = "conflicting definitions: " ++ i ++ "\n" +++            "already bound at " ++ prErrPos x+  in StateT $ \_ -> bindingError y msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates two conflicting enumeration values.++errEnumConflict+  :: String -> String -> String -> String -> ExprPos -> Either Error b++errEnumConflict e s1 s2 v y =+  let msg = "conflict in enumeration: " ++ e ++ "\n" +++            s1 ++ " and " ++ s2 ++ " share the same value: " ++ v+  in bindingError y msg++-----------------------------------------------------------------------------++-- | Throws an error informing the user that formulas cannot be used+-- as a right hand side of a pattern matching.++errPattern+  :: ExprPos -> StateT a (Either Error) b++errPattern pos =+  let msg = "Formulas are not allowed on the right hand side " +++            "of a pattern match."+  in StateT $ \_ -> typeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that inidactes the use of a function as a parameter.++errNoPFuns+  :: Int -> ExprPos -> StateT a (Either Error) b++errNoPFuns n y =+  let msg = "expecting: " ++ show TNumber ++ " expression\n" +++            "but found: function with " ++ show n ++ "arguments"+  in StateT $ \_ -> typeError y msg++-----------------------------------------------------------------------------++-- | Throws an error that inidactes two many arguments passed to a+-- function.++errArgArity+  :: String -> Int -> ExprPos -> ExprPos -> StateT a (Either Error) b++errArgArity i n x y =+  let msg = "unexpected number of arguments: " ++ i ++ "\n" +++            "According to its definition (" ++  prErrPos x +++            "),\nthe function has to be applied to " ++ show n +++            " arguments."+  in StateT $ \_ -> typeError y msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates a sub-expression that does not conform+-- to the big-operator notation.++errConditional+  :: ExprPos -> StateT a (Either Error) b++errConditional pos =+  let msg = "expecting expression of the form:\n" +++            "  identifyer <- set"+  in StateT $ \_ -> syntaxError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates a set of identifiers that decribe a+-- circular dependency between each other.++errCircularDep+  :: [(String,ExprPos)] -> ExprPos -> Either Error b++errCircularDep xs pos =+  let+    m = foldl max (length $ fst $ head xs) $ map (length . fst) xs+    msg = "detected circular dependencies between:" +++          concatMap (\(x,y) -> "\n  " ++ x +++                              replicate (m - length x) ' ' +++                              " (defined at " ++ prErrPos y ++ ")") xs +++            if length xs > 1 then "" else " depends on itself"+  in depError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that incicates a wrongly typed subexpression.++errExpect+  :: IdType -> IdType -> ExprPos -> StateT a (Either Error) b++errExpect x y pos =+  let msg = "expecting: " ++ show x ++ " expression\n" +++            "but found: " ++ show y ++ " expression"+  in StateT $ \_ -> typeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that incicates a sub-expression that does not conform+-- to the range syntax.++errRange+  :: IdType -> ExprPos -> StateT a (Either Error) b++errRange x pos =+  let msg = "expecting: range expression\n" +++            "but found: " ++ show x ++ " expression"+  in StateT $ \_ -> typeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that inidactes the use higher order functions.++errNoHigher+  :: String -> ExprPos -> StateT a (Either Error) b++errNoHigher n y =+  let msg = "function passed as an argument: " ++ show n ++ "\n" +++            "higher order functions not supported"+  in StateT $ \_ -> typeError y msg++-----------------------------------------------------------------------------++-- | Throws an error that incicates a wrongly typed subexpression.++errEquality+  :: IdType -> ExprPos -> StateT a (Either Error) b++errEquality x pos =+  let msg = "expecting numerical or enum comparison\n" +++            "but found: " ++ show x ++ " expression"+  in StateT $ \_ -> typeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that incicates the construction of an infinite type++errInfinite+  :: String -> ExprPos -> StateT a (Either Error) b++errInfinite n pos =+  let msg = "cannot construct infinite type\n" +++            "check the definition of: " ++ n+  in StateT $ \_ -> typeError pos msg++-----------------------------------------------------------------------------
+ src/Reader/InferType.hs view
@@ -0,0 +1,1028 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.InferType+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Infers and checks types of all bound expressions.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , TupleSections+  , RecordWildCards+  , MultiWayIf+  , ViewPatterns++  #-}++-----------------------------------------------------------------------------++module Reader.InferType+  ( inferTypes+  ) where++-----------------------------------------------------------------------------++import Prelude hiding+  ((!))++import Control.Arrow+  ( (>>>)+  , (&&&)+  )++import Control.Monad+  ( (>=>)+  , foldM+  )++import Utils+  ( imLookup+  )++import Data.Graph+  ( Graph+  , buildG+  , transposeG+  , topSort+  )++import qualified Data.Set as S+  ( fromList+  , toList+  , insert+  , intersection+  , difference+  )++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Types+  ( IdType(..)+  , SignalType(..)+  , SignalDecType(..)+  )++import Data.Binding+  ( Binding+  , BindExpr(..)+  )++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  , ExprPos+  )++import Reader.Data+  ( TypeTable+  , ExpressionTable+  , ArgumentTable+  , Specification(..)+  )++import Reader.Error+  ( Error+  , errExpect+  , errRange+  , errPattern+  , errNoPFuns+  , errArgArity+  , errNoHigher+  , errEquality+  , errInfinite+  )++import Data.Maybe+  ( fromJust+  )++import Data.Either+  ( partitionEithers+  )++import Control.Monad.State+  ( StateT(..)+  , execStateT+  , get+  , put+  , liftM+  , when+  , unless+  )++import Control.Exception+  ( assert+  )++import qualified Data.IntMap.Strict as IM+  ( map+  )++import Data.IntMap.Strict+  ( IntMap+  , (!)+  , insert+  , fromList+  , findMax+  , mapWithKey+  )++-----------------------------------------------------------------------------++type TypeChecker a = a -> StateT ST (Either Error) ()++type TC a = StateT ST (Either Error) a++type ExprType = IdType++type ID = Int++type Expression = Expr ID++-----------------------------------------------------------------------------++data ST = ST+  { tCount :: Int+  , tTypes :: TypeTable+  , targs :: ArgumentTable+  , spec :: Specification+  , curBinding :: ID+  }++-----------------------------------------------------------------------------++-- | Infers and checks types of all bound expressions as well as of+-- the assumptions, the invariants and the guarantees. Additionally, a+-- mapping from each identifier to its type is created.++inferTypes+  :: Specification -> Either Error Specification++inferTypes s@Specification{..} = do+  let st = ST { tCount = (+1) $ fst $ findMax names+              , tTypes = mapWithKey (flip $ const TPoly) names+              , targs = arguments+              , spec = s+              , curBinding = -1+              }++  tt <- execStateT inferTypeSpec st+  return $ s { types = tTypes tt }++-----------------------------------------------------------------------------++-- | Returns the list of bindings, which is ordered accoring to the+-- respective dependencies of the entries. The result is a list of+-- @Either@s, where @Left@ entries corresponds to parameter bindings+-- and @Right@ entries to definition bindings.++depOrderedBindings+  :: Specification -> [Either (BindExpr ID) (BindExpr ID)]++depOrderedBindings Specification{..} =+  let+    -- get ID map+    im =+      fromList $+        map (bIdent &&& Left) parameters +++        map (bIdent &&& Right) definitions++    -- get the parameter ids+    ps :: [ID]+    ps = map bIdent parameters++    -- get the definition ids+    ds :: [ID]+    ds = map bIdent definitions++    -- list of all bindings ids+    xs :: [ID]+    xs = ps ++ ds+  in+    if null xs+    then []+    else+      let+        -- create list of edges+        es :: [(ID, ID)]+        es = concatMap (\x -> map (x,) $ deps xs x) xs++        -- create the depencency graph+        g :: Graph+        g = buildG (minimum xs, maximum xs) es+      in+        map (im !) $+        filter (`elem` xs) $+        topSort $+        transposeG g++  where+    deps+      :: [Int] -> Int -> [Int]++    deps xs x =+      S.toList $+      S.intersection+        (S.fromList $ dependencies ! x)+        (S.fromList xs)++-----------------------------------------------------------------------------++inferTypeSpec+  :: TC ()++inferTypeSpec = do+  -- get the specification+  s@Specification{..} <- spec <$> get++  -- set the enumeration types+  mapM_ setEnumType enumerations+  -- set the signal types fo input and outputs+  mapM_ (setSignalType STInput) inputs+  mapM_ (setSignalType STOutput) outputs+  -- set the parameter types+  mapM_ (updType TNumber . bIdent) parameters++  -- fix and check the binding types+  mapM_ typeCheckBinding $ depOrderedBindings s+  -- type-check bus-parameters+  mapM_ typeCheckBusParameter inputs+  mapM_ typeCheckBusParameter outputs+  -- type-check LTL formulas+  mapM_ (`typeCheck` TLtl) initially+  mapM_ (`typeCheck` TLtl) preset+  mapM_ (`typeCheck` TLtl) requirements+  mapM_ (`typeCheck` TLtl) assumptions+  mapM_ (`typeCheck` TLtl) invariants+  mapM_ (`typeCheck` TLtl) guarantees++  where+    setSignalType+      :: SignalType -> SignalDecType ID -> TC ()++    setSignalType s = \case+      SDSingle (x,_)     -> updType (TSignal s) x+      SDBus (x,_) _      -> updType (TBus s) x+      SDEnum (x,_) (y,_) -> do+        Specification{..} <- spec <$> get+        updType (TTypedBus s (imLookup y names) y) x+++    setEnumType+      :: EnumDefinition ID -> TC ()++    setEnumType e = do+      Specification{..} <- spec <$> get++      mapM_+        (updType (TEnum (imLookup (eName e) names) $ eName e)+          . (\(y,_,_) -> y))+        (eValues e)++-----------------------------------------------------------------------------++typeCheckBinding+  :: Either (BindExpr ID) (BindExpr ID) -> TC ()++typeCheckBinding = \case+  Left x  -> typeCheckParameter $ bIdent x+  Right x -> typeCheckDefinition $ bIdent x++-----------------------------------------------------------------------------++typeCheckParameter+  :: ID -> TC ()++typeCheckParameter i = do+  Specification{..} <- spec <$> get++  let+    n :: Int+    n = length $ arguments ! i++  if n <= 0+  then typeCheck (bindings ! i) $ TSet TNumber+  else errNoPFuns n $ positions ! i++-----------------------------------------------------------------------------++typeCheckDefinition+  :: ID -> TC ()++typeCheckDefinition i = do+  -- set the current binding to detect recursive function definitions+  setCur i++  -- get the expression bound the the identifier+  e <- ((! i) . bindings . spec) <$> get++  -- tyepcheck and infer types+  check e 10++  -- reset the recursion indicator+  setCur (-1)++  where+    setCur+      :: Int -> TC ()++    setCur c = do+      st <- get+      put st+        { curBinding = c+        }+++    inferBinding+      :: Expression -> TC ExprType++    inferBinding e = inferFromExpr e >>= \case+      TSet TBoolean -> inferFromBoolExpr e+      t'            -> return t'+++    check+      :: Expression -> Int -> TC ()++    check e n = do+      -- get the type of the expression+      TSet t <- inferBinding e+      -- update the type in the type table+      updType t i+      -- typecheck the expression+      typeCheck e $ TSet t++      if n > 0+      then check e (n-1)+      else do+        TSet t' <- inferBinding e++        when (t /= t') $ do+          n <- ((! i) . names . spec) <$> get+          p <- ((! i) . positions . spec) <$> get+          errInfinite n p++-----------------------------------------------------------------------------++typeCheckBusParameter+  :: SignalDecType ID -> TC ()++typeCheckBusParameter = \case+  SDBus _ e -> typeCheck e TNumber+  _         -> return ()++-----------------------------------------------------------------------------++typeCheck+  :: Expression -> ExprType -> TC ()++typeCheck e = \case+  -- check signal types+  TSignal x           -> typeChIdF e $ TSignal x++  -- check normal bus types+  TBus x              -> typeChIdF e $ TBus x++  -- check enum bus types+  TEnum t x           -> typeChIdF e $ TEnum t x++  -- check typed bus types+  TTypedBus x y z     -> typeChIdF e $ TTypedBus x y z++  -- check for empty sets+  TEmptySet -> case expr e of+    SetExplicit []    -> return ()+    SetExplicit (x:_) -> typeErrES e x+    SetCup x y        -> typeChck2 x y TEmptySet+    SetCap x y        -> typeChck2 x y TEmptySet+    SetMinus x y      -> typeChck2 x y TEmptySet+    SetRCup _ x       -> typeCheck x TEmptySet+    SetRCap _ x       -> typeCheck x TEmptySet+    _                 -> typeChIdF e TEmptySet++  -- check set types+  TSet t -> case expr e of+    SetExplicit xs    -> typeChSEx t xs+    SetRange x y z    -> typeChSRg x y z+    SetCup x y        -> typeChck2 x y $ TSet t+    SetRCup xs x      -> typeChckO xs x $ TSet t+    SetCap x y        -> typeChck2 x y $ TSet t+    SetRCap xs x      -> typeChckO xs x $ TSet t+    SetMinus x y      -> typeChck2 x y $ TSet t+    _                 -> typeChIdF e $ TSet t++  -- check numerical types+  TNumber -> case expr e of+    BaseCon {}        -> return ()+    NumSMin xs        -> typeCheck xs $ TSet TNumber+    NumSMax xs        -> typeCheck xs $ TSet TNumber+    NumSSize x        -> typeChckS x+    NumSizeOf b       -> typeCheck b $ TBus STGeneric+    NumPlus x y       -> typeChck2 x y TNumber+    NumRPlus xs x     -> typeChckO xs x TNumber+    NumMinus x y      -> typeChck2 x y TNumber+    NumMul x y        -> typeChck2 x y TNumber+    NumRMul xs x      -> typeChckO xs x TNumber+    NumDiv x y        -> typeChck2 x y TNumber+    NumMod x y        -> typeChck2 x y TNumber+    _                 -> typeChIdF e TNumber++  -- check boolean types+  TBoolean -> case expr e of+    BaseTrue          -> return ()+    BaseFalse         -> return ()+    BaseOtherwise     -> return ()+    Pattern x y       -> typeChckP e+    BlnElem x xs      -> typeChElm x xs+    BlnEQ x y         -> typeChEqB x y+    BlnNEQ x y        -> typeChEqB x y+    BlnGE x y         -> typeChck2 x y TNumber+    BlnGEQ x y        -> typeChck2 x y TNumber+    BlnLE x y         -> typeChck2 x y TNumber+    BlnLEQ x y        -> typeChck2 x y TNumber+    BlnNot x          -> typeCheck x TBoolean+    BlnOr x y         -> typeChck2 x y TBoolean+    BlnAnd x y        -> typeChck2 x y TBoolean+    BlnImpl x y       -> typeChck2 x y TBoolean+    BlnEquiv x y      -> typeChck2 x y TBoolean+    BlnROr xs x       -> typeChckO xs x TBoolean+    BlnRAnd xs x      -> typeChckO xs x TBoolean+    _                 -> typeChIdF e TBoolean++  -- check LTL formula types+  TLtl -> case expr e of+    BaseTrue          -> return ()+    BaseFalse         -> return ()+    BlnElem x xs      -> typeChElm x xs+    BlnEQ x y         -> typeChEqL x y+    BlnNEQ x y        -> typeChEqL x y+    BlnGE x y         -> typeChck2 x y TNumber+    BlnGEQ x y        -> typeChck2 x y TNumber+    BlnLE x y         -> typeChck2 x y TNumber+    BlnLEQ x y        -> typeChck2 x y TNumber+    BlnNot x          -> typeCheck x TLtl+    BlnOr x y         -> typeChck2 x y TLtl+    BlnAnd x y        -> typeChck2 x y TLtl+    BlnImpl x y       -> typeChck2 x y TLtl+    BlnEquiv x y      -> typeChck2 x y TLtl+    BlnROr xs x       -> typeChckO xs x TLtl+    BlnRAnd xs x      -> typeChckO xs x TLtl+    LtlNext x         -> typeCheck x TLtl+    LtlRNext x y      -> typeChckR x y+    LtlGlobally x     -> typeCheck x TLtl+    LtlRGlobally x y  -> typeChckR x y+    LtlFinally x      -> typeCheck x TLtl+    LtlRFinally x y   -> typeChckR x y+    LtlUntil x y      -> typeChck2 x y TLtl+    LtlWeak x y       -> typeChck2 x y TLtl+    LtlRelease x y    -> typeChck2 x y TLtl+    _                 -> typeChIdF e TLtl++  TPattern -> case expr e of+    BaseTrue          -> return ()+    BaseFalse         -> return ()+    BaseWild          -> return ()+    BlnElem x xs      -> typeChElm x xs+    BlnEQ x y         -> typeChck2 x y TNumber+    BlnNEQ x y        -> typeChck2 x y TNumber+    BlnGE x y         -> typeChck2 x y TNumber+    BlnGEQ x y        -> typeChck2 x y TNumber+    BlnLE x y         -> typeChck2 x y TNumber+    BlnLEQ x y        -> typeChck2 x y TNumber+    BlnNot x          -> typeCheck x TPattern+    BlnOr x y         -> typeChck2 x y TPattern+    BlnAnd x y        -> typeChck2 x y TPattern+    BlnImpl x y       -> typeChck2 x y TPattern+    BlnEquiv x y      -> typeChck2 x y TPattern+    BlnROr xs x       -> typeChckO xs x TPattern+    BlnRAnd xs x      -> typeChckO xs x TPattern+    LtlNext x         -> typeCheck x TPattern+    LtlRNext x y      -> typeChckU x y+    LtlGlobally x     -> typeCheck x TPattern+    LtlRGlobally x y  -> typeChckU x y+    LtlFinally x      -> typeCheck x TPattern+    LtlRFinally x y   -> typeChckU x y+    LtlUntil x y      -> typeChck2 x y TPattern+    LtlWeak x y       -> typeChck2 x y TPattern+    LtlRelease x y    -> typeChck2 x y TPattern+    _                 -> typeChIdF e TPattern++  TPoly i -> inferFromExpr e >>= \case+    TPoly j+      | i == j     -> typeChIdF e $ TPoly i+      | otherwise -> equalPolyType i j >> inferFromExpr e >>= typeCheck e+    t             -> updatePolyType i t >> typeCheck e t++-----------------------------------------------------------------------------++typeChIdF+  :: Expression -> ExprType -> TC ()++typeChIdF e t = case expr e of+  BaseId i     -> typeCheckId t i $ srcPos e+  BaseFml xs f -> typeCheckFml t xs f $ srcPos e+  BaseBus x b  -> typeCheckBus t x b $ srcPos e+  Colon x y    -> typeCheck x TBoolean >> typeCheck y t+  x            -> do+    TSet t' <- inferFromExpr e+    errExpect t t' $ srcPos e++-----------------------------------------------------------------------------++typeCheckBus+  :: ExprType -> Expression -> ID -> ExprPos -> TC ()++typeCheckBus t n b p = do+  typeCheck n TNumber++  ((! b) . tTypes) <$> get >>= \case+    TBus s'          -> case t of+      TSignal s -> case (s,s') of+        (STInput, STOutput) -> errExpect t (TSignal s') p+        (STOutput, STInput) -> errExpect t (TSignal s') p+        _                   -> return ()+      TLtl      -> return ()+      _         -> errExpect t (TSignal s') p+    TTypedBus s' _ _ -> case t of+      TSignal s -> case (s,s') of+        (STInput, STOutput) -> errExpect t (TSignal s') p+        (STOutput, STInput) -> errExpect t (TSignal s') p+        _                   -> return ()+      TLtl      -> return ()+      _         -> errExpect t (TSignal s') p+    TPoly p          -> updatePolyType p $ TBus STGeneric+    t'               -> errExpect t t' p++-----------------------------------------------------------------------------++typeCheckId+  :: ExprType -> Int -> ExprPos -> TC ()++typeCheckId t i p = do+  -- get the arguments of the identifier+  as <- ((! i) . arguments . spec) <$> get++  -- higher order functions are not supported+  unless (null as) $ do+    Specification{..} <- spec <$> get+    errNoHigher (names ! i) p++  tt <- tTypes <$> get+  validTypes p i t (tt ! i)++-----------------------------------------------------------------------------++validTypes+  :: ExprPos -> Int -> ExprType -> ExprType+      -> StateT ST (Either Error) ()++validTypes p i = vt+  where+    vt (TSignal STGeneric) (TSignal _)         = return ()+    vt (TSignal _)         (TSignal STGeneric) = return ()+    vt (TBus STGeneric)    (TBus _)            = return ()+    vt (TBus _)            (TBus STGeneric)    = return ()+    vt (TEnum m x)         (TTypedBus _ n y)   = vt (TEnum m x) $ TEnum n y+    vt (TTypedBus _ m x)   (TEnum n y)         = vt (TEnum m x) $ TEnum n y+    vt (TTypedBus _ m x)   (TTypedBus _ n y)   = vt (TEnum m x) $ TEnum n y+    vt TEmptySet           (TSet _)            = return ()+    vt (TSet s)            TEmptySet           = updType (TSet s) i+    vt (TSet s)            (TSet s')           = vt s s'+    vt TLtl                TBoolean            = return ()+    vt TLtl                (TSignal _)         = return ()+    vt (TPoly p')          (TPoly p)           = equalPolyType p p'+    vt (TPoly _)           _                   = return ()+    vt t                   (TPoly p)           = updatePolyType p t+    vt t                   t'+      | t == t'    = return ()+      | otherwise = errExpect t t' p++-----------------------------------------------------------------------------++typeCheckFml+  :: ExprType -> [Expression] -> Int -> ExprPos -> TC ()++typeCheckFml t xs f p = do+  -- get the position of the definition of f+  pf <- ((! f) . positions . spec) <$> get+  -- get athe rguments of f+  as <- ((! f) . arguments . spec) <$> get+  -- get current type table+  tt <- tTypes <$> get+  -- get argument types of f+  let at = map (tt !) as++  -- check argument arity+  when (length as /= length xs) $+    errArgArity (show $ length xs) (length as) pf p++  -- typecheck the arguments+  mapM_ (uncurry typeCheck) $ zip xs at+  -- get the result type+  rt <- ((! f) . tTypes) <$> get+  -- reset bound types for dependant functions (polymorphism)+  resetDependencies tt f+  -- check the compatibility of the result type+  validTypes p f t rt++-----------------------------------------------------------------------------++resetDependencies+  :: TypeTable -> ID -> TC ()++resetDependencies tt x = do+  i <- curBinding <$> get+  as <- (S.fromList . (! x) . arguments . spec) <$> get+  ds <- (S.fromList . (! x) . dependencies . spec) <$> get++  if i == x+  then+    mapM_ (resetDependencies tt) $+    S.toList $+    S.difference ds $+    S.insert x as+  else do+    resetType tt x+    mapM_ (resetDependencies tt) $+      filter (/= x) $ S.toList ds++-----------------------------------------------------------------------------++resetType+  :: TypeTable -> Int -> TC ()++resetType tt i = do+  st@ST{..} <- get+  put st { tTypes = insert i (tt ! i) tTypes }++-----------------------------------------------------------------------------++updType+  :: ExprType -> ID -> TC ()++updType t i = do+  st@ST{..} <- get+  put st { tTypes = insert i t tTypes }++-----------------------------------------------------------------------------++equalPolyType+  :: Int -> Int -> TC ()++equalPolyType n m = do+  st@ST{..} <- get+  put st { tTypes = IM.map upd tTypes }++  where+    upd = \case+      TPoly x+        | x == n || x == m -> TPoly $ min n m+        | otherwise     -> TPoly x+      x                 -> x++-----------------------------------------------------------------------------++updatePolyType+  :: Int -> ExprType -> TC ()++updatePolyType n t = do+  st@ST{..} <- get+  put st { tTypes = IM.map upd tTypes }++  where+    upd = \case+      TPoly x+        | x == n     -> t+        | otherwise -> TPoly x+      x             -> x++-----------------------------------------------------------------------------++typeChEqL+  :: Expression -> Expression -> TC ()++typeChEqL x y = inferFromExpr x >>= \case+  TNumber -> typeChck2 x y TNumber+  TTypedBus s m i -> inferFromExpr y >>= \case+    TEnum n j+      | i == j     -> return ()+      | otherwise -> errExpect (TEnum m i) (TEnum n j) $ srcPos y+    t -> errExpect (TEnum m i) t $ srcPos y+  TEnum n j -> inferFromExpr y >>= \case+    TTypedBus s m i+      | i == j     -> return ()+      | otherwise -> errExpect+                      (TTypedBus STGeneric n j)+                      (TTypedBus STGeneric m i)+                      (srcPos y)+    t -> errExpect (TTypedBus STGeneric n j) t $ srcPos y+  TPoly p -> inferFromExpr y >>= \case+    TNumber         -> updatePolyType p TNumber+    TEnum n j       -> updatePolyType p (TTypedBus STGeneric n j)+    TTypedBus _ n j -> updatePolyType p (TEnum n j)+    TPoly p'        -> equalPolyType p p'+    t               -> errEquality t $ srcPos y+  t -> errEquality t $ srcPos x++-----------------------------------------------------------------------------++typeChEqB+  :: Expression -> Expression -> TC ()++typeChEqB x y = inferFromExpr x >>= \case+  TNumber -> typeChck2 x y TNumber+  TPoly p -> inferFromExpr y >>= \case+    TNumber -> updatePolyType p TNumber+    TPoly p'-> updatePolyType p TNumber >> updatePolyType p' TNumber+    t       -> errExpect TNumber t $ srcPos y+  t       -> errExpect TNumber t $ srcPos x++-----------------------------------------------------------------------------++typeChck2+  :: Expression -> Expression -> ExprType -> TC ()++typeChck2 x y t = do+  typeCheck x t+  typeCheck y t++-----------------------------------------------------------------------------++typeChSEx+  :: ExprType -> [Expression] -> TC ()++typeChSEx t =+  mapM_ (`typeCheck` t)++-----------------------------------------------------------------------------++typeChSRg+  :: Expression -> Expression -> Expression -> TC ()++typeChSRg x y z = do+  typeCheck x TNumber+  typeCheck y TNumber+  typeCheck z TNumber++-----------------------------------------------------------------------------++typeChckS+  :: Expression -> TC ()++typeChckS x =+  inferFromExpr x >>= typeCheck x++-----------------------------------------------------------------------------++typeChElm+  :: Expression -> Expression -> TC ()++typeChElm x xs = do+  inferFromExpr x >>= typeCheck x+  inferFromExpr x >>= (typeCheck xs . TSet)++-----------------------------------------------------------------------------++typeChckR+  :: Expression -> Expression -> StateT ST (Either Error) ()++typeChckR e x = case expr e of+  Colon n m -> do+    typeCheck n TNumber+    typeCheck m TNumber+    typeCheck x TLtl+  _         -> do+    typeCheck e TNumber+    typeCheck x TLtl++-----------------------------------------------------------------------------++typeChckU+  :: Expression -> Expression -> StateT ST (Either Error) ()++typeChckU e x = case expr e of+  Colon n m -> do+    typeCheck n TNumber+    typeCheck m TNumber+    typeCheck x TPattern+  _         -> do+    typeCheck e TNumber+    typeCheck x TPattern++-----------------------------------------------------------------------------++typeChckP+  :: Expression -> StateT ST (Either Error) ()++typeChckP (expr -> Pattern x y) = do+  typeCheck x TLtl+  typeCheck y TPattern++-----------------------------------------------------------------------------++typeChckO+  :: [Expression] -> Expression -> ExprType -> StateT ST (Either Error) ()++typeChckO xs y t = do+  mapM_ typeChckI xs+  typeCheck y t++-----------------------------------------------------------------------------++typeChckI+  :: Expression -> StateT ST (Either Error) ()++typeChckI = expr >>> \case+  BlnElem x xs                 -> typeChElm x xs+  BlnLE (expr -> BlnLE x y) z   -> typeChSRg x y z+  BlnLE (expr -> BlnLEQ x y) z  -> typeChSRg x y z+  BlnLEQ (expr -> BlnLE x y) z  -> typeChSRg x y z+  BlnLEQ (expr -> BlnLEQ x y) z -> typeChSRg x y z+  _                            -> assert False undefined++-----------------------------------------------------------------------------++typeErrES+  :: Expression -> Expression -> StateT ST (Either Error) ()++typeErrES e x = do+  t <- inferFromExpr x+  typeCheck x t+  errExpect TEmptySet (TSet t) $ srcPos e++-----------------------------------------------------------------------------++typeChSBn+  :: ExprType -> Expression -> Expression -> StateT ST (Either Error) ()++typeChSBn t x y = do+  typeCheck x $ TSet t+  typeCheck y $ TSet t++-----------------------------------------------------------------------------++inferFromExpr+  :: Expression -> StateT ST (Either Error) ExprType++inferFromExpr e = case expr e of+  BaseCon {}        -> return TNumber+  NumSMin {}        -> return TNumber+  NumSMax {}        -> return TNumber+  NumSSize {}       -> return TNumber+  NumSizeOf {}      -> return TNumber+  NumPlus {}        -> return TNumber+  NumMinus {}       -> return TNumber+  NumMul {}         -> return TNumber+  NumDiv {}         -> return TNumber+  NumMod {}         -> return TNumber+  NumRPlus {}       -> return TNumber+  NumRMul {}        -> return TNumber+  BaseWild          -> return TPattern+  BaseOtherwise     -> return TBoolean+  Pattern {}        -> return TBoolean+  BaseTrue          -> inferFromBoolExpr e+  BaseFalse         -> inferFromBoolExpr e+  BlnEQ {}          -> inferFromBoolExpr e+  BlnNEQ {}         -> inferFromBoolExpr e+  BlnGE {}          -> inferFromBoolExpr e+  BlnGEQ {}         -> inferFromBoolExpr e+  BlnLE {}          -> inferFromBoolExpr e+  BlnLEQ {}         -> inferFromBoolExpr e+  BlnNot {}         -> inferFromBoolExpr e+  BlnOr {}          -> inferFromBoolExpr e+  BlnROr {}         -> inferFromBoolExpr e+  BlnAnd {}         -> inferFromBoolExpr e+  BlnRAnd {}        -> inferFromBoolExpr e+  BlnImpl {}        -> inferFromBoolExpr e+  BlnElem {}        -> inferFromBoolExpr e+  BlnEquiv {}       -> inferFromBoolExpr e+  BaseBus {}        -> return TLtl+  LtlNext {}        -> return TLtl+  LtlRNext {}       -> return TLtl+  LtlGlobally {}    -> return TLtl+  LtlRGlobally {}   -> return TLtl+  LtlFinally {}     -> return TLtl+  LtlRFinally {}    -> return TLtl+  LtlUntil {}       -> return TLtl+  LtlWeak {}        -> return TLtl+  LtlRelease {}     -> return TLtl+  SetRange {}       -> return $ TSet TNumber+  SetExplicit []    -> return TEmptySet+  SetExplicit (x:_) -> TSet <$> inferFromExpr x+  SetCup x y        -> inferSetOp x y+  SetCap x y        -> inferSetOp x y+  SetMinus x y      -> inferSetOp x y+  SetRCap _ x       -> inferFromExpr x+  SetRCup _ x       -> inferFromExpr x+  Colon _ x         -> inferFromExpr x+  BaseId i          -> (imLookup i . tTypes) <$> get+  BaseFml _ i       -> (imLookup i . tTypes) <$> get++  where+    inferSetOp x y =+      inferFromExpr x >>= \case+        TEmptySet -> inferFromExpr y+        t         -> return t++-----------------------------------------------------------------------------++inferFromBoolExpr+  :: Expression -> StateT ST (Either Error) ExprType++inferFromBoolExpr e = case expr e of+  SetExplicit xs -> inferFromBoolSet xs+  SetCup x y     -> inferFromBoolE2 x y+  SetCap x y     -> inferFromBoolE2 x y+  SetMinus x y   -> inferFromBoolE2 x y+  BaseTrue       -> return TBoolean+  BaseFalse      -> return TBoolean+  BlnEQ x y      -> inferFromEqExpr x y+  BlnNEQ x y     -> inferFromEqExpr x y+  BlnGE {}       -> return TBoolean+  BlnGEQ {}      -> return TBoolean+  BlnLE {}       -> return TBoolean+  BlnLEQ {}      -> return TBoolean+  BlnElem {}     -> return TBoolean+  BlnNot x       -> inferFromBoolExpr x+  BlnOr x y      -> inferFromBoolE2 x y+  BlnROr _ x     -> inferFromBoolExpr x+  BlnAnd x y     -> inferFromBoolE2 x y+  BlnRAnd _ x    -> inferFromBoolExpr x+  BlnImpl x y    -> inferFromBoolE2 x y+  BlnEquiv x y   -> inferFromBoolE2 x y+  BaseId i       -> inferFromBoolId i+  BaseFml _ i    -> inferFromBoolId i+  _              -> inferFromExpr e >>= \case+    TSignal _ -> return TLtl+    TLtl      -> return TLtl+    _         -> return TBoolean++  where+    inferFromEqExpr+      :: Expression -> Expression -> TC ExprType++    inferFromEqExpr x y = inferFromExpr x >>= \case+      TTypedBus {} -> return TLtl+      TEnum {}     -> return TLtl+      TPoly p      -> inferFromExpr y >>= \case+        TTypedBus {} -> return TLtl+        TEnum {}     -> return TLtl+        TPoly p'     -> return TLtl+        _            -> return TBoolean+      _            -> return TBoolean++    inferFromBoolId+      :: ID -> TC ExprType++    inferFromBoolId i =+      (imLookup i . tTypes) <$> get >>= \case+        TSignal _ -> return TLtl+        TLtl      -> return TLtl+        _         -> return TBoolean++    inferFromBoolE2+      :: Expression -> Expression -> TC ExprType++    inferFromBoolE2 x y =+      inferFromBoolExpr x >>= \case+        TBoolean         -> inferFromBoolExpr y >>= \case+          TSignal _ -> return TLtl+          TLtl      -> return TLtl+          _         -> return TBoolean+        TSet TBoolean    -> inferFromBoolExpr y >>= \case+          TSet (TSignal _) -> return $ TSet TLtl+          TSet TLtl        -> return $ TSet TLtl+          _                -> return $ TSet TBoolean+        TSignal {}       -> return TLtl+        TSet (TSignal _) -> return $ TSet TLtl+        TLtl             -> return TLtl+        TSet TLtl        -> return $ TSet TLtl+        TSet _           -> return $ TSet TBoolean+        _                -> return TBoolean++    inferFromBoolSet+      :: [Expression] -> TC ExprType++    inferFromBoolSet =+      fmap TSet . foldM inferFromBoolElement TBoolean++    inferFromBoolElement+      :: ExprType -> Expression -> TC ExprType++    inferFromBoolElement = \case+      TBoolean ->+        inferFromBoolExpr >=> \case+          TSignal _ -> return TLtl+          TLtl      -> return TLtl+          _         -> return TBoolean+      TSignal _ -> const $ return TLtl+      TLtl      -> const $ return TLtl+      _         -> const $ return TBoolean++-----------------------------------------------------------------------------
+ src/Reader/Parser.hs view
@@ -0,0 +1,117 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Parsing module containing all neccessary parsers.+--+-----------------------------------------------------------------------------++module Reader.Parser+  ( parse+  ) where++-----------------------------------------------------------------------------++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Error+  ( Error+  , parseError+  )++import Reader.Error+  ( errEnumConflict+  )++import Reader.Parser.Data+  ( Specification(..)+  )++import Reader.Parser.Info+  ( infoParser+  )++import Reader.Parser.Global+  ( globalParser+  )++import Reader.Parser.Component+  ( componentParser+  )++import Text.Parsec+  ( (<|>)+  )++import qualified Text.Parsec as P+  ( parse+  )++import Text.Parsec.String+  ( Parser+  )++-----------------------------------------------------------------------------++-- | @parseSpecification str @ parses a specification from the string @str@.++parse+  :: String -> Either Error Specification++parse str =+  case P.parse specificationParser "Syntax Error" str of+    Left err -> parseError err+    Right x  -> do+      mapM_ checkEnum $ enumerations x+      return x++-----------------------------------------------------------------------------++specificationParser+  :: Parser Specification++specificationParser = do+  (i,d,s,r,a) <- infoParser+  (ps,vs,ms) <- globalParser <|> return ([],[],[])+  (is,os,es,ss,rs,as,ns,gs) <- componentParser++  return Specification+    { title = i+    , description = d+    , semantics = s+    , target = r+    , tags = a+    , enumerations = ms+    , parameters = ps+    , definitions = vs+    , inputs = is+    , outputs = os+    , initially = es+    , preset = ss+    , requirements = rs+    , assumptions = as+    , invariants = ns+    , guarantees = gs+    }++-----------------------------------------------------------------------------++checkEnum+  :: EnumDefinition String -> Either Error ()++checkEnum e = case eDouble e of+  Just ((m,p),(x,_),(y,_),f) -> errEnumConflict m x y (toStr (eSize e) f) p+  Nothing                    -> return ()++  where+    toStr n f = map (toS . f) [0,1..n-1]++    toS (Right ())    = '*'+    toS (Left True)  = '1'+    toS (Left False) = '0'++-----------------------------------------------------------------------------
+ src/Reader/Parser/Component.hs view
@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Component+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Parser for the MAIN section.+--+-----------------------------------------------------------------------------++module Reader.Parser.Component+  ( componentParser+  ) where++-----------------------------------------------------------------------------++import Text.Parsec+  ( (<|>)+  , many+  , char+  , sepBy+  , oneOf+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec.Token+  ( GenLanguageDef(..)+  , makeTokenParser+  , braces+  , reservedOp+  , whiteSpace+  , reserved+  )++import Data.Types+  ( SignalDecType(..)+  )++import Data.Expression+  ( Expr(..)+  , ExprPos(..)+  )++import Reader.Parser.Data+  ( globalDef+  )++import Reader.Parser.Utils+  ( identifier+  , getPos+  )++import Reader.Parser.Expression+  ( exprParser+  )++import Data.Maybe+  ( catMaybes+  )++import Control.Monad+  ( void+  , liftM+  )++-----------------------------------------------------------------------------++data Component =+  Component+  { inputs :: [SignalDecType String]+  , outputs :: [SignalDecType String]+  , initially :: [Expr String]+  , preset :: [Expr String]+  , requirements :: [Expr String]+  , assumptions :: [Expr String]+  , invariants :: [Expr String]+  , guarantees :: [Expr String]+  }++-----------------------------------------------------------------------------++-- | Parses the MAIN section of a specification file. It returns:+--+--     * the input signals of the specification+--+--     * the output signals of the specification+--+--     * the initial configuration of the inputs+--+--     * the initial configuration of the outputs+--+--     * the requirements of the specification+--+--     * the assumptions of the specification+--+--     * the invariants of the specification+--+--     * the guarantees of the specification++componentParser+  :: Parser ([SignalDecType String], [SignalDecType String],+            [Expr String], [Expr String], [Expr String],+            [Expr String], [Expr String], [Expr String])++componentParser = do+  keyword "MAIN"+  xs <- br $ many $ componentContentParser+        Component+        { inputs = []+        , outputs = []+        , initially = []+        , preset = []+        , requirements = []+        , assumptions = []+        , invariants = []+        , guarantees = []+        }++  return+    ( concatMap inputs xs+    , concatMap outputs xs+    , concatMap initially xs+    , concatMap preset xs+    , concatMap requirements xs+    , concatMap assumptions xs+    , concatMap invariants xs+    , concatMap guarantees xs )++  where+    tokenparser =+      makeTokenParser globalDef+      { opStart = oneOf "=;"+      , opLetter = oneOf "=;"+      , reservedOpNames = [ "=", ";" ]+      , reservedNames =+          [ "MAIN"+          , "INPUTS"+          , "OUTPUTS"+          , "INITIALLY"+          , "PRESET"+          , "ASSUME"+          , "ASSUMPTIONS"+          , "REQUIRE"+          , "REQUIREMENTS"+          , "ASSERT"+          , "INVARIANTS"+          , "GUARANTEE"+          , "GUARANTEES"+          ]+      }++    componentContentParser c =+          (sectionParser "INPUTS" signalParser+             >>= \x -> return c { inputs = x       })+      <|> (sectionParser "OUTPUTS" signalParser+             >>= \x -> return c { outputs = x      })+      <|> (sectionParser "INITIALLY" exprParser+             >>= \x -> return c { initially = x    })+      <|> (sectionParser "PRESET" exprParser+             >>= \x -> return c { preset = x       })+      <|> (sectionParser "REQUIRE" exprParser+             >>= \x -> return c { requirements = x })+      <|> (sectionParser "REQUIREMENTS" exprParser+             >>= \x -> return c { requirements = x })+      <|> (sectionParser "ASSUME" exprParser+             >>= \x -> return c { assumptions = x  })+      <|> (sectionParser "ASSUMPTIONS" exprParser+             >>= \x -> return c { assumptions = x  })+      <|> (sectionParser "ASSERT" exprParser+             >>= \x -> return c { invariants = x   })+      <|> (sectionParser "INVARIANTS"  exprParser+             >>= \x -> return c { invariants = x   })+      <|> (sectionParser "GUARANTEE"  exprParser+             >>= \x -> return c { guarantees = x   })+      <|> (sectionParser "GUARANTEES"  exprParser+             >>= \x -> return c { guarantees = x   })++    signalParser = do+      (x,pos) <- identifier (~~)+      typedBusParser x pos+        <|> busParser x pos+        <|> return (SDSingle (x,pos))++    busParser x pos = do+      ch '['; (~~)+      e <- exprParser+      ch ']'; p <- getPos; (~~)+      return $ SDBus (x,(ExprPos (srcBegin pos) p)) e++    typedBusParser x pos = do+      (y,p) <- identifier (~~)+      return $ SDEnum (y,p) (x,pos)++    sectionParser x p = do+      keyword x+      xs <- br $ sepBy (nonEmptyParser p) $ rOp ";"+      return $ catMaybes xs++    nonEmptyParser p =+      liftM return p <|> return Nothing++    ch = void . char+    br = braces tokenparser+    rOp = reservedOp tokenparser+    (~~) = whiteSpace tokenparser+    keyword = void . reserved tokenparser++-----------------------------------------------------------------------------
+ src/Reader/Parser/Data.hs view
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Data+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Common data used by the parser module.+--+-----------------------------------------------------------------------------++module Reader.Parser.Data+  ( Specification(..)+  , globalDef+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( SignalDecType+  )++import Data.Enum+  ( EnumDefinition+  )++import Data.Types+  ( Target+  , Semantics+  )++import Data.Expression+  ( Expr+  , ExprPos(..)+  )++import Data.Binding+  ( BindExpr+  )++import Text.Parsec+  ( (<|>)+  , char+  , letter+  , alphaNum+  )++import Text.Parsec.Token+  ( LanguageDef+  , GenLanguageDef(..)+  )++import Text.Parsec.Language+  ( emptyDef+  )++-----------------------------------------------------------------------------++-- | The @Specification@ record contains all the data of a+-- specification that is extracted by the parsing process. This includes:+--+--     * The title of the specification+--+--     * The description of the specification+--+--     * The semantics flag of the specification+--+--     * The target flag of the specification+--+--     * The tag list of the specification+--+--     * The list of bindings of an identifier to an+--       expression defined in the PARAMETERS subsection+--+--     * The list of bindings of an identifier to any+--       other expression defined in the DEFINITIONS subsection+--+--     * The list of input signals+--+--     * The list of output signals+--+--     * The list of expresssions representing the initial input of+--       the environment+--+--     * The list of expresssions representing the initial output of+--       the system+--+--     * The list of expresssions representing the globally asserted+--       requirements on the inputs of the specification+--+--     * The list of expresssions representing the+--       assumptions of the specification+--+--     * The list of expressions representing the+--       invariants of the specification+--+--     * The list of expressions representing the+--       guarantees of the specification++data Specification =+  Specification+  { title :: (String, ExprPos)+  , description :: (String, ExprPos)+  , semantics :: (Semantics, ExprPos)+  , target :: (Target, ExprPos)+  , tags :: [(String, ExprPos)]+  , enumerations :: [EnumDefinition String]+  , parameters :: [BindExpr String]+  , definitions :: [BindExpr String]+  , inputs :: [SignalDecType String]+  , outputs :: [SignalDecType String]+  , initially :: [Expr String]+  , preset :: [Expr String]+  , requirements :: [Expr String]+  , assumptions :: [Expr String]+  , invariants :: [Expr String]+  , guarantees :: [Expr String]+  }++-----------------------------------------------------------------------------++-- | The language definition which is shared among all parsers.++globalDef+  :: LanguageDef a++globalDef =+  emptyDef+  { identStart     = letter <|> char '_' <|> char '@'+  , identLetter    = alphaNum <|> char '_' <|> char '@' <|> char '\''+  , commentLine    = "//"+  , commentStart   = "/*"+  , commentEnd     = "*/"+  , nestedComments = True+  , caseSensitive  = True+  }++-----------------------------------------------------------------------------
+ src/Reader/Parser/Expression.hs view
@@ -0,0 +1,362 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Expression+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Expression Parser.+--+-----------------------------------------------------------------------------++module Reader.Parser.Expression+  ( exprParser+  ) where++-----------------------------------------------------------------------------++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  , SrcPos(..)+  , ExprPos(..)+  )++import Reader.Parser.Data+  ( globalDef+  )++import Reader.Parser.Utils+  ( getPos+  , identifier+  , positionParser+  )++import Control.Monad+  ( liftM+  , void+  )++import Text.Parsec+  ( (<|>)+  , char+  , try+  , oneOf+  , many1+  , digit+  , lookAhead+  , notFollowedBy+  )++import Text.Parsec.Expr+  ( Assoc(..)+  , Operator(..)+  , buildExpressionParser+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec.Token+  ( GenLanguageDef(..)+  , commaSep+  , reservedNames+  , whiteSpace+  , makeTokenParser+  , reserved+  , reservedOp+  )++-----------------------------------------------------------------------------++-- | Parses an expression.++exprParser+  :: Parser (Expr String)++exprParser = (~~) >> buildExpressionParser table term+  where+    table =+      [ [ Prefix $ unaryOperators numUnary+        ]++      , [ Infix  (binOp "*"        NumMul)     AssocLeft+        , Infix  (binOp "MUL"      NumMul)     AssocLeft+        ]+      , [ Infix  (binOp "/"        NumDiv)     AssocRight+        , Infix  (binOp "DIV"      NumDiv)     AssocRight+        , Infix  (binOp "%"        NumMod)     AssocRight+        , Infix  (binOp "MOD"      NumMod)     AssocRight+        ]+      , [ Infix  (binOp "+"        NumPlus)    AssocLeft+        , Infix  (binOp "PLUS"     NumPlus)    AssocLeft+        , Infix  (binOp "-"        NumMinus)   AssocLeft+        , Infix  (binOp "MINUS"    NumMinus)   AssocLeft+        ]++      , [ Prefix $ unaryOperators setUnary+        ]++      , [ Infix  (binOp "(-)"      SetMinus)   AssocRight+        , Infix  (binOp "(\\)"     SetMinus)   AssocRight+        , Infix  (binOp "SETMINUS" SetMinus)   AssocRight+        ]+      , [ Infix  (binOp "(*)"      SetCap)     AssocLeft+        , Infix  (binOp "CAP"      SetCap)     AssocLeft+        ]+      , [ Infix  (binOp "(+)"      SetCup)     AssocLeft+        , Infix  (binOp "CUP"      SetCup)     AssocLeft+        ]+      , [ Infix  (binOp "=="       BlnEQ)      AssocLeft+        , Infix  (binOp "EQ"       BlnEQ)      AssocLeft+        , Infix  (binOp "/="       BlnNEQ)     AssocLeft+        , Infix  (binOp "!="       BlnNEQ)     AssocLeft+        , Infix  (binOp "NEQ"      BlnNEQ)     AssocLeft+        , Infix  (binOp ">"        BlnGE)      AssocLeft+        , Infix  (binOp "GE"       BlnGE)      AssocLeft+        , Infix  (binOp ">="       BlnGEQ)     AssocLeft+        , Infix  (binOp "GEQ"      BlnGEQ)     AssocLeft+        , Infix  (binOp "<"        BlnLE)      AssocLeft+        , Infix  (binOp "LE"       BlnLE)      AssocLeft+        , Infix  (binOp "<="       BlnLEQ)     AssocLeft+        , Infix  (binOp "LEQ"      BlnLEQ)     AssocLeft+        ]+      , [ Infix  (binOp "<-"       BlnElem)    AssocLeft+        , Infix  (binOp "IN"       BlnElem)    AssocLeft+        , Infix  (binOp "ELEM"     BlnElem)    AssocLeft+        ]++      , [ Prefix $ unaryOperators ltlUnary+        ]++      , [ Infix  (binOp "&&"       BlnAnd)     AssocLeft+        , Infix  (binOp "AND"      BlnAnd)     AssocLeft+        ]+      , [ Infix  (binOp "||"       BlnOr)      AssocLeft+        , Infix  (binOp "OR"       BlnOr)      AssocLeft+        ]+      , [ Infix  (binOp "->"       BlnImpl)    AssocRight+        , Infix  (binOp "IMPIES"   BlnImpl)    AssocRight+        , Infix  (binOp "<->"      BlnEquiv)   AssocRight+        , Infix  (binOp "EQUIV"    BlnEquiv)   AssocRight+        ]+      , [ Infix  (binOp "W"        LtlWeak)    AssocRight+        ]+      , [ Infix  (binOp "U"        LtlUntil)   AssocRight+        ]+      , [ Infix  (binOp "R"        LtlRelease) AssocLeft+        ]+      , [ Infix  (binOp "~"        Pattern)    AssocLeft+        ]+      , [ Infix  (binOp ":"        Colon)      AssocLeft+        ]+      ]++    tokenDef =+      globalDef+      { opStart = oneOf "!&|-<=/+*%(:~,."+      , opLetter = oneOf "!&|<->=/\\[+*%():~,."+      , reservedOpNames =+          ["!","&&","||","->","<->","==","/=","<",">","<=",">=",+           "<-","&&[","||[","NOT","AND","OR","IMPLIES","EQUIV","EQ",+           "NEQ", "LE", "GE", "LEQ", "GEQ", "ELEM","AND[","OR[",+           "+","-","*","/","%","PLUS","MINUS","MUL","DIV","MOD",+           "SIZE","MIN","MAX","(-)","(\\)","(+)","(*)","SETMINUS",+           "CAP","CUP",":","~","W","U","R","X","G","F",",","X[",+           "G[","F[","AND[","OR[","SUM","PROD","IN","SIZEOF"]+      , reservedNames =+          ["NOT","AND","OR","IMPLIES","EQUIV","true","false","F",+           "PLUS","MINUS","MUL","DIV","MOD","SIZE","MIN","MAX","_",+           "SETMINUS","CAP","CUP","otherwise","W","U","R","X","G",+           "SUM","PROD","IN","SIZEOF"] }++    tokenparser = makeTokenParser tokenDef++    term =+          parentheses+      <|> setExplicit+      <|> between' '|' '|' (liftM NumSSize exprParser)+      <|> keyword "otherwise" BaseOtherwise+      <|> keyword "false" BaseFalse+      <|> keyword "true" BaseTrue+      <|> keyword "_" BaseWild+      <|> constant+      <|> ident++    numUnary =+          unOp6 'S' 'I' 'Z' 'E' 'O' 'F' NumSizeOf+      <|> unOp4 'S' 'I' 'Z' 'E' NumSSize+      <|> unOp3 'M' 'I' 'N' NumSMin+      <|> unOp3 'M' 'A' 'X' NumSMax+      <|> parOp "+" manyExprParser NumRPlus+      <|> parOp "SUM" manyExprParser NumRPlus+      <|> parOp "*" manyExprParser NumRMul+      <|> parOp "PROD" manyExprParser NumRMul++    setUnary =+          parOp "(+)" manyExprParser SetRCup+      <|> parOp "CUP" manyExprParser SetRCap+      <|> parOp "(-)" manyExprParser SetRCup+      <|> parOp "CAP" manyExprParser SetRCap++    ltlUnary =+          unOp' '!' BlnNot+      <|> unOp3 'N' 'O' 'T' BlnNot+      <|> unOp1 'X' LtlNext+      <|> unOp1 'G' LtlGlobally+      <|> unOp1 'F' LtlFinally+      <|> parOp "X" exprParser LtlRNext+      <|> parOp "G" exprParser LtlRGlobally+      <|> parOp "F" exprParser LtlRFinally+      <|> parOp "&&" manyExprParser BlnRAnd+      <|> parOp "AND" manyExprParser BlnRAnd+      <|> parOp "FORALL" manyExprParser BlnRAnd+      <|> parOp "||" manyExprParser BlnROr+      <|> parOp "OR" manyExprParser BlnROr+      <|> parOp "EXISTS" manyExprParser BlnROr++    parentheses = do+      notFollowedBy $ ch '(' >> oneOf "+-*/"+      between' '(' ')' $ liftM expr exprParser++    keyword x c = do+      s <- getPos+      void $ reserved tokenparser x+      return $ Expr c $ ExprPos s $+        SrcPos (srcLine s) (srcColumn s + length x)++    setExplicit = do+      s <- getPos; ch '{'; (~~)+      emptySet s <|> nonEmptySet s++    emptySet s = do+      e <- closeSet+      return $ Expr (SetExplicit []) (ExprPos s e)++    nonEmptySet s = do+      x <- exprParser+      singeltonSet s x <|> nonSingeltonSet s x++    singeltonSet s x = do+      e <- closeSet+      return $ Expr (SetExplicit [x]) (ExprPos s e)++    nonSingeltonSet s x = do+      ch ','; (~~)+      y <- exprParser+      twoElmSet s x y <|> rangeSet s x y <|> manyElmSet s x y++    twoElmSet s x y = do+      e <- closeSet+      return $ Expr (SetExplicit [x,y]) (ExprPos s e)++    rangeSet s x y = do+      ch '.'; ch '.'; (~~)+      z <- exprParser+      e <- closeSet+      return $ Expr (SetRange x y z) (ExprPos s e)++    manyElmSet s x y = do+      ch ','; (~~)+      xs <- manyExprParser+      e <- closeSet+      return $ Expr (SetExplicit (x:y:xs)) (ExprPos s e)++    closeSet = do { ch '}'; e <- getPos; (~~); return e }++    binOp x c = do+      reservedOp tokenparser x+      return $ \a b -> Expr (c a b) $+                       ExprPos (srcBegin $ srcPos a) $+                       srcEnd $ srcPos b++    unaryOperators p = do+      (x:xr) <- many1 $ unaryOperator p+      return $ conUnOp x xr++    unaryOperator p = do+      s <- getPos+      c <- p+      return (s,c)++    conUnOp (s,c) xs = case xs of+      []     -> \e -> Expr (c e) $+                      ExprPos s $ srcEnd $ srcPos e+      (x:xr) -> \e -> Expr (c $ conUnOp x xr e) $+                      ExprPos s $ srcEnd $ srcPos e++    unOp6 c1 c2 c3 c4 c5 c6 c = try $ do+      ch4 c1 c2 c3 c4+      ch2 c5 c6+      lookahead+      return c++    unOp4 c1 c2 c3 c4 c = try $ do+      ch4 c1 c2 c3 c4+      lookahead+      return c++    unOp' x c = do+      ch x+      (~~)+      return c++    unOp1 x c = try $ do+      ch x+      lookahead+      return c++    unOp3 c1 c2 c3 c = try $ do+      ch2 c1 c2+      ch c3+      lookahead+      return c++    parOp x p c = do+      reservedOp tokenparser (x ++ "[")+      e <- p; ch ']'; (~~)+      return (c e)++    between' c1 c2 p = do+      s <- getPos; ch c1; (~~); x <- p+      ch c2; e <- getPos; (~~)+      return $ Expr x $ ExprPos s e++    constant = do+      (x,pos) <- positionParser (~~) $ many1 digit+      return $ Expr (BaseCon $ read x) pos++    ident = do+      (i,pos) <- identifier (~~)+      functionParser pos i+        <|> busParser pos i+        <|> return (Expr (BaseId i) pos)++    functionParser pos i = do+      notFollowedBy $ ch '(' >> oneOf "+-*/"+      ch '('; (~~)+      ys <- manyExprParser+      ch ')'; e <- getPos; (~~)+      return $ Expr (BaseFml ys i) $+        ExprPos (srcBegin pos) e++    busParser pos i = do+      ch '['; (~~)+      x <- exprParser+      ch ']'; p <- getPos; (~~)+      return $ Expr (BaseBus x i) $+        ExprPos (srcBegin pos) p++    manyExprParser = commaSep tokenparser exprParser++    (~~) = whiteSpace tokenparser++    lookahead = do+      lookAhead (ch ' ' <|> ch '(' <|> ch '\t' <|> ch '\n')+      (~~)++    ch = void . char+    ch2 c1 c2 = do { ch c1; ch c2 }+    ch4 c1 c2 c3 c4 = do { ch2 c1 c2; ch2 c3 c4 }++-----------------------------------------------------------------------------
+ src/Reader/Parser/Global.hs view
@@ -0,0 +1,260 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Global+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Parser for the GLOBAl section.+--+-----------------------------------------------------------------------------++module Reader.Parser.Global+  ( globalParser+  ) where++-----------------------------------------------------------------------------++import Data.List+  ( find+  )++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Binding+  ( BindExpr(..)+  )++import Data.Expression+  ( ExprPos(..)+  )++import Reader.Parser.Data+  ( globalDef+  )++import Reader.Parser.Utils+  ( identifier+  , getPos+  )++import Reader.Parser.Expression+  ( exprParser+  )++import Data.Either+  ( partitionEithers+  )++import Data.Maybe+  ( catMaybes+  )++import Control.Monad+  ( void+  )++import Text.Parsec+  ( (<|>)+  , char+  , oneOf+  , sepBy+  , many1+  , many+  , count+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec.Token+  ( GenLanguageDef(..)+  , commaSep+  , reservedNames+  , whiteSpace+  , makeTokenParser+  , reserved+  , braces+  , reservedOp+  )++import Control.Exception+  ( assert+  )++import qualified Data.Array.IArray as A+  ( Array+  , (!)+  , array+  )++-----------------------------------------------------------------------------++-- | Parses the GLOBAL section of a specification file and returns the list+-- of parameter bindings and the list of the remaining definitions.++globalParser+  :: Parser ([BindExpr String], [BindExpr String], [EnumDefinition String])++globalParser = do+  keyword "GLOBAL"+  ch '{'; (~~)+  globalContentParser [] [] []++  where+    tokenparser =+      makeTokenParser globalDef+      { opStart = oneOf "=;:"+      , opLetter = oneOf "=;:"+      , reservedOpNames = [ "=", ";", ":"]+      , reservedNames =+          [ "GLOBAL"+          , "PARAMETERS"+          , "DEFINITIONS"+          , "enum"+          ]+      }++    globalContentParser ps gs ns =+          do { ch '}'; (~~); return (ps,gs,ns) }+      <|> do { keyword "PARAMETERS"; x <- sectionParser;+               globalContentParser (ps ++ x) gs ns }+      <|> do { keyword "DEFINITIONS"; (x,y) <- sectionEnumParser;+               globalContentParser ps (gs ++ x) (ns ++ y) }++    sectionParser = do+      xs <- br $ sepBy assignmentParser $ rOp ";"+      return $ catMaybes xs++    sectionEnumParser = do+      xs <- br $ sepBy assignmentEnumParser $ rOp ";"+      return $ partitionEithers $ catMaybes xs++    assignmentParser =+          nonemptyAssignmentParser+      <|> return Nothing++    assignmentEnumParser =+          enumParser+      <|> nonemptyAssignmentEnumParser+      <|> return Nothing++    nonemptyAssignmentParser = do+      (x,pos) <- identifier (~~)+      argumentsParser x pos <|> reminderParser x [] pos++    nonemptyAssignmentEnumParser = do+      (x,pos) <- identifier (~~)+      argumentsEnumParser x pos <|> reminderEnumParser x [] pos++    enumParser = do+      keyword "enum"+      (x,pos) <- identifier (~~)+      rOp "="+      (v,n) <- enumVParser+      vr <- many (enumVParserL n)+      let (d,m) = analyze n (x,pos) (v:vr)+      return $ Just $ Right EnumDefinition {+        eName = x,+        eSize = n,+        ePos = pos,+        eValues = v : vr,+        eMissing = m,+        eDouble = d+        }++    analyze n e vs = let+        as = [ (v, appears v vs) | v <- allValues [[]] n ]+        ms = map (toMap n . fst) $ filter (null . snd) as+      in case find ((> 1) . length . snd) as of+        Nothing        -> (Nothing, ms)+        Just (v,x:y:_) -> (Just (e,x,y,toMap n v), ms)+        _              -> assert False undefined++    appears vs = foldl (appV vs) []++    appV vs a (m,p,xs) = foldl (appF vs m p) a xs++    appF vs m p a f+      | cmpF f (reverse vs) = (m,p) :a+      | otherwise           = a++    cmpF _ []     = True+    cmpF f (x:xr) = case f $ length xr of+      Right () -> cmpF f xr+      v       -> v == x && cmpF f xr++    allValues a n+      | n <= 0     = a+      | otherwise =+        allValues (map (Left True :) a +++                   map (Left False :) a) (n-1)++    enumVParser = do+      (x,p) <- identifier (~~)+      rOp ":"+      v <- valueParser+      vr <- many $ valueSepParserL (length v)+      (~~)+      let fs = map (toMap (length v)) (v:vr)+      return ((x, p, fs), length v)++    enumVParserL n = do+      (x,p) <- identifier (~~)+      rOp ":"+      v <- valueParserL n+      vr <- many $ valueSepParserL n+      (~~)+      let fs = map (toMap n) (v:vr)+      return (x, p, fs)++    toMap n xs =+      let+        a :: A.Array Int (Either Bool ())+        a = A.array (0,n-1) $ zip [0,1..n-1] xs+      in+        (a A.!)++    valueParser = many1 bitParser++    valueParserL n = count n bitParser++    valueSepParserL n =+      ch ',' >> (~~) >> valueParserL n++    bitParser =+          do { ch '0'; return $ Left False }+      <|> do { ch '1'; return $ Left True }+      <|> do { ch '*'; return $ Right () }++    argumentsParser x pos = do+      ch '('; (~~)+      args <- commaSep tokenparser $ identifier (~~)+      ch ')'; p <- getPos; (~~)+      reminderParser x args $ ExprPos (srcBegin pos) p++    reminderParser x args pos = do+      rOp "="+      es <- many1 exprParser+      return $ Just $ BindExpr x args pos es++    argumentsEnumParser x pos = do+      ch '('; (~~)+      args <- commaSep tokenparser $ identifier (~~)+      ch ')'; p <- getPos; (~~)+      reminderEnumParser x args $ ExprPos (srcBegin pos) p++    reminderEnumParser x args pos = do+      rOp "="+      es <- many1 exprParser+      return $ Just $ Left $ BindExpr x args pos es++    ch = void . char+    br = braces tokenparser+    rOp = reservedOp tokenparser+    (~~) = whiteSpace tokenparser+    keyword = void . reserved tokenparser++-----------------------------------------------------------------------------
+ src/Reader/Parser/Info.hs view
@@ -0,0 +1,248 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Info+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Parser for the INFO section.+--+-----------------------------------------------------------------------------++module Reader.Parser.Info+  ( infoParser+  , targetParser+  , semanticsParser+  ) where++-----------------------------------------------------------------------------++import Data.List+  ( dropWhileEnd+  )++import Data.Types+  ( Semantics(..)+  , Target(..)+  )++import Data.Expression+  ( SrcPos(..)+  , ExprPos(..)+  )++import Reader.Parser.Data+  ( globalDef+  )++import Reader.Parser.Utils+  ( getPos+  , stringParser+  , identifier+  )++import Control.Monad+  ( void+  )++import Data.Functor.Identity+  ( Identity+  )++import Text.Parsec+  ( ParsecT+  , (<|>)+  , char+  , unexpected+  , parserFail+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec.Token+  ( TokenParser+  , commaSep+  , reservedNames+  , whiteSpace+  , makeTokenParser+  , reserved+  )++-----------------------------------------------------------------------------++-- | Parses the INFO section of a specification file. It returns:+--+--     * the title of the specification+--+--     * the description of the specification+--+--     * the semantics of the specification+--+--     * the target of the specification+--+--     * the tag list of the specification++infoParser+  :: Parser+     ( (String, ExprPos)+     , (String, ExprPos)+     , (Semantics, ExprPos)+     , (Target, ExprPos)+     , [ (String, ExprPos) ]+     )++infoParser = (~~) >> do+  keyword "INFO"+  ch '{'+  infoContentParser Nothing Nothing Nothing Nothing Nothing++  where+    infoContentParser t d y g a =+          do { keyword "TITLE"; titleParser t d y g a }+      <|> do { keyword "DESCRIPTION"; descriptionParser t d y g a}+      <|> do { keyword "SEMANTICS"; semanticsParser' t d y g a }+      <|> do { keyword "TARGET"; targetParser' t d y g a }+      <|> do { keyword "TAGS"; tagsParser t d y g a }+      <|> do { ch '}'; endParser  t d y g a }++    titleParser t d y g a = case t of+      Nothing -> ch ':' >> do+        str <- strParser; (~~)+        infoContentParser (Just str) d y g a+      _       -> errDoubleDef "TITLE"++    descriptionParser t d y g a = case d of+      Nothing -> ch ':' >> do+        str <- strParser; (~~)+        infoContentParser t (Just str) y g a+      _       -> errDoubleDef "DESCRIPTION"++    semanticsParser' t d y g a = case y of+      Nothing -> ch ':' >> do+        v <- semanticsParser+        infoContentParser t d (Just v) g a+      _       -> errDoubleDef "TYPE"++    targetParser' t d y g a = case g of+      Nothing -> ch ':' >> do+        x <- targetParser+        infoContentParser t d y (Just x) a+      _       -> errDoubleDef "TARGET"++    tagsParser t d y g a = case a of+      Nothing -> ch ':' >> do+        xs <- commaSep tokenparser (identifier (~~))+        infoContentParser t d y g (Just xs)+      _       -> errDoubleDef "TAGS"++    endParser t d y g a = case (t,d,y,g) of+      (Nothing, _, _, _)               -> errMissing "TITLE"+      (_, Nothing, _, _)               -> errMissing "DESCRIPTION"+      (_, _, Nothing, _)               -> errMissing "SEMANTICS"+      (_, _, _, Nothing)               -> errMissing "TARGET"+      (Just u, Just v, Just w, Just x) -> case a of+        Just ts -> return (u,v,w,x,ts)+        _       -> return (u,v,w,x,[])+++    ch x = void $ char x >> (~~)+    (~~) = whiteSpace tokenparser++    errMissing str =+      parserFail $+      "The " ++ str ++ " entry is missing in the INFO section."+    errDoubleDef str =+      unexpected $+      str ++ " (already defined)"++-----------------------------------------------------------------------------++-- | Parses the target description.++strParser+  :: Parser (String, ExprPos)++strParser = do+  p1 <- getPos+  str <- stringParser+  let+    cn = length $ filter (== '\n') str+    cc = length $ dropWhileEnd (/= '\n') str+    p2 = SrcPos (srcLine p1 + cn)+           (if cn == 0 then srcColumn p1 + length str else cc)+  return (str, ExprPos p1 p2)++-----------------------------------------------------------------------------++-- | Parses the target description.++targetParser+  :: Parser (Target, ExprPos)++targetParser =+      do { p1 <- getPos;+           keyword "Mealy";+           let p2 = SrcPos (srcLine p1) (srcColumn p1 + length "Mealy")+           in return (TargetMealy, ExprPos p1 p2)+         }+  <|> do { p1 <- getPos;+           keyword "Moore";+           let p2 = SrcPos (srcLine p1) (srcColumn p1 + length "Moore")+           in return (TargetMoore, ExprPos p1 p2) }++-----------------------------------------------------------------------------++-- | Parses the semantics description.++semanticsParser+  :: Parser (Semantics, ExprPos)++semanticsParser = do+  p1 <- getPos+  x <- semanticKeyword+  (z,p2) <- do { void $ char ',';+                p <- getPos;+                k <- semanticKeyword;+                return (k, SrcPos (srcLine p) (srcColumn p + length k))+              }+           <|> return ("none", SrcPos (srcLine p1) (srcColumn p1 + length x))+  case (x,z) of+    ("mealy","none")   -> return (SemanticsMealy, ExprPos p1 p2)+    ("moore","none")   -> return (SemanticsMoore, ExprPos p1 p2)+    ("mealy","strict") -> return (SemanticsStrictMealy, ExprPos p1 p2)+    ("strict","mealy") -> return (SemanticsStrictMealy, ExprPos p1 p2)+    ("moore","strict") -> return (SemanticsStrictMoore, ExprPos p1 p2)+    ("strict","moore") -> return (SemanticsStrictMoore, ExprPos p1 p2)+    ("mealy","moore")  -> unexpected "Moore"+    ("moore","moore")  -> unexpected "Mealy"+    ("moore","mealy")  -> unexpected "Mealy"+    ("mealy","mealy")  -> unexpected "Mealy"+    _                  -> unexpected "Strict"++  where+    semanticKeyword =+          do { keyword "Mealy"; return "mealy" }+      <|> do { keyword "Moore"; return "moore" }+      <|> do { keyword "Strict"; return "strict" }++-----------------------------------------------------------------------------++tokenparser+  :: TokenParser a++tokenparser =+  makeTokenParser globalDef+  { reservedNames  =+       ["INFO","TITLE","DESCRIPTION", "SEMANTICS",+        "TAGS","Strict","Mealy","Moore","TARGET"] }++-----------------------------------------------------------------------------++keyword+  :: String -> ParsecT String u Identity ()++keyword =+  void . reserved tokenparser++-----------------------------------------------------------------------------
+ src/Reader/Parser/Utils.hs view
@@ -0,0 +1,131 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Parser.Utils+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Functions shared among the different parsers.+--+-----------------------------------------------------------------------------++module Reader.Parser.Utils+  ( stringParser+  , identifier+  , positionParser+  , getPos+  ) where++-----------------------------------------------------------------------------++import Data.Expression+  ( ExprPos(..)+  , SrcPos(..)+  )++import Reader.Parser.Data+  ( globalDef+  )++import Control.Monad+  ( void+  )++import Data.Functor.Identity+  ( Identity+  )++import Text.Parsec+  ( ParsecT+  , Stream+  , (<|>)+  , char+  , many+  , anyChar+  , noneOf+  , getPosition+  , sourceLine+  , sourceColumn+  )++import Text.Parsec.String+  ( Parser+  )++import Text.Parsec.Token+  ( identStart+  , identLetter+  )++-----------------------------------------------------------------------------++-- | Parses a string surrounded by double quotation marks.+-- Double quotation marks inside the string have to be escabed by a backslash.+-- The string may contain special characters like new line or tabs.++stringParser+  :: Parser String++stringParser = do+    void $ char '"'+    xs <- many character+    void $ char '"'+    return $ concat xs++  where+    character =+      escaped <|> nonescaped++    escaped = do+      d <- char '\\'+      c <- anyChar+      case c of+        '"' -> return [c]+        _   -> return [d,c]++    nonescaped = do+      c <- noneOf "\""+      return [c]++-----------------------------------------------------------------------------++-- | @identifier wp@ is an exteded version of its equivalent exported by+-- 'Text.Parser.Token', which additionally stores the starting source position+-- and the ending source position. The parser @wp@ is assumed to parse the+-- subsequent whitespace after the identifier.++identifier+  :: ParsecT String u Identity () -> ParsecT String u Identity (String, ExprPos)++identifier wp = positionParser wp $ do+    x <- identStart globalDef+    xr <- many $ identLetter globalDef+    return (x:xr)++-----------------------------------------------------------------------------++-- | @positionParser wp p@ parses the same as parser @p@, but additionally+-- returns the starting and ending source positions of the result parsed by+-- @p@. The parser @wp@ is assumed to parse the subsequent whitespace after+-- @p@ has been invoked.++positionParser+ :: (Stream s m t) => ParsecT s u m () -> ParsecT s u m a+    -> ParsecT s u m (a,ExprPos)++positionParser wp p = do+  x <- getPos; e <- p+  y <- getPos; wp+  return (e,ExprPos x y)++-----------------------------------------------------------------------------++-- | Return the current position of the parser in the source file.++getPos+ :: (Stream s m t) => ParsecT s u m SrcPos++getPos = do+  x <- getPosition+  return $ SrcPos (sourceLine x) (sourceColumn x - 1)++-----------------------------------------------------------------------------
+ src/Reader/Sugar.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Reader.Sugar+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Removes syntactic sugar elements from the specification.+--+-----------------------------------------------------------------------------++module Reader.Sugar+  ( replaceSugar+  ) where++-----------------------------------------------------------------------------++import Reader.Error+  ( Error+  )++import Data.Binding+  ( Binding+  , BindExpr(..)+  )++import Reader.Data+  ( Specification(..)+  )++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  )++import Data.Either+  ( partitionEithers+  )++-----------------------------------------------------------------------------++-- | Replaces syntactic sugar elements in the given specification by their+-- corresponding standard elements.++replaceSugar+  :: Specification -> Either Error Specification++replaceSugar s = do+  vs <- mapM replaceBinding $ definitions s+  return s { definitions = vs }++-----------------------------------------------------------------------------++replaceBinding+  :: Binding -> Either Error Binding++replaceBinding b =+  case bVal b of+    []  -> return b+    [_] -> return b+    xs  -> return b { bVal = replaceExpr xs }++-----------------------------------------------------------------------------++replaceExpr+  :: [Expr Int] -> [Expr Int]++replaceExpr xs =+  let+    ys = if any ischeck xs then map addcheck xs else xs+    (zs,os) = partitionEithers $ map isOtherwise ys+    ncond p = Expr (BlnNot (orlist p $ map cond zs)) p+    os' = map (replace ncond) os+  in+    zs ++ os'++  where+    ischeck e = case expr e of+      Colon {} -> True+      _        -> False++    cond e = case expr e of+      Colon x _ -> x+      _         -> Expr BaseTrue (srcPos e)++    isOtherwise e = case expr e of+      Colon x _ -> case expr x of+        BaseOtherwise -> Right e+        _             -> Left e+      _        -> Left e++    addcheck e = case expr e of+      Colon {} -> e+      _        -> Expr (Colon (cond e) e) $ srcPos e++    replace f e = case expr e of+      Colon _ y -> Expr (Colon (f (srcPos e)) y) $ srcPos e+      _         -> e++    orlist p = foldl (fldor p) (Expr BaseFalse p)++    fldor p e1 e2 = Expr (BlnOr e1 e2) p++-----------------------------------------------------------------------------
+ src/Simplify.hs view
@@ -0,0 +1,360 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Simplify+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Linear temporal logic formula simplifcations.+--+-----------------------------------------------------------------------------++module Simplify+    ( simplify+    ) where++-----------------------------------------------------------------------------++import Config+    ( Configuration(..)+    )++import Data.LTL+    ( Formula(..)+    )++import Data.Error+    ( Error+    )++import Data.Either+    ( partitionEithers+    )++-----------------------------------------------------------------------------++-- | Applies the simplifications specified via the command line arguments.++simplify+  :: Configuration -> Formula -> Either Error Formula++simplify c f =+  let+    f' = simplify' f+  in+   if f == f' then+     return f+   else+     simplify c f'++  where+    simplify' fml = case fml of++      -- Optimization Rules --++      Globally TTrue+        | sw || ss || ng || nd                -> TTrue+        | otherwise                        -> Globally TTrue+      Globally FFalse+        | sw || ss || ng || nd                -> FFalse+        | otherwise                        -> Globally FFalse+      Finally TTrue+        | sw || ss || nf || nd                -> TTrue+        | otherwise                        -> Finally TTrue+      Finally FFalse+        | sw || ss || nf || nd                -> FFalse+        | otherwise                        -> Finally FFalse+      Not TTrue+        | sw || ss || nnf                    -> FFalse+        | otherwise                        -> Not TTrue+      Not FFalse+        | sw || ss || nnf                    -> TTrue+        | otherwise                        -> Not FFalse+      Next TTrue+        | sw || ss                          -> TTrue+        | otherwise                        -> Next TTrue+      Next FFalse+        | sw || ss                          -> FFalse+        | otherwise                        -> Next FFalse+      Globally (Globally x)+        | sw || ss || hg || lg || ng || nd      -> simplify' $ Globally x+        | otherwise                        -> Globally $ simplify' $ Globally x+      Finally (Finally x)+        | sw || ss || hf || lf || nf || nd      -> simplify' $ Finally x+        | otherwise                        -> Finally $ simplify' $ Finally x+      Equiv TTrue x+        | sw || ss                          -> simplify' x+        | otherwise                        -> Equiv TTrue $ simplify' x+      Equiv x TTrue+        | sw || ss                          -> simplify' x+        | otherwise                        -> Equiv (simplify' x) TTrue+      Equiv x FFalse+        | sw || ss                          -> simplify' $ Not x+        | otherwise                        -> Equiv (simplify' x) FFalse+      Equiv FFalse x+        | sw || ss                          -> simplify' $ Not x+        | otherwise                        -> Equiv FFalse $ simplify' x+      Implies FFalse x+        | sw || ss                          -> TTrue+        | otherwise                        -> Implies FFalse $ simplify' x+      Implies TTrue x+        | sw || ss                          -> simplify' x+        | otherwise                        -> Implies TTrue $ simplify' x+      Implies x FFalse+        | sw || ss                          -> simplify' $ Not x+        | otherwise                        -> Implies (simplify' x) FFalse+      Implies x TTrue+        | sw || ss                          -> TTrue+        | otherwise                        -> Implies (simplify' x) TTrue+      Not (Not x)+        | sw || ss || nnf                    -> simplify' x+        | otherwise                        -> Not $ Not $ simplify' x+      Not (Next x)+        | ss || ln || nnf                    -> Next $ simplify' $ Not x+        | otherwise                        -> Not $ simplify' $ Next x+      Not (Globally x)+        | ss || nnf                         -> Finally $ simplify' $ Not x+        | otherwise                        -> Not $ simplify' $ Globally x+      Not (Finally x)+        | ss || nnf                         -> Globally $ simplify' $ Not x+        | otherwise                        -> Not $ simplify' $ Finally x+      Not (And xs)+        | ss || nnf                         -> Or $ map (simplify' . Not) xs+        | otherwise                        -> Not $ And $ map simplify' xs+      Not (Or xs)+        | ss || nnf                         -> And $ map (simplify' . Not) xs+        | otherwise                        -> Not $ Or $ map simplify' xs+      Not (Implies x y)+        | ss || nnf                         -> And [simplify' x, simplify' $ Not y]+        | otherwise                        -> Not $ Implies (simplify' x) $ simplify' y+      Not (Equiv (Not x) y)+        | ss || nnf                         -> simplify' $ Equiv x y+        | otherwise                        -> Not $ Equiv (simplify' $ Not x) $ simplify' x+      Not (Equiv x y)+        | ss || nnf                         -> Equiv (simplify' x) $ simplify' $ Not y+        | otherwise                        -> Not $ Equiv (simplify' x) $ simplify' y+      Not (Until x y)+        | (ss || nnf) && not nr                -> simplify' $ Release (Not x) $ Not y+        | otherwise                        -> Not $ Until (simplify' x) $ simplify' y+      Not (Release x y)+        | ss || nr || nnf                    -> Until (simplify' $ Not x) $ simplify' $ Not y+        | otherwise                        -> Not $ Release (simplify' x) $ simplify' y+      Not (Weak x y)+        | (ss || nw || nnf) && not nr           -> simplify' $ Not $ Release y $ Or [x,y]+        | otherwise                        -> Not $ Weak (simplify' x) $ simplify' y+      Finally (Next x)+        | ss || ln || hf                     -> simplify' $ Next $ Finally x+        | nf || nd                          -> simplify' $ Until TTrue $ Next x+        | otherwise                        -> Finally $ simplify' $ Next x+      Next (Finally x)+        | (hn && not hf) || (lf && not ln && not ss) -> simplify' $ Finally $ Next x+        | otherwise                        -> Next $ simplify' $ Finally x+      Globally (Next x)+        | ss || ln || hg                     -> simplify' $ Next $ Globally x+        | ng || nd                          -> simplify' $ Release FFalse $ Next x+        | otherwise                        -> Globally $ simplify' $ Next x+      Next (Globally x)+        | (hn && not hg) || (lg && not ln && not ss) -> simplify' $ Globally $ Next x+        | otherwise                        -> Next $ simplify' $ Globally x+      Until TTrue x+        | ss || (sw && not nf && not nd)          -> simplify' $ Finally x+        | otherwise                        -> Until TTrue $ simplify' x+      Release FFalse x+        | ss || (sw && not ng && not nd)          -> simplify' $ Globally x+        | not nr                             -> Release FFalse $ simplify' x+        | nnf                              -> simplify' $ Weak x FFalse+        | otherwise                        -> simplify' $ Not $ Until TTrue $ Not x+      Until (Next x) (Next y)+        | ss || ln                          -> simplify' $ Next $ Until x y+        | otherwise                        -> Until (simplify' $ Next x) $ simplify' $ Next y+      Next (Until x y)+        | hn                               -> simplify' $ Until (Next x) $ Next y+        | otherwise                        -> Next $ simplify' $ Until x y+      Release (Next x) (Next y)+        | ss || ln                          -> simplify' $ Next $ Release x y+        | not nr                             -> Release (simplify' $ Next x) $ simplify' $ Next y+        | nnf                              -> simplify' $ Weak (Next y) $ And [Next x, Next y]+        | otherwise                        -> simplify' $ Not $ Until (Not $ Next x) (Not $ Next y)+      Next (Release x y)+        | hn                               -> simplify' $ Release (Next x) $ Next y+        | otherwise                        -> Next $ simplify' $ Release x y+      Weak (Next x) (Next y)+        | ss || ln                          -> simplify' $ Next $ Weak x y+        | nw || nd                          -> simplify' $ Or [Until (Next x) $ Next y, Globally $ Next x]+        | otherwise                        -> Weak (simplify' $ Next x) $ simplify' $ Next y+      Next (Weak x y)+        | hn                               -> simplify' $ Weak (Next x) $ Next y+        | otherwise                        -> Next $ simplify' $ Weak x y+      Until x (Finally y)+        | ss                               -> simplify' $ Finally y+        | otherwise                        -> Until (simplify' x) $ simplify' $ Finally y+      Globally (And xs)+        | hg                               -> simplify' $ And $ map Globally xs+        | ng || nd                          -> simplify' $ Release FFalse $ And xs+        | otherwise                        -> case simplify' $ And xs of+          And ys -> Globally $ And ys+          z      -> simplify' $ Globally z+      Finally (Or xs)+        | hf                               -> simplify' $ Or $ map Finally xs+        | nf || nd                          -> simplify' $ Until TTrue $ Or xs+        | otherwise                        -> case simplify' $ Or xs of+          Or ys -> Finally $ Or ys+          z     -> simplify' $ Finally z+      And []+        | sw || ss                          -> TTrue+        | otherwise                        -> And []+      And [Next x]+        | sw || ss || ln                     -> simplify' $ Next x+        | otherwise                        -> And [simplify' $ Next x]+      And [Globally x]+        | sw || ss || lg                     -> simplify' $ Globally x+        | otherwise                        -> And [simplify' $ Globally x]+      And [x]+        | sw || ss                          -> simplify' x+        | otherwise                        -> And [simplify' x]+      And xs+        | not (sw || ss || lg || ln)            -> And $ map simplify' xs+        | otherwise                        ->+          let+            cs | sw || ss   = filter (TTrue /=) $ warpAnd $ map simplify' xs+               | otherwise = xs+          in+            if (sw || ss) && (FFalse `elem` cs) then FFalse+            else case cs of+              []           | sw || ss   -> TTrue+                           | otherwise -> And []+              [Next x]     | sw || ss   -> Next x+                           | ln        -> Next $ And [x]+                           | otherwise -> And [Next x]+              [Globally x] | sw || ss   -> Globally x+                           | lg        -> Globally $ And [x]+                           | otherwise -> And [Globally x]+              [x]          | sw || ss   -> x+                           | otherwise -> And [x]+              _                      ->+                let+                  (ns, ys) | ln || ss   = partitionEithers $ map splitNext cs+                           | otherwise = ([], cs)+                  (as, zs) | lg || ss   = partitionEithers $ map splitGlobally ys+                           | otherwise = ([], ys)+                in case (ns, as) of+                  ([],[])   -> And zs+                  ([],[y])  -> And $ reverse $ (Globally y) : reverse zs+                  ([],_)    -> And $ reverse $ (Globally $ And as) : reverse zs+                  ([x],[])  -> And $ reverse $ (Next x) : reverse zs+                  ([x],[y]) -> And $ reverse $ (Globally y) : (Next x) : reverse zs+                  ([x],_)   -> And $ reverse $ (Globally $ And as) : (Next x) : reverse zs+                  (_,[])    -> And $ reverse $ (Next $ And ns) : reverse zs+                  (_,[y])   -> And $ reverse $ (Globally y) : (Next $ And ns) : reverse zs+                  (_,_)     -> And $ reverse $ (Globally $ And as) : (Next $ And ns) : reverse zs+      Or []+        | sw || ss                          -> FFalse+        | otherwise                        -> Or []+      Or [Next x]+        | sw || ss || ln                     -> simplify' $ Next x+        | otherwise                        -> Or [simplify' $ Next x]+      Or [Finally x]+        | sw || ss || lf                     -> simplify' $ Finally x+        | otherwise                        -> Or [simplify' $ Finally x]+      Or [x]+        | sw || ss                          -> simplify' x+        | otherwise                        -> Or [simplify' x]+      Or xs+        | not (sw || ss || lf || ln)            -> Or $ map simplify' xs+        | otherwise                        ->+          let+            cs | sw || ss   = filter (FFalse /=) $ warpOr $ map simplify' xs+               | otherwise = xs+          in+            if (sw || ss) && (TTrue `elem` cs) then TTrue+            else case cs of+               []          | sw || ss   -> FFalse+                           | otherwise -> Or []+               [Next x]    | sw || ss   -> Next x+                           | ln        -> Next $ Or [x]+                           | otherwise -> Or [Next x]+               [Finally x] | sw || ss   -> Finally x+                           | lf        -> Finally $ Or [x]+                           | otherwise -> Or [Finally x]+               [x]         | sw || ss   -> x+                           | otherwise -> Or [x]+               _                          ->+                 let+                   (ns, ys) | ln || ss   = partitionEithers $ map splitNext cs+                            | otherwise = ([], cs)+                   (es, zs) | lf || ss   = partitionEithers $ map splitFinally ys+                            | otherwise = ([], ys)+                 in case (ns, es) of+                   ([],[])   -> Or zs+                   ([],[y])  -> Or $ reverse $ (Finally y) : reverse zs+                   ([],_)    -> Or $ reverse $ (Finally $ Or es) : reverse zs+                   ([x],[])  -> Or $ reverse $ (Next x) : reverse zs+                   ([x],[y]) -> Or $ reverse $ (Finally y) : (Next x) : reverse zs+                   ([x],_)   -> Or $ reverse $ (Finally $ Or es) : (Next x) : reverse zs+                   (_,[])    -> Or $ reverse $ (Next $ Or ns) : reverse zs+                   (_,[y])   -> Or $ reverse $ (Finally y) : (Next $ And ns) : reverse zs+                   (_,_)     -> Or $ reverse $ (Finally $ Or es) : (Next $ And ns) : reverse zs++      -- pass through++      Finally x+        | nf || nd                          -> simplify' $ Until TTrue x+        | otherwise                        -> Finally $ simplify' x+      Globally x+        | ng || nd                          -> simplify' $ Release FFalse x+        | otherwise                        -> Globally $ simplify' x+      Release x y+        | not nr                             -> Release (simplify' x) $ simplify' y+        | nnf                              -> simplify' $ Weak y $ And [x,y]+        | otherwise                        -> simplify' $ Not $ Until (Not x) $ Not y+      Weak x y+        | nw || nd                          -> simplify' $ Or [Until x y, Globally x]+        | otherwise                        -> Weak (simplify' x) $ simplify' y+      Equiv x y                            -> Equiv (simplify' x) (simplify' y)+      Implies x y                          -> Implies (simplify' x) (simplify' y)+      Until x y                            -> Until (simplify' x) (simplify' y)+      Next x                               -> Next (simplify' x)+      Not (Atomic x)                       -> Not (Atomic x)+      Atomic x                             -> Atomic x+      FFalse                               -> FFalse+      TTrue                                -> TTrue++    fAnd fml = case fml of+      And x -> x+      _     -> [fml]++    warpAnd = concatMap fAnd++    fOr fml = case fml of+      Or x -> x+      _    -> [fml]++    warpOr = concatMap fOr++    splitNext fml = case fml of+      Next x -> Left x+      _      -> Right fml++    splitGlobally fml = case fml of+      Globally x -> Left x+      _          -> Right fml++    splitFinally fml = case fml of+      Finally x -> Left x+      _          -> Right fml++    nnf = negNormalForm c+    sw = simplifyWeak c+    ss = simplifyStrong c+    nr = noRelease c+    nw = noWeak c+    ng = noGlobally c+    nf = noFinally c+    lg = pullGlobally c+    hg = pushGlobally c+    lf = pullFinally c+    hf = pushFinally c+    ln = pullNext c+    hn = pushNext c+    nd = noDerived c++-----------------------------------------------------------------------------
+ src/Syfco.hs view
@@ -0,0 +1,177 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Syfco+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Syfco Library Interface.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Syfco+  ( -- * Data Structures+    Configuration(..)+  , WriteFormat(..)+  , WriteMode(..)+  , Semantics(..)+  , Target(..)+  , Specification+  , Error+    -- * Configurations+  , defaultCfg+  , update+  , verify+    -- * Specifcations+  , source+  , title+  , description+  , semantics+  , target+  , tags+  , parameters+  , signals+  , inputs+  , outputs+  , symboltable+  , fromTLSF+  , apply+    -- * Fragment Detection+  , checkGR+    -- * Meta Information+  , version+  ) where++-----------------------------------------------------------------------------++import Data.Types+  ( Semantics(..)+  , Target(..)+  )++import Data.Error+  ( Error+  )++import Config+  ( Configuration(..)+  , defaultCfg+  , update+  , verify+  )++import Writer.Data+  ( WriteMode(..)+  )++import Writer+  ( WriteFormat(..)+  , apply+  )++import Writer.Eval+  ( signals+  )++import Data.Specification+  ( Specification+  , source+  , title+  , description+  , semantics+  , target+  , tags+  )++import qualified Data.Specification as S+  ( symboltable+  , parameters+  )++import Reader+  ( fromTLSF+  )++import Detection+  ( checkGR+  )++import Data.Binding+  ( BindExpr(..)+  )++import Data.SymbolTable+  ( IdRec(..)+  , st2csv+  )++import Data.Array+  ( (!)+  )++import Writer.Eval+  ( eval+  )++import Data.LTL+  ( Formula(..)+  , fmlInputs+  , fmlOutputs+  )++import Data.Info+  ( version+  )++-----------------------------------------------------------------------------++-- | Returns the parameters of a specification.++parameters+  :: Specification -> [String]++parameters s =+  map (idName . ((S.symboltable s) !) . bIdent) $ S.parameters s++-----------------------------------------------------------------------------++-- | Returns the input signals of a specification using the format as+-- implied by the given configuration.++inputs+  :: Configuration -> Specification -> Either Error [String]++inputs c s = case signals c s of+  Left err     -> Left err+  Right (is,_) -> return is++-----------------------------------------------------------------------------++-- | Returns the ouputs signals of a specification using the format as+-- implied by the given configuration.++outputs+  :: Configuration -> Specification -> Either Error [String]++outputs c s = case signals c s of+  Left err     -> Left err+  Right (_,os) -> return os++-----------------------------------------------------------------------------++-- | Returns the symbol table of a specification in CSV format.++symboltable+  :: Specification -> String++symboltable =+  st2csv . S.symboltable++-----------------------------------------------------------------------------
+ src/Utils.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Utils+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Functions on standard data types that are not in Prelude.+-- +-----------------------------------------------------------------------------++module Utils+    ( strictSort+    , bucketSort  +    , iter+    , imLookup+    ) where++-----------------------------------------------------------------------------++import qualified Data.IntMap as IM+    ( Key+    , IntMap+    , lookup+    )++import Data.Maybe+    ( fromJust+    )++import Data.Set+    ( elems+    , fromList+    )++import Data.Ix+    ( Ix+    )    ++import qualified Data.Array.ST as A+import Control.Monad.ST++-----------------------------------------------------------------------------++-- | Strict version of 'sort'.++strictSort+  :: Ord a => [a] -> [a]++strictSort  = elems . fromList++-----------------------------------------------------------------------------++-- | Strict version of 'sort' for indexable types using array buckets.++bucketSort+  :: Num i => Ix i => [i] -> [i]++bucketSort xs = case xs of+  []     -> []+  (x:xr) -> +    let bounds = foldl (\(a,b) y -> (min a y, max b y)) (x,x) xr+    in runST (bucketSortST bounds xs)++  where+    bucketSortST (l,u) ys = +      let+        newArray :: Ix j => (j, j) -> Int -> ST s (A.STArray s j Int)+        newArray = A.newArray +      in do+        a <- newArray (l,u) 0 +        mapM_ (incIdx a) ys               +        getPositive l a [] u++    incIdx a i = do +      v <- A.readArray a i+      A.writeArray a i (v+1)    ++    getPositive l a b i+      | i < l     = return b+      | otherwise = do+        v <- A.readArray a i+        if v > 0 then+          getPositive l a (i:b) (i-1)+        else+          getPositive l a b (i-1)++-----------------------------------------------------------------------------++-- | @iter f n s@ applies the function @f@ @n@ times to @s@.++iter+  :: (a -> a) -> Int -> a -> a++iter f n s =+  if n == 0 then s+  else iter f (n-1) (f s)++-----------------------------------------------------------------------------++-- | @imLookup n im@ looks up an element @n@ of an int map @im@ and takes it+-- out of the 'Maybe' monad. The function assumes that the corresponding+-- element exists in @im@.++imLookup+  :: IM.Key -> IM.IntMap a -> a++imLookup n im =+  fromJust $ IM.lookup n im++-----------------------------------------------------------------------------
+ src/Writer.hs view
@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- The module provides the different writers, linked via+-- 'writeSpecification'.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    FlexibleContexts+  , RecordWildCards++  #-}++-----------------------------------------------------------------------------++module Writer+  ( WriteFormat(..)+  , apply+  ) where++-----------------------------------------------------------------------------++import Data.Convertible+  ( convert+  )++import Config+  ( Configuration(..)+  )++import Data.Error+  ( Error+  )++import Data.Specification+  ( Specification+  )++import Writer.Utils+  ( checkLower+  )++import Writer.Error+  ( prError+  )++import Writer.Formats+  ( WriteFormat(..)+  , needsLower+  )++import Control.Monad+  ( when+  )++-----------------------------------------------------------------------------++import qualified Writer.Formats.Utf8 as Utf8+import qualified Writer.Formats.Wring as Wring+import qualified Writer.Formats.Promela as Promela+import qualified Writer.Formats.Acacia as Acacia+import qualified Writer.Formats.AcaciaSpecs as AcaciaSpecs+import qualified Writer.Formats.Lily as Lily+import qualified Writer.Formats.Ltlxba as Ltlxba+import qualified Writer.Formats.Unbeast as Unbeast+import qualified Writer.Formats.Slugs as Slugs+import qualified Writer.Formats.SlugsIn as SlugsIn+import qualified Writer.Formats.Basic as Basic+import qualified Writer.Formats.Full as Full+import qualified Writer.Formats.Psl as Psl+import qualified Writer.Formats.Smv as Smv+import qualified Writer.Formats.Bosy as Bosy++-----------------------------------------------------------------------------++-- | Applies the parameters of in the configuration and turns the given+-- specification into the desired target format.++apply+  :: Configuration -> Specification -> Either Error String++apply c@Configuration{..} s = do+  when (needsLower outputFormat) $+    checkLower (convert outputFormat) s++  case outputFormat of+    UTF8        -> Utf8.writeFormat c s+    BASIC       -> Basic.writeFormat c s+    FULL        -> Full.writeFormat c s+    WRING       -> Wring.writeFormat c s+    LTLXBA      -> Ltlxba.writeFormat c s+    LILY        -> Lily.writeFormat c s+    ACACIA      -> Acacia.writeFormat c s+    ACACIASPECS -> AcaciaSpecs.writeFormat c s+    PROMELA     -> Promela.writeFormat c s+    UNBEAST     -> Unbeast.writeFormat c s+    SLUGS       -> Slugs.writeFormat c s+    SLUGSIN     -> SlugsIn.writeFormat c s+    PSL         -> Psl.writeFormat c s+    SMV         -> Smv.writeFormat c s+    BOSY        -> Bosy.writeFormat c s++-----------------------------------------------------------------------------
+ src/Writer/Data.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Data+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Common data used by the writer module.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , MultiParamTypeClasses+  , TypeSynonymInstances+  , FlexibleInstances++  #-}++-----------------------------------------------------------------------------++module Writer.Data+  ( WriteMode(..)+  , OperatorConfig(..)+  , UnaryOperator(..)+  , BinaryOperator(..)+  , Unsupported(..)+  , Assoc(..)+  ) where++-----------------------------------------------------------------------------++import Data.Convertible+  ( Convertible(..)+  , ConvertError(..)+  )++-----------------------------------------------------------------------------++-- | There are two writing modes currently supported:++data WriteMode =+    Pretty+    -- ^ pretty printing, producing a well readable, minimal ouptut+  | Fully+    -- ^ fully paranthesized printing, producing fully parenthesized+    --   expressions+  deriving (Eq, Ord)++-----------------------------------------------------------------------------++instance Convertible WriteMode String where+  safeConvert = return . \case+    Pretty -> "pretty"+    Fully  -> "fully"++-----------------------------------------------------------------------------++instance Convertible String WriteMode where+  safeConvert = \case+    "pretty" -> return Pretty+    "fully"  -> return Fully+    str      -> Left ConvertError+      { convSourceValue = str+      , convSourceType = "String"+      , convDestType = "WriteMode"+      , convErrorMessage = "Unknown mode"+      }++-----------------------------------------------------------------------------++-- | Associativity type to distinguis left associative operators from+-- right associative operators++data Assoc =+    AssocLeft+  | AssocRight+  deriving (Eq)++-----------------------------------------------------------------------------++-- | A unary operator can be set up by providing a name and its precedence.++data UnaryOperator =+  UnaryOp+    { uopName :: String+    , uopPrecedence :: Int+    }+  | UnaryOpUnsupported+  deriving (Eq)++-----------------------------------------------------------------------------++-- | A binary operator can be set up by a name, its precedencs and its+-- associativity.++data BinaryOperator =+  BinaryOp+    { bopName :: String+    , bopPrecedence :: Int+    , bopAssoc :: Assoc+    }+  | BinaryOpUnsupported+  deriving (Eq)++-----------------------------------------------------------------------------++-- | A simple expression printer can be set up using the function+-- 'printFormula' from 'Writer.Pretty'. The bundle the specific+-- operator names, their precedence and their associativity, the data+-- structure @OperatorNames@ is used.+--+-- Thereby, constants as True and False are given by Strings and unary+-- operators are given by their name their precedence. For binary+-- operators, additionally the associativity has to be defined.+--+-- The precedence is given by an Integer, where a lower value means+-- higher precedence. If the same value is used for multiple+-- operators, their precedence is treated equally.+--+-- The associativity is either 'AssocLeft' or 'AssocRight'.+--+-- Unsupported Operators can be disabled using 'UnaryOpUnsupported' or+-- 'BinaryOpUnsupported', respectively.++data OperatorConfig =+  OperatorConfig+  { tTrue :: String+  , fFalse :: String+  , opNot :: UnaryOperator+  , opAnd :: BinaryOperator+  , opOr :: BinaryOperator+  , opImplies :: BinaryOperator+  , opEquiv :: BinaryOperator+  , opNext :: UnaryOperator+  , opFinally :: UnaryOperator+  , opGlobally :: UnaryOperator+  , opUntil :: BinaryOperator+  , opRelease :: BinaryOperator+  , opWeak :: BinaryOperator+  } deriving (Eq)++-----------------------------------------------------------------------------++-- | Unification class to check whether an operator is unsupported or not.++class Unsupported a where+  unsupported :: a -> Bool++instance Unsupported UnaryOperator where+  unsupported = (== UnaryOpUnsupported)++instance Unsupported BinaryOperator where+  unsupported = (== BinaryOpUnsupported)++-----------------------------------------------------------------------------
+ src/Writer/Error.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Error+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Pretty and informative error messages that may be thrown while writing +-- out a specification to another format.+-- +-----------------------------------------------------------------------------++module Writer.Error+    ( Error+    , errBounds+    , errBusCmp  +    , errMinSet+    , errMaxSet+    , errSetCap+    , errNoMatch+    , errToLower+    , errNoGR1  +    , prError      +    ) where++-----------------------------------------------------------------------------+    +import Data.Error+    ( Error+    , runtimeError+    , conversionError+    , prError+    )  +    +import Data.Expression+    ( ExprPos+    )+    +import Control.Monad.State+    ( StateT(..)+    )  ++-----------------------------------------------------------------------------++-- | Throws an error that indicates an out of bounds access to a bus.++errBounds+  :: String -> Int -> Int -> ExprPos -> StateT a (Either Error) ()++errBounds i u r pos =+  let msg = "index out of bounds: " ++ i ++ "[" ++ show r ++ "]" ++ "\n" +++            "valid range:         0 - " ++ show (u - 1)  +  in StateT $ \_ -> runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates a comparison of two busses of+-- unequal length.++errBusCmp+  :: String -> String -> String -> Int -> Int -> ExprPos -> StateT a (Either Error) b++errBusCmp v1 v2 cm i j pos =+  let msg = "invalid comparison: " ++ v1 ++ " " ++ show cm ++ " " ++ v2+            ++ "\n" +++            "they are of unequal length: " ++ show i ++ " != " ++ show j +  in StateT $ \_ -> runtimeError pos msg                    ++-----------------------------------------------------------------------------++-- | Throws an error that indicates that the minimum operation is applied+-- to an empty set.++errMinSet+  :: ExprPos -> StateT a (Either Error) b++errMinSet pos = +  let msg = "Cannot compute the minumum of an empty set."+  in StateT $ \_ -> runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates that the maximum operation is applied+-- to an empty set.++errMaxSet+  :: ExprPos -> StateT a (Either Error) b++errMaxSet pos = +  let msg = "Cannot compute the maximum of an empty set."+  in StateT $ \_ -> runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates that the intersection operation is+-- to an empty list of sets.++errSetCap+  :: ExprPos -> StateT a (Either Error) b++errSetCap pos = +  let msg = "Cannot compute the intersection of an empty set of sets."+  in StateT $ \_ -> runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates that during the evaluation of a function+-- no guard could be applied.++errNoMatch+  :: String -> [String] -> ExprPos -> StateT a (Either Error) b++errNoMatch i xs pos = +  let msg = "there is no positive guard to evaluate:\n" +++            "  " ++ i ++ "(" +++            (if null xs then "" else+               head xs ++ concatMap ((:) ',' . (:) ' ') (tail xs)) +++            ")"+  in StateT $ \_ -> runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates a pair of variables that would clash+-- if converted to lower case.++errToLower+  :: String -> String -> String -> ExprPos -> Either Error a ++errToLower fmt n1 n2 pos =+  let msg = "The " ++ fmt ++ " format only accepts lower case variables. " +++            "However, automatic conversion introduces a clash, since " +++            "then '" ++ n1 ++ "' equals '" ++ n2 ++ "'."+  in runtimeError pos msg++-----------------------------------------------------------------------------++-- | Throws an error that indicates that the given formula is not in GR1,+-- which is neccessary for the corresponding conversation.++errNoGR1+  :: String -> String -> Either Error a ++errNoGR1 t fmt =+  let msg = "The given specification is not in GR(1), which is " +++            "neccessary to convert to the " ++ fmt ++ " format."+  in conversionError t msg++-----------------------------------------------------------------------------
+ src/Writer/Eval.hs view
@@ -0,0 +1,1200 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Eval+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Unfolds all high level constructs of a specification to the corresponding+-- low level constructs.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    FlexibleContexts++  #-}++-----------------------------------------------------------------------------++module Writer.Eval+  ( eval+  , signals+  ) where++-----------------------------------------------------------------------------++import Utils+  ( iter+  )++import Data.Error+  ( cfgError+  )++import Data.Enum+  ( EnumDefinition(..)+  )++import Data.Maybe+  ( fromMaybe+  , catMaybes+  )++import Config+  ( Configuration(..)+  )++import Data.Either+  ( partitionEithers+  )++import Data.List+  ( find+  )++import Data.Char+  ( toLower+  )++import Data.LTL+  ( Atomic(..)+  , Formula(..)+  , subFormulas+  , applyAtomic+  , applySub+  , fGlobally+  , fAnd+  , fNot+  )++import Data.Types+  ( IdType(..)+  , Semantics(..)+  , SignalType(..)+  , SignalDecType(..)+  )++import Data.Binding+  ( BindExpr(..)+  )++import Data.Expression+  ( Expr(..)+  , Expr'(..)+  , ExprPos+  )++import Data.Specification+  ( Specification(..)+  )++import Data.SymbolTable+  ( IdRec(..)+  , SymbolTable+  )++import Writer.Error+  ( Error+  , errBounds+  , errBusCmp+  , errMinSet+  , errMaxSet+  , errSetCap+  , errNoMatch+  )++import Writer.Formats+  ( needsLower+  )++import Control.Monad.State+  ( StateT(..)+  , foldM+  , execStateT+  , evalStateT+  , liftM2+  , liftM+  , when+  , get+  , put+  )++import Control.Exception+  ( assert+  )++import Data.Array.IArray+  ( (!)+  )++import qualified Data.Graph as G++import qualified Data.IntMap as IM++import qualified Data.Set as S++import qualified Data.Array.IArray as A++-----------------------------------------------------------------------------++data Value =+    VEmpty+  | VNumber Int+  | VLtl Formula+  | VSet (S.Set Value)+  | VEnum String Int [Int -> Either Bool ()]+  | VSignal SignalType String+  | VBus SignalType Int String++instance Show Value where+  show v = case v of+    VEmpty      -> "VEmpty"+    VNumber i   -> "VNumber " ++ show i+    VLtl f      -> "VLtl " ++ show f+    VSet s      -> "VSet " ++ show s+    VEnum {}    -> "VEnum"+    VSignal _ s -> "VSingal " ++ s+    VBus _ i s  -> "VBus " ++ s ++ "[" ++ show i ++ "]"++instance Eq Value where+  (==) VEmpty VEmpty                 = True+  (==) (VNumber i) (VNumber j)       = i == j+  (==) (VLtl f) (VLtl f')            = f == f'+  (==) (VSet s) (VSet s')            = s == s'+  (==) (VSignal _ s) (VSignal _ s')  = s == s'+  (==) (VBus _ _ s) (VBus _ _ s')    = s == s'+  (==) (VEnum _ i xs) (VEnum _ j ys) =+     i == j && length xs == length ys &&+     map (\f -> map f [0,1..i-1]) xs ==+     map (\f -> map f [0,1..i-1]) ys+  (==) _ _                           = False++instance Ord Value where+  compare VEmpty VEmpty                 = EQ+  compare (VNumber i) (VNumber j)       = compare i j+  compare (VLtl f) (VLtl f')            = compare f f'+  compare (VSet s) (VSet s')            = compare s s'+  compare (VSignal _ s) (VSignal _ s')  = compare s s'+  compare (VBus _ _ s) (VBus _ _ s')    = compare s s'+  compare (VEnum _ i xs) (VEnum _ j ys)+    | i /= j                 = compare i j+    | length xs /= length ys = compare (length xs) (length ys)+    | otherwise             =+        compare (map (\f -> map f [0,1..i-1]) xs)+                (map (\f -> map f [0,1..i-1]) ys)+  compare x y                           = compare (cidx x) (cidx y)++    where+      cidx :: Value -> Int+      cidx VEmpty     = 0+      cidx VNumber {} = 1+      cidx VLtl {}    = 2+      cidx VSet {}    = 3+      cidx VEnum {}   = 4+      cidx VSignal {} = 5+      cidx VBus {}    = 6++-----------------------------------------------------------------------------++type Evaluator a = a -> StateT ST (Either Error) Value++-----------------------------------------------------------------------------++data ST = ST+  { tLookup :: SymbolTable+  , tValues :: IM.IntMap Value+  , delimiter :: String+  , enums :: [EnumDefinition Int]+  }++-----------------------------------------------------------------------------++-- | @eval c s@ evaluates all high level constructs of the given+-- specification @s@ under the current configuration @c@.++eval+  :: Configuration -> Specification+     -> Either Error ([Formula],[Formula],[Formula],+                     [Formula],[Formula],[Formula])++eval c s = do+  (s', st0, xs) <- initialize c s+  let ios = inputs s' ++ outputs s'++  stt <- execStateT (mapM_ staticBinding xs) st0+  (rr,sti) <- runStateT (mapM componentSignal ios) stt+  let (er,sr) = partitionEithers $ catMaybes rr++  es <- evalStateT (mapM evalLtl $ initially s') sti+  ts <- evalStateT (mapM evalLtl $ preset s') sti+  rs <- evalStateT (mapM evalLtl $ requirements s') sti+  as <- evalStateT (mapM evalLtl $ assumptions s') sti+  is <- evalStateT (mapM evalLtl $ invariants s') sti+  gs <- evalStateT (mapM evalLtl $ guarantees s') sti++  return $ splitConjuncts $ overwrite s'+    ( map plainltl es, map plainltl ts, map plainltl (rs ++ er),+      map plainltl as, map plainltl (is ++ sr), map plainltl gs )++  where+    plainltl = applyAtomic apA . vltl++    apA :: Atomic -> Formula+    apA x = Atomic $ case x of+      Input y  -> Input $ repap (atSymbol c) (primeSymbol c)+                  $ lower $ last $ words y+      Output y -> Output $ repap (atSymbol c) (primeSymbol c)+                  $ lower $ last $ words y++    lower x =+      if needsLower (outputFormat c)+      then map toLower x+      else x++    overwrite sp (es,ss,rs,as,is,gs) =+      let+        og = all outputsGuarded (es ++ ss ++ rs ++ as ++ is ++ gs)+        ig = all inputsGuarded (es ++ ss ++ rs ++ as ++ is ++ gs)++        (es',ss',rs',as',is',gs') =+          if (semantics sp, owSemantics c) `elem`+             [(SemanticsStrictMealy, Just SemanticsMealy),+              (SemanticsStrictMealy, Just SemanticsMoore),+              (SemanticsStrictMoore, Just SemanticsMealy),+              (SemanticsStrictMoore, Just SemanticsMoore)]+          then (es, filter (/= TTrue) ((fWeak (fAnd is) (fNot (fAnd rs))) : ss),+                rs, as, [], gs)+          else (es,ss,rs,as,is,gs)+      in+        (map (adjustOW og ig sp) es',+         map (adjustOW og ig sp) ss',+         map (adjustOW og ig sp) rs',+         map (adjustOW og ig sp) as',+         map (adjustOW og ig sp) is',+         map (adjustOW og ig sp) gs')++    fWeak TTrue _  = TTrue+    fWeak x FFalse = fGlobally x+    fWeak x y      = Weak x y++    adjustOW og ig sp e = case owSemantics c of+      Nothing -> e+      Just m+        | (semantics sp, m) `elem`+            [(SemanticsMealy, SemanticsMealy),+             (SemanticsMoore, SemanticsMoore),+             (SemanticsStrictMealy, SemanticsStrictMealy),+             (SemanticsStrictMoore, SemanticsStrictMoore),+             (SemanticsStrictMealy, SemanticsMealy),+             (SemanticsStrictMoore, SemanticsMoore)] -> e+        | (semantics sp, m) `elem`+            [(SemanticsMealy, SemanticsMoore),+             (SemanticsStrictMealy, SemanticsMoore),+             (SemanticsStrictMealy, SemanticsStrictMoore)] ->+              if ig then unGuardInputs sp e else guardOutputs sp e+        | (semantics sp, m) `elem`+            [(SemanticsMoore, SemanticsMealy),+             (SemanticsStrictMoore, SemanticsMealy),+             (SemanticsStrictMoore, SemanticsStrictMealy)] ->+              if og then unGuardOutputs sp e else guardInputs sp e+        | otherwise ->+             error "Conversion from non-strict -> strict semantics not possible"++    outputsGuarded e = case e of+      Next (Atomic (Output _)) -> True+      Atomic (Output _) -> False+      _ -> all outputsGuarded $ subFormulas e++    inputsGuarded e = case e of+      Next (Atomic (Input _)) -> True+      Atomic (Input _) -> False+      _ -> all inputsGuarded $ subFormulas e++    guardOutputs sp e = case e of+      Atomic (Output x) -> Next $ Atomic $ Output x+      _        -> applySub (guardOutputs sp) e++    guardInputs sp e = case  e of+      Atomic (Input x) -> Next $ Atomic $ Input x+      _        -> applySub (guardInputs sp) e++    unGuardOutputs sp e  = case e of+      Next (Atomic (Output x)) -> Atomic $ Output x+      _                        -> applySub (unGuardOutputs sp) e++    unGuardInputs sp e  = case e of+      Next (Atomic (Input x)) -> Atomic $ Input x+      _                       -> applySub (unGuardInputs sp) e++    splitConjuncts (es,ss,rs,xs,ys,zs) =+      ( concatMap splitC es,+        concatMap splitC ss,+        concatMap splitC rs,+        concatMap splitC xs,+        concatMap splitC ys,+        concatMap splitC zs)++    splitC fml = case fml of+      And xs -> concatMap splitC xs+      _      -> [fml]++-----------------------------------------------------------------------------++-- | Returns the signals of a specification using the format as+-- implied by the given configuration.++signals+  :: Configuration -> Specification+  -> Either Error ([String],[String])++signals c s = do+  (s',st,xs) <- initialize c s+  let ios = inputs s' ++ outputs s'+  stt <- execStateT (mapM_ staticBinding xs) st+  stf <- execStateT (mapM_ componentSignal ios) stt+  let+    is = map getId $ inputs s'+    os = map getId $ outputs s'++  iv <- evalStateT (mapM getV is) stf+  ov <- evalStateT (mapM getV os) stf++  return (+    map (lower . repap (atSymbol c) (primeSymbol c)) $ concat iv,+    map (lower . repap (atSymbol c) (primeSymbol c)) $ concat ov+    )++  where+    lower x =+      if needsLower (outputFormat c)+      then map toLower x+      else x++    getId v = case v of+      SDSingle (i,_) -> i+      SDBus (i,_) _  -> i+      SDEnum (i,_) _ -> i++    getV i = do+      st <- get+      case IM.lookup i (tValues st) of+        Nothing -> assert False undefined+        Just x  -> case x of+          VSignal _ y -> return [y]+          VBus _ n y  -> return [y ++ delimiter st ++ show j | j <- [0,1..n-1]]+          _           -> assert False undefined++-----------------------------------------------------------------------------++-- | Computes the initial state for the evaluation of the+-- specification, as well as the adapted specification and the+-- resolution order.++initialize+  :: Configuration -> Specification -> Either Error (Specification, ST, [Int])++initialize c s = do+  s' <- foldM overwriteParameter s $ owParameter c+  let+    s'' = s' {+      target = fromMaybe (target s') $ owTarget c+      }+    xs = filter (isunary s'') $+         map bIdent $ parameters s'' ++ definitions s''+    ys = concatMap (\i -> map (\j -> (i,j)) $ filter (isunary s'') $+                         idDeps $ symboltable s'' ! i) xs+    minkey = foldl min (head xs) xs+    maxkey = foldl max (head xs) xs+    zs = if null xs then []+         else reverse $ G.topSort $ G.buildG (minkey,maxkey) ys++  st <- execStateT (mapM_ enumBinding $ enumerations s) $ ST+        (symboltable s'')+        IM.empty+        (busDelimiter c)+        (enumerations s)++  return (s'', st, zs)++  where+    isunary y x = null $ idArgs $ symboltable y ! x++-----------------------------------------------------------------------------++enumBinding+  :: EnumDefinition Int -> StateT ST (Either Error) ()++enumBinding x = do+  st <- get+  let n = idName $ tLookup st ! eName x+  put $ st {+    tValues = foldl (add n $ eSize x) (tValues st) $ eValues x+    }++  where+    add n s im (v,_,fs) =+      IM.insert v (VEnum n s fs) im++-----------------------------------------------------------------------------++staticBinding+  :: Int -> StateT ST (Either Error) ()++staticBinding x = do+  st <- get++  VSet bs <- evalSet $ idBindings $ tLookup st ! x++  case S.toList bs of+    []  -> return ()+    v:_ ->+      put $ st {+        tValues = IM.insert x v $ tValues st+        }++-----------------------------------------------------------------------------++componentSignal+  :: SignalDecType Int -> StateT ST (Either Error) (Maybe (Either Value Value))++componentSignal s = do+  st <- get+  (i,v,r) <- case s of+    SDSingle (i,_) -> case idType $ tLookup st ! i of+      TSignal io  -> return (i,VSignal io $ idName (tLookup st ! i), Nothing)+      _           -> assert False undefined+    SDBus (i,_) e  -> do+      VNumber n <- evalNum e+      case idType $ tLookup st ! i of+        TBus io  -> return (i,VBus io n $ idName (tLookup st ! i), Nothing)+        _        -> assert False undefined+    SDEnum (i,_) _ ->+      case idType $ tLookup st ! i of+        TTypedBus io _ t -> case find ((== t) . eName) $ enums st of+          Nothing -> assert False undefined+          Just e  ->+            let+              m = idName (tLookup st ! i)+              v = VBus io (eSize e) m+              r = case eMissing e of+                [] -> Nothing+                xs -> case io of+                  STInput  -> Just $ Left $+                             missing (delimiter st) m Input (eSize e) xs+                  STOutput -> Just $ Right $+                             missing (delimiter st) m Output (eSize e) xs+                  _        -> assert False undefined+            in+              return (i,v,r)++        _                -> assert False undefined++  put $ st {+    tValues = IM.insert i v $ tValues st+    }++  return r++  where+    missing d m c n xs = VLtl $ And $ map (tB d m c n) xs++    tB d m c n f = Or $ map (tV d m c f) [0,1..n-1]++    tV d m c f i = case f i of+      Left True  -> Not $ Atomic $ c $ m ++ d ++ show i+      Left False -> Atomic $ c $ m ++ d ++ show i+      _          -> assert False undefined++-----------------------------------------------------------------------------++evalExpr+  :: Evaluator (Expr Int)++evalExpr e = case expr e of+  BaseWild        -> evalLtl e+  BaseCon {}      -> evalNum e+  NumSMin {}      -> evalNum e+  NumSMax {}      -> evalNum e+  NumSSize {}     -> evalNum e+  NumSizeOf {}    -> evalNum e+  NumPlus {}      -> evalNum e+  NumMinus {}     -> evalNum e+  NumMul {}       -> evalNum e+  NumDiv {}       -> evalNum e+  NumMod {}       -> evalNum e+  NumRPlus {}     -> evalNum e+  NumRMul {}      -> evalNum e+  BaseTrue        -> evalLtl e+  BaseFalse       -> evalLtl e+  BaseBus {}      -> evalLtl e+  BlnEQ {}        -> evalLtl e+  BlnNEQ {}       -> evalLtl e+  BlnGE {}        -> evalLtl e+  BlnGEQ {}       -> evalLtl e+  BlnLE {}        -> evalLtl e+  BlnLEQ {}       -> evalLtl e+  BlnNot {}       -> evalLtl e+  BlnOr {}        -> evalLtl e+  BlnROr {}       -> evalLtl e+  BlnAnd {}       -> evalLtl e+  BlnRAnd {}      -> evalLtl e+  BlnImpl {}      -> evalLtl e+  BlnElem {}      -> evalLtl e+  BlnEquiv {}     -> evalLtl e+  LtlNext {}      -> evalLtl e+  LtlRNext {}     -> evalLtl e+  LtlGlobally {}  -> evalLtl e+  LtlRGlobally {} -> evalLtl e+  LtlFinally {}   -> evalLtl e+  LtlRFinally {}  -> evalLtl e+  LtlUntil {}     -> evalLtl e+  LtlWeak {}      -> evalLtl e+  LtlRelease {}   -> evalLtl e+  SetExplicit {}  -> evalSet e+  SetRange {}     -> evalSet e+  SetCup {}       -> evalSet e+  SetRCup {}      -> evalSet e+  SetCap {}       -> evalSet e+  SetRCap {}      -> evalSet e+  SetMinus {}     -> evalSet e+  BaseId x        -> idValue x+  BaseFml xs x    -> fmlValue xs (srcPos e) x+  Colon {}        -> evalColon e+  _               -> assert False undefined++-----------------------------------------------------------------------------++evalLtl+  :: Evaluator (Expr Int)++evalLtl e = case expr e of+  BaseTrue         -> return $ VLtl TTrue+  BaseFalse        -> return $ VLtl FFalse+  BlnNot x         -> liftMLtl Not x+  LtlNext x        -> liftMLtl Next x+  LtlGlobally x    -> liftMLtl Globally x+  LtlFinally x     -> liftMLtl Finally x+  LtlUntil x y     -> liftM2Ltl Until x y+  LtlRelease x y   -> liftM2Ltl Release x y+  LtlWeak x y      -> liftM2Ltl Weak x y+  BlnImpl x y      -> liftM2Ltl Implies x y+  BlnEquiv x y     -> liftM2Ltl Equiv x y+  BlnEQ x y        -> do+    b <- evalEquality (==) "==" x y $ srcPos e+    case b of+      Left v -> return v+      Right True -> return $ VLtl TTrue+      Right False -> return $ VLtl FFalse+  BlnNEQ x y       -> do+    b <- evalEquality (/=) "!=" x y $ srcPos e+    case b of+      Left v -> return v+      Right True -> return $ VLtl TTrue+      Right False -> return $ VLtl FFalse+  BlnGE x y        -> liftM2Num (>) x y+  BlnGEQ x y       -> liftM2Num (>=) x y+  BlnLE x y        -> liftM2Num (<) x y+  BlnLEQ x y       -> liftM2Num (<=) x y+  BaseId _         -> do+    x <- evalExpr e+    case x of+      VLtl y             -> return $ VLtl y+      VSignal STInput y  -> return $ VLtl $ Atomic $ Input y+      VSignal STOutput y -> return $ VLtl $ Atomic $ Output y+      _                  -> assert False undefined+  BaseFml _ _      -> do+    x <- evalExpr e+    case x of+      VLtl y             -> return $ VLtl y+      VSignal STInput y  -> return $ VLtl $ Atomic $ Input y+      VSignal STOutput y -> return $ VLtl $ Atomic $ Output y+      _                  -> assert False undefined+  LtlRNext x y     -> do+    VNumber n <- evalNum x+    VLtl v <- evalLtl y+    return $ VLtl $ iter Next n v+  LtlRGlobally x y -> do+    (i,j) <- evalRange x+    if i > j then+      return $ VLtl TTrue+    else do+      VLtl v <- evalLtl y+      return $ VLtl $ iter Next i $+        iter (\a -> And [v, Next a]) (j - i) v+  LtlRFinally x y  -> do+    (i,j) <- evalRange x+    if i > j then+      return $ VLtl TTrue+    else do+      VLtl v <- evalLtl y+      return $ VLtl $ iter Next i $+        iter (\a -> Or [v, Next a]) (j - i) v++  BlnElem x y      -> do+    a <- evalExpr x+    VSet b <- evalExpr y+    return $ VLtl $ if S.member a b then+      TTrue+    else+      FFalse+  BlnOr x y        -> do+    VLtl a <- evalLtl x+    VLtl b <- evalLtl y+    return $ VLtl $ Or [a,b]+  BlnAnd x y       -> do+    VLtl a <- evalLtl x+    VLtl b <- evalLtl y+    return $ VLtl $ And [a,b]+  BlnRAnd xs x     ->+    let f = VLtl . And . map (\(VLtl v) -> v)+    in evalConditional evalLtl f xs x+  BlnROr xs x      ->+    let f = VLtl . Or . map (\(VLtl v) -> v)+    in evalConditional evalLtl f xs x+  BaseBus x y      -> do+    VBus io l s <- idValue y+    VNumber b <- evalNum x++    when (b < 0 || b >= l) $+      errBounds s l b $ srcPos e++    st <- get+    return $ VLtl $ Atomic $ case io of+      STInput   -> Input $ s ++ delimiter st ++ show b+      STOutput  -> Output $ s ++  delimiter st ++ show b+      STGeneric -> assert False undefined+  _                -> assert False undefined++  where+    liftMLtl f m = do+      VLtl x <- evalLtl m+      return $ VLtl $ f x++    liftM2Ltl f m n = do+      VLtl x <- evalLtl m+      VLtl y <- evalLtl n+      return $ VLtl $ f x y++    liftM2Num f m n = do+      VNumber x <- evalNum m+      VNumber y <- evalNum n+      return $ VLtl $ if f x y then+        TTrue+      else+        FFalse++-----------------------------------------------------------------------------++idValue+  :: Evaluator Int++idValue i = do+  st <- get+  case IM.lookup i $ tValues st of+    Just x  -> return x+    Nothing -> assert False undefined++-----------------------------------------------------------------------------++evalNum+  :: Evaluator (Expr Int)++evalNum e = case expr e of+  BaseCon x     -> return $ VNumber x+  NumPlus x y   -> liftM2Num (+) x y+  NumMinus x y  -> liftM2Num (-) x y+  NumMul x y    -> liftM2Num (*) x y+  NumDiv x y    -> liftM2Num div x y+  NumMod x y    -> liftM2Num mod x y+  NumSMin x     -> do+    VSet y <- evalExpr x+    let xs = map (\(VNumber v) -> v) $ S.elems y+    if null xs then+      errMinSet $ srcPos e+    else+      return $ VNumber $ foldl min (head xs) xs+  NumSMax x     -> do+    VSet y <- evalExpr x+    let xs = map (\(VNumber v) -> v) $ S.elems y+    if null xs then+      errMaxSet $ srcPos e+    else+      return $ VNumber $ foldl max (head xs) xs+  NumSSize x    -> do+    VSet y <- evalExpr x+    return $ VNumber $ S.size y+  NumSizeOf x   -> do+    VBus _ i _ <- evalExpr x+    return $ VNumber i+  NumRPlus xs x ->+    let f = VNumber . sum . map (\(VNumber v) -> v)+    in evalConditional evalNum f xs x+  NumRMul xs x  ->+    let f = VNumber . product . map (\(VNumber v) -> v)+    in evalConditional evalNum f xs x+  BaseId _      -> do+    VNumber x <- evalExpr e+    return $ VNumber x+  BaseFml _ _   -> do+    VNumber x <- evalExpr e+    return $ VNumber x+  _             -> assert False undefined++  where+    liftM2Num f m n = do+      VNumber x <- evalNum m+      VNumber y <- evalNum n+      return $ VNumber $ f x y++-----------------------------------------------------------------------------++evalBool+  :: Expr Int -> StateT ST (Either Error) Bool++evalBool e = case expr e of+  BaseOtherwise -> return True+  BaseTrue      -> return True+  BaseFalse     -> return False+  BlnNot x      -> liftM not $ evalBool x+  BlnImpl x y   -> do+    a <- evalBool x+    if a then+      evalBool y+    else+      return True+  BlnEquiv x y  -> liftM2 (==) (evalBool x) (evalBool y)+  BlnOr x y     -> liftM2 (||) (evalBool x) (evalBool y)+  BlnAnd x y    -> liftM2 (&&) (evalBool x) (evalBool y)+  BlnEQ x y     -> do+    b <- evalEquality (==) "==" x y $ srcPos e+    case b of+      Left _  -> assert False undefined+      Right v -> return v+  BlnNEQ x y    -> do+    b <- evalEquality (/=) "!=" x y $ srcPos e+    case b of+      Left _  -> assert False undefined+      Right v -> return v+  BlnGE x y     -> liftM2Num (>) x y+  BlnGEQ x y    -> liftM2Num (>=) x y+  BlnLE x y     -> liftM2Num (<) x y+  BlnLEQ x y    -> liftM2Num (<=) x y+  BlnElem x y   -> do+    a <- evalExpr x+    VSet b <- evalExpr y+    return $ S.member a b+  BlnRAnd xs x  -> evalConditional evalBool and xs x+  BlnROr xs x   -> evalConditional evalBool or xs x+  Pattern x y   -> do+    VLtl a <- evalLtl x+    checkPattern a y+  _             -> assert False undefined++  where+    liftM2Num f m n = do+      VNumber x <- evalNum m+      VNumber y <- evalNum n+      return $ f x y++-----------------------------------------------------------------------------++checkPattern+  :: Formula -> Expr Int -> StateT ST (Either Error) Bool++checkPattern f e = case (f,expr e) of+  (_, BaseWild)                     -> return True+  (TTrue, BaseTrue)             -> return True+  (FFalse, BaseFalse)           -> return True+  (Not x, BlnNot y)             -> checkPattern x y+  (Next x, LtlNext y)           -> checkPattern x y+  (Globally x, LtlGlobally y)   -> checkPattern x y+  (Finally x, LtlFinally y)     -> checkPattern x y+  (Implies x y, BlnImpl z v)    -> binary x y z v+  (Equiv x y, BlnEquiv z v)     -> binary x y z v+  (Until x y, LtlUntil z v)     -> binary x y z v+  (Release x y, LtlRelease z v) -> binary x y z v+  (And xs, BlnAnd z v)          -> case xs of+    [x,y] -> binary x y z v+    _     -> assert False undefined+  (Or xs, BlnOr z v)            -> case xs of+    [x,y] -> binary x y z v+    _     -> assert False undefined+  (_, BaseId i)                     -> do+    st <- get+    put st {+      tValues = IM.insert i (VLtl f) $ tValues st+      }+    return True+  _                                 -> return False++  where+    binary x y z a = do+      b <- checkPattern x z+      if b then+        checkPattern  y a+      else+        return False++-----------------------------------------------------------------------------++evalSet+  :: Evaluator (Expr Int)++evalSet e = case expr e of+  SetExplicit xs -> do+    ys <- mapM evalExpr xs+    return $ VSet $ S.fromList ys+  SetRange x y z -> do+    [VNumber a,VNumber b,VNumber c] <- mapM evalNum [x,y,z]+    return $ VSet $ S.fromList $ map VNumber [a,b..c]+  SetCup x y     -> liftM2Set S.union x y+  SetCap x y     -> liftM2Set S.intersection x y+  SetMinus x y   -> liftM2Set S.difference x y+  SetRCup xs x   ->+    let f = VSet . S.unions . map (\(VSet v) -> v)+    in evalConditional evalSet f xs x+  SetRCap xs x   ->+    if null xs then+      errSetCap $ srcPos e+    else+      let+        g vs = foldl S.intersection (head vs) vs+        f = VSet . g . map (\(VSet v) -> v)+      in+        evalConditional evalSet f xs x+  BaseId _       -> do+    VSet x <- evalExpr e+    return $ VSet x+  BaseFml _ _    -> do+    VSet x <- evalExpr e+    return $ VSet x+  _ -> assert False undefined++  where+    liftM2Set f x y = do+      VSet a <- evalSet x+      VSet b <- evalSet y+      return $ VSet $ f a b++-----------------------------------------------------------------------------++evalConditional+  :: (Expr Int -> StateT ST (Either Error) a) -> ([a] -> a)+      -> [Expr Int] -> Expr Int -> StateT ST (Either Error) a++evalConditional fun f xs x =+  if null xs then+    fun x+  else do+    st <- get+    let+      i = case expr $ head xs of+        BlnElem e _ -> case expr e of+          BaseId r -> r+          _ -> assert False undefined+        BlnLE e _   -> case expr e of+          BlnLE _ m -> case expr m of+            BaseId r -> r+            _ -> assert False undefined+          BlnLEQ _ m -> case expr m of+            BaseId r -> r+            _ -> assert False undefined+          _ -> assert False undefined+        BlnLEQ e _  -> case expr e of+          BlnLE _ m -> case expr m of+            BaseId r -> r+            _ -> assert False undefined+          BlnLEQ _ m -> case expr m of+            BaseId r -> r+            _ -> assert False undefined+          _ -> assert False undefined+        _ -> assert False undefined+      s = idBindings $ tLookup st ! i+    VSet vs <- evalSet s+    rs <- mapM (bindExec i (tail xs) x) $ S.toList vs+    return $ f rs++  where+    bindExec i xr e v = do+      st <- get+      put st {+        tValues = IM.insert i v $ tValues st+        }+      r <- evalConditional fun f xr e+      put st+      return r++-----------------------------------------------------------------------------++evalRange+  :: Expr Int -> StateT ST (Either Error) (Int,Int)++evalRange e = case expr e of+  Colon x y -> do+    VNumber a <- evalNum x+    VNumber b <- evalNum y+    return (a,b)+  _ -> assert False undefined++-----------------------------------------------------------------------------++evalColon+  :: Evaluator (Expr Int)++evalColon e = case expr e of+  Colon x y -> do+    st <- get+    a <- evalBool x+    if a then do+      r <- evalExpr y+      put st+      return r+    else do+      put st+      return VEmpty+  _ -> assert False undefined++-----------------------------------------------------------------------------++evalEquality+  :: (Value -> Value -> Bool) -> String -> Expr Int -> Expr Int -> ExprPos+  -> StateT ST (Either Error) (Either Value Bool)++evalEquality eq eqs e1 e2 pos = do+  a <- evalExpr e1+  b <- evalExpr e2++  st <- get+  case (a,b) of+    (VEnum n i xs, VBus io l s)+      | l /= i     -> errBusCmp n s eqs l i pos+      | otherwise -> return $ Left $ VLtl $ opeq eq $ Or $+                    map (toB (delimiter st) io s [] i) xs+    (VBus io l s, VEnum n i xs)+      | l /= i     -> errBusCmp n s eqs l i pos+      | otherwise -> return $ Left $ VLtl $ opeq eq $ Or $+                    map (toB (delimiter st) io s [] i) xs+    (VBus io l s, VBus io' l' s')+      | l /= l'    -> errBusCmp s s' eqs l l' pos+      | otherwise ->+          return $ Left $ VLtl $ And+            [ Equiv (Atomic $ cio io $ s ++ delimiter st ++ show i)+              (Atomic $ cio io' $ s' ++ delimiter st ++ show i)+            | i <- [0,1..l-1] ]+    (VBus io l s, VSignal io' s')+      | l /= 1     -> errBusCmp s s' eqs l 1 pos+      | otherwise ->+          return $ Left $ VLtl $ Equiv+            (Atomic $ cio io $ s ++ delimiter st ++ "0")+            (Atomic $ cio io' s')+    (VSignal io' s', VBus io l s)+      | l /= 1     -> errBusCmp s s' eqs l 1 pos+      | otherwise ->+          return $ Left $ VLtl $ Equiv+            (Atomic $ cio io $ s ++ delimiter st ++ "0")+            (Atomic $ cio io' s')+    (VEnum _ 1 [f], VSignal io' s')  ->+      return $ Left $ VLtl $ case f 0 of+        Right () -> TTrue+        Left False -> Not $ Atomic $ cio io' s'+        Left True  -> Atomic $ cio io' s'+    (VSignal io' s', VEnum _ 1 [f])  ->+      return $ Left $ VLtl $ case f 0 of+        Right () -> TTrue+        Left False -> Not $ Atomic $ cio io' s'+        Left True  -> Atomic $ cio io' s'+    (VEnum n j _, VSignal _ s') ->+      errBusCmp n s' eqs j 1 pos+    (VSignal _ s', VEnum n j _) ->+      errBusCmp n s' eqs j 1 pos+    (VEnum {}, _) -> assert False undefined+    (VBus {}, _)  -> assert False undefined+    (_, VEnum {}) -> assert False undefined+    (_, VBus {})  -> assert False undefined+    _             ->+      if eq a b+      then return $ Right True+      else return $ Right False++  where+    opeq o+      | o VEmpty VEmpty = id+      | otherwise       = fNot++    toB _ _  _ a 0 _ = And a+    toB d io s a i f = case f (i-1) of+      Right ()    -> toB d io s a (i-1) f+      Left True  ->+        toB d io s ((Atomic $ cio io $ s ++ d ++ show (i-1)):a) (i-1) f+      Left False ->+        toB d io s ((Not $ Atomic $ cio io $ s ++ d ++ show (i-1)):a) (i-1) f++    cio STInput   = Input+    cio STOutput  = Output+    cio STGeneric = assert False undefined++-----------------------------------------------------------------------------++fmlValue+  :: [Expr Int] -> ExprPos -> Evaluator Int++fmlValue args p i = do+  st <- get+  as <- mapM evalExpr args+  let xs = zip as $ idArgs $ tLookup st ! i+  put st {+    tValues = foldl (\m (v,j) -> IM.insert j v m) (tValues st) xs+    }+  VSet a <- evalSet $ idBindings $ tLookup st ! i+  put st+  let ys = filter (/= VEmpty) $ S.toList a+  if null ys then+    errNoMatch (idName $ tLookup st ! i) (map (prVal . fst) xs) p+  else+    return $ head ys++-----------------------------------------------------------------------------++vltl+  :: Value -> Formula++vltl x = case x of+  VLtl y -> y+  _      -> assert False undefined++-----------------------------------------------------------------------------++prVal+  :: Value -> String++prVal v = case v of+  VNumber x -> show x+  VLtl x -> asciiLTL x+  VSet x -> case S.toList x of+    []     -> "{}"+    (y:yr) -> "{ " ++ prVal y +++             concatMap ((:) ',' . (:) ' ' . prVal) yr ++ " }"+  _ -> assert False undefined++-----------------------------------------------------------------------------++asciiLTL+  :: Formula -> String++asciiLTL fml = case fml of+  TTrue                   -> ptrue+  FFalse                  -> pfalse+  Not (Atomic (Input x))  -> pnot ++ prUO' (Atomic (Input x))+  Not (Atomic (Output x)) -> pnot ++ prUO' (Atomic (Output x))+  Atomic (Input x)        -> x+  Atomic (Output x)       -> x+  Not x                   -> pnot ++ prUO' x+  And []                  -> asciiLTL TTrue+  And [x]                 -> asciiLTL x+  And (x:xr)              -> prAnd' x ++ concatMap (((" " ++ pand ++ " ") ++)+                                                    . prAnd') xr+  Or []                   -> asciiLTL FFalse+  Or [x]                  -> asciiLTL x+  Or (x:xr)               -> prOr' x ++ concatMap (((" " ++ por ++ " ") ++)+                                                   . prOr') xr+  Implies x y             -> prOr' x ++ " " ++ pimplies ++ " " ++ prOr' y+  Equiv x y               -> prOr' x ++ " " ++ pequiv ++ " " ++ prOr' y+  Next x                  -> pnext ++ prUO' x+  Globally x              -> pglobally ++ prUO' x+  Finally x               -> pfinally ++ prUO' x+  Until x y               -> prOr' x ++ " " ++ puntil ++ " " ++ prOr' y+  Release x y             -> prOr' x ++ " " ++ prelease ++ " " ++ prOr' y+  Weak x y                -> prOr' x ++ " " ++ pweak ++ " " ++ prOr' y++  where+    parens x = "(" ++ x ++ ")"++    prUO p f = case f of+      And _       -> parens $ p f+      Or _        -> parens $ p f+      Implies _ _ -> parens $ p f+      Equiv _ _   -> parens $ p f+      Until _ _   -> parens $ p f+      Release _ _ -> parens $ p f+      _              -> p f++    prAnd p f = case f of+      Or _        -> parens $ p f+      Implies _ _ -> parens $ p f+      Equiv _ _   -> parens $ p f+      Until _ _   -> parens $ p f+      Release _ _ -> parens $ p f+      _              -> p f++    prOr p f = case f of+      Implies _ _ -> parens $ p f+      Equiv _ _   -> parens $ p f+      Until _ _   -> parens $ p f+      Release _ _ -> parens $ p f+      _              -> p f++    prUO' =  prUO asciiLTL+    prAnd' = prAnd asciiLTL+    prOr' = prOr asciiLTL++    ptrue = "true"+    pfalse = "false"+    pnot = "!"+    pand = "&&"+    por = "||"+    pimplies = "->"+    pequiv = "<->"+    pnext = "X"+    pglobally = "F"+    pfinally = "G"+    puntil = "U"+    prelease = "R"+    pweak = "W"++-----------------------------------------------------------------------------++-- | Overwrites a given parameter by the given new value.++overwriteParameter+  :: Specification -> (String, Int) -> Either Error Specification++overwriteParameter s (n,v) =+  case find ((n ==) . idName . (symboltable s !) . bIdent) $ parameters s of+  Nothing -> cfgError $ "Specification has no parameter: " ++ n+  Just b  -> do+    let b' = b {+          bVal = if null $ bVal b+                 then []+                 else [ Expr (BaseCon v) $ srcPos $ head $ bVal b ]+          }+    return s {+      parameters = map (replace b') $ parameters s,+      symboltable = updSymTable b' $ symboltable s+      }++  where+    replace b' b =+      if bIdent b == bIdent b'+      then b' else b++    updSymTable y t =+      A.amap (\x -> if idName x /= idName (t ! bIdent y) then x else x {+                 idBindings =+                    if null $ bVal y+                    then Expr (SetExplicit []) $ bPos y+                    else Expr (SetExplicit [head $ bVal y]) $ bPos y+                 }) t++-----------------------------------------------------------------------------++-- | Replaces at and prime symbols by their defined counterpart.++repap+  :: String -> String -> String -> String++repap atSym primeSym =+  concatMap (\x -> if x == '@' then atSym else [x]) .+  concatMap (\x -> if x == '\'' then primeSym else [x])++-----------------------------------------------------------------------------
+ src/Writer/Formats.hs view
@@ -0,0 +1,154 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Main list of supported writer formats.+--+-----------------------------------------------------------------------------++{-# LANGUAGE++    LambdaCase+  , MultiParamTypeClasses+  , TypeSynonymInstances+  , FlexibleInstances++  #-}++-----------------------------------------------------------------------------++module Writer.Formats+  ( WriteFormat(..)+  , needsLower+  ) where++-----------------------------------------------------------------------------++import Data.Convertible+  ( Convertible(..)+  , ConvertError(..)+  )++import Data.List+  ( find+  )++-----------------------------------------------------------------------------++-- | Supported writer formats.++data WriteFormat =+    UTF8+    -- ^ human readable output using UTF8 symbols+  | FULL+    -- ^ full format including all extensions+  | BASIC+    -- ^ basic format restricted to pure LTL formulas+  | WRING+    -- ^ <http://www.ist.tugraz.at/staff/bloem/wring.html>+  | PROMELA+    -- ^ <http://spinroot.com/spin/Man/ltl.html>+  | UNBEAST+    -- ^ <https://www.react.uni-saarland.de/tools/unbeast>+  | LTLXBA+    -- ^ LTL2BA / LTL3BA input format+  | LILY+    -- ^ Lily input format+  | ACACIA+    -- ^ Acacia / Acacia+ input format+  | ACACIASPECS+    -- ^ Acacia input format with spec units+  | SLUGS+    -- ^ <https://github.com/VerifiableRobotics/slugs/blob/master/doc/input_formats.md#structuredslugs>+  | SLUGSIN+    -- ^ <https://github.com/VerifiableRobotics/slugs/blob/master/doc/input_formats.md#slugsin>+  | PSL+    -- ^ <https://en.wikipedia.org/wiki/Property_Specification_Language>+  | SMV+    -- ^ SMV file format+  | BOSY+    -- ^ <https://github.com/reactive-systems/bosy>+  deriving (Eq, Ord)++-----------------------------------------------------------------------------++-- | Human readable names of the formats, which may include spaces or+-- other special characters.++instance Show WriteFormat where+  show = \case+    UTF8        -> "Utf8"+    WRING       -> "Wring"+    PROMELA     -> "Promela LTL"+    UNBEAST     -> "Unbeast"+    LTLXBA      -> "LtlXba"+    LILY        -> "Lily"+    ACACIA      -> "Acacia"+    ACACIASPECS -> "AcaciaSpecs"+    BASIC       -> "Basic"+    SLUGS       -> "Slugs"+    SLUGSIN     -> "SlugsIn"+    FULL        -> "Full"+    PSL         -> "Psl"+    SMV         -> "SMV"+    BOSY        -> "BoSy"++-----------------------------------------------------------------------------++instance Convertible WriteFormat String where+  safeConvert = return . \case+    UTF8        -> "utf8"+    WRING       -> "wring"+    PROMELA     -> "promela"+    UNBEAST     -> "unbeast"+    LTLXBA      -> "ltlxba"+    LILY        -> "lily"+    ACACIA      -> "acacia"+    ACACIASPECS -> "acacia-specs"+    BASIC       -> "basic"+    SLUGS       -> "slugs"+    SLUGSIN     -> "slugsin"+    FULL        -> "full"+    PSL         -> "psl"+    SMV         -> "smv"+    BOSY        -> "bosy"++-----------------------------------------------------------------------------++instance Convertible String WriteFormat where+  safeConvert = \case+    "utf8"         -> return UTF8+    "wring"        -> return WRING+    "promela"      -> return PROMELA+    "unbeast"      -> return UNBEAST+    "ltlxba"       -> return LTLXBA+    "lily"         -> return LILY+    "acacia"       -> return ACACIA+    "acacia-specs" -> return ACACIASPECS+    "basic"        -> return BASIC+    "slugs"        -> return SLUGS+    "slugsin"      -> return SLUGSIN+    "full"         -> return FULL+    "psl"          -> return PSL+    "smv"          -> return SMV+    "bosy"         -> return BOSY+    str            -> Left ConvertError+      { convSourceValue = str+      , convSourceType = "String"+      , convDestType = "WriteFormat"+      , convErrorMessage = "Unknown format"+      }++-----------------------------------------------------------------------------++-- | Indicates the formats only support lower case signal names.++needsLower+  :: WriteFormat -> Bool++needsLower s =+  s `elem` [LTLXBA, PROMELA, ACACIA, ACACIASPECS, LILY, BOSY]++-----------------------------------------------------------------------------
+ src/Writer/Formats/Acacia.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Acacia+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Transforms a specification to the Acacia+ format.+--+-----------------------------------------------------------------------------++module Writer.Formats.Acacia where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.LTL+import Data.Error+import Data.Types+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Acacia / Acacia+ operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp "!"    1+  , opAnd      = BinaryOp "*"   3 AssocLeft+  , opOr       = BinaryOp "+"   3 AssocLeft+  , opImplies  = BinaryOp "->"  3 AssocLeft+  , opEquiv    = BinaryOp "<->" 3 AssocLeft+  , opNext     = UnaryOp  "X"   1+  , opFinally  = UnaryOp  "F"   1+  , opGlobally = UnaryOp  "G"   1+  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOpUnsupported+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Acacia / Acacia+ writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es1,ss1,rs1,as1,is1,gs1) <-+    eval c s++  as2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) $+         case ss1 of+           [] -> filter (/= FFalse) $ es1 ++ map fGlobally rs1 ++ as1+           _  -> filter (/= FFalse) $ es1 +++                  map (\f -> fOr [fNot $ fAnd ss1, f])+                    (map fGlobally rs1 ++ as1)++  is2 <- mapM (simplify (adjust c opConfig) . fGlobally . adjustAtomic) is1+  gs2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) (gs1 ++ ss1)++  let+    as3 = map (printFormula opConfig (outputMode c)) as2+    is3 = map (printFormula opConfig (outputMode c)) is2+    gs3 = map (printFormula opConfig (outputMode c)) gs2++    as4 = map (\x -> "assume " ++ x ++ ";") as3+    is4 = map (++ ";") is3+    gs4 = map (++ ";") gs3++    xs = case as4 ++ is4 ++ gs4 of+      [] -> []+      ys -> map (++ "\n") $ filter nonempty $ (init ys) ++ [last ys]++  return $ concat xs++  where+    nonempty = any (\x -> x /= ' ' && x /= '\t')++    adjustAtomic fml = case fml of+      Not (Atomic (Output x)) -> Atomic (Output ("(" ++ x ++ "=0)"))+      Not (Atomic (Input x))  -> Atomic (Input ("(" ++ x ++ "=0)"))+      Atomic (Output x)       -> Atomic (Output ("(" ++ x ++ "=1)"))+      Atomic (Input x)        -> Atomic (Input ("(" ++ x ++ "=1)"))+      _                       -> applySub adjustAtomic fml++-----------------------------------------------------------------------------
+ src/Writer/Formats/AcaciaSpecs.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.AcaciaSpecs+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Guillermo Perez (gperezme@ulb.ac.be)+--                Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to the Acacia+ format including a unit+-- separation.+-- +-----------------------------------------------------------------------------++module Writer.Formats.AcaciaSpecs where++-----------------------------------------------------------------------------++import qualified Data.Char as Char++import Config+import Simplify++import Data.LTL+import Data.Error+import Data.Types+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Acacia / Acacia+ operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp "!"    1+  , opAnd      = BinaryOp "*"   3 AssocLeft+  , opOr       = BinaryOp "+"   3 AssocLeft+  , opImplies  = BinaryOp "->"  3 AssocLeft+  , opEquiv    = BinaryOp "<->" 3 AssocLeft+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "F"   1 +  , opGlobally = UnaryOp  "G"   1 +  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOpUnsupported+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Acacia / Acacia+ writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es1,ss1,rs1,as1,is1,gs1) <- eval c s+    +  as2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) $+         case ss1 of+           [] -> filter (/= FFalse) $ es1 ++ map fGlobally rs1 ++ as1+           _  -> filter (/= FFalse) $ es1 +++                  map (\f -> fOr [fNot $ fAnd ss1, f])+                    (map fGlobally rs1 ++ as1)++  is2 <- mapM (simplify (adjust c opConfig) . fGlobally . adjustAtomic) is1+  gs2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) (gs1 ++ ss1)+    +  let+    as3 = map (printFormula opConfig (outputMode c)) as2+    is3 = map (printFormula opConfig (outputMode c)) is2+    gs3 = map (printFormula opConfig (outputMode c)) gs2+  +    as4 = map (\x -> "assume " ++ x ++ ";") as3+    is4 = map (++ ";") is3+    gs4 = map (++ ";") gs3++    ws = map (++ "\n") as4+    flatws = concat ws++    xs = case is4 ++ gs4 of+      [] -> []+      ys -> map (++ "\n") (init ys) ++ [last ys]++    zs = zip [0..] xs++    finals = map (\x -> "[spec_unit " ++ show(fst x) ++ "]\n" ++ flatws ++ (snd x)) zs++  return $ concat finals++  where+    adjustAtomic fml = case fml of+      Not (Atomic (Output x)) -> Atomic (Output ("(" ++ x ++ "=0)"))+      Not (Atomic (Input x))  -> Atomic (Input ("(" ++ x ++ "=0)"))+      Atomic (Output x)       -> Atomic (Output ("(" ++ x ++ "=1)"))            +      Atomic (Input x)        -> Atomic (Input ("(" ++ x ++ "=1)"))+      _                       -> applySub adjustAtomic fml+    +-----------------------------------------------------------------------------
+ src/Writer/Formats/Basic.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Basic+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to the basic TLSF version without high level+-- constructs.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Basic where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Maybe+import Data.LTL+import Data.Types+import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Basic Format operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue     = "true"+  , fFalse    = "false"+  , opNot      = UnaryOp "!"   1+  , opAnd      = BinaryOp "&&"  2 AssocLeft+  , opOr       = BinaryOp "||"  3 AssocLeft+  , opImplies  = BinaryOp "->"  4 AssocRight+  , opEquiv    = BinaryOp "<->" 4 AssocRight+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "F"   1 +  , opGlobally = UnaryOp  "G"   1 +  , opUntil    = BinaryOp "U"   6 AssocRight+  , opRelease  = BinaryOp "R"   7 AssocLeft+  , opWeak     = BinaryOp "W"   5 AssocRight+  }++-----------------------------------------------------------------------------++-- | Basic TLSF writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  let s' = s {+      target = fromMaybe (target s) $ owTarget c,+      semantics = fromMaybe (semantics s) $ owSemantics c+      }++  (es,ss,rs,as,is,gs) <- eval c s+  es' <- mapM (simplify (adjust c opConfig)) es+  ss' <- mapM (simplify (adjust c opConfig)) ss+  rs' <- mapM (simplify (adjust c opConfig)) rs+  as' <- mapM (simplify (adjust c opConfig)) as+  is' <- mapM (simplify (adjust c opConfig)) is+  gs' <- mapM (simplify (adjust c opConfig)) gs  ++  (si,so) <- signals c s'++  return $+    "INFO {"+    ++ "\n" ++ "  TITLE:       \"" ++ title s' ++ "\""+    ++ "\n" ++ "  DESCRIPTION: \"" ++ description s' ++ "\""+    ++ "\n" ++ "  SEMANTICS:   " ++ +      (case semantics s' of+         SemanticsMealy       -> "Mealy"+         SemanticsMoore       -> "Moore"+         SemanticsStrictMealy -> "Strict,Mealy"+         SemanticsStrictMoore -> "Strict,Moore")    +    ++ "\n" ++ "  TARGET:      " ++ +      (case target s' of+         TargetMealy -> "Mealy"+         TargetMoore -> "Moore")+    ++ (if null $ tags s' then "" +        else "\n  TAGS:        " ++ head (tags s') +++             concatMap ((:) ' ' . (:) ',') (tail $ tags s'))+    ++ "\n" ++ "}"+    ++ "\n"+    ++ "\n" ++ "MAIN {"+    ++ "\n" ++ "  INPUTS {"+    ++ concatMap printSignal si+    ++ "\n" ++ "  }"+    ++ "\n" ++ "  OUTPUTS {"+    ++ concatMap printSignal so+    ++ "\n" ++ "  }"+    ++ (if not $ any checkTrue es' then "" +        else "\n" ++ "  INITIALLY {" +++             concatMap pr (filter checkTrue es') +++             "\n" ++ "  }")+    ++ (if not $ any checkTrue ss' then "" +        else "\n" ++ "  PRESET {" +++             concatMap pr (filter checkTrue ss') +++             "\n" ++ "  }")+    ++ (if not $ any checkTrue rs' then "" +        else "\n" ++ "  REQUIRE {" +++             concatMap pr (filter checkTrue rs') +++             "\n" ++ "  }")+    ++ (if not $ any checkTrue as' then "" +        else "\n" ++ "  ASSUME {" +++             concatMap pr (filter checkTrue as') +++             "\n" ++ "  }")+    ++ (if not $ any checkTrue is' then "" +        else "\n" ++ "  ASSERT {" +++             concatMap pr (filter checkTrue is') +++             "\n" ++ "  }")+    ++ (if not $ any checkTrue gs' then "" +        else "\n" ++ "  GUARANTEE {" +++             concatMap pr (filter checkTrue gs') +++             "\n" ++ "  }")+    ++ "\n" ++ "}"+    ++ "\n"++  where+    checkTrue f = case f of+      TTrue -> False+      _     -> True++    printSignal sig = +      "\n    " ++ sig ++ ";"++    pr = (++ ";") . ("\n    " ++) . printFormula opConfig Fully++-----------------------------------------------------------------------------
+ src/Writer/Formats/Bosy.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Bosy+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Leander Tentrup (tentrup@react.uni-saarland.de)+--                Felix Klein (klein@react.uni-saarland.de)+--+-- Transforms a specification to the BoSy JSON file format+--+-----------------------------------------------------------------------------++module Writer.Formats.Bosy where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Maybe+import Data.List+import Data.LTL+import Data.Types+import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++import Data.Char( toLower )++-----------------------------------------------------------------------------++-- | Basic Format operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue     = "true"+  , fFalse    = "false"+  , opNot      = UnaryOp "!"   1+  , opAnd      = BinaryOp "&&"  2 AssocLeft+  , opOr       = BinaryOp "||"  3 AssocLeft+  , opImplies  = BinaryOp "->"  4 AssocRight+  , opEquiv    = BinaryOp "<->" 4 AssocRight+  , opNext     = UnaryOp  "X"   1+  , opFinally  = UnaryOp  "F"   1+  , opGlobally = UnaryOp  "G"   1+  , opUntil    = BinaryOp "U"   6 AssocRight+  , opRelease  = BinaryOp "R"   7 AssocLeft+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Bosy JSON writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat config specification = do+  let config' = config {+      simplifyStrong = True+  }++  (initial, preset, requirments, assumptions, assertions, guarantees) <- eval config' specification+  initial' <- mapM (simplify (adjust config' opConfig)) initial+  preset' <- mapM (simplify (adjust config' opConfig)) preset+  requirments' <- mapM ((simplify (adjust config' opConfig)) . fGlobally) requirments+  assumptions' <- mapM (simplify (adjust config' opConfig)) assumptions+  assertions' <- mapM ((simplify (adjust config' opConfig)) . fGlobally) assertions+  guarantees' <- mapM (simplify (adjust config' opConfig)) guarantees++  (inputs, outputs) <- signals config' specification++  return $+    "{" +++    "\"semantics\": " +++      (case semantics specification of+         SemanticsMealy       -> "\"mealy\""+         SemanticsMoore       -> "\"moore\""+         SemanticsStrictMealy -> "\"mealy\""+         SemanticsStrictMoore -> "\"moore\"") ++ ", " +++    "\"inputs\": [" ++ (intercalate ", " (map printSignal inputs)) ++ "], " +++    "\"outputs\": [" ++ (intercalate ", " (map printSignal outputs)) ++ "], " +++    "\"assumptions\": [" ++ (intercalate ", " (map printFormula' (requirments' ++ assumptions'))) ++ "], " +++    "\"guarantees\": [" ++ (intercalate ", " (map printFormula' (assertions' ++ guarantees'))) ++ "] " +++    "}\n"++  where++    printFormula' f =+      "\"" ++ (printFormula opConfig Fully) f ++ "\""++    printSignal sig =+      "\"" ++ (map toLower sig) ++ "\""++-----------------------------------------------------------------------------
+ src/Writer/Formats/Full.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Full+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Returns a specification in full TLSF.+--+-----------------------------------------------------------------------------++module Writer.Formats.Full where++-----------------------------------------------------------------------------++import Config++import Data.Error+import Data.Binding+import Data.Expression+import Data.SymbolTable+import Data.Specification++import Data.List+import Data.Array as A++-----------------------------------------------------------------------------++-- | Replaces a list of positions in a given string.++replaces+  :: [(ExprPos, String)] -> String -> String++replaces xs str =+  let+    -- create an index mapping for the string+    idx = indexer str+    -- convert all entries in the list+    ys = sort $ map (\(p,s) -> (idx $ srcBegin p, idx $ srcEnd p, s)) xs+    -- recursively replace the entries+    (_,_,_,zs) = foldl rep (1, 0, ys, []) str+  in+    reverse zs++  where+    rep a x = case a of+      (i, v, [], xr)+        | i < v     -> (i+1, v, [], xr)+        | otherwise -> (i+1, v, [], x:xr)+      (i, v, (s,e,z):yr, xr)+        | i < v     -> (i+1, v, (s,e,z):yr, xr)+        | i < s     -> (i+1, v, (s,e,z):yr, x:xr)+        | otherwise -> (i+1, e, yr, reverse z ++ xr)++    indexer s =+      let+        -- split string into lines+        ls = map length $ lines s+        -- annotate each line with it's line number+        ys = zip [1,2..length ls] ls+        -- annotate each line with the index in the string+        (_,zs) = foldl (\(n,rs) (i,m) -> (n+m+1, (i,n):rs)) (0,[]) ys+        -- create a mapping from lines to the index of the start+        a = A.array (1,length ls) $ reverse zs+      in+       -- return a mapping that maps a position to the index+       \pos -> a ! srcLine pos + srcColumn pos++-----------------------------------------------------------------------------++-- | Full TLSF writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  xs <- mapM parToRep $ owParameter c+  return $ replaces xs $ source s++  where+    parToRep (str,v) =+      case findParam str of+        Nothing -> cfgError $ "Specification has no parameter: " ++ str+        Just p  -> return (p, show v)++    findParam str =+      let f x = str == idName (symboltable s ! bIdent x)+      in case filter f $ parameters s of+        []  -> Nothing+        x:_ -> return $ srcPos $ head $ bVal x++-----------------------------------------------------------------------------
+ src/Writer/Formats/Lily.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Acacia+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to the Ltl2ba / Ltl3ba format.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Lily where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.LTL+import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Lily operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp "!"    3+  , opAnd      = BinaryOp "*"   2 AssocLeft+  , opOr       = BinaryOp "+"   2 AssocLeft+  , opImplies  = BinaryOp "->"  2 AssocLeft+  , opEquiv    = BinaryOp "<->" 2 AssocLeft+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "F"   1 +  , opGlobally = UnaryOp  "G"   1 +  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOp "R"   2 AssocLeft+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Acacia / Acacia+ writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es1,ss1,rs1,as1,is1,gs1) <- eval c s+    +  as2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) $+         case ss1 of+           [] -> filter (/= FFalse) $ es1 ++ map fGlobally rs1 ++ as1+           _  -> filter (/= FFalse) $ es1 +++                  map (\f -> fOr [fNot $ fAnd ss1, f])+                    (map fGlobally rs1 ++ as1)++  is2 <- mapM (simplify (adjust c opConfig) . fGlobally . adjustAtomic) is1+  gs2 <- mapM (simplify (adjust c opConfig) . adjustAtomic) (gs1 ++ ss1)+    +  let+    as3 = map (printFormula opConfig (outputMode c)) as2+    is3 = map (printFormula opConfig (outputMode c)) is2+    gs3 = map (printFormula opConfig (outputMode c)) gs2+  +    as4 = map (\x -> "assume " ++ x ++ ";") as3+    is4 = map (++ ";") is3+    gs4 = map (++ ";") gs3++    xs = case as4 ++ is4 ++ gs4 of+      [] -> []+      ys -> map (++ "\n") (init ys) ++ [last ys]++  return $ concat xs++  where+    adjustAtomic fml = case fml of+      Not (Atomic (Output x)) -> Atomic (Output ("(" ++ x ++ "=0)"))+      Not (Atomic (Input x))  -> Atomic (Input ("(" ++ x ++ "=0)"))+      Atomic (Output x)       -> Atomic (Output ("(" ++ x ++ "=1)"))            +      Atomic (Input x)        -> Atomic (Input ("(" ++ x ++ "=1)"))+      _                       -> applySub adjustAtomic fml++-----------------------------------------------------------------------------+++
+ src/Writer/Formats/Ltlxba.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Ltlxba+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to the Ltl2ba / Ltl3ba format.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Ltlxba where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Ltl2ba / LTL3ba operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp  "!"   1+  , opAnd      = BinaryOp "&&"  4 AssocLeft+  , opOr       = BinaryOp "||"  4 AssocLeft+  , opImplies  = BinaryOp "->"  4 AssocLeft+  , opEquiv    = BinaryOp "<->" 4 AssocLeft+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "F"   1 +  , opGlobally = UnaryOp  "G"   1 +  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOp "R"   3 AssocLeft+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Ltl2ba / LTL3ba writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  fml0 <- merge es ss rs as is gs+  fml1 <- simplify (adjust c opConfig) fml0+    +  return $ printFormula opConfig (outputMode c) fml1++-----------------------------------------------------------------------------++
+ src/Writer/Formats/Promela.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Promela+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to Spins Promela LTL.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Promela where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Promela operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp  "!"   1+  , opAnd      = BinaryOp "&&"  3 AssocLeft+  , opOr       = BinaryOp "||"  3 AssocLeft+  , opImplies  = BinaryOp "->"  3 AssocLeft+  , opEquiv    = BinaryOp "<->" 3 AssocLeft+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "<>"  1 +  , opGlobally = UnaryOp  "[]"  1  +  , opUntil    = BinaryOp "U"   2 AssocLeft +  , opRelease  = BinaryOp "V"   2 AssocLeft +  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Promela LTL writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  fml0 <- merge es ss rs as is gs+  fml1 <- simplify (adjust c opConfig) fml0+    +  return $ printFormula opConfig (outputMode c) fml1  ++-----------------------------------------------------------------------------+++
+ src/Writer/Formats/Psl.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Utf8+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to a UTF8 string.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Psl where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | PSL operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "true"+  , fFalse     = "false"+  , opNot      = UnaryOp  "!"           1+  , opAnd      = BinaryOp "&&"          2 AssocLeft+  , opOr       = BinaryOp "||"          3 AssocLeft+  , opImplies  = BinaryOp "->"          6 AssocRight+  , opEquiv    = BinaryOp "<->"         6 AssocRight+  , opNext     = UnaryOp  "next!"       4 +  , opFinally  = UnaryOp  "eventually!" 4 +  , opGlobally = UnaryOp  "always"      7      +  , opUntil    = BinaryOp "until!"      5 AssocRight+  , opRelease  = BinaryOpUnsupported+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | PSL format writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  fml0 <- merge es ss rs as is gs+  fml1 <- simplify (adjust c opConfig) fml0+  +  return $ printFormula opConfig (outputMode c) fml1++-----------------------------------------------------------------------------+
+ src/Writer/Formats/Slugs.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Slugs+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification in GR(1) into the Slugs format.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Slugs where++-----------------------------------------------------------------------------++import Config++import Data.Error+import Data.LTL+import Data.List+import Writer.Eval+import Writer.Error+import Data.Specification++import Detection+import Control.Exception++-----------------------------------------------------------------------------++-- | Slugs format writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = +  case detectGR c s of+    Left v -> case v of+      Left err -> Left err+      Right _  -> errNoGR1 "not in GR(1)" "slugs"+    Right gr+      | level gr > 1        ->+          errNoGR1 ("in GR(" ++ show (level gr) ++ ")") "slugs"+      | primeSymbol c == "'" -> do+          (iv,ov) <- signals c s+          case find (== '\'') $ concat (iv ++ ov) of+            Nothing -> printSlugs gr+            Just _  ->+              cfgError $+                "The specification contains primes, which cannot be used " +++                "inside Slugs signal names.\nThey can be replaced " +++                "by changing the default value of the \"-ps\" option."+      | otherwise           -> printSlugs gr+  +  where+    printSlugs gr = do+      let+        es = initEnv gr+        ss = initSys gr+        rs = assertEnv gr+        is = assertSys gr+        (le,ls) = case liveness gr of+          []  -> ([],[])+          x:_ -> x++      (iv,ov) <- signals c s+      +      return $ "[INPUT]"+        ++ "\n" ++ unlines iv+        ++ "\n" ++ "[OUTPUT]"+        ++ "\n" ++ unlines ov+        ++ (if null es then "" else+             "\n" ++ "[ENV_INIT]" ++ +             "\n" ++ unlines (map prFormula es))+        ++ (if null ss then "" else             +             "\n" ++ "[SYS_INIT]" +++             "\n" ++ unlines (map prFormula ss))+        ++ (if null rs then "" else        +              "\n" ++ "[ENV_TRANS]" +++              "\n" ++ unlines (map prFormula rs))+        ++ (if null is then "" else        +              "\n" ++ "[SYS_TRANS]" +++              "\n" ++ unlines (map prFormula is))+        ++ (if null le then "" else +              "\n" ++ "[ENV_LIVENESS]" +++              "\n" ++ unlines (map prFormula le))+        ++ (if null ls then "" else        +             "\n" ++ "[SYS_LIVENESS]" +++             "\n" ++ unlines (map prFormula ls))++    prFormula fml = case fml of+      TTrue                 -> "TRUE"+      FFalse                -> "FALSE"+      Atomic x              -> show x+      Not x                 -> "!" ++ prFormula' x +      Next (Atomic x)       -> show x ++ "'"+      Next (Not (Atomic x)) -> "!(" ++ show x ++ "')"+      Next (And xs)         -> prFormula $ And $ map Next xs+      Next (Or xs)          -> prFormula $ Or $ map Next xs      +      Next x                -> "X " ++ prFormula' x +      And []                -> prFormula TTrue+      And [x]               -> prFormula x+      And (x:xr)            -> prFormula' x +++                              concatMap (\y -> " && " ++ prFormula' y) xr+      Or []                 -> prFormula FFalse+      Or [x]                -> prFormula x+      Or (x:xr)             -> prFormula' x ++ +                              concatMap (\y -> " || " ++ prFormula' y) xr+      Implies x y           -> prFormula' x ++ " -> " ++ prFormula' y+      Equiv x y             -> prFormula' x ++ " <-> " ++ prFormula' y+      _                     -> assert False undefined++      where+        prFormula' f = case f of+          TTrue                 -> prFormula f+          FFalse                -> prFormula f+          Atomic _              -> prFormula f+          Not _                 -> prFormula f+          Next (Atomic _)       -> prFormula f+          Next (Not (Atomic _)) -> prFormula f          +          _                     -> "(" ++ prFormula f ++ ")"++-----------------------------------------------------------------------------
+ src/Writer/Formats/SlugsIn.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.SlugsIn+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Ioannis Filippidis (jfilippidis@gmail.com)+--                Felix Klein (klein@react.uni-saarland.de)+--+-- Translates GR(1) specification to SlugsIn syntax.+--+-----------------------------------------------------------------------------++module Writer.Formats.SlugsIn where++-----------------------------------------------------------------------------++import Config++import Data.LTL+import Writer.Eval+import Writer.Error+import Data.Specification++import Detection+import Control.Exception++-----------------------------------------------------------------------------++-- | SlugsIn format writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s =+  case detectGR c s of+    Left v -> case v of+      Left err -> Left err+      Right _  -> errNoGR1 "not in GR(1)" "slugsin"+    Right gr+      | level gr > 1 -> errNoGR1 ("in GR(" ++ show (level gr) ++ ")") "slugsin"+      | otherwise    -> printSlugs gr++  where+    printSlugs gr = do+      let+        es = initEnv gr+        ss = initSys gr+        rs = assertEnv gr+        is = assertSys gr+        (le,ls) = case liveness gr of+          []  -> ([],[])+          x:_ -> x++      (iv,ov) <- signals c s++      return $ "[INPUT]"+        ++ "\n" ++ unlines iv+        ++ "\n" ++ "[OUTPUT]"+        ++ "\n" ++ unlines ov+        ++ (if null es then "" else+             "\n" ++ "[ENV_INIT]" +++             "\n" ++ unlines (map prFormula es))+        ++ (if null ss then "" else+             "\n" ++ "[SYS_INIT]" +++             "\n" ++ unlines (map prFormula ss))+        ++ (if null rs then "" else+              "\n" ++ "[ENV_TRANS]" +++              "\n" ++ unlines (map prFormula rs))+        ++ (if null is then "" else+              "\n" ++ "[SYS_TRANS]" +++              "\n" ++ unlines (map prFormula is))+        ++ (if null le then "" else+              "\n" ++ "[ENV_LIVENESS]" +++              "\n" ++ unlines (map prFormula le))+        ++ (if null ls then "" else+             "\n" ++ "[SYS_LIVENESS]" +++             "\n" ++ unlines (map prFormula ls))++    prFormula fml = case fml of+      TTrue                 -> " 1 "+      FFalse                -> " 0 "+      Atomic x              -> " " ++ show x ++ " "+      Not x                 -> "! " ++ prFormula x+      Next x                -> prFormula' x+      And []                -> prFormula TTrue+      And [x]               -> prFormula x+      And (x:xr)            -> concatMap (\y -> " & ") xr +++                               prFormula x +++                               concatMap (\y -> prFormula y) xr+      Or []                 -> prFormula FFalse+      Or [x]                -> prFormula x+      Or (x:xr)             -> concatMap (\y -> " | ") xr +++                               prFormula x +++                               concatMap (\y -> prFormula y) xr+      Implies x y           -> " | ! " +++                               prFormula x +++                               prFormula y+      Equiv x y             -> " ! ^ " +++                               prFormula x +++                               prFormula y+      _                     -> assert False undefined+++      where prFormula' f = case f of+              TTrue                 -> " 1 "+              FFalse                -> " 0 "+              Atomic x              -> " " ++ show x ++ "' "+              Not x                 -> "! " ++ prFormula' x+              Next x                -> assert False undefined+              And []                -> prFormula' TTrue+              And [x]               -> prFormula' x+              And (x:xr)            -> concatMap (\y -> " & ") xr +++                                       prFormula' x +++                                       concatMap (\y -> prFormula' y) xr+              Or []                 -> prFormula' FFalse+              Or [x]                -> prFormula' x+              Or (x:xr)             -> concatMap (\y -> " | ") xr +++                                       prFormula' x +++                                       concatMap (\y -> prFormula' y) xr+              Implies x y           -> " | ! " +++                                       prFormula' x +++                                       prFormula' y+              Equiv x y             -> " ! ^ " +++                                       prFormula' x +++                                       prFormula' y+              _                     -> assert False undefined+++-----------------------------------------------------------------------------+
+ src/Writer/Formats/Smv.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Smv+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Leander Tentrup (tentrup@react.uni-saarland.de)+--                Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to SMV format.+-- See http://nusmv.fbk.eu/NuSMV/userman/v21/nusmv_3.html#SEC31 for more+-- information about the SMV LTL specification.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Smv where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | SMV LTL operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "TRUE"+  , fFalse     = "FALSE"+  , opNot      = UnaryOp  "!"   1+  , opAnd      = BinaryOp "&"   3 AssocLeft+  , opOr       = BinaryOp "|"   4 AssocLeft+  , opImplies  = BinaryOp "->"  6 AssocRight+  , opEquiv    = BinaryOp "<->" 5 AssocLeft+  , opNext     = UnaryOp  "X"   1+  , opFinally  = UnaryOp  "F"   1+  , opGlobally = UnaryOp  "G"   1+  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOp "V"   2 AssocLeft+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | SMV LTL writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat config spec = do+  (es,ss,rs,as,is,gs) <- eval config spec+  formula <- merge es ss rs as is gs+  simplified_formula <- simplify (adjust config opConfig) formula+    +  +  (input_signals, output_signals) <- signals config spec+  let +    all_signals = (input_signals ++ output_signals)+  +  return $ main (printFormula opConfig (outputMode config) simplified_formula) all_signals+  +  where +    main formula xs =+        "MODULE main\n"+        ++ "\tVAR\n"+        ++ (printSignals xs)+        ++ "\tLTLSPEC " ++ formula ++ "\n"++    printSignals xs = case xs of+      []               -> ""+      (x:xr) -> "\t\t" ++ x ++ " : boolean;\n" ++ (printSignals xr)++-----------------------------------------------------------------------------+++
+ src/Writer/Formats/Unbeast.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Unbeast+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+--+-- Transforms a specification to the Unbeast format.+--+-----------------------------------------------------------------------------++module Writer.Formats.Unbeast where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.LTL+import Data.Error+import Data.Specification++import Writer.Eval+import Control.Exception++-----------------------------------------------------------------------------++-- | Unbeast format writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  us <- mapM (simplify' (c { noRelease = True, noWeak = True })) $+     case ss of+       [] -> filter (/= FFalse) $ es ++ map fGlobally rs ++ as+       _  -> filter (/= FFalse) $ es +++              map (\f -> fOr [fNot $ fAnd ss, f])+                (map fGlobally rs ++ as)++  vs <- mapM (simplify' (c { noRelease = True, noWeak = True })) $+         filter (/= TTrue) $ ss ++ [fGlobally $ fAnd is] ++ gs++  (si,so) <- signals c s++  return $ main si so us vs++  where+    main si so as vs =+                 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\" ?>"+      ++ "\n" ++ "<!DOCTYPE SynthesisProblem SYSTEM \""+              ++ specfile ++ "\">"+      ++ "\n"+      ++ "\n" ++ "<!--"+      ++ "\n" ++ "This specification was automatically created "+              ++ "from a TLSF specification,"+      ++ "\n" ++ "using the SyFCo tool."+      ++ "\n"+      ++ "\n" ++ "Please consider that default values for the .dtd file "+              ++ "and the LTL compiler"+      ++ "\n" ++ "have been used. To change them, you can use the "+              ++ "'updatePathsInXML.py' script,"+      ++ "\n" ++ "that is shipped with the Unbeast tool."+      ++ "\n" ++ "-->"+      ++ "\n"+      ++ "\n" ++ "<SynthesisProblem>"+      ++ "\n" ++ "  <Title>" ++ title s ++ "</Title>"+      ++ "\n" ++ "  <Description>"+      ++ "\n" ++ fixedIndent (description s)+      ++ "\n" ++ "  </Description>"+      ++ "\n" ++ "  <PathToLTLCompiler>" ++ compiler+              ++ "</PathToLTLCompiler>"+      ++ "\n" ++ "  <GlobalInputs>"+      ++ concatMap printSignal si+      ++ "\n" ++ "  </GlobalInputs>"+      ++ "\n" ++ "  <GlobalOutputs>"+      ++ concatMap printSignal so+      ++ "\n" ++ "  </GlobalOutputs>"+      ++ (if null as then ""+          else "\n" ++ "  <Assumptions>" +++               concatMap (\x -> "\n    <LTL>\n" ++ printFormula 6 x+                               ++ "    </LTL>\n") as +++               "  </Assumptions>")+      ++ "\n" ++ "  <Specification>"+      ++ concatMap (\x -> "\n    <LTL>\n" ++ printFormula 6 x+                         ++ "    </LTL>\n") vs+      ++ "  </Specification>"+      ++ "\n" ++ "</SynthesisProblem>"+      ++ "\n"++    specfile = "SynSpec.dtd"+    compiler = "ltl2ba -f"++    fixedIndent str = case str of+      []        -> []+      (' ':xr)  -> fixedIndent xr+      ('\t':xr) -> fixedIndent xr+      ('\n':xr) -> fixedIndent xr+      _         -> "    " +++                 concatMap ident (rmLeadingSpace [] False str)++    ident chr = case chr of+      '\n' -> "\n    "+      _    -> [chr]++    rmLeadingSpace a b str = case str of+      []        -> reverse a+      ('\n':xr) -> rmLeadingSpace ('\n':a) True xr+      ('\t':xr) ->+        if b+        then rmLeadingSpace a b xr+        else rmLeadingSpace (' ':a) b xr+      (' ':xr)  ->+        if b+        then rmLeadingSpace a b xr+        else rmLeadingSpace (' ':a) b xr+      (x:xr)    -> rmLeadingSpace (x:a) False xr++    printSignal sig =+      "\n    <Bit>" ++ sig ++ "</Bit>"++    printFormula n f = replicate n ' ' ++ printFormula' (n + 2) f++    printFormula' n f = case f of+      TTrue       -> "<True></True>\n"+      FFalse      -> "<False></False>\n"+      Atomic x    -> "<Var>" ++ show x ++ "</Var>\n"+      Not x       -> "<Not>\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "</Not>\n"+      Next x      -> "<X>\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "</X>\n"+      Globally x  -> "<G>\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "</G>\n"+      Finally x   -> "<F>\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "</F>\n"+      Or xs       -> "<Or>\n" ++ concatMap (printFormula n) xs ++ replicate (n - 2) ' ' ++ "</Or>\n"+      And xs      -> "<And>\n" ++ concatMap (printFormula n) xs ++ replicate (n - 2) ' ' ++ "</And>\n"+      Equiv x y   -> "<Iff>\n" ++ printFormula n x ++ printFormula n y ++ replicate (n - 2) ' ' ++ "</Iff>\n"+      Until x y   -> "<U>\n" ++ printFormula n x ++ printFormula n y ++ replicate (n - 2) ' ' ++ "</U>\n"+      _           -> assert False undefined++    noImpl fml = case fml of+      Implies x y -> Or [Not $ noImpl x, noImpl y]+      _           -> applySub noImpl fml++    simplify' cc f = do+      f' <- simplify cc $ noImpl f+      if f' == f then return f else simplify' cc f'++-----------------------------------------------------------------------------
+ src/Writer/Formats/Utf8.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Utf8+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to a UTF8 string.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Utf8 where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | UTF8 operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "⊤"+  , fFalse     = "⊥"+  , opNot      = UnaryOp  "¬" 1+  , opAnd      = BinaryOp "∧" 2 AssocLeft+  , opOr       = BinaryOp "∨" 3 AssocLeft+  , opImplies  = BinaryOp "→" 4 AssocRight+  , opEquiv    = BinaryOp "↔" 4 AssocRight+  , opNext     = UnaryOp  "◯" 1 +  , opFinally  = UnaryOp  "◇" 1 +  , opGlobally = UnaryOp  "□" 1 +  , opUntil    = BinaryOp "U" 6 AssocRight+  , opRelease  = BinaryOp "R" 7 AssocLeft+  , opWeak     = BinaryOp "W" 5 AssocRight+  }++-----------------------------------------------------------------------------++-- | UTF8 writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  fml0 <- merge es ss rs as is gs+  fml1 <- simplify (adjust c opConfig) fml0+    +  return $ printFormula opConfig (outputMode c) fml1++-----------------------------------------------------------------------------+
+ src/Writer/Formats/Wring.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Formats.Wring+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Transforms a specification to a wring format.+-- +-----------------------------------------------------------------------------++module Writer.Formats.Wring where++-----------------------------------------------------------------------------++import Config+import Simplify++import Data.LTL+import Data.Error+import Data.Specification++import Writer.Eval+import Writer.Data+import Writer.Utils++-----------------------------------------------------------------------------++-- | Wring operator configuration.++opConfig+  :: OperatorConfig++opConfig = OperatorConfig+  { tTrue      = "TRUE"+  , fFalse     = "FALSE"+  , opNot      = UnaryOp  "!"   1+  , opAnd      = BinaryOp "*"   2 AssocLeft+  , opOr       = BinaryOp "+"   2 AssocLeft+  , opImplies  = BinaryOp "->"  2 AssocLeft+  , opEquiv    = BinaryOp "<->" 2 AssocLeft+  , opNext     = UnaryOp  "X"   1 +  , opFinally  = UnaryOp  "F"   1 +  , opGlobally = UnaryOp  "G"   1 +  , opUntil    = BinaryOp "U"   2 AssocLeft+  , opRelease  = BinaryOp "R"   2 AssocLeft+  , opWeak     = BinaryOpUnsupported+  }++-----------------------------------------------------------------------------++-- | Wring format writer.++writeFormat+  :: Configuration -> Specification -> Either Error String++writeFormat c s = do+  (es,ss,rs,as,is,gs) <- eval c s+  fml0 <- merge es ss rs as is gs+  fml1 <- simplify (adjust c opConfig) $ adjustAtomic fml0+    +  return $ printFormula opConfig (outputMode c) fml1++  where+    adjustAtomic fml = case fml of+      Not (Atomic (Output x)) -> Atomic (Output ("(" ++ x ++ "=0)"))+      Not (Atomic (Input x))  -> Atomic (Input ("(" ++ x ++ "=0)"))+      Atomic (Output x)       -> Atomic (Output ("(" ++ x ++ "=1)"))            +      Atomic (Input x)        -> Atomic (Input ("(" ++ x ++ "=1)"))+      _                       -> applySub adjustAtomic fml    ++-----------------------------------------------------------------------------
+ src/Writer/Utils.hs view
@@ -0,0 +1,312 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Writer.Utils+-- License     :  MIT (see the LICENSE file)+-- Maintainer  :  Felix Klein (klein@react.uni-saarland.de)+-- +-- Functions shared among the different writer modules.+-- +-----------------------------------------------------------------------------++module Writer.Utils+    ( printFormula+    , checkLower+    , merge+    , adjust  +    ) where++-----------------------------------------------------------------------------++import Data.Maybe+    ( mapMaybe+    )  ++import Data.Char+    ( toLower+    )++import Config+    ( Configuration(..)+    )++import Data.Types+    ( SignalDecType(..)+    )  ++import Data.LTL+    ( Atomic(..)+    , Formula(..)+    , fNot  +    )++import Data.SymbolTable+    ( IdRec(..)+    )  ++import Data.Specification+    ( Specification(..)+    )+    +import Writer.Error+    ( Error+    , errToLower+    )++import Writer.Data+    ( WriteMode(..)+    , OperatorConfig(..)        +    , UnaryOperator(..)+    , BinaryOperator(..)      +    , Assoc(..)+    , Unsupported(..)  +    )+    +import Data.Array.IArray+    ( (!)+    )  ++-----------------------------------------------------------------------------++-- | Gernealized printer that supports pretty printing and printing+-- fully parenthesized formulas for arbitrary operator configurations,+-- passed via @OperatorNames@.++printFormula+  :: OperatorConfig -> WriteMode -> Formula -> String++printFormula opc mode formula = reverse $ case mode of+  Pretty -> pr [] formula+  Fully  -> parens pr [] formula++  where+    parens c a x = ')' : c ('(':a) x ++    pr' a y r x = case mode of+      Fully  -> parens pr a x+      Pretty -> case compare (precedence' y) (precedence' x) of+        LT -> parens pr a x        +        GT -> pr a x+        EQ -> case (assoc' y, r) of+          (AssocRight, False) -> parens pr a x+          (AssocRight, True)  -> pr a x+          (_, False)          -> pr a x+          (_, True)           -> parens pr a x++    pr a f = case f of+      TTrue                   -> revappend a ttrue+      FFalse                  -> revappend a ffalse+      Atomic (Input x)        -> revappend a x+      Atomic (Output x)       -> revappend a x      +      Not x                   -> pr' (unOp opnot a) f False x+      And []                  -> pr a TTrue+      And [x]                 -> pr a x+      And [x,y]               -> pr' (binOp opand $ pr' a f False x) f True y+      And (x:y:xr)            -> case assoc' f of+        AssocRight -> pr' (binOp opand $ pr' a f False x) f True $ And (y:xr)+        _          -> pr a $ And $ And [x,y] : xr+      Or []                   -> pr a FFalse+      Or [x]                  -> pr a x+      Or [x,y]                -> pr' (binOp opor $ pr' a f False x) f True y+      Or (x:y:xr)             -> case assoc' f of+        AssocRight -> pr' (binOp opor $ pr' a f False x) f True $ Or (y:xr)+        _          -> pr a $ Or $ Or [x,y] : xr+      Implies x y             -> pr' (binOp opimplies $ pr' a f False x) f True y+      Equiv x y               -> pr' (binOp opequiv $ pr' a f False x) f True y+      Next x                  -> pr' (unOp opnext a) f True x    +      Globally x              -> pr' (unOp opglobally a) f True x    +      Finally x               -> pr' (unOp opfinally a) f True x    +      Until x y               -> pr' (binOp opuntil $ pr' a f False x) f True y+      Release x y             -> pr' (binOp oprelease $ pr' a f False x) f True y+      Weak x y                -> pr' (binOp opweak $ pr' a f False x) f True y++    precedence' f = case f of+      TTrue       -> 0+      FFalse      -> 0+      Atomic {}   -> 0+      Not {}      -> dp + uopPrecedence opnot+      And {}      -> dp + bopPrecedence opand+      Or {}       -> dp + bopPrecedence opor+      Implies {}  -> dp + bopPrecedence opimplies+      Equiv {}    -> dp + bopPrecedence opequiv+      Next {}     -> dp + uopPrecedence opnext+      Globally {} -> dp + uopPrecedence opglobally+      Finally {}  -> dp + uopPrecedence opfinally+      Until {}    -> dp + bopPrecedence opuntil+      Release {}  -> dp + bopPrecedence oprelease+      Weak {}     -> dp + bopPrecedence opweak++    assoc' f = case f of+      TTrue       -> AssocLeft+      FFalse      -> AssocLeft+      Atomic {}   -> AssocLeft+      Not {}      -> AssocLeft+      And {}      -> bopAssoc opand+      Or {}       -> bopAssoc opor+      Implies {}  -> bopAssoc opimplies+      Equiv {}    -> bopAssoc opequiv+      Next {}     -> AssocLeft+      Globally {} -> AssocLeft+      Finally {}  -> AssocLeft+      Until {}    -> bopAssoc opuntil+      Release {}  -> bopAssoc oprelease+      Weak {}     -> bopAssoc opweak+++    binOp op a = ' ' : revappend (' ' : a) (bopName op)++    unOp op a = ' ' : revappend a (uopName op)++    uopPrecedence' x =+      if unsupported x+      then Nothing+      else Just $ uopPrecedence x++    bopPrecedence' x =+      if unsupported x+      then Nothing+      else Just $ bopPrecedence x           ++    dp =+      let+        xs = mapMaybe (\f -> f opc) +          [ uopPrecedence' . opNot +          , bopPrecedence' . opAnd+          , bopPrecedence' . opOr+          , bopPrecedence' . opImplies+          , bopPrecedence' . opEquiv+          , uopPrecedence' . opNext+          , uopPrecedence' . opFinally+          , uopPrecedence' . opGlobally+          , bopPrecedence' . opUntil+          , bopPrecedence' . opRelease+          , bopPrecedence' . opWeak+          ]+        m = foldl min 1 xs+      in if m > 0+         then 0+         else 1 - m++    ttrue = tTrue opc+    ffalse = fFalse opc+    opnot = opNot opc+    opand = opAnd opc+    opor = opOr opc+    opimplies = opImplies opc+    opequiv = opEquiv opc+    opnext = opNext opc+    opfinally = opFinally opc+    opglobally = opGlobally opc+    opuntil = opUntil opc+    oprelease = opRelease opc+    opweak = opWeak opc++    revappend a xs = case xs of+      []     -> a+      (x:xr) -> revappend (x:a) xr++-----------------------------------------------------------------------------++-- | Merges a list of assumption formulas, invariant formulas and guarantee+-- formulas to one single formula without introducing any overhead in case+-- one of the lists is empty or a singleton.++merge+  :: [Formula] -> [Formula] -> [Formula] ->+    [Formula] -> [Formula] -> [Formula] -> Either Error Formula++merge es ss rs as is gs =+  let+    fmle = case (rs,as) of+      ([],[])   -> TTrue+      ([],[x])  -> x+      ([],_)    -> And as+      ([x],[])  -> Globally x+      ([x],[y]) -> And [Globally x,y]+      ([x],_)   -> And (Globally x : as)+      (_,[])    -> Globally $ And rs+      (_,[x])   -> And [Globally $ And rs, x]+      (_,_)     -> And ((Globally $ And rs) : as)      +    +    fmls = case (is,gs) of+      ([],[])   -> TTrue+      ([],[x])  -> x+      ([],_)    -> And gs+      ([x],[])  -> Globally x+      ([x],[y]) -> And [Globally x,y]+      ([x],_)   -> And (Globally x : gs)+      (_,[])    -> Globally $ And is+      (_,[x])   -> And [Globally $ And is, x]+      (_,_)     -> And ((Globally $ And is) : gs)++    fmli = case (fmle, fmls) of+      (FFalse,_) -> TTrue+      (TTrue,x)  -> x+      (x,FFalse) -> fNot x+      (_,TTrue)  -> TTrue+      _          -> Implies fmle fmls++    fmlc = case (ss,fmli) of+      ([],_)      -> fmli+      (_,FFalse)  -> FFalse+      ([x],TTrue) -> x+      (xs, TTrue) -> And xs+      _           -> And (ss ++ [fmli])+        +    fmlf = case (es,fmlc) of+      ([],_)       -> fmlc+      ([x],FFalse) -> fNot x+      (xs,FFalse)  -> Or $ map fNot xs+      (_,TTrue)    -> TTrue+      ([x],_)      -> Implies x fmlc+      _            -> Implies (And es) fmlc+  in+    return fmlf++-----------------------------------------------------------------------------++-- | Checks whether a conversion of the signal names to lower case would+-- introduce any clash.++checkLower+  :: String -> Specification -> Either Error ()++checkLower fmt s =+  let+    ids = map ident (inputs s) +++          map ident (outputs s)+    names = map (idName . (symboltable s !)) ids+    lnames = map (map toLower) names+    znames = zip3 ids names lnames+  in+    checkDouble znames+    +  where+    ident x = case x of+      SDSingle (y,_) -> y+      SDBus (y,_) _  -> y+      SDEnum (y,_) _ -> y+    +    checkDouble xs = case xs of+      [] ->  return ()+      [_] -> return ()+      ((i,a,b):(x,c,d):xr) ->+        if b == d +        then errToLower fmt a c $ idPos $ symboltable s ! i+        else checkDouble ((x,c,d) : xr)++-----------------------------------------------------------------------------++-- | Adjust the configuration according to unsupported operators.++adjust+  :: Configuration -> OperatorConfig -> Configuration++adjust c oc =+  c {+    noRelease = noRelease c || unsupported (opRelease oc),+    noWeak = noWeak c || unsupported (opWeak oc),+    noGlobally = noGlobally c || unsupported (opGlobally oc),+    noFinally = noFinally c || unsupported (opFinally oc)+    }++-----------------------------------------------------------------------------
+ syfco.cabal view
@@ -0,0 +1,170 @@+name:                syfco+version:             1.1.0.0+synopsis:            Synthesis Format Conversion Tool / Library+description:         Library and tool for reading, manipulating and transforming synthesis specifications.+license:             MIT+license-file:        LICENSE+author:              Felix Klein <klein@react.uni-saarland.de>+maintainer:          Felix Klein <klein@react.uni-saarland.de>+stability:           stable+category:            SyntComp+homepage:            https://github.com/reactive-systems/syfco+bug-reports:         https://github.com/reactive-systems/syfco/issues+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/reactive-systems/syfco++library++  build-depends:+      base >=4.7 && <4.10+    , array >=0.5 && <0.6+    , containers >=0.5 && <0.6+    , directory >=1.2 && <1.4+    , mtl >=2.2 && <2.3+    , parsec >=3.1 && <3.2+    , transformers >= 0.4 && <0.6+    , convertible >= 1.1++  exposed-modules:+    Syfco++  other-modules:+    Utils+    Config+    Simplify+    Reader+    Reader.Data+    Reader.Error+    Reader.Sugar+    Reader.InferType+    Reader.Abstraction+    Reader.Bindings+    Reader.Parser+    Reader.Parser.Info+    Reader.Parser.Utils+    Reader.Parser.Expression+    Reader.Parser.Global+    Reader.Parser.Component+    Reader.Parser.Data+    Writer+    Writer.Error+    Writer.Utils+    Writer.Data+    Writer.Eval+    Writer.Formats+    Writer.Formats.Lily+    Writer.Formats.Wring+    Writer.Formats.Utf8+    Writer.Formats.Psl+    Writer.Formats.Smv+    Writer.Formats.SlugsIn+    Writer.Formats.Ltlxba+    Writer.Formats.Full+    Writer.Formats.Unbeast+    Writer.Formats.Acacia+    Writer.Formats.Promela+    Writer.Formats.Bosy+    Writer.Formats.Basic+    Writer.Formats.AcaciaSpecs+    Writer.Formats.Slugs+    Detection+    Detection.GeneralizedReactivity+    Data.Info+    Data.Error+    Data.StringMap+    Data.Enum+    Data.Types+    Data.Expression+    Data.Specification+    Data.SymbolTable+    Data.LTL+    Data.Binding+    Paths_syfco++  hs-source-dirs:+    src++  default-language:+    Haskell2010++executable syfco++  main-is:+    Main.hs++  other-modules:+    Arguments+    Info+    Syfco+    Utils+    Config+    Simplify+    Reader+    Reader.Data+    Reader.Error+    Reader.Sugar+    Reader.InferType+    Reader.Abstraction+    Reader.Bindings+    Reader.Parser+    Reader.Parser.Info+    Reader.Parser.Utils+    Reader.Parser.Expression+    Reader.Parser.Global+    Reader.Parser.Component+    Reader.Parser.Data+    Writer+    Writer.Error+    Writer.Utils+    Writer.Data+    Writer.Eval+    Writer.Formats+    Writer.Formats.Lily+    Writer.Formats.Wring+    Writer.Formats.Utf8+    Writer.Formats.Psl+    Writer.Formats.Smv+    Writer.Formats.SlugsIn+    Writer.Formats.Ltlxba+    Writer.Formats.Full+    Writer.Formats.Unbeast+    Writer.Formats.Acacia+    Writer.Formats.Promela+    Writer.Formats.Bosy+    Writer.Formats.Basic+    Writer.Formats.AcaciaSpecs+    Writer.Formats.Slugs+    Detection+    Detection.GeneralizedReactivity+    Data.Info+    Data.Error+    Data.StringMap+    Data.Enum+    Data.Types+    Data.Expression+    Data.Specification+    Data.SymbolTable+    Data.LTL+    Data.Binding+    Paths_syfco++  build-depends:+      base >=4.7 && <4.10+    , array >=0.5 && <0.6+    , containers >=0.5 && <0.6+    , directory >=1.2 && <1.4+    , mtl >=2.2 && <2.3+    , parsec >=3.1 && <3.2+    , transformers >= 0.4 && <0.6+    , convertible >= 1.1++  hs-source-dirs:+    src++  default-language:+    Haskell2010