diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Arguments.hs b/src/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Arguments.hs @@ -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) + +----------------------------------------------------------------------------- diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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:/   + -- @ format = ... @ /)/ + + , outputMode :: WriteMode + -- ^ The output mode used by the writer. + -- + -- /(can be changed via a configuration file, use:/   + -- @ 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:/   + -- @ bus_delimiter = ... @ /)/ + + , primeSymbol :: String + -- ^ The prime symbol \/ string representing primes in signals of + -- the input format. + -- + -- /(can be changed via a configuration file, use:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ weak_simplify = ... @ /)/ + + , simplifyStrong :: Bool + -- ^ A boolean flag specifying whether strong simplifications + -- should be applied or not. + -- + -- /(can be changed via a configuration file, use:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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:/   + -- @ 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 '. " ++ + "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" + } + +----------------------------------------------------------------------------- diff --git a/src/Data/Binding.hs b/src/Data/Binding.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binding.hs @@ -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) + +----------------------------------------------------------------------------- + diff --git a/src/Data/Enum.hs b/src/Data/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enum.hs @@ -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 + } + +----------------------------------------------------------------------------- diff --git a/src/Data/Error.hs b/src/Data/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Error.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Data/Expression.hs b/src/Data/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expression.hs @@ -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 ++ ")" + +----------------------------------------------------------------------------- diff --git a/src/Data/Info.hs b/src/Data/Info.hs new file mode 100644 --- /dev/null +++ b/src/Data/Info.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Data/LTL.hs b/src/Data/LTL.hs new file mode 100644 --- /dev/null +++ b/src/Data/LTL.hs @@ -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 ++ ")" + +----------------------------------------------------------------------------- diff --git a/src/Data/Specification.hs b/src/Data/Specification.hs new file mode 100644 --- /dev/null +++ b/src/Data/Specification.hs @@ -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 + } + +----------------------------------------------------------------------------- diff --git a/src/Data/StringMap.hs b/src/Data/StringMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/StringMap.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Data/SymbolTable.hs b/src/Data/SymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/Data/SymbolTable.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Data/Types.hs b/src/Data/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Types.hs @@ -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" + +----------------------------------------------------------------------------- diff --git a/src/Detection.hs b/src/Detection.hs new file mode 100644 --- /dev/null +++ b/src/Detection.hs @@ -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 + ) + +----------------------------------------------------------------------------- diff --git a/src/Detection/GeneralizedReactivity.hs b/src/Detection/GeneralizedReactivity.hs new file mode 100644 --- /dev/null +++ b/src/Detection/GeneralizedReactivity.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Info.hs b/src/Info.hs new file mode 100644 --- /dev/null +++ b/src/Info.hs @@ -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]... ") ++ + 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 ("
" ++) xr) ++ + case sub of + Nothing -> "" + Just ys -> "
" ++ + concatMap prMSub ys ++ + "
" + ) ++ "|" + + prMSub (name,d,desc) = + "" ++ code m name ++ + "" ++ concat (addbreaks desc) ++ + (if d then " (default)" else "") ++ + "" + + addbreaks xs = case xs of + [] -> [] + x:xr -> x : map ("
" ++) 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
(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 + +----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader.hs b/src/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Reader.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Abstraction.hs b/src/Reader/Abstraction.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Abstraction.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Bindings.hs b/src/Reader/Bindings.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Bindings.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Data.hs b/src/Reader/Data.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Data.hs @@ -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 + + } + +----------------------------------------------------------------------------- diff --git a/src/Reader/Error.hs b/src/Reader/Error.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Error.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/InferType.hs b/src/Reader/InferType.hs new file mode 100644 --- /dev/null +++ b/src/Reader/InferType.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser.hs b/src/Reader/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser.hs @@ -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' + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Component.hs b/src/Reader/Parser/Component.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Component.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Data.hs b/src/Reader/Parser/Data.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Data.hs @@ -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 + } + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Expression.hs b/src/Reader/Parser/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Expression.hs @@ -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 } + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Global.hs b/src/Reader/Parser/Global.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Global.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Info.hs b/src/Reader/Parser/Info.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Info.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Reader/Parser/Utils.hs b/src/Reader/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Parser/Utils.hs @@ -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) + +----------------------------------------------------------------------------- diff --git a/src/Reader/Sugar.hs b/src/Reader/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Reader/Sugar.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Simplify.hs b/src/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Simplify.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Syfco.hs b/src/Syfco.hs new file mode 100644 --- /dev/null +++ b/src/Syfco.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer.hs b/src/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Writer.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Data.hs b/src/Writer/Data.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Data.hs @@ -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) + +----------------------------------------------------------------------------- diff --git a/src/Writer/Error.hs b/src/Writer/Error.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Error.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Eval.hs b/src/Writer/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Eval.hs @@ -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]) + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats.hs b/src/Writer/Formats.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats.hs @@ -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 + -- ^ + | PROMELA + -- ^ + | UNBEAST + -- ^ + | LTLXBA + -- ^ LTL2BA / LTL3BA input format + | LILY + -- ^ Lily input format + | ACACIA + -- ^ Acacia / Acacia+ input format + | ACACIASPECS + -- ^ Acacia input format with spec units + | SLUGS + -- ^ + | SLUGSIN + -- ^ + | PSL + -- ^ + | SMV + -- ^ SMV file format + | 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] + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Acacia.hs b/src/Writer/Formats/Acacia.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Acacia.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/AcaciaSpecs.hs b/src/Writer/Formats/AcaciaSpecs.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/AcaciaSpecs.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Basic.hs b/src/Writer/Formats/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Basic.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Bosy.hs b/src/Writer/Formats/Bosy.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Bosy.hs @@ -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) ++ "\"" + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Full.hs b/src/Writer/Formats/Full.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Full.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Lily.hs b/src/Writer/Formats/Lily.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Lily.hs @@ -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 + +----------------------------------------------------------------------------- + + + diff --git a/src/Writer/Formats/Ltlxba.hs b/src/Writer/Formats/Ltlxba.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Ltlxba.hs @@ -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 + +----------------------------------------------------------------------------- + + diff --git a/src/Writer/Formats/Promela.hs b/src/Writer/Formats/Promela.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Promela.hs @@ -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 + +----------------------------------------------------------------------------- + + + diff --git a/src/Writer/Formats/Psl.hs b/src/Writer/Formats/Psl.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Psl.hs @@ -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 + +----------------------------------------------------------------------------- + diff --git a/src/Writer/Formats/Slugs.hs b/src/Writer/Formats/Slugs.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Slugs.hs @@ -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 ++ ")" + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/SlugsIn.hs b/src/Writer/Formats/SlugsIn.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/SlugsIn.hs @@ -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 + + +----------------------------------------------------------------------------- + diff --git a/src/Writer/Formats/Smv.hs b/src/Writer/Formats/Smv.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Smv.hs @@ -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) + +----------------------------------------------------------------------------- + + + diff --git a/src/Writer/Formats/Unbeast.hs b/src/Writer/Formats/Unbeast.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Unbeast.hs @@ -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 = + "" + ++ "\n" ++ "" + ++ "\n" + ++ "\n" ++ "" + ++ "\n" + ++ "\n" ++ "" + ++ "\n" ++ " " ++ title s ++ "" + ++ "\n" ++ " " + ++ "\n" ++ fixedIndent (description s) + ++ "\n" ++ " " + ++ "\n" ++ " " ++ compiler + ++ "" + ++ "\n" ++ " " + ++ concatMap printSignal si + ++ "\n" ++ " " + ++ "\n" ++ " " + ++ concatMap printSignal so + ++ "\n" ++ " " + ++ (if null as then "" + else "\n" ++ " " ++ + concatMap (\x -> "\n \n" ++ printFormula 6 x + ++ " \n") as ++ + " ") + ++ "\n" ++ " " + ++ concatMap (\x -> "\n \n" ++ printFormula 6 x + ++ " \n") vs + ++ " " + ++ "\n" ++ "" + ++ "\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 " ++ sig ++ "" + + printFormula n f = replicate n ' ' ++ printFormula' (n + 2) f + + printFormula' n f = case f of + TTrue -> "\n" + FFalse -> "\n" + Atomic x -> "" ++ show x ++ "\n" + Not x -> "\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "\n" + Next x -> "\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "\n" + Globally x -> "\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "\n" + Finally x -> "\n" ++ printFormula n x ++ replicate (n - 2) ' ' ++ "\n" + Or xs -> "\n" ++ concatMap (printFormula n) xs ++ replicate (n - 2) ' ' ++ "\n" + And xs -> "\n" ++ concatMap (printFormula n) xs ++ replicate (n - 2) ' ' ++ "\n" + Equiv x y -> "\n" ++ printFormula n x ++ printFormula n y ++ replicate (n - 2) ' ' ++ "\n" + Until x y -> "\n" ++ printFormula n x ++ printFormula n y ++ replicate (n - 2) ' ' ++ "\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' + +----------------------------------------------------------------------------- diff --git a/src/Writer/Formats/Utf8.hs b/src/Writer/Formats/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Utf8.hs @@ -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 + +----------------------------------------------------------------------------- + diff --git a/src/Writer/Formats/Wring.hs b/src/Writer/Formats/Wring.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Formats/Wring.hs @@ -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 + +----------------------------------------------------------------------------- diff --git a/src/Writer/Utils.hs b/src/Writer/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Writer/Utils.hs @@ -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) + } + +----------------------------------------------------------------------------- diff --git a/syfco.cabal b/syfco.cabal new file mode 100644 --- /dev/null +++ b/syfco.cabal @@ -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 +maintainer: Felix Klein +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